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/lib/JEDI-SDL/SDL/Pas/Readme.txt | 52 +- Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc | 876 +- Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas | 5376 +++++----- Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas | 376 +- Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas | 638 +- .../JEDI-SDL/SDL/Pas/registryuserpreferences.pas | 458 +- Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas | 308 +- .../Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas | 404 +- Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas | 10472 +++++++++---------- Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas | 1846 ++-- Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas | 432 +- Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas | 392 +- Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas | 8726 +++++++-------- Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas | 1132 +- Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas | 318 +- 15 files changed, 15903 insertions(+), 15903 deletions(-) (limited to 'Game/Code/lib/JEDI-SDL/SDL/Pas') diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt b/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt index 76d63a9d..f176d0c9 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt @@ -1,27 +1,27 @@ -Delphi interface unit for OpenGL version 1.2 compilable with Delphi 3-6 and Kylix. - -This unit is open source under the Mozilla Public License and -the original author is Dipl. Ing. Mike Lischke (public@lischke-online.de). - -You can obtain this unit also from the JEDI (Joint Endeavor of Delphi Innovators) -API page at www.delphi-jedi.org. - -Note for GLScene users: Eric Grange has provided a general vector types unit which -resolves conflicts for types which are defined in OpenGL12.pas as well as Geometry.pas. -This unit is located in the sub folder "GLScene AddOn". -Please add this unit to the uses clause of OpenGL12.pas and remove the few types which -are already declared in VectorTypes.pas. - -For tests and as starting point three demos are included into the package. Two of them (GLDiag and GLTest) -need the (also provided) simple OpenGL control GLControl (see "GLControl\Package"). - -- Basic is a very simple test program which only uses an empty form. -- GLTest (in GLControl) uses GLControl to show four rendering contexts simultanously. -- GLDiag is a diagnosis tool similar to DXDiag which shows some properties of the current - OpenGL driver implementation. - -Have fun and - -Ciao, Mike -www.lischke-online.de +Delphi interface unit for OpenGL version 1.2 compilable with Delphi 3-6 and Kylix. + +This unit is open source under the Mozilla Public License and +the original author is Dipl. Ing. Mike Lischke (public@lischke-online.de). + +You can obtain this unit also from the JEDI (Joint Endeavor of Delphi Innovators) +API page at www.delphi-jedi.org. + +Note for GLScene users: Eric Grange has provided a general vector types unit which +resolves conflicts for types which are defined in OpenGL12.pas as well as Geometry.pas. +This unit is located in the sub folder "GLScene AddOn". +Please add this unit to the uses clause of OpenGL12.pas and remove the few types which +are already declared in VectorTypes.pas. + +For tests and as starting point three demos are included into the package. Two of them (GLDiag and GLTest) +need the (also provided) simple OpenGL control GLControl (see "GLControl\Package"). + +- Basic is a very simple test program which only uses an empty form. +- GLTest (in GLControl) uses GLControl to show four rendering contexts simultanously. +- GLDiag is a diagnosis tool similar to DXDiag which shows some properties of the current + OpenGL driver implementation. + +Have fun and + +Ciao, Mike +www.lischke-online.de www.delphi-unicode.net \ No newline at end of file diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc b/Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc index 31283d40..0130ad32 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc @@ -1,438 +1,438 @@ -{ - $Id: jedi-sdl.inc,v 1.15 2007/05/29 21:30:48 savage Exp $ -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ Global Conditional Definitions for JEDI-SDL cross-compilation } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Prof. Abimbola Olowofoyeku } -{ } -{ Portions created by Prof. Abimbola Olowofoyeku are } -{ Copyright (C) 2000 - 2100 Prof. Abimbola Olowofoyeku. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Prof. Abimbola Olowofoyeku } -{ Dominqiue Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ This code has been copied from... } -{ Global Conditional Definitions for Chief's UNZIP package } -{ By Prof. Abimbola Olowofoyeku (The African Chief) } -{ http://www.bigfoot.com/~African_Chief/ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2003-04-03 DL - Initial addition } -{ } -{ 2003-04-07 DL - Added Macro ON derective for FPC and OpenGL and removed } -{ WEAKPACKAGE derective. WEAKPACKAGE should be set when } -{ appropriate. } -{ } -{ 2003-04-23 - DL : under instruction from Alexey Barkovoy I have added } -{ better TMT Pascal support and under instruction } -{ from Prof. Abimbola Olowofoyeku (The African Chief) } -{ I have added better Gnu Pascal support } -{ } -{ 2004-01-19 - DL : Under instruction from Marco van de Voort, I have added } -{ Better FPC support for FreeBSD. } -{ } -(* - $Log: jedi-sdl.inc,v $ - Revision 1.15 2007/05/29 21:30:48 savage - Changes as suggested by Almindor for 64bit compatibility. - - Revision 1.14 2007/05/20 20:29:11 savage - Initial Changes to Handle 64 Bits - - Revision 1.13 2007/01/21 15:51:45 savage - Added Delphi 2006 support - - Revision 1.12 2006/11/19 18:41:01 savage - removed THREADING ON flag as it is no longer needed in latest versions of FPC. - - Revision 1.11 2006/01/04 00:52:41 drellis - Updated to include defined for ENDIAN values, SDL_BYTEORDER should now be correctly defined depending onthe platform. Code taken from sdl_mixer - - Revision 1.10 2005/05/22 18:42:31 savage - Changes as suggested by Michalis Kamburelis. Thanks again. - - Revision 1.9 2004/12/23 23:42:17 savage - Applied Patches supplied by Michalis Kamburelis ( THANKS! ), for greater FreePascal compatability. - - Revision 1.8 2004/10/20 22:43:04 savage - Ensure that UNSAFE type warning are off in D9 as well - - Revision 1.7 2004/04/05 09:59:51 savage - Changes for FreePacal as suggested by Marco - - Revision 1.6 2004/03/31 22:18:15 savage - Small comment for turning off warning under GnuPascal - - Revision 1.5 2004/03/30 22:41:02 savage - Added extra commenting due to previous compiler directive - - Revision 1.4 2004/03/30 22:08:33 savage - Added Kylix Define - - Revision 1.3 2004/03/30 21:34:40 savage - {$H+} needed for FPC compatiblity - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - -*) -{******************************************************************************} - -{.$define Debug} { uncomment for debugging } - -{$IFNDEF FPC} - {$IFDEF __GPC__} - {$I-} - {$W-} // turn off GPC warnings - {$X+} - {$ELSE} {__GPC__} - {$IFDEF Debug} - {$F+,D+,Q-,L+,R+,I-,S+,Y+,A+} - {$ELSE} - {$F+,Q-,R-,S-,I-,A+} - {$ENDIF} - {$ENDIF} {__GPC__} -{$ELSE} {FPC} - //{$M+} -{$ENDIF} {FPC} - -{$IFDEF LINUX} -{$DEFINE UNIX} -{$ENDIF} - -{$IFDEF ver70} - {$IFDEF Windows} - {$DEFINE Win16} - {$ENDIF Windows} - {$IFDEF MSDOS} - {$DEFINE NO_EXPORTS} - {$ENDIF MSDOS} - {$IFDEF DPMI} - {$DEFINE BP_DPMI} - {$ENDIF} - {$DEFINE OS_16_BIT} - {$DEFINE __OS_DOS__} -{$ENDIF ver70} - -{$IFDEF ver80} - {$DEFINE Delphi} {Delphi 1.x} - {$DEFINE Delphi16} - {$DEFINE Win16} - {$DEFINE OS_16_BIT} - {$DEFINE __OS_DOS__} -{$ENDIF ver80} - -{$IFDEF ver90} - {$DEFINE Delphi} {Delphi 2.x} - {$DEFINE Delphi32} - {$DEFINE WIN32} - {$DEFINE WINDOWS} -{$ENDIF ver90} - -{$IFDEF ver100} - {$DEFINE Delphi} {Delphi 3.x} - {$DEFINE Delphi32} - {$DEFINE WIN32} - {$DEFINE WINDOWS} -{$ENDIF ver100} - -{$IFDEF ver93} - {$DEFINE Delphi} {C++ Builder 1.x} - {$DEFINE Delphi32} - {$DEFINE WINDOWS} -{$ENDIF ver93} - -{$IFDEF ver110} - {$DEFINE Delphi} {C++ Builder 3.x} - {$DEFINE Delphi32} - {$DEFINE WINDOWS} -{$ENDIF ver110} - -{$IFDEF ver120} - {$DEFINE Delphi} {Delphi 4.x} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Has_Int64} - {$DEFINE WINDOWS} -{$ENDIF ver120} - -{$IFDEF ver130} - {$DEFINE Delphi} {Delphi 5.x} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Has_Int64} - {$DEFINE WINDOWS} -{$ENDIF ver130} - -{$IFDEF ver140} - {$DEFINE Delphi} {Delphi 6.x} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Delphi6UP} - {$DEFINE Has_Int64} - {$DEFINE HAS_TYPES} -{$ENDIF ver140} - -{$IFDEF ver150} - {$DEFINE Delphi} {Delphi 7.x} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Delphi6UP} - {$DEFINE Delphi7UP} - {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} - {$DEFINE Has_Int64} - {$DEFINE HAS_TYPES} -{$ENDIF ver150} - -{$IFDEF ver160} - {$DEFINE Delphi} {Delphi 8} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Delphi6UP} - {$DEFINE Delphi7UP} - {$DEFINE Delphi8UP} - {$DEFINE Has_Int64} - {$DEFINE HAS_TYPES} -{$ENDIF ver160} - -{$IFDEF ver170} - {$DEFINE Delphi} {Delphi 2005} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Delphi6UP} - {$DEFINE Delphi7UP} - {$DEFINE Delphi8UP} - {$DEFINE Delphi9UP} - {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} - {$DEFINE Has_Int64} - {$DEFINE HAS_TYPES} -{$ENDIF ver170} - -{$IFDEF ver180} - {$DEFINE Delphi} {Delphi 2006} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Delphi6UP} - {$DEFINE Delphi7UP} - {$DEFINE Delphi8UP} - {$DEFINE Delphi9UP} - {$DEFINE Delphi10UP} - {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} - {$DEFINE Has_Int64} - {$DEFINE HAS_TYPES} -{$ENDIF ver180} - -{$IFDEF ver185} - {$DEFINE Delphi} {Delphi 2007} - {$DEFINE Delphi32} - {$DEFINE Delphi4UP} - {$DEFINE Delphi5UP} - {$DEFINE Delphi6UP} - {$DEFINE Delphi7UP} - {$DEFINE Delphi8UP} - {$DEFINE Delphi9UP} - {$DEFINE Delphi10UP} - {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} - {$DEFINE Has_Int64} - {$DEFINE HAS_TYPES} -{$ENDIF ver180} - -{$IFDEF UNIX} - {$ifdef VER140} // Kylix 1 & 2 - {$DEFINE KYLIX} - {$DEFINE KYLIX1UP} - {$DEFINE KYLIX2UP} - {$DEFINE HAS_TYPES} - {$endif} - - {$ifdef VER150} // Kylix 3 - {$DEFINE KYLIX} - {$DEFINE KYLIX1UP} - {$DEFINE KYLIX2UP} - {$DEFINE KYLIX3UP} - {$DEFINE HAS_TYPES} - {$endif} -{$ENDIF UNIX} - -{$IFDEF VirtualPascal} { Virtual Pascal 2.x } - {$DEFINE Delphi} { Use Delphi Syntax } - {$DEFINE VP2} - {&Delphi+} -{$ENDIF VirtualPascal} - -{$IFDEF Delphi} - {$DEFINE Windows} - {$DEFINE USE_STDCALL} - //{$ALIGN ON} -{$ENDIF Delphi} - -{$IFDEF FPC} - {$MODE Delphi} { use Delphi compatibility mode } - {$H+} - {$PACKRECORDS C} // Added for record - {$MACRO ON} // Added For OpenGL - {$DEFINE Delphi} - {$DEFINE UseAT} - {$UNDEF USE_STDCALL} - {$DEFINE OS_BigMem} - {$DEFINE NO_EXPORTS} - {$DEFINE Has_Int64} - {$DEFINE NOCRT} - {$IFDEF UNIX} - {$DEFINE fpc_unix} - {$ELSE} - {$DEFINE __OS_DOS__} - {$ENDIF} - {$IFDEF WIN32} - {$DEFINE UseWin} - {$ENDIF} - {$DEFINE HAS_TYPES} -{$ENDIF FPC} - -{$IFDEF Win16} - {$K+} {smart callbacks} -{$ENDIF Win16} - - {$IFDEF OS2} - {$UNDEF Windows} - {$DEFINE UseWin} - {$DEFINE OS_BigMem} - {$ENDIF OS2} - -{$IFDEF __GPC__} - {$UNDEF UseWin} - {$UNDEF USE_STDCALL} - {$DEFINE OS_BigMem} - {$DEFINE NO_EXPORTS} - {$DEFINE NOCRT} - {$DEFINE cdecl attribute(cdecl)} -{$ENDIF} - -{$IFDEF __TMT__} - {$DEFINE OS_BigMem} - {$DEFINE NO_EXPORTS} - {$DEFINE __OS_DOS__} - {$DEFINE UseAT} - {$IFNDEF MSDOS} - {$DEFINE USE_STDCALL} - {$ENDIF} - - {$IFDEF __WIN32__} - {$DEFINE Win32} - {$DEFINE UseWin} - {$DEFINE NOCRT} - {$DEFINE Win32} - {$IFNDEF __CON__} - {$DEFINE Windows} - {$ENDIF} - {$ENDIF} - - {$A+} // Word alignment data - {$OA+} // Objects and structures align -{$ENDIF} - -{$IFDEF Win32} - {$DEFINE OS_BigMem} -{$ELSE Win32} - {$IFDEF ver70} - {$DEFINE assembler} - {$ENDIF} { use 16-bit assembler! } -{$ENDIF Win32} - -{ ************************** dos/dos-like platforms **************} -{$IFDEF Windows} - {$DEFINE __OS_DOS__} - {$DEFINE UseWin} - {$DEFINE MSWINDOWS} -{$ENDIF Delphi} - -{$IFDEF OS2} - {$DEFINE __OS_DOS__} - {$DEFINE Can_Use_DLL} -{$ENDIF Delphi} - -{$IFDEF UseWin} - {$DEFINE Can_Use_DLL} -{$ENDIF} - -{$IFDEF Win16} - {$DEFINE Can_Use_DLL} -{$ENDIF} - -{$IFDEF BP_DPMI} - {$DEFINE Can_Use_DLL} -{$ENDIF} - -{$IFDEF USE_STDCALL} - {$IFNDEF __TMT__} - {$DEFINE BY_NAME} - {$ENDIF} -{$ENDIF} - -{$IFNDEF ver70} - {$UNDEF assembler} -{$ENDIF} - -{*************** define LITTLE ENDIAN platforms ********************} - - -{$IFDEF Delphi} -{$DEFINE IA32} -{$ENDIF} - -{$IFDEF KYLIX} -{$DEFINE IA32} -{$ENDIF} - -{$IFDEF FPC} -{$IFDEF FPC_LITTLE_ENDIAN} -{$DEFINE IA32} -{$ENDIF} -{$ENDIF} +{ + $Id: jedi-sdl.inc,v 1.15 2007/05/29 21:30:48 savage Exp $ +} +{******************************************************************************} +{ } +{ Borland Delphi SDL - Simple DirectMedia Layer } +{ Global Conditional Definitions for JEDI-SDL cross-compilation } +{ } +{ } +{ The initial developer of this Pascal code was : } +{ Prof. Abimbola Olowofoyeku } +{ } +{ Portions created by Prof. Abimbola Olowofoyeku are } +{ Copyright (C) 2000 - 2100 Prof. Abimbola Olowofoyeku. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Prof. Abimbola Olowofoyeku } +{ Dominqiue Louis } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ This code has been copied from... } +{ Global Conditional Definitions for Chief's UNZIP package } +{ By Prof. Abimbola Olowofoyeku (The African Chief) } +{ http://www.bigfoot.com/~African_Chief/ } +{ } +{ } +{ Requires } +{ -------- } +{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } +{ They are available from... } +{ http://www.libsdl.org . } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ 2003-04-03 DL - Initial addition } +{ } +{ 2003-04-07 DL - Added Macro ON derective for FPC and OpenGL and removed } +{ WEAKPACKAGE derective. WEAKPACKAGE should be set when } +{ appropriate. } +{ } +{ 2003-04-23 - DL : under instruction from Alexey Barkovoy I have added } +{ better TMT Pascal support and under instruction } +{ from Prof. Abimbola Olowofoyeku (The African Chief) } +{ I have added better Gnu Pascal support } +{ } +{ 2004-01-19 - DL : Under instruction from Marco van de Voort, I have added } +{ Better FPC support for FreeBSD. } +{ } +(* + $Log: jedi-sdl.inc,v $ + Revision 1.15 2007/05/29 21:30:48 savage + Changes as suggested by Almindor for 64bit compatibility. + + Revision 1.14 2007/05/20 20:29:11 savage + Initial Changes to Handle 64 Bits + + Revision 1.13 2007/01/21 15:51:45 savage + Added Delphi 2006 support + + Revision 1.12 2006/11/19 18:41:01 savage + removed THREADING ON flag as it is no longer needed in latest versions of FPC. + + Revision 1.11 2006/01/04 00:52:41 drellis + Updated to include defined for ENDIAN values, SDL_BYTEORDER should now be correctly defined depending onthe platform. Code taken from sdl_mixer + + Revision 1.10 2005/05/22 18:42:31 savage + Changes as suggested by Michalis Kamburelis. Thanks again. + + Revision 1.9 2004/12/23 23:42:17 savage + Applied Patches supplied by Michalis Kamburelis ( THANKS! ), for greater FreePascal compatability. + + Revision 1.8 2004/10/20 22:43:04 savage + Ensure that UNSAFE type warning are off in D9 as well + + Revision 1.7 2004/04/05 09:59:51 savage + Changes for FreePacal as suggested by Marco + + Revision 1.6 2004/03/31 22:18:15 savage + Small comment for turning off warning under GnuPascal + + Revision 1.5 2004/03/30 22:41:02 savage + Added extra commenting due to previous compiler directive + + Revision 1.4 2004/03/30 22:08:33 savage + Added Kylix Define + + Revision 1.3 2004/03/30 21:34:40 savage + {$H+} needed for FPC compatiblity + + Revision 1.2 2004/02/14 00:23:39 savage + As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. + +*) +{******************************************************************************} + +{.$define Debug} { uncomment for debugging } + +{$IFNDEF FPC} + {$IFDEF __GPC__} + {$I-} + {$W-} // turn off GPC warnings + {$X+} + {$ELSE} {__GPC__} + {$IFDEF Debug} + {$F+,D+,Q-,L+,R+,I-,S+,Y+,A+} + {$ELSE} + {$F+,Q-,R-,S-,I-,A+} + {$ENDIF} + {$ENDIF} {__GPC__} +{$ELSE} {FPC} + //{$M+} +{$ENDIF} {FPC} + +{$IFDEF LINUX} +{$DEFINE UNIX} +{$ENDIF} + +{$IFDEF ver70} + {$IFDEF Windows} + {$DEFINE Win16} + {$ENDIF Windows} + {$IFDEF MSDOS} + {$DEFINE NO_EXPORTS} + {$ENDIF MSDOS} + {$IFDEF DPMI} + {$DEFINE BP_DPMI} + {$ENDIF} + {$DEFINE OS_16_BIT} + {$DEFINE __OS_DOS__} +{$ENDIF ver70} + +{$IFDEF ver80} + {$DEFINE Delphi} {Delphi 1.x} + {$DEFINE Delphi16} + {$DEFINE Win16} + {$DEFINE OS_16_BIT} + {$DEFINE __OS_DOS__} +{$ENDIF ver80} + +{$IFDEF ver90} + {$DEFINE Delphi} {Delphi 2.x} + {$DEFINE Delphi32} + {$DEFINE WIN32} + {$DEFINE WINDOWS} +{$ENDIF ver90} + +{$IFDEF ver100} + {$DEFINE Delphi} {Delphi 3.x} + {$DEFINE Delphi32} + {$DEFINE WIN32} + {$DEFINE WINDOWS} +{$ENDIF ver100} + +{$IFDEF ver93} + {$DEFINE Delphi} {C++ Builder 1.x} + {$DEFINE Delphi32} + {$DEFINE WINDOWS} +{$ENDIF ver93} + +{$IFDEF ver110} + {$DEFINE Delphi} {C++ Builder 3.x} + {$DEFINE Delphi32} + {$DEFINE WINDOWS} +{$ENDIF ver110} + +{$IFDEF ver120} + {$DEFINE Delphi} {Delphi 4.x} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Has_Int64} + {$DEFINE WINDOWS} +{$ENDIF ver120} + +{$IFDEF ver130} + {$DEFINE Delphi} {Delphi 5.x} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Has_Int64} + {$DEFINE WINDOWS} +{$ENDIF ver130} + +{$IFDEF ver140} + {$DEFINE Delphi} {Delphi 6.x} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Delphi6UP} + {$DEFINE Has_Int64} + {$DEFINE HAS_TYPES} +{$ENDIF ver140} + +{$IFDEF ver150} + {$DEFINE Delphi} {Delphi 7.x} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Delphi6UP} + {$DEFINE Delphi7UP} + {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} + {$DEFINE Has_Int64} + {$DEFINE HAS_TYPES} +{$ENDIF ver150} + +{$IFDEF ver160} + {$DEFINE Delphi} {Delphi 8} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Delphi6UP} + {$DEFINE Delphi7UP} + {$DEFINE Delphi8UP} + {$DEFINE Has_Int64} + {$DEFINE HAS_TYPES} +{$ENDIF ver160} + +{$IFDEF ver170} + {$DEFINE Delphi} {Delphi 2005} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Delphi6UP} + {$DEFINE Delphi7UP} + {$DEFINE Delphi8UP} + {$DEFINE Delphi9UP} + {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} + {$DEFINE Has_Int64} + {$DEFINE HAS_TYPES} +{$ENDIF ver170} + +{$IFDEF ver180} + {$DEFINE Delphi} {Delphi 2006} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Delphi6UP} + {$DEFINE Delphi7UP} + {$DEFINE Delphi8UP} + {$DEFINE Delphi9UP} + {$DEFINE Delphi10UP} + {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} + {$DEFINE Has_Int64} + {$DEFINE HAS_TYPES} +{$ENDIF ver180} + +{$IFDEF ver185} + {$DEFINE Delphi} {Delphi 2007} + {$DEFINE Delphi32} + {$DEFINE Delphi4UP} + {$DEFINE Delphi5UP} + {$DEFINE Delphi6UP} + {$DEFINE Delphi7UP} + {$DEFINE Delphi8UP} + {$DEFINE Delphi9UP} + {$DEFINE Delphi10UP} + {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7} + {$DEFINE Has_Int64} + {$DEFINE HAS_TYPES} +{$ENDIF ver180} + +{$IFDEF UNIX} + {$ifdef VER140} // Kylix 1 & 2 + {$DEFINE KYLIX} + {$DEFINE KYLIX1UP} + {$DEFINE KYLIX2UP} + {$DEFINE HAS_TYPES} + {$endif} + + {$ifdef VER150} // Kylix 3 + {$DEFINE KYLIX} + {$DEFINE KYLIX1UP} + {$DEFINE KYLIX2UP} + {$DEFINE KYLIX3UP} + {$DEFINE HAS_TYPES} + {$endif} +{$ENDIF UNIX} + +{$IFDEF VirtualPascal} { Virtual Pascal 2.x } + {$DEFINE Delphi} { Use Delphi Syntax } + {$DEFINE VP2} + {&Delphi+} +{$ENDIF VirtualPascal} + +{$IFDEF Delphi} + {$DEFINE Windows} + {$DEFINE USE_STDCALL} + //{$ALIGN ON} +{$ENDIF Delphi} + +{$IFDEF FPC} + {$MODE Delphi} { use Delphi compatibility mode } + {$H+} + {$PACKRECORDS C} // Added for record + {$MACRO ON} // Added For OpenGL + {$DEFINE Delphi} + {$DEFINE UseAT} + {$UNDEF USE_STDCALL} + {$DEFINE OS_BigMem} + {$DEFINE NO_EXPORTS} + {$DEFINE Has_Int64} + {$DEFINE NOCRT} + {$IFDEF UNIX} + {$DEFINE fpc_unix} + {$ELSE} + {$DEFINE __OS_DOS__} + {$ENDIF} + {$IFDEF WIN32} + {$DEFINE UseWin} + {$ENDIF} + {$DEFINE HAS_TYPES} +{$ENDIF FPC} + +{$IFDEF Win16} + {$K+} {smart callbacks} +{$ENDIF Win16} + + {$IFDEF OS2} + {$UNDEF Windows} + {$DEFINE UseWin} + {$DEFINE OS_BigMem} + {$ENDIF OS2} + +{$IFDEF __GPC__} + {$UNDEF UseWin} + {$UNDEF USE_STDCALL} + {$DEFINE OS_BigMem} + {$DEFINE NO_EXPORTS} + {$DEFINE NOCRT} + {$DEFINE cdecl attribute(cdecl)} +{$ENDIF} + +{$IFDEF __TMT__} + {$DEFINE OS_BigMem} + {$DEFINE NO_EXPORTS} + {$DEFINE __OS_DOS__} + {$DEFINE UseAT} + {$IFNDEF MSDOS} + {$DEFINE USE_STDCALL} + {$ENDIF} + + {$IFDEF __WIN32__} + {$DEFINE Win32} + {$DEFINE UseWin} + {$DEFINE NOCRT} + {$DEFINE Win32} + {$IFNDEF __CON__} + {$DEFINE Windows} + {$ENDIF} + {$ENDIF} + + {$A+} // Word alignment data + {$OA+} // Objects and structures align +{$ENDIF} + +{$IFDEF Win32} + {$DEFINE OS_BigMem} +{$ELSE Win32} + {$IFDEF ver70} + {$DEFINE assembler} + {$ENDIF} { use 16-bit assembler! } +{$ENDIF Win32} + +{ ************************** dos/dos-like platforms **************} +{$IFDEF Windows} + {$DEFINE __OS_DOS__} + {$DEFINE UseWin} + {$DEFINE MSWINDOWS} +{$ENDIF Delphi} + +{$IFDEF OS2} + {$DEFINE __OS_DOS__} + {$DEFINE Can_Use_DLL} +{$ENDIF Delphi} + +{$IFDEF UseWin} + {$DEFINE Can_Use_DLL} +{$ENDIF} + +{$IFDEF Win16} + {$DEFINE Can_Use_DLL} +{$ENDIF} + +{$IFDEF BP_DPMI} + {$DEFINE Can_Use_DLL} +{$ENDIF} + +{$IFDEF USE_STDCALL} + {$IFNDEF __TMT__} + {$DEFINE BY_NAME} + {$ENDIF} +{$ENDIF} + +{$IFNDEF ver70} + {$UNDEF assembler} +{$ENDIF} + +{*************** define LITTLE ENDIAN platforms ********************} + + +{$IFDEF Delphi} +{$DEFINE IA32} +{$ENDIF} + +{$IFDEF KYLIX} +{$DEFINE IA32} +{$ENDIF} + +{$IFDEF FPC} +{$IFDEF FPC_LITTLE_ENDIAN} +{$DEFINE IA32} +{$ENDIF} +{$ENDIF} diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas index 0cdf44c7..63e7b7fb 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas @@ -1,2688 +1,2688 @@ -(** -=============================================================================================== -Name : LibXmlParser -=============================================================================================== -Project : All Projects -=============================================================================================== -Subject : Progressive XML Parser for all types of XML Files -=============================================================================================== -Author : Stefan Heymann - Eschenweg 3 - 72076 Tübingen - GERMANY - -E-Mail: stefan@destructor.de -URL: www.destructor.de -=============================================================================================== -Source, Legals ("Licence") --------------------------- -The official site to get this parser is http://www.destructor.de/ - -Usage and Distribution of this Source Code is ruled by the -"Destructor.de Source code Licence" (DSL) which comes with this file or -can be downloaded at http://www.destructor.de/ - -IN SHORT: Usage and distribution of this source code is free. - You use it completely on your own risk. - -Postcardware ------------- -If you like this code, please send a postcard of your city to my above address. -=============================================================================================== -!!! All parts of this code which are not finished or not conforming exactly to - the XmlSpec are marked with three exclamation marks - --!- Parts where the parser may be able to detect errors in the document's syntax are - marked with the dash-exlamation mark-dash sequence. -=============================================================================================== -Terminology: ------------- -- Start: Start of a buffer part -- Final: End (last character) of a buffer part -- DTD: Document Type Definition -- DTDc: Document Type Declaration -- XMLSpec: The current W3C XML Recommendation (version 1.0 as of 1998-02-10), Chapter No. -- Cur*: Fields concerning the "Current" part passed back by the "Scan" method -=============================================================================================== -Scanning the XML document -------------------------- -- Create TXmlParser Instance MyXml := TXmlParser.Create; -- Load XML Document MyXml.LoadFromFile (Filename); -- Start Scanning MyXml.StartScan; -- Scan Loop WHILE MyXml.Scan DO -- Test for Part Type CASE MyXml.CurPartType OF -- Handle Parts ... : ;;; -- Handle Parts ... : ;;; -- Handle Parts ... : ;;; - END; -- Destroy MyXml.Free; -=============================================================================================== -Loading the XML document ------------------------- -You can load the XML document from a file with the "LoadFromFile" method. -It is beyond the scope of this parser to perform HTTP or FTP accesses. If you want your -application to handle such requests (URLs), you can load the XML via HTTP or FTP or whatever -protocol and hand over the data buffer using the "LoadFromBuffer" or "SetBuffer" method. -"LoadFromBuffer" loads the internal buffer of TXmlParser with the given null-terminated -string, thereby creating a copy of that buffer. -"SetBuffer" just takes the pointer to another buffer, which means that the given -buffer pointer must be valid while the document is accessed via TXmlParser. -=============================================================================================== -Encodings: ----------- -This XML parser kind of "understands" the following encodings: -- UTF-8 -- ISO-8859-1 -- Windows-1252 - -Any flavor of multi-byte characters (and this includes UTF-16) is not supported. Sorry. - -Every string which has to be passed to the application passes the virtual method -"TranslateEncoding" which translates the string from the current encoding (stored in -"CurEncoding") into the encoding the application wishes to receive. -The "TranslateEncoding" method that is built into TXmlParser assumes that the application -wants to receive Windows ANSI (Windows-1252, about the same as ISO-8859-1) and is able -to convert UTF-8 and ISO-8859-1 encodings. -For other source and target encodings, you will have to override "TranslateEncoding". -=============================================================================================== -Buffer Handling ---------------- -- The document must be loaded completely into a piece of RAM -- All character positions are referenced by PChar pointers -- The TXmlParser instance can either "own" the buffer itself (then, FBufferSize is > 0) - or reference the buffer of another instance or object (then, FBuffersize is 0 and - FBuffer is not NIL) -- The Property DocBuffer passes back a pointer to the first byte of the document. If there - is no document stored (FBuffer is NIL), the DocBuffer returns a pointer to a NULL character. -=============================================================================================== -Whitespace Handling -------------------- -The TXmlParser property "PackSpaces" determines how Whitespace is returned in Text Content: -While PackSpaces is true, all leading and trailing whitespace characters are trimmed of, all -Whitespace is converted to Space #x20 characters and contiguous Whitespace characters are -compressed to one. -If the "Scan" method reports a ptContent part, the application can get the original text -with all whitespace characters by extracting the characters from "CurStart" to "CurFinal". -If the application detects an xml:space attribute, it can set "PackSpaces" accordingly or -use CurStart/CurFinal. -Please note that TXmlParser does _not_ normalize Line Breaks to single LineFeed characters -as the XmlSpec requires (XmlSpec 2.11). -The xml:space attribute is not handled by TXmlParser. This is on behalf of the application. -=============================================================================================== -Non-XML-Conforming ------------------- -TXmlParser does not conform 100 % exactly to the XmlSpec: -- UTF-16 is not supported (XmlSpec 2.2) - (Workaround: Convert UTF-16 to UTF-8 and hand the buffer over to TXmlParser) -- As the parser only works with single byte strings, all Unicode characters > 255 - can currently not be handled correctly. -- Line breaks are not normalized to single Linefeed #x0A characters (XmlSpec 2.11) - (Workaround: The Application can access the text contents on its own [CurStart, CurFinal], - thereby applying every normalization it wishes to) -- The attribute value normalization does not work exactly as defined in the - Second Edition of the XML 1.0 specification. -- See also the code parts marked with three consecutive exclamation marks. These are - parts which are not finished in the current code release. - -This list may be incomplete, so it may grow if I get to know any other points. -As work on the parser proceeds, this list may also shrink. -=============================================================================================== -Things Todo ------------ -- Introduce a new event/callback which is called when there is an unresolvable - entity or character reference -- Support Unicode -- Use Streams instead of reading the whole XML into memory -=============================================================================================== -Change History, Version numbers -------------------------------- -The Date is given in ISO Year-Month-Day (YYYY-MM-DD) order. -Versions are counted from 1.0.0 beginning with the version from 2000-03-16. -Unreleased versions don't get a version number. - -Date Author Version Changes ------------------------------------------------------------------------------------------------ -2000-03-16 HeySt 1.0.0 Start -2000-03-28 HeySt 1.0.1 Initial Publishing of TXmlParser on the destructor.de Web Site -2000-03-30 HeySt 1.0.2 TXmlParser.AnalyzeCData: Call "TranslateEncoding" for CurContent -2000-03-31 HeySt 1.0.3 Deleted the StrPosE function (was not needed anyway) -2000-04-04 HeySt 1.0.4 TDtdElementRec modified: Start/Final for all Elements; - Should be backwards compatible. - AnalyzeDtdc: Set CurPartType to ptDtdc -2000-04-23 HeySt 1.0.5 New class TObjectList. Eliminated reference to the Delphi 5 - "Contnrs" unit so LibXmlParser is Delphi 4 compatible. -2000-07-03 HeySt 1.0.6 TNvpNode: Added Constructor -2000-07-11 HeySt 1.0.7 Removed "Windows" from USES clause - Added three-exclamation-mark comments for Utf8ToAnsi/AnsiToUtf8 - Added three-exclamation-mark comments for CHR function calls -2000-07-23 HeySt 1.0.8 TXmlParser.Clear: CurAttr.Clear; EntityStack.Clear; - (This was not a bug; just defensive programming) -2000-07-29 HeySt 1.0.9 TNvpList: Added methods: Node(Index), Value(Index), Name(Index); -2000-10-07 HeySt Introduced Conditional Defines - Uses Contnrs unit and its TObjectList class again for - Delphi 5 and newer versions -2001-01-30 HeySt Introduced Version Numbering - Made LoadFromFile and LoadFromBuffer BOOLEAN functions - Introduced FileMode parameter for LoadFromFile - BugFix: TAttrList.Analyze: Must add CWhitespace to ExtractName call - Comments worked over -2001-02-28 HeySt 1.0.10 Completely worked over and tested the UTF-8 functions - Fixed a bug in TXmlParser.Scan which caused it to start over when it - was called after the end of scanning, resulting in an endless loop - TEntityStack is now a TObjectList instead of TList -2001-07-03 HeySt 1.0.11 Updated Compiler Version IFDEFs for Kylix -2001-07-11 HeySt 1.0.12 New TCustomXmlScanner component (taken over from LibXmlComps.pas) -2001-07-14 HeySt 1.0.13 Bugfix TCustomXmlScanner.FOnTranslateEncoding -2001-10-22 HeySt Don't clear CurName anymore when the parser finds a CDATA section. -2001-12-03 HeySt 1.0.14 TObjectList.Clear: Make call to INHERITED method (fixes a memory leak) -2001-12-05 HeySt 1.0.15 TObjectList.Clear: removed call to INHERITED method - TObjectList.Destroy: Inserted SetCapacity call. - Reduces need for frequent re-allocation of pointer buffer - Dedicated to my father, Theodor Heymann -2002-06-26 HeySt 1.0.16 TXmlParser.Scan: Fixed a bug with PIs whose name is beginning - with 'xml'. Thanks to Uwe Kamm for submitting this bug. - The CurEncoding property is now always in uppercase letters (the XML - spec wants it to be treated case independently so when it's uppercase - comparisons are faster) -2002-03-04 HeySt 1.0.17 Included an IFDEF for Delphi 7 (VER150) and Kylix - There is a new symbol HAS_CONTNRS_UNIT which is used now to - distinguish between IDEs which come with the Contnrs unit and - those that don't. -*) - -UNIT libxmlparser; - -{$I jedi-sdl.inc} - -INTERFACE - -USES - SysUtils, Classes, - (*$IFDEF HAS_CONTNRS_UNIT *) // The Contnrs Unit was introduced in Delphi 5 - Contnrs, - (*$ENDIF*) - Math; - -CONST - CVersion = '1.0.17'; // This variable will be updated for every release - // (I hope, I won't forget to do it everytime ...) - -TYPE - TPartType = // --- Document Part Types - (ptNone, // Nothing - ptXmlProlog, // XML Prolog XmlSpec 2.8 / 4.3.1 - ptComment, // Comment XmlSpec 2.5 - ptPI, // Processing Instruction XmlSpec 2.6 - ptDtdc, // Document Type Declaration XmlSpec 2.8 - ptStartTag, // Start Tag XmlSpec 3.1 - ptEmptyTag, // Empty-Element Tag XmlSpec 3.1 - ptEndTag, // End Tag XmlSpec 3.1 - ptContent, // Text Content between Tags - ptCData); // CDATA Section XmlSpec 2.7 - - TDtdElemType = // --- DTD Elements - (deElement, // !ELEMENT declaration - deAttList, // !ATTLIST declaration - deEntity, // !ENTITY declaration - deNotation, // !NOTATION declaration - dePI, // PI in DTD - deComment, // Comment in DTD - deError); // Error found in the DTD - -TYPE - TAttrList = CLASS; - TEntityStack = CLASS; - TNvpList = CLASS; - TElemDef = CLASS; - TElemList = CLASS; - TEntityDef = CLASS; - TNotationDef = CLASS; - - TDtdElementRec = RECORD // --- This Record is returned by the DTD parser callback function - Start, Final : PChar; // Start/End of the Element's Declaration - CASE ElementType : TDtdElemType OF // Type of the Element - deElement, // - deAttList : (ElemDef : TElemDef); // - deEntity : (EntityDef : TEntityDef); // - deNotation : (NotationDef : TNotationDef); // - dePI : (Target : PChar; // - Content : PChar; - AttrList : TAttrList); - deError : (Pos : PChar); // Error - // deComment : ((No additional fields here)); // - END; - - TXmlParser = CLASS // --- Internal Properties and Methods - PROTECTED - FBuffer : PChar; // NIL if there is no buffer available - FBufferSize : INTEGER; // 0 if the buffer is not owned by the Document instance - FSource : STRING; // Name of Source of document. Filename for Documents loaded with LoadFromFile - - FXmlVersion : STRING; // XML version from Document header. Default is '1.0' - FEncoding : STRING; // Encoding from Document header. Default is 'UTF-8' - FStandalone : BOOLEAN; // Standalone declaration from Document header. Default is 'yes' - FRootName : STRING; // Name of the Root Element (= DTD name) - FDtdcFinal : PChar; // Pointer to the '>' character terminating the DTD declaration - - FNormalize : BOOLEAN; // If true: Pack Whitespace and don't return empty contents - EntityStack : TEntityStack; // Entity Stack for Parameter and General Entities - FCurEncoding : STRING; // Current Encoding during parsing (always uppercase) - - PROCEDURE AnalyzeProlog; // Analyze XML Prolog or Text Declaration - PROCEDURE AnalyzeComment (Start : PChar; VAR Final : PChar); // Analyze Comments - PROCEDURE AnalyzePI (Start : PChar; VAR Final : PChar); // Analyze Processing Instructions (PI) - PROCEDURE AnalyzeDtdc; // Analyze Document Type Declaration - PROCEDURE AnalyzeDtdElements (Start : PChar; VAR Final : PChar); // Analyze DTD declarations - PROCEDURE AnalyzeTag; // Analyze Start/End/Empty-Element Tags - PROCEDURE AnalyzeCData; // Analyze CDATA Sections - PROCEDURE AnalyzeText (VAR IsDone : BOOLEAN); // Analyze Text Content between Tags - PROCEDURE AnalyzeElementDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); - - PROCEDURE PushPE (VAR Start : PChar); - PROCEDURE ReplaceCharacterEntities (VAR Str : STRING); - PROCEDURE ReplaceParameterEntities (VAR Str : STRING); - PROCEDURE ReplaceGeneralEntities (VAR Str : STRING); - - FUNCTION GetDocBuffer : PChar; // Returns FBuffer or a pointer to a NUL char if Buffer is empty - - PUBLIC // --- Document Properties - PROPERTY XmlVersion : STRING READ FXmlVersion; // XML version from the Document Prolog - PROPERTY Encoding : STRING READ FEncoding; // Document Encoding from Prolog - PROPERTY Standalone : BOOLEAN READ FStandalone; // Standalone Declaration from Prolog - PROPERTY RootName : STRING READ FRootName; // Name of the Root Element - PROPERTY Normalize : BOOLEAN READ FNormalize WRITE FNormalize; // True if Content is to be normalized - PROPERTY Source : STRING READ FSource; // Name of Document Source (Filename) - PROPERTY DocBuffer : PChar READ GetDocBuffer; // Returns document buffer - PUBLIC // --- DTD Objects - Elements : TElemList; // Elements: List of TElemDef (contains Attribute Definitions) - Entities : TNvpList; // General Entities: List of TEntityDef - ParEntities : TNvpList; // Parameter Entities: List of TEntityDef - Notations : TNvpList; // Notations: List of TNotationDef - PUBLIC - CONSTRUCTOR Create; - DESTRUCTOR Destroy; OVERRIDE; - - // --- Document Handling - FUNCTION LoadFromFile (Filename : STRING; - FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; - // Loads Document from given file - FUNCTION LoadFromBuffer (Buffer : PChar) : BOOLEAN; // Loads Document from another buffer - PROCEDURE SetBuffer (Buffer : PChar); // References another buffer - PROCEDURE Clear; // Clear Document - - PUBLIC - // --- Scanning through the document - CurPartType : TPartType; // Current Type - CurName : STRING; // Current Name - CurContent : STRING; // Current Normalized Content - CurStart : PChar; // Current First character - CurFinal : PChar; // Current Last character - CurAttr : TAttrList; // Current Attribute List - PROPERTY CurEncoding : STRING READ FCurEncoding; // Current Encoding - PROCEDURE StartScan; - FUNCTION Scan : BOOLEAN; - - // --- Events / Callbacks - FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : STRING) : TXmlParser; VIRTUAL; - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; VIRTUAL; - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); VIRTUAL; - END; - - TValueType = // --- Attribute Value Type - (vtNormal, // Normal specified Attribute - vtImplied, // #IMPLIED attribute value - vtFixed, // #FIXED attribute value - vtDefault); // Attribute value from default value in !ATTLIST declaration - - TAttrDefault = // --- Attribute Default Type - (adDefault, // Normal default value - adRequired, // #REQUIRED attribute - adImplied, // #IMPLIED attribute - adFixed); // #FIXED attribute - - TAttrType = // --- Type of attribute - (atUnknown, // Unknown type - atCData, // Character data only - atID, // ID - atIdRef, // ID Reference - atIdRefs, // Several ID References, separated by Whitespace - atEntity, // Name of an unparsed Entity - atEntities, // Several unparsed Entity names, separated by Whitespace - atNmToken, // Name Token - atNmTokens, // Several Name Tokens, separated by Whitespace - atNotation, // A selection of Notation names (Unparsed Entity) - atEnumeration); // Enumeration - - TElemType = // --- Element content type - (etEmpty, // Element is always empty - etAny, // Element can have any mixture of PCDATA and any elements - etChildren, // Element must contain only elements - etMixed); // Mixed PCDATA and elements - - (*$IFDEF HAS_CONTNRS_UNIT *) - TObjectList = Contnrs.TObjectList; // Re-Export this identifier - (*$ELSE *) - TObjectList = CLASS (TList) - DESTRUCTOR Destroy; OVERRIDE; - PROCEDURE Delete (Index : INTEGER); - PROCEDURE Clear; OVERRIDE; - END; - (*$ENDIF *) - - TNvpNode = CLASS // Name-Value Pair Node - Name : STRING; - Value : STRING; - CONSTRUCTOR Create (TheName : STRING = ''; TheValue : STRING = ''); - END; - - TNvpList = CLASS (TObjectList) // Name-Value Pair List - PROCEDURE Add (Node : TNvpNode); - FUNCTION Node (Name : STRING) : TNvpNode; OVERLOAD; - FUNCTION Node (Index : INTEGER) : TNvpNode; OVERLOAD; - FUNCTION Value (Name : STRING) : STRING; OVERLOAD; - FUNCTION Value (Index : INTEGER) : STRING; OVERLOAD; - FUNCTION Name (Index : INTEGER) : STRING; - END; - - TAttr = CLASS (TNvpNode) // Attribute of a Start-Tag or Empty-Element-Tag - ValueType : TValueType; - AttrType : TAttrType; - END; - - TAttrList = CLASS (TNvpList) // List of Attributes - PROCEDURE Analyze (Start : PChar; VAR Final : PChar); - END; - - TEntityStack = CLASS (TObjectList) // Stack where current position is stored before parsing entities - PROTECTED - Owner : TXmlParser; - PUBLIC - CONSTRUCTOR Create (TheOwner : TXmlParser); - PROCEDURE Push (LastPos : PChar); OVERLOAD; - PROCEDURE Push (Instance : TObject; LastPos : PChar); OVERLOAD; - FUNCTION Pop : PChar; // Returns next char or NIL if EOF is reached. Frees Instance. - END; - - TAttrDef = CLASS (TNvpNode) // Represents a '; - - // --- Name Constants for the above enumeration types - CPartType_Name : ARRAY [TPartType] OF STRING = - ('', 'XML Prolog', 'Comment', 'PI', - 'DTD Declaration', 'Start Tag', 'Empty Tag', 'End Tag', - 'Text', 'CDATA'); - CValueType_Name : ARRAY [TValueType] OF STRING = ('Normal', 'Implied', 'Fixed', 'Default'); - CAttrDefault_Name : ARRAY [TAttrDefault] OF STRING = ('Default', 'Required', 'Implied', 'Fixed'); - CElemType_Name : ARRAY [TElemType] OF STRING = ('Empty', 'Any', 'Childs only', 'Mixed'); - CAttrType_Name : ARRAY [TAttrType] OF STRING = ('Unknown', 'CDATA', - 'ID', 'IDREF', 'IDREFS', - 'ENTITY', 'ENTITIES', - 'NMTOKEN', 'NMTOKENS', - 'Notation', 'Enumeration'); - -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; // Convert WS to spaces #x20 -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); // SetString by Start/Final of buffer -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; // Convert buffer part to Pascal string -FUNCTION TrimWs (Source : STRING) : STRING; // Trim Whitespace - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; // Convert Win-1252 to UTF-8 -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; // Convert UTF-8 to Win-1252 - - -(* -=============================================================================================== -TCustomXmlScanner event based component wrapper for TXmlParser -=============================================================================================== -*) - -TYPE - TCustomXmlScanner = CLASS; - TXmlPrologEvent = PROCEDURE (Sender : TObject; XmlVersion, Encoding: STRING; Standalone : BOOLEAN) OF OBJECT; - TCommentEvent = PROCEDURE (Sender : TObject; Comment : STRING) OF OBJECT; - TPIEvent = PROCEDURE (Sender : TObject; Target, Content: STRING; Attributes : TAttrList) OF OBJECT; - TDtdEvent = PROCEDURE (Sender : TObject; RootElementName : STRING) OF OBJECT; - TStartTagEvent = PROCEDURE (Sender : TObject; TagName : STRING; Attributes : TAttrList) OF OBJECT; - TEndTagEvent = PROCEDURE (Sender : TObject; TagName : STRING) OF OBJECT; - TContentEvent = PROCEDURE (Sender : TObject; Content : STRING) OF OBJECT; - TElementEvent = PROCEDURE (Sender : TObject; ElemDef : TElemDef) OF OBJECT; - TEntityEvent = PROCEDURE (Sender : TObject; EntityDef : TEntityDef) OF OBJECT; - TNotationEvent = PROCEDURE (Sender : TObject; NotationDef : TNotationDef) OF OBJECT; - TErrorEvent = PROCEDURE (Sender : TObject; ErrorPos : PChar) OF OBJECT; - TExternalEvent = PROCEDURE (Sender : TObject; SystemId, PublicId, NotationId : STRING; - VAR Result : TXmlParser) OF OBJECT; - TEncodingEvent = FUNCTION (Sender : TObject; CurrentEncoding, Source : STRING) : STRING OF OBJECT; - - - TCustomXmlScanner = CLASS (TComponent) - PROTECTED - FXmlParser : TXmlParser; - FOnXmlProlog : TXmlPrologEvent; - FOnComment : TCommentEvent; - FOnPI : TPIEvent; - FOnDtdRead : TDtdEvent; - FOnStartTag : TStartTagEvent; - FOnEmptyTag : TStartTagEvent; - FOnEndTag : TEndTagEvent; - FOnContent : TContentEvent; - FOnCData : TContentEvent; - FOnElement : TElementEvent; - FOnAttList : TElementEvent; - FOnEntity : TEntityEvent; - FOnNotation : TNotationEvent; - FOnDtdError : TErrorEvent; - FOnLoadExternal : TExternalEvent; - FOnTranslateEncoding : TEncodingEvent; - FStopParser : BOOLEAN; - FUNCTION GetNormalize : BOOLEAN; - PROCEDURE SetNormalize (Value : BOOLEAN); - - PROCEDURE WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); VIRTUAL; - PROCEDURE WhenComment (Comment : STRING); VIRTUAL; - PROCEDURE WhenPI (Target, Content: STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenDtdRead (RootElementName : STRING); VIRTUAL; - PROCEDURE WhenStartTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenEmptyTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenEndTag (TagName : STRING); VIRTUAL; - PROCEDURE WhenContent (Content : STRING); VIRTUAL; - PROCEDURE WhenCData (Content : STRING); VIRTUAL; - PROCEDURE WhenElement (ElemDef : TElemDef); VIRTUAL; - PROCEDURE WhenAttList (ElemDef : TElemDef); VIRTUAL; - PROCEDURE WhenEntity (EntityDef : TEntityDef); VIRTUAL; - PROCEDURE WhenNotation (NotationDef : TNotationDef); VIRTUAL; - PROCEDURE WhenDtdError (ErrorPos : PChar); VIRTUAL; - - PUBLIC - CONSTRUCTOR Create (AOwner: TComponent); OVERRIDE; - DESTRUCTOR Destroy; OVERRIDE; - - PROCEDURE LoadFromFile (Filename : TFilename); // Load XML Document from file - PROCEDURE LoadFromBuffer (Buffer : PChar); // Load XML Document from buffer - PROCEDURE SetBuffer (Buffer : PChar); // Refer to Buffer - FUNCTION GetFilename : TFilename; - - PROCEDURE Execute; // Perform scanning - - PROTECTED - PROPERTY XmlParser : TXmlParser READ FXmlParser; - PROPERTY StopParser : BOOLEAN READ FStopParser WRITE FStopParser; - PROPERTY Filename : TFilename READ GetFilename WRITE LoadFromFile; - PROPERTY Normalize : BOOLEAN READ GetNormalize WRITE SetNormalize; - PROPERTY OnXmlProlog : TXmlPrologEvent READ FOnXmlProlog WRITE FOnXmlProlog; - PROPERTY OnComment : TCommentEvent READ FOnComment WRITE FOnComment; - PROPERTY OnPI : TPIEvent READ FOnPI WRITE FOnPI; - PROPERTY OnDtdRead : TDtdEvent READ FOnDtdRead WRITE FOnDtdRead; - PROPERTY OnStartTag : TStartTagEvent READ FOnStartTag WRITE FOnStartTag; - PROPERTY OnEmptyTag : TStartTagEvent READ FOnEmptyTag WRITE FOnEmptyTag; - PROPERTY OnEndTag : TEndTagEvent READ FOnEndTag WRITE FOnEndTag; - PROPERTY OnContent : TContentEvent READ FOnContent WRITE FOnContent; - PROPERTY OnCData : TContentEvent READ FOnCData WRITE FOnCData; - PROPERTY OnElement : TElementEvent READ FOnElement WRITE FOnElement; - PROPERTY OnAttList : TElementEvent READ FOnAttList WRITE FOnAttList; - PROPERTY OnEntity : TEntityEvent READ FOnEntity WRITE FOnEntity; - PROPERTY OnNotation : TNotationEvent READ FOnNotation WRITE FOnNotation; - PROPERTY OnDtdError : TErrorEvent READ FOnDtdError WRITE FOnDtdError; - PROPERTY OnLoadExternal : TExternalEvent READ FOnLoadExternal WRITE FOnLoadExternal; - PROPERTY OnTranslateEncoding : TEncodingEvent READ FOnTranslateEncoding WRITE FOnTranslateEncoding; - END; - -(* -=============================================================================================== -IMPLEMENTATION -=============================================================================================== -*) - -IMPLEMENTATION - - -(* -=============================================================================================== -Unicode and UTF-8 stuff -=============================================================================================== -*) - -CONST - // --- Character Translation Table for Unicode <-> Win-1252 - WIN1252_UNICODE : ARRAY [$00..$FF] OF WORD = ( - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, - - $20AC, $0081, $201A, $0192, $201E, $2026, $2020, $2021, $02C6, $2030, - $0160, $2039, $0152, $008D, $017D, $008F, $0090, $2018, $2019, $201C, - $201D, $2022, $2013, $2014, $02DC, $2122, $0161, $203A, $0153, $009D, - $017E, $0178, $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, $00B0, $00B1, - $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, $00B8, $00B9, $00BA, $00BB, - $00BC, $00BD, $00BE, $00BF, $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, - $00C6, $00C7, $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, $00D8, $00D9, - $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, $00E0, $00E1, $00E2, $00E3, - $00E4, $00E5, $00E6, $00E7, $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, - $00EE, $00EF, $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF); - -(* UTF-8 (somewhat simplified) - ----- - Character Range Byte sequence - --------------- -------------------------- (x=Bits from original character) - $0000..$007F 0xxxxxxx - $0080..$07FF 110xxxxx 10xxxxxx - $8000..$FFFF 1110xxxx 10xxxxxx 10xxxxxx - - Example - -------- - Transforming the Unicode character U+00E4 LATIN SMALL LETTER A WITH DIAERESIS ("ä"): - - ISO-8859-1, Decimal 228 - Win1252, Hex $E4 - ANSI Bin 1110 0100 - abcd efgh - - UTF-8 Binary 1100xxab 10cdefgh - Binary 11000011 10100100 - Hex $C3 $A4 - Decimal 195 164 - ANSI Ã ¤ *) - - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; - (* Converts the given Windows ANSI (Win1252) String to UTF-8. *) -VAR - I : INTEGER; // Loop counter - U : WORD; // Current Unicode value - Len : INTEGER; // Current real length of "Result" string -BEGIN - SetLength (Result, Length (Source) * 3); // Worst case - Len := 0; - FOR I := 1 TO Length (Source) DO BEGIN - U := WIN1252_UNICODE [ORD (Source [I])]; - CASE U OF - $0000..$007F : BEGIN - INC (Len); - Result [Len] := CHR (U); - END; - $0080..$07FF : BEGIN - INC (Len); - Result [Len] := CHR ($C0 OR (U SHR 6)); - INC (Len); - Result [Len] := CHR ($80 OR (U AND $3F)); - END; - $0800..$FFFF : BEGIN - INC (Len); - Result [Len] := CHR ($E0 OR (U SHR 12)); - INC (Len); - Result [Len] := CHR ($80 OR ((U SHR 6) AND $3F)); - INC (Len); - Result [Len] := CHR ($80 OR (U AND $3F)); - END; - END; - END; - SetLength (Result, Len); -END; - - -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; - (* Converts the given UTF-8 String to Windows ANSI (Win-1252). - If a character can not be converted, the "UnknownChar" is inserted. *) -VAR - SourceLen : INTEGER; // Length of Source string - I, K : INTEGER; - A : BYTE; // Current ANSI character value - U : WORD; - Ch : CHAR; // Dest char - Len : INTEGER; // Current real length of "Result" string -BEGIN - SourceLen := Length (Source); - SetLength (Result, SourceLen); // Enough room to live - Len := 0; - I := 1; - WHILE I <= SourceLen DO BEGIN - A := ORD (Source [I]); - IF A < $80 THEN BEGIN // Range $0000..$007F - INC (Len); - Result [Len] := Source [I]; - INC (I); - END - ELSE BEGIN // Determine U, Inc I - IF (A AND $E0 = $C0) AND (I < SourceLen) THEN BEGIN // Range $0080..$07FF - U := (WORD (A AND $1F) SHL 6) OR (ORD (Source [I+1]) AND $3F); - INC (I, 2); - END - ELSE IF (A AND $F0 = $E0) AND (I < SourceLen-1) THEN BEGIN // Range $0800..$FFFF - U := (WORD (A AND $0F) SHL 12) OR - (WORD (ORD (Source [I+1]) AND $3F) SHL 6) OR - ( ORD (Source [I+2]) AND $3F); - INC (I, 3); - END - ELSE BEGIN // Unknown/unsupported - INC (I); - FOR K := 7 DOWNTO 0 DO - IF A AND (1 SHL K) = 0 THEN BEGIN - INC (I, (A SHR (K+1))-1); - BREAK; - END; - U := WIN1252_UNICODE [ORD (UnknownChar)]; - END; - Ch := UnknownChar; // Retrieve ANSI char - FOR A := $00 TO $FF DO - IF WIN1252_UNICODE [A] = U THEN BEGIN - Ch := CHR (A); - BREAK; - END; - INC (Len); - Result [Len] := Ch; - END; - END; - SetLength (Result, Len); -END; - - -(* -=============================================================================================== -"Special" Helper Functions - -Don't ask me why. But including these functions makes the parser *DRAMATICALLY* faster -on my K6-233 machine. You can test it yourself just by commenting them out. -They do exactly the same as the Assembler routines defined in SysUtils. -(This is where you can see how great the Delphi compiler really is. The compiled code is -faster than hand-coded assembler!) -=============================================================================================== ---> Just move this line below the StrScan function --> *) - - -FUNCTION StrPos (CONST Str, SearchStr : PChar) : PChar; - // Same functionality as SysUtils.StrPos -VAR - First : CHAR; - Len : INTEGER; -BEGIN - First := SearchStr^; - Len := StrLen (SearchStr); - Result := Str; - REPEAT - IF Result^ = First THEN - IF StrLComp (Result, SearchStr, Len) = 0 THEN BREAK; - IF Result^ = #0 THEN BEGIN - Result := NIL; - BREAK; - END; - INC (Result); - UNTIL FALSE; -END; - - -FUNCTION StrScan (CONST Start : PChar; CONST Ch : CHAR) : PChar; - // Same functionality as SysUtils.StrScan -BEGIN - Result := Start; - WHILE Result^ <> Ch DO BEGIN - IF Result^ = #0 THEN BEGIN - Result := NIL; - EXIT; - END; - INC (Result); - END; -END; - - -(* -=============================================================================================== -Helper Functions -=============================================================================================== -*) - -FUNCTION DelChars (Source : STRING; CharsToDelete : TCharset) : STRING; - // Delete all "CharsToDelete" from the string -VAR - I : INTEGER; -BEGIN - Result := Source; - FOR I := Length (Result) DOWNTO 1 DO - IF Result [I] IN CharsToDelete THEN - Delete (Result, I, 1); -END; - - -FUNCTION TrimWs (Source : STRING) : STRING; - // Trimms off Whitespace characters from both ends of the string -VAR - I : INTEGER; -BEGIN - // --- Trim Left - I := 1; - WHILE (I <= Length (Source)) AND (Source [I] IN CWhitespace) DO - INC (I); - Result := Copy (Source, I, MaxInt); - - // --- Trim Right - I := Length (Result); - WHILE (I > 1) AND (Result [I] IN CWhitespace) DO - DEC (I); - Delete (Result, I+1, Length (Result)-I); -END; - - -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; - // Converts all Whitespace characters to the Space #x20 character - // If "PackWs" is true, contiguous Whitespace characters are packed to one -VAR - I : INTEGER; -BEGIN - Result := Source; - FOR I := Length (Result) DOWNTO 1 DO - IF (Result [I] IN CWhitespace) THEN - IF PackWs AND (I > 1) AND (Result [I-1] IN CWhitespace) - THEN Delete (Result, I, 1) - ELSE Result [I] := #32; -END; - - -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); -BEGIN - SetString (S, BufferStart, BufferFinal-BufferStart+1); -END; - - -FUNCTION StrLPas (Start : PChar; Len : INTEGER) : STRING; -BEGIN - SetString (Result, Start, Len); -END; - - -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; -BEGIN - SetString (Result, Start, Finish-Start+1); -END; - - -FUNCTION StrScanE (CONST Source : PChar; CONST CharToScanFor : CHAR) : PChar; - // If "CharToScanFor" is not found, StrScanE returns the last char of the - // buffer instead of NIL -BEGIN - Result := StrScan (Source, CharToScanFor); - IF Result = NIL THEN - Result := StrEnd (Source)-1; -END; - - -PROCEDURE ExtractName (Start : PChar; Terminators : TCharset; VAR Final : PChar); - (* Extracts the complete Name beginning at "Start". - It is assumed that the name is contained in Markup, so the '>' character is - always a Termination. - Start: IN Pointer to first char of name. Is always considered to be valid - Terminators: IN Characters which terminate the name - Final: OUT Pointer to last char of name *) -BEGIN - Final := Start+1; - Include (Terminators, #0); - Include (Terminators, '>'); - WHILE NOT (Final^ IN Terminators) DO - INC (Final); - DEC (Final); -END; - - -PROCEDURE ExtractQuote (Start : PChar; VAR Content : STRING; VAR Final : PChar); - (* Extract a string which is contained in single or double Quotes. - Start: IN Pointer to opening quote - Content: OUT The quoted string - Final: OUT Pointer to closing quote *) -BEGIN - Final := StrScan (Start+1, Start^); - IF Final = NIL THEN BEGIN - Final := StrEnd (Start+1)-1; - SetString (Content, Start+1, Final-Start); - END - ELSE - SetString (Content, Start+1, Final-1-Start); -END; - - -(* -=============================================================================================== -TEntityStackNode -This Node is pushed to the "Entity Stack" whenever the parser parses entity replacement text. -The "Instance" field holds the Instance pointer of an External Entity buffer. When it is -popped, the Instance is freed. -The "Encoding" field holds the name of the Encoding. External Parsed Entities may have -another encoding as the document entity (XmlSpec 4.3.3). So when there is an " 0 THEN BEGIN - ESN := TEntityStackNode (Items [Count-1]); - Result := ESN.LastPos; - IF ESN.Instance <> NIL THEN - ESN.Instance.Free; - IF ESN.Encoding <> '' THEN - Owner.FCurEncoding := ESN.Encoding; // Restore current Encoding - Delete (Count-1); - END - ELSE - Result := NIL; -END; - - -(* -=============================================================================================== -TExternalID ------------ -XmlSpec 4.2.2: ExternalID ::= 'SYSTEM' S SystemLiteral | - 'PUBLIC' S PubidLiteral S SystemLiteral -XmlSpec 4.7: PublicID ::= 'PUBLIC' S PubidLiteral -SystemLiteral and PubidLiteral are quoted -=============================================================================================== -*) - -TYPE - TExternalID = CLASS - PublicId : STRING; - SystemId : STRING; - Final : PChar; - CONSTRUCTOR Create (Start : PChar); - END; - -CONSTRUCTOR TExternalID.Create (Start : PChar); -BEGIN - INHERITED Create; - Final := Start; - IF StrLComp (Start, 'SYSTEM', 6) = 0 THEN BEGIN - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, SystemID, Final); - END - ELSE IF StrLComp (Start, 'PUBLIC', 6) = 0 THEN BEGIN - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, PublicID, Final); - INC (Final); - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, SystemID, Final); - END; -END; - - -(* -=============================================================================================== -TXmlParser -=============================================================================================== -*) - -CONSTRUCTOR TXmlParser.Create; -BEGIN - INHERITED Create; - FBuffer := NIL; - FBufferSize := 0; - Elements := TElemList.Create; - Entities := TNvpList.Create; - ParEntities := TNvpList.Create; - Notations := TNvpList.Create; - CurAttr := TAttrList.Create; - EntityStack := TEntityStack.Create (Self); - Clear; -END; - - -DESTRUCTOR TXmlParser.Destroy; -BEGIN - Clear; - Elements.Free; - Entities.Free; - ParEntities.Free; - Notations.Free; - CurAttr.Free; - EntityStack.Free; - INHERITED Destroy; -END; - - -PROCEDURE TXmlParser.Clear; - // Free Buffer and clear all object attributes -BEGIN - IF (FBufferSize > 0) AND (FBuffer <> NIL) THEN - FreeMem (FBuffer); - FBuffer := NIL; - FBufferSize := 0; - FSource := ''; - FXmlVersion := ''; - FEncoding := ''; - FStandalone := FALSE; - FRootName := ''; - FDtdcFinal := NIL; - FNormalize := TRUE; - Elements.Clear; - Entities.Clear; - ParEntities.Clear; - Notations.Clear; - CurAttr.Clear; - EntityStack.Clear; -END; - - -FUNCTION TXmlParser.LoadFromFile (Filename : STRING; FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; - // Loads Document from given file - // Returns TRUE if successful -VAR - f : FILE; - ReadIn : INTEGER; - OldFileMode : INTEGER; -BEGIN - Result := FALSE; - Clear; - - // --- Open File - OldFileMode := SYSTEM.FileMode; - TRY - SYSTEM.FileMode := FileMode; - TRY - AssignFile (f, Filename); - Reset (f, 1); - EXCEPT - EXIT; - END; - - TRY - // --- Allocate Memory - TRY - FBufferSize := Filesize (f) + 1; - GetMem (FBuffer, FBufferSize); - EXCEPT - Clear; - EXIT; - END; - - // --- Read File - TRY - BlockRead (f, FBuffer^, FBufferSize, ReadIn); - (FBuffer+ReadIn)^ := #0; // NULL termination - EXCEPT - Clear; - EXIT; - END; - FINALLY - CloseFile (f); - END; - - FSource := Filename; - Result := TRUE; - - FINALLY - SYSTEM.FileMode := OldFileMode; - END; -END; - - -FUNCTION TXmlParser.LoadFromBuffer (Buffer : PChar) : BOOLEAN; - // Loads Document from another buffer - // Returns TRUE if successful - // The "Source" property becomes '' if successful -BEGIN - Result := FALSE; - Clear; - FBufferSize := StrLen (Buffer) + 1; - TRY - GetMem (FBuffer, FBufferSize); - EXCEPT - Clear; - EXIT; - END; - StrCopy (FBuffer, Buffer); - FSource := ''; - Result := TRUE; -END; - - -PROCEDURE TXmlParser.SetBuffer (Buffer : PChar); // References another buffer -BEGIN - Clear; - FBuffer := Buffer; - FBufferSize := 0; - FSource := ''; -END; - - -//----------------------------------------------------------------------------------------------- -// Scanning through the document -//----------------------------------------------------------------------------------------------- - -PROCEDURE TXmlParser.StartScan; -BEGIN - CurPartType := ptNone; - CurName := ''; - CurContent := ''; - CurStart := NIL; - CurFinal := NIL; - CurAttr.Clear; - EntityStack.Clear; -END; - - -FUNCTION TXmlParser.Scan : BOOLEAN; - // Scans the next Part - // Returns TRUE if a part could be found, FALSE if there is no part any more - // - // "IsDone" can be set to FALSE by AnalyzeText in order to go to the next part - // if there is no Content due to normalization -VAR - IsDone : BOOLEAN; -BEGIN - REPEAT - IsDone := TRUE; - - // --- Start of next Part - IF CurStart = NIL - THEN CurStart := DocBuffer - ELSE CurStart := CurFinal+1; - CurFinal := CurStart; - - // --- End of Document of Pop off a new part from the Entity stack? - IF CurStart^ = #0 THEN - CurStart := EntityStack.Pop; - - // --- No Document or End Of Document: Terminate Scan - IF (CurStart = NIL) OR (CurStart^ = #0) THEN BEGIN - CurStart := StrEnd (DocBuffer); - CurFinal := CurStart-1; - EntityStack.Clear; - Result := FALSE; - EXIT; - END; - - IF (StrLComp (CurStart, ''); - IF CurFinal <> NIL - THEN INC (CurFinal) - ELSE CurFinal := StrEnd (CurStart)-1; - FCurEncoding := AnsiUpperCase (CurAttr.Value ('encoding')); - IF FCurEncoding = '' THEN - FCurEncoding := 'UTF-8'; // Default XML Encoding is UTF-8 - CurPartType := ptXmlProlog; - CurName := ''; - CurContent := ''; -END; - - -PROCEDURE TXmlParser.AnalyzeComment (Start : PChar; VAR Final : PChar); - // Analyze Comments -BEGIN - Final := StrPos (Start+4, '-->'); - IF Final = NIL - THEN Final := StrEnd (Start)-1 - ELSE INC (Final, 2); - CurPartType := ptComment; -END; - - -PROCEDURE TXmlParser.AnalyzePI (Start : PChar; VAR Final : PChar); - // Analyze Processing Instructions (PI) - // This is also called for Character -VAR - F : PChar; -BEGIN - CurPartType := ptPI; - Final := StrPos (Start+2, '?>'); - IF Final = NIL - THEN Final := StrEnd (Start)-1 - ELSE INC (Final); - ExtractName (Start+2, CWhitespace + ['?', '>'], F); - SetStringSF (CurName, Start+2, F); - SetStringSF (CurContent, F+1, Final-2); - CurAttr.Analyze (F+1, F); -END; - - -PROCEDURE TXmlParser.AnalyzeDtdc; - (* Analyze Document Type Declaration - doctypedecl ::= '' - markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment - PEReference ::= '%' Name ';' - - elementdecl ::= '' - AttlistDecl ::= '' - EntityDecl ::= '' | - '' - NotationDecl ::= '' - PI ::= '' Char* )))? '?>' - Comment ::= '' *) -TYPE - TPhase = (phName, phDtd, phInternal, phFinishing); -VAR - Phase : TPhase; - F : PChar; - ExternalID : TExternalID; - ExternalDTD : TXmlParser; - DER : TDtdElementRec; -BEGIN - DER.Start := CurStart; - EntityStack.Clear; // Clear stack for Parameter Entities - CurPartType := ptDtdc; - - // --- Don't read DTDc twice - IF FDtdcFinal <> NIL THEN BEGIN - CurFinal := FDtdcFinal; - EXIT; - END; - - // --- Scan DTDc - CurFinal := CurStart + 9; // First char after '' : BREAK; - ELSE IF NOT (CurFinal^ IN CWhitespace) THEN BEGIN - CASE Phase OF - phName : IF (CurFinal^ IN CNameStart) THEN BEGIN - ExtractName (CurFinal, CWhitespace + ['[', '>'], F); - SetStringSF (FRootName, CurFinal, F); - CurFinal := F; - Phase := phDtd; - END; - phDtd : IF (StrLComp (CurFinal, 'SYSTEM', 6) = 0) OR - (StrLComp (CurFinal, 'PUBLIC', 6) = 0) THEN BEGIN - ExternalID := TExternalID.Create (CurFinal); - ExternalDTD := LoadExternalEntity (ExternalId.SystemId, ExternalID.PublicId, ''); - F := StrPos (ExternalDtd.DocBuffer, ' NIL THEN - AnalyzeDtdElements (F, F); - ExternalDTD.Free; - CurFinal := ExternalID.Final; - ExternalID.Free; - END; - ELSE BEGIN - DER.ElementType := deError; - DER.Pos := CurFinal; - DER.Final := CurFinal; - DtdElementFound (DER); - END; - END; - - END; - END; - INC (CurFinal); - UNTIL FALSE; - - CurPartType := ptDtdc; - CurName := ''; - CurContent := ''; - - // It is an error in the document if "EntityStack" is not empty now - IF EntityStack.Count > 0 THEN BEGIN - DER.ElementType := deError; - DER.Final := CurFinal; - DER.Pos := CurFinal; - DtdElementFound (DER); - END; - - EntityStack.Clear; // Clear stack for General Entities - FDtdcFinal := CurFinal; -END; - - -PROCEDURE TXmlParser.AnalyzeDtdElements (Start : PChar; VAR Final : PChar); - // Analyze the "Elements" of a DTD contained in the external or - // internal DTD subset. -VAR - DER : TDtdElementRec; -BEGIN - Final := Start; - REPEAT - CASE Final^ OF - '%' : BEGIN - PushPE (Final); - CONTINUE; - END; - #0 : IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurFinal := EntityStack.Pop; - CONTINUE; - END; - ']', - '>' : BREAK; - '<' : IF StrLComp (Final, ''); - - // --- Set Default Attribute values for nonexistent attributes - IF (CurPartType = ptStartTag) OR (CurPartType = ptEmptyTag) THEN BEGIN - ElemDef := Elements.Node (CurName); - IF ElemDef <> NIL THEN BEGIN - FOR I := 0 TO ElemDef.Count-1 DO BEGIN - AttrDef := TAttrDef (ElemDef [I]); - Attr := TAttr (CurAttr.Node (AttrDef.Name)); - IF (Attr = NIL) AND (AttrDef.Value <> '') THEN BEGIN - Attr := TAttr.Create (AttrDef.Name, AttrDef.Value); - Attr.ValueType := vtDefault; - CurAttr.Add (Attr); - END; - IF Attr <> NIL THEN BEGIN - CASE AttrDef.DefaultType OF - adDefault : ; - adRequired : ; // -!- It is an error in the document if "Attr.Value" is an empty string - adImplied : Attr.ValueType := vtImplied; - adFixed : BEGIN - Attr.ValueType := vtFixed; - Attr.Value := AttrDef.Value; - END; - END; - Attr.AttrType := AttrDef.AttrType; - END; - END; - END; - - // --- Normalize Attribute Values. XmlSpec: - // - a character reference is processed by appending the referenced character to the attribute value - // - an entity reference is processed by recursively processing the replacement text of the entity - // - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20 to the normalized value, - // except that only a single #x20 is appended for a "#xD#xA" sequence that is part of an external - // parsed entity or the literal entity value of an internal parsed entity - // - other characters are processed by appending them to the normalized value - // If the declared value is not CDATA, then the XML processor must further process the - // normalized attribute value by discarding any leading and trailing space (#x20) characters, - // and by replacing sequences of space (#x20) characters by a single space (#x20) character. - // All attributes for which no declaration has been read should be treated by a - // non-validating parser as if declared CDATA. - // !!! The XML 1.0 SE specification is somewhat different here - // This code does not conform exactly to this specification - FOR I := 0 TO CurAttr.Count-1 DO - WITH TAttr (CurAttr [I]) DO BEGIN - ReplaceGeneralEntities (Value); - ReplaceCharacterEntities (Value); - IF (AttrType <> atCData) AND (AttrType <> atUnknown) - THEN Value := TranslateEncoding (TrimWs (ConvertWs (Value, TRUE))) - ELSE Value := TranslateEncoding (ConvertWs (Value, FALSE)); - END; - END; -END; - - -PROCEDURE TXmlParser.AnalyzeCData; - // Analyze CDATA Sections -BEGIN - CurPartType := ptCData; - CurFinal := StrPos (CurStart, CDEnd); - IF CurFinal = NIL THEN BEGIN - CurFinal := StrEnd (CurStart)-1; - CurContent := TranslateEncoding (StrPas (CurStart+Length (CDStart))); - END - ELSE BEGIN - SetStringSF (CurContent, CurStart+Length (CDStart), CurFinal-1); - INC (CurFinal, Length (CDEnd)-1); - CurContent := TranslateEncoding (CurContent); - END; -END; - - -PROCEDURE TXmlParser.AnalyzeText (VAR IsDone : BOOLEAN); - (* Analyzes Text Content between Tags. CurFinal will point to the last content character. - Content ends at a '<' character or at the end of the document. - Entity References and Character Entity references are resolved. - If PackSpaces is TRUE, contiguous Whitespace Characters will be compressed to - one Space #x20 character, Whitespace at the beginning and end of content will - be trimmed off and content which is or becomes empty is not returned to - the application (in this case, "IsDone" is set to FALSE which causes the - Scan method to proceed directly to the next part. *) - - PROCEDURE ProcessEntity; - (* Is called if there is an ampsersand '&' character found in the document. - IN "CurFinal" points to the ampersand - OUT "CurFinal" points to the first character after the semi-colon ';' *) - VAR - P : PChar; - Name : STRING; - EntityDef : TEntityDef; - ExternalEntity : TXmlParser; - BEGIN - P := StrScan (CurFinal , ';'); - IF P <> NIL THEN BEGIN - SetStringSF (Name, CurFinal+1, P-1); - - // Is it a Character Entity? - IF (CurFinal+1)^ = '#' THEN BEGIN - IF UpCase ((CurFinal+2)^) = 'X' // !!! Can't use "CHR" for Unicode characters > 255: - THEN CurContent := CurContent + CHR (StrToIntDef ('$'+Copy (Name, 3, MaxInt), 32)) - ELSE CurContent := CurContent + CHR (StrToIntDef (Copy (Name, 2, MaxInt), 32)); - CurFinal := P+1; - EXIT; - END - - // Is it a Predefined Entity? - ELSE IF Name = 'lt' THEN BEGIN CurContent := CurContent + '<'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'gt' THEN BEGIN CurContent := CurContent + '>'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'amp' THEN BEGIN CurContent := CurContent + '&'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'apos' THEN BEGIN CurContent := CurContent + ''''; CurFinal := P+1; EXIT; END - ELSE IF Name = 'quot' THEN BEGIN CurContent := CurContent + '"'; CurFinal := P+1; EXIT; END; - - // Replace with Entity from DTD - EntityDef := TEntityDef (Entities.Node (Name)); - IF EntityDef <> NIL THEN BEGIN - IF EntityDef.Value <> '' THEN BEGIN - EntityStack.Push (P+1); - CurFinal := PChar (EntityDef.Value); - END - ELSE BEGIN - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); - EntityStack.Push (ExternalEntity, P+1); - CurFinal := ExternalEntity.DocBuffer; - END; - END - ELSE BEGIN - CurContent := CurContent + Name; - CurFinal := P+1; - END; - END - ELSE BEGIN - INC (CurFinal); - END; - END; - -VAR - C : INTEGER; -BEGIN - CurFinal := CurStart; - CurPartType := ptContent; - CurContent := ''; - C := 0; - REPEAT - CASE CurFinal^ OF - '&' : BEGIN - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - C := 0; - ProcessEntity; - CONTINUE; - END; - #0 : BEGIN - IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - C := 0; - CurFinal := EntityStack.Pop; - CONTINUE; - END; - END; - '<' : BREAK; - ELSE INC (C); - END; - INC (CurFinal); - UNTIL FALSE; - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - DEC (CurFinal); - - IF FNormalize THEN BEGIN - CurContent := ConvertWs (TrimWs (CurContent), TRUE); - IsDone := CurContent <> ''; // IsDone will only get FALSE if PackSpaces is TRUE - END; -END; - - -PROCEDURE TXmlParser.AnalyzeElementDecl (Start : PChar; VAR Final : PChar); - (* Parse ' character - XmlSpec 3.2: - elementdecl ::= '' - contentspec ::= 'EMPTY' | 'ANY' | Mixed | children - Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' | - '(' S? '#PCDATA' S? ')' - children ::= (choice | seq) ('?' | '*' | '+')? - choice ::= '(' S? cp ( S? '|' S? cp )* S? ')' - cp ::= (Name | choice | seq) ('?' | '*' | '+')? - seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' - - More simply: - contentspec ::= EMPTY - ANY - '(#PCDATA)' - '(#PCDATA | A | B)*' - '(A, B, C)' - '(A | B | C)' - '(A?, B*, C+), - '(A, (B | C | D)* )' *) -VAR - Element : TElemDef; - Elem2 : TElemDef; - F : PChar; - DER : TDtdElementRec; -BEGIN - Element := TElemDef.Create; - Final := Start + 9; - DER.Start := Start; - REPEAT - IF Final^ = '>' THEN BREAK; - IF (Final^ IN CNameStart) AND (Element.Name = '') THEN BEGIN - ExtractName (Final, CWhitespace, F); - SetStringSF (Element.Name, Final, F); - Final := F; - F := StrScan (Final+1, '>'); - IF F = NIL THEN BEGIN - Element.Definition := STRING (Final); - Final := StrEnd (Final); - BREAK; - END - ELSE BEGIN - SetStringSF (Element.Definition, Final+1, F-1); - Final := F; - BREAK; - END; - END; - INC (Final); - UNTIL FALSE; - Element.Definition := DelChars (Element.Definition, CWhitespace); - ReplaceParameterEntities (Element.Definition); - IF Element.Definition = 'EMPTY' THEN Element.ElemType := etEmpty - ELSE IF Element.Definition = 'ANY' THEN Element.ElemType := etAny - ELSE IF Copy (Element.Definition, 1, 8) = '(#PCDATA' THEN Element.ElemType := etMixed - ELSE IF Copy (Element.Definition, 1, 1) = '(' THEN Element.ElemType := etChildren - ELSE Element.ElemType := etAny; - - Elem2 := Elements.Node (Element.Name); - IF Elem2 <> NIL THEN - Elements.Delete (Elements.IndexOf (Elem2)); - Elements.Add (Element); - Final := StrScanE (Final, '>'); - DER.ElementType := deElement; - DER.ElemDef := Element; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); - (* Parse ' character - XmlSpec 3.3: - AttlistDecl ::= '' - AttDef ::= S Name S AttType S DefaultDecl - AttType ::= StringType | TokenizedType | EnumeratedType - StringType ::= 'CDATA' - TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' - EnumeratedType ::= NotationType | Enumeration - NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' - Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' - DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) - AttValue ::= '"' ([^<&"] | Reference)* '"' | "'" ([^<&'] | Reference)* "'" - Examples: - *) -TYPE - TPhase = (phElementName, phName, phType, phNotationContent, phDefault); -VAR - Phase : TPhase; - F : PChar; - ElementName : STRING; - ElemDef : TElemDef; - AttrDef : TAttrDef; - AttrDef2 : TAttrDef; - Strg : STRING; - DER : TDtdElementRec; -BEGIN - Final := Start + 9; // The character after ' : BREAK; - ELSE CASE Phase OF - phElementName : BEGIN - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); - SetStringSF (ElementName, Final, F); - Final := F; - ElemDef := Elements.Node (ElementName); - IF ElemDef = NIL THEN BEGIN - ElemDef := TElemDef.Create; - ElemDef.Name := ElementName; - ElemDef.Definition := 'ANY'; - ElemDef.ElemType := etAny; - Elements.Add (ElemDef); - END; - Phase := phName; - END; - phName : BEGIN - AttrDef := TAttrDef.Create; - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); - SetStringSF (AttrDef.Name, Final, F); - Final := F; - AttrDef2 := TAttrDef (ElemDef.Node (AttrDef.Name)); - IF AttrDef2 <> NIL THEN - ElemDef.Delete (ElemDef.IndexOf (AttrDef2)); - ElemDef.Add (AttrDef); - Phase := phType; - END; - phType : BEGIN - IF Final^ = '(' THEN BEGIN - F := StrScan (Final+1, ')'); - IF F <> NIL - THEN SetStringSF (AttrDef.TypeDef, Final+1, F-1) - ELSE AttrDef.TypeDef := STRING (Final+1); - AttrDef.TypeDef := DelChars (AttrDef.TypeDef, CWhitespace); - AttrDef.AttrType := atEnumeration; - ReplaceParameterEntities (AttrDef.TypeDef); - ReplaceCharacterEntities (AttrDef.TypeDef); - Phase := phDefault; - END - ELSE IF StrLComp (Final, 'NOTATION', 8) = 0 THEN BEGIN - INC (Final, 8); - AttrDef.AttrType := atNotation; - Phase := phNotationContent; - END - ELSE BEGIN - ExtractName (Final, CWhitespace+CQuoteChar+['#'], F); - SetStringSF (AttrDef.TypeDef, Final, F); - IF AttrDef.TypeDef = 'CDATA' THEN AttrDef.AttrType := atCData - ELSE IF AttrDef.TypeDef = 'ID' THEN AttrDef.AttrType := atId - ELSE IF AttrDef.TypeDef = 'IDREF' THEN AttrDef.AttrType := atIdRef - ELSE IF AttrDef.TypeDef = 'IDREFS' THEN AttrDef.AttrType := atIdRefs - ELSE IF AttrDef.TypeDef = 'ENTITY' THEN AttrDef.AttrType := atEntity - ELSE IF AttrDef.TypeDef = 'ENTITIES' THEN AttrDef.AttrType := atEntities - ELSE IF AttrDef.TypeDef = 'NMTOKEN' THEN AttrDef.AttrType := atNmToken - ELSE IF AttrDef.TypeDef = 'NMTOKENS' THEN AttrDef.AttrType := atNmTokens; - Phase := phDefault; - END - END; - phNotationContent : BEGIN - F := StrScan (Final, ')'); - IF F <> NIL THEN - SetStringSF (AttrDef.Notations, Final+1, F-1) - ELSE BEGIN - AttrDef.Notations := STRING (Final+1); - Final := StrEnd (Final); - END; - ReplaceParameterEntities (AttrDef.Notations); - AttrDef.Notations := DelChars (AttrDef.Notations, CWhitespace); - Phase := phDefault; - END; - phDefault : BEGIN - IF Final^ = '#' THEN BEGIN - ExtractName (Final, CWhiteSpace + CQuoteChar, F); - SetStringSF (Strg, Final, F); - Final := F; - ReplaceParameterEntities (Strg); - IF Strg = '#REQUIRED' THEN BEGIN AttrDef.DefaultType := adRequired; Phase := phName; END - ELSE IF Strg = '#IMPLIED' THEN BEGIN AttrDef.DefaultType := adImplied; Phase := phName; END - ELSE IF Strg = '#FIXED' THEN AttrDef.DefaultType := adFixed; - END - ELSE IF (Final^ IN CQuoteChar) THEN BEGIN - ExtractQuote (Final, AttrDef.Value, Final); - ReplaceParameterEntities (AttrDef.Value); - ReplaceCharacterEntities (AttrDef.Value); - Phase := phName; - END; - IF Phase = phName THEN BEGIN - AttrDef := NIL; - END; - END; - - END; - END; - INC (Final); - UNTIL FALSE; - - Final := StrScan (Final, '>'); - - DER.ElementType := deAttList; - DER.ElemDef := ElemDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); - (* Parse ' character - XmlSpec 4.2: - EntityDecl ::= '' | - '' - EntityDef ::= EntityValue | (ExternalID NDataDecl?) - PEDef ::= EntityValue | ExternalID - NDataDecl ::= S 'NDATA' S Name - EntityValue ::= '"' ([^%&"] | PEReference | EntityRef | CharRef)* '"' | - "'" ([^%&'] | PEReference | EntityRef | CharRef)* "'" - PEReference ::= '%' Name ';' - - Examples - - - - "> - - - Dies ist ein Test-Absatz

"> - *) -TYPE - TPhase = (phName, phContent, phNData, phNotationName, phFinalGT); -VAR - Phase : TPhase; - IsParamEntity : BOOLEAN; - F : PChar; - ExternalID : TExternalID; - EntityDef : TEntityDef; - EntityDef2 : TEntityDef; - DER : TDtdElementRec; -BEGIN - Final := Start + 8; // First char after ' : BREAK; - ELSE CASE Phase OF - phName : IF Final^ IN CNameStart THEN BEGIN - ExtractName (Final, CWhitespace + CQuoteChar, F); - SetStringSF (EntityDef.Name, Final, F); - Final := F; - Phase := phContent; - END; - phContent : IF Final^ IN CQuoteChar THEN BEGIN - ExtractQuote (Final, EntityDef.Value, Final); - Phase := phFinalGT; - END - ELSE IF (StrLComp (Final, 'SYSTEM', 6) = 0) OR - (StrLComp (Final, 'PUBLIC', 6) = 0) THEN BEGIN - ExternalID := TExternalID.Create (Final); - EntityDef.SystemId := ExternalID.SystemId; - EntityDef.PublicId := ExternalID.PublicId; - Final := ExternalID.Final; - Phase := phNData; - ExternalID.Free; - END; - phNData : IF StrLComp (Final, 'NDATA', 5) = 0 THEN BEGIN - INC (Final, 4); - Phase := phNotationName; - END; - phNotationName : IF Final^ IN CNameStart THEN BEGIN - ExtractName (Final, CWhitespace + ['>'], F); - SetStringSF (EntityDef.NotationName, Final, F); - Final := F; - Phase := phFinalGT; - END; - phFinalGT : ; // -!- There is an error in the document if this branch is called - END; - END; - INC (Final); - UNTIL FALSE; - IF IsParamEntity THEN BEGIN - EntityDef2 := TEntityDef (ParEntities.Node (EntityDef.Name)); - IF EntityDef2 <> NIL THEN - ParEntities.Delete (ParEntities.IndexOf (EntityDef2)); - ParEntities.Add (EntityDef); - ReplaceCharacterEntities (EntityDef.Value); - END - ELSE BEGIN - EntityDef2 := TEntityDef (Entities.Node (EntityDef.Name)); - IF EntityDef2 <> NIL THEN - Entities.Delete (Entities.IndexOf (EntityDef2)); - Entities.Add (EntityDef); - ReplaceParameterEntities (EntityDef.Value); // Create replacement texts (see XmlSpec 4.5) - ReplaceCharacterEntities (EntityDef.Value); - END; - Final := StrScanE (Final, '>'); - - DER.ElementType := deEntity; - DER.EntityDef := EntityDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); - // Parse ' character - // XmlSpec 4.7: NotationDecl ::= '' -TYPE - TPhase = (phName, phExtId, phEnd); -VAR - ExternalID : TExternalID; - Phase : TPhase; - F : PChar; - NotationDef : TNotationDef; - DER : TDtdElementRec; -BEGIN - Final := Start + 10; // Character after ', - #0 : BREAK; - ELSE CASE Phase OF - phName : BEGIN - ExtractName (Final, CWhitespace + ['>'], F); - SetStringSF (NotationDef.Name, Final, F); - Final := F; - Phase := phExtId; - END; - phExtId : BEGIN - ExternalID := TExternalID.Create (Final); - NotationDef.Value := ExternalID.SystemId; - NotationDef.PublicId := ExternalID.PublicId; - Final := ExternalId.Final; - ExternalId.Free; - Phase := phEnd; - END; - phEnd : ; // -!- There is an error in the document if this branch is called - END; - END; - INC (Final); - UNTIL FALSE; - Notations.Add (NotationDef); - Final := StrScanE (Final, '>'); - - DER.ElementType := deNotation; - DER.NotationDef := NotationDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.PushPE (VAR Start : PChar); - (* If there is a parameter entity reference found in the data stream, - the current position will be pushed to the entity stack. - Start: IN Pointer to the '%' character starting the PE reference - OUT Pointer to first character of PE replacement text *) -VAR - P : PChar; - EntityDef : TEntityDef; -BEGIN - P := StrScan (Start, ';'); - IF P <> NIL THEN BEGIN - EntityDef := TEntityDef (ParEntities.Node (StrSFPas (Start+1, P-1))); - IF EntityDef <> NIL THEN BEGIN - EntityStack.Push (P+1); - Start := PChar (EntityDef.Value); - END - ELSE - Start := P+1; - END; -END; - - -PROCEDURE TXmlParser.ReplaceCharacterEntities (VAR Str : STRING); - // Replaces all Character Entity References in the String -VAR - Start : INTEGER; - PAmp : PChar; - PSemi : PChar; - PosAmp : INTEGER; - Len : INTEGER; // Length of Entity Reference -BEGIN - IF Str = '' THEN EXIT; - Start := 1; - REPEAT - PAmp := StrPos (PChar (Str) + Start-1, '&#'); - IF PAmp = NIL THEN BREAK; - PSemi := StrScan (PAmp+2, ';'); - IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PChar (Str) + 1; - Len := PSemi-PAmp+1; - IF CompareText (Str [PosAmp+2], 'x') = 0 // !!! Can't use "CHR" for Unicode characters > 255 - THEN Str [PosAmp] := CHR (StrToIntDef ('$'+Copy (Str, PosAmp+3, Len-4), 0)) - ELSE Str [PosAmp] := CHR (StrToIntDef (Copy (Str, PosAmp+2, Len-3), 32)); - Delete (Str, PosAmp+1, Len-1); - Start := PosAmp + 1; - UNTIL FALSE; -END; - - -PROCEDURE TXmlParser.ReplaceParameterEntities (VAR Str : STRING); - // Recursively replaces all Parameter Entity References in the String - PROCEDURE ReplaceEntities (VAR Str : STRING); - VAR - Start : INTEGER; - PAmp : PChar; - PSemi : PChar; - PosAmp : INTEGER; - Len : INTEGER; - Entity : TEntityDef; - Repl : STRING; // Replacement - BEGIN - IF Str = '' THEN EXIT; - Start := 1; - REPEAT - PAmp := StrPos (PChar (Str)+Start-1, '%'); - IF PAmp = NIL THEN BREAK; - PSemi := StrScan (PAmp+2, ';'); - IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PChar (Str) + 1; - Len := PSemi-PAmp+1; - Entity := TEntityDef (ParEntities.Node (Copy (Str, PosAmp+1, Len-2))); - IF Entity <> NIL THEN BEGIN - Repl := Entity.Value; - ReplaceEntities (Repl); // Recursion - END - ELSE - Repl := Copy (Str, PosAmp, Len); - Delete (Str, PosAmp, Len); - Insert (Repl, Str, PosAmp); - Start := PosAmp + Length (Repl); - UNTIL FALSE; - END; -BEGIN - ReplaceEntities (Str); -END; - - -PROCEDURE TXmlParser.ReplaceGeneralEntities (VAR Str : STRING); - // Recursively replaces General Entity References in the String - PROCEDURE ReplaceEntities (VAR Str : STRING); - VAR - Start : INTEGER; - PAmp : PChar; - PSemi : PChar; - PosAmp : INTEGER; - Len : INTEGER; - EntityDef : TEntityDef; - EntName : STRING; - Repl : STRING; // Replacement - ExternalEntity : TXmlParser; - BEGIN - IF Str = '' THEN EXIT; - Start := 1; - REPEAT - PAmp := StrPos (PChar (Str)+Start-1, '&'); - IF PAmp = NIL THEN BREAK; - PSemi := StrScan (PAmp+2, ';'); - IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PChar (Str) + 1; - Len := PSemi-PAmp+1; - EntName := Copy (Str, PosAmp+1, Len-2); - IF EntName = 'lt' THEN Repl := '<' - ELSE IF EntName = 'gt' THEN Repl := '>' - ELSE IF EntName = 'amp' THEN Repl := '&' - ELSE IF EntName = 'apos' THEN Repl := '''' - ELSE IF EntName = 'quot' THEN Repl := '"' - ELSE BEGIN - EntityDef := TEntityDef (Entities.Node (EntName)); - IF EntityDef <> NIL THEN BEGIN - IF EntityDef.Value <> '' THEN // Internal Entity - Repl := EntityDef.Value - ELSE BEGIN // External Entity - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); - Repl := StrPas (ExternalEntity.DocBuffer); // !!! What if it contains a Text Declaration? - ExternalEntity.Free; - END; - ReplaceEntities (Repl); // Recursion - END - ELSE - Repl := Copy (Str, PosAmp, Len); - END; - Delete (Str, PosAmp, Len); - Insert (Repl, Str, PosAmp); - Start := PosAmp + Length (Repl); - UNTIL FALSE; - END; -BEGIN - ReplaceEntities (Str); -END; - - -FUNCTION TXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser; - // This will be called whenever there is a Parsed External Entity or - // the DTD External Subset to be parsed. - // It has to create a TXmlParser instance and load the desired Entity. - // This instance of LoadExternalEntity assumes that "SystemId" is a valid - // file name (relative to the Document source) and loads this file using - // the LoadFromFile method. -VAR - Filename : STRING; -BEGIN - // --- Convert System ID to complete filename - Filename := StringReplace (SystemId, '/', '\', [rfReplaceAll]); - IF Copy (FSource, 1, 1) <> '<' THEN - IF (Copy (Filename, 1, 2) = '\\') OR (Copy (Filename, 2, 1) = ':') THEN - // Already has an absolute Path - ELSE BEGIN - Filename := ExtractFilePath (FSource) + Filename; - END; - - // --- Load the File - Result := TXmlParser.Create; - Result.LoadFromFile (Filename); -END; - - -FUNCTION TXmlParser.TranslateEncoding (CONST Source : STRING) : STRING; - // The member variable "CurEncoding" always holds the name of the current - // encoding, e.g. 'UTF-8' or 'ISO-8859-1'. - // This virtual method "TranslateEncoding" is responsible for translating - // the content passed in the "Source" parameter to the Encoding which - // is expected by the application. - // This instance of "TranlateEncoding" assumes that the Application expects - // Windows ANSI (Win1252) strings. It is able to transform UTF-8 or ISO-8859-1 - // encodings. - // If you want your application to understand or create other encodings, you - // override this function. -BEGIN - IF CurEncoding = 'UTF-8' - THEN Result := Utf8ToAnsi (Source) - ELSE Result := Source; -END; - - -PROCEDURE TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); - // This method is called for every element which is found in the DTD - // declaration. The variant record TDtdElementRec is passed which - // holds informations about the element. - // You can override this function to handle DTD declarations. - // Note that when you parse the same Document instance a second time, - // the DTD will not get parsed again. -BEGIN -END; - - -FUNCTION TXmlParser.GetDocBuffer: PChar; - // Returns FBuffer or a pointer to a NUL char if Buffer is empty -BEGIN - IF FBuffer = NIL - THEN Result := #0 - ELSE Result := FBuffer; -END; - - -(*$IFNDEF HAS_CONTNRS_UNIT -=============================================================================================== -TObjectList -=============================================================================================== -*) - -DESTRUCTOR TObjectList.Destroy; -BEGIN - Clear; - SetCapacity(0); - INHERITED Destroy; -END; - - -PROCEDURE TObjectList.Delete (Index : INTEGER); -BEGIN - IF (Index < 0) OR (Index >= Count) THEN EXIT; - TObject (Items [Index]).Free; - INHERITED Delete (Index); -END; - - -PROCEDURE TObjectList.Clear; -BEGIN - WHILE Count > 0 DO - Delete (Count-1); -END; - -(*$ENDIF *) - -(* -=============================================================================================== -TNvpNode --------- -Node base class for the TNvpList -=============================================================================================== -*) - -CONSTRUCTOR TNvpNode.Create (TheName, TheValue : STRING); -BEGIN - INHERITED Create; - Name := TheName; - Value := TheValue; -END; - - -(* -=============================================================================================== -TNvpList --------- -A generic List of Name-Value Pairs, based on the TObjectList introduced in Delphi 5 -=============================================================================================== -*) - -PROCEDURE TNvpList.Add (Node : TNvpNode); -VAR - I : INTEGER; -BEGIN - FOR I := Count-1 DOWNTO 0 DO - IF Node.Name > TNvpNode (Items [I]).Name THEN BEGIN - Insert (I+1, Node); - EXIT; - END; - Insert (0, Node); -END; - - - -FUNCTION TNvpList.Node (Name : STRING) : TNvpNode; - // Binary search for Node -VAR - L, H : INTEGER; // Low, High Limit - T, C : INTEGER; // Test Index, Comparison result - Last : INTEGER; // Last Test Index -BEGIN - IF Count=0 THEN BEGIN - Result := NIL; - EXIT; - END; - - L := 0; - H := Count; - Last := -1; - REPEAT - T := (L+H) DIV 2; - IF T=Last THEN BREAK; - Result := TNvpNode (Items [T]); - C := CompareStr (Result.Name, Name); - IF C = 0 THEN EXIT - ELSE IF C < 0 THEN L := T - ELSE H := T; - Last := T; - UNTIL FALSE; - Result := NIL; -END; - - -FUNCTION TNvpList.Node (Index : INTEGER) : TNvpNode; -BEGIN - IF (Index < 0) OR (Index >= Count) - THEN Result := NIL - ELSE Result := TNvpNode (Items [Index]); -END; - - -FUNCTION TNvpList.Value (Name : STRING) : STRING; -VAR - Nvp : TNvpNode; -BEGIN - Nvp := TNvpNode (Node (Name)); - IF Nvp <> NIL - THEN Result := Nvp.Value - ELSE Result := ''; -END; - - -FUNCTION TNvpList.Value (Index : INTEGER) : STRING; -BEGIN - IF (Index < 0) OR (Index >= Count) - THEN Result := '' - ELSE Result := TNvpNode (Items [Index]).Value; -END; - - -FUNCTION TNvpList.Name (Index : INTEGER) : STRING; -BEGIN - IF (Index < 0) OR (Index >= Count) - THEN Result := '' - ELSE Result := TNvpNode (Items [Index]).Name; -END; - - -(* -=============================================================================================== -TAttrList -List of Attributes. The "Analyze" method extracts the Attributes from the given Buffer. -Is used for extraction of Attributes in Start-Tags, Empty-Element Tags and the "pseudo" -attributes in XML Prologs, Text Declarations and PIs. -=============================================================================================== -*) - -PROCEDURE TAttrList.Analyze (Start : PChar; VAR Final : PChar); - // Analyze the Buffer for Attribute=Name pairs. - // Terminates when there is a character which is not IN CNameStart - // (e.g. '?>' or '>' or '/>') -TYPE - TPhase = (phName, phEq, phValue); -VAR - Phase : TPhase; - F : PChar; - Name : STRING; - Value : STRING; - Attr : TAttr; -BEGIN - Clear; - Phase := phName; - Final := Start; - REPEAT - IF (Final^ = #0) OR (Final^ = '>') THEN BREAK; - IF NOT (Final^ IN CWhitespace) THEN - CASE Phase OF - phName : BEGIN - IF NOT (Final^ IN CNameStart) THEN EXIT; - ExtractName (Final, CWhitespace + ['=', '/'], F); - SetStringSF (Name, Final, F); - Final := F; - Phase := phEq; - END; - phEq : BEGIN - IF Final^ = '=' THEN - Phase := phValue - END; - phValue : BEGIN - IF Final^ IN CQuoteChar THEN BEGIN - ExtractQuote (Final, Value, F); - Attr := TAttr.Create; - Attr.Name := Name; - Attr.Value := Value; - Attr.ValueType := vtNormal; - Add (Attr); - Final := F; - Phase := phName; - END; - END; - END; - INC (Final); - UNTIL FALSE; -END; - - -(* -=============================================================================================== -TElemList -List of TElemDef nodes. -=============================================================================================== -*) - -FUNCTION TElemList.Node (Name : STRING) : TElemDef; - // Binary search for the Node with the given Name -VAR - L, H : INTEGER; // Low, High Limit - T, C : INTEGER; // Test Index, Comparison result - Last : INTEGER; // Last Test Index -BEGIN - IF Count=0 THEN BEGIN - Result := NIL; - EXIT; - END; - - L := 0; - H := Count; - Last := -1; - REPEAT - T := (L+H) DIV 2; - IF T=Last THEN BREAK; - Result := TElemDef (Items [T]); - C := CompareStr (Result.Name, Name); - IF C = 0 THEN EXIT - ELSE IF C < 0 THEN L := T - ELSE H := T; - Last := T; - UNTIL FALSE; - Result := NIL; -END; - - -PROCEDURE TElemList.Add (Node : TElemDef); -VAR - I : INTEGER; -BEGIN - FOR I := Count-1 DOWNTO 0 DO - IF Node.Name > TElemDef (Items [I]).Name THEN BEGIN - Insert (I+1, Node); - EXIT; - END; - Insert (0, Node); -END; - - -(* -=============================================================================================== -TScannerXmlParser -A TXmlParser descendant for the TCustomXmlScanner component -=============================================================================================== -*) - -TYPE - TScannerXmlParser = CLASS (TXmlParser) - Scanner : TCustomXmlScanner; - CONSTRUCTOR Create (TheScanner : TCustomXmlScanner); - FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : STRING) : TXmlParser; OVERRIDE; - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; OVERRIDE; - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); OVERRIDE; - END; - -CONSTRUCTOR TScannerXmlParser.Create (TheScanner : TCustomXmlScanner); -BEGIN - INHERITED Create; - Scanner := TheScanner; -END; - - -FUNCTION TScannerXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser; -BEGIN - IF Assigned (Scanner.FOnLoadExternal) - THEN Scanner.FOnLoadExternal (Scanner, SystemId, PublicId, Notation, Result) - ELSE Result := INHERITED LoadExternalEntity (SystemId, PublicId, Notation); -END; - - -FUNCTION TScannerXmlParser.TranslateEncoding (CONST Source : STRING) : STRING; -BEGIN - IF Assigned (Scanner.FOnTranslateEncoding) - THEN Result := Scanner.FOnTranslateEncoding (Scanner, CurEncoding, Source) - ELSE Result := INHERITED TranslateEncoding (Source); -END; - - -PROCEDURE TScannerXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); -BEGIN - WITH DtdElementRec DO - CASE ElementType OF - deElement : Scanner.WhenElement (ElemDef); - deAttList : Scanner.WhenAttList (ElemDef); - deEntity : Scanner.WhenEntity (EntityDef); - deNotation : Scanner.WhenNotation (NotationDef); - dePI : Scanner.WhenPI (STRING (Target), STRING (Content), AttrList); - deComment : Scanner.WhenComment (StrSFPas (Start, Final)); - deError : Scanner.WhenDtdError (Pos); - END; -END; - - -(* -=============================================================================================== -TCustomXmlScanner -=============================================================================================== -*) - -CONSTRUCTOR TCustomXmlScanner.Create (AOwner: TComponent); -BEGIN - INHERITED; - FXmlParser := TScannerXmlParser.Create (Self); -END; - - -DESTRUCTOR TCustomXmlScanner.Destroy; -BEGIN - FXmlParser.Free; - INHERITED; -END; - - -PROCEDURE TCustomXmlScanner.LoadFromFile (Filename : TFilename); - // Load XML Document from file -BEGIN - FXmlParser.LoadFromFile (Filename); -END; - - -PROCEDURE TCustomXmlScanner.LoadFromBuffer (Buffer : PChar); - // Load XML Document from buffer -BEGIN - FXmlParser.LoadFromBuffer (Buffer); -END; - - -PROCEDURE TCustomXmlScanner.SetBuffer (Buffer : PChar); - // Refer to Buffer -BEGIN - FXmlParser.SetBuffer (Buffer); -END; - - -FUNCTION TCustomXmlScanner.GetFilename : TFilename; -BEGIN - Result := FXmlParser.Source; -END; - - -FUNCTION TCustomXmlScanner.GetNormalize : BOOLEAN; -BEGIN - Result := FXmlParser.Normalize; -END; - - -PROCEDURE TCustomXmlScanner.SetNormalize (Value : BOOLEAN); -BEGIN - FXmlParser.Normalize := Value; -END; - - -PROCEDURE TCustomXmlScanner.WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); - // Is called when the parser has parsed the declaration of the prolog -BEGIN - IF Assigned (FOnXmlProlog) THEN FOnXmlProlog (Self, XmlVersion, Encoding, Standalone); -END; - - -PROCEDURE TCustomXmlScanner.WhenComment (Comment : STRING); - // Is called when the parser has parsed a -BEGIN - IF Assigned (FOnComment) THEN FOnComment (Self, Comment); -END; - - -PROCEDURE TCustomXmlScanner.WhenPI (Target, Content: STRING; Attributes : TAttrList); - // Is called when the parser has parsed a -BEGIN - IF Assigned (FOnPI) THEN FOnPI (Self, Target, Content, Attributes); -END; - - -PROCEDURE TCustomXmlScanner.WhenDtdRead (RootElementName : STRING); - // Is called when the parser has completely parsed the DTD -BEGIN - IF Assigned (FOnDtdRead) THEN FOnDtdRead (Self, RootElementName); -END; - - -PROCEDURE TCustomXmlScanner.WhenStartTag (TagName : STRING; Attributes : TAttrList); - // Is called when the parser has parsed a start tag like

-BEGIN - IF Assigned (FOnStartTag) THEN FOnStartTag (Self, TagName, Attributes); -END; - - -PROCEDURE TCustomXmlScanner.WhenEmptyTag (TagName : STRING; Attributes : TAttrList); - // Is called when the parser has parsed an Empty Element Tag like
-BEGIN - IF Assigned (FOnEmptyTag) THEN FOnEmptyTag (Self, TagName, Attributes); -END; - - -PROCEDURE TCustomXmlScanner.WhenEndTag (TagName : STRING); - // Is called when the parser has parsed an End Tag like

-BEGIN - IF Assigned (FOnEndTag) THEN FOnEndTag (Self, TagName); -END; - - -PROCEDURE TCustomXmlScanner.WhenContent (Content : STRING); - // Is called when the parser has parsed an element's text content -BEGIN - IF Assigned (FOnContent) THEN FOnContent (Self, Content); -END; - - -PROCEDURE TCustomXmlScanner.WhenCData (Content : STRING); - // Is called when the parser has parsed a CDATA section -BEGIN - IF Assigned (FOnCData) THEN FOnCData (Self, Content); -END; - - -PROCEDURE TCustomXmlScanner.WhenElement (ElemDef : TElemDef); - // Is called when the parser has parsed an definition - // inside the DTD -BEGIN - IF Assigned (FOnElement) THEN FOnElement (Self, ElemDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenAttList (ElemDef : TElemDef); - // Is called when the parser has parsed an definition - // inside the DTD -BEGIN - IF Assigned (FOnAttList) THEN FOnAttList (Self, ElemDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenEntity (EntityDef : TEntityDef); - // Is called when the parser has parsed an definition - // inside the DTD -BEGIN - IF Assigned (FOnEntity) THEN FOnEntity (Self, EntityDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenNotation (NotationDef : TNotationDef); - // Is called when the parser has parsed a definition - // inside the DTD -BEGIN - IF Assigned (FOnNotation) THEN FOnNotation (Self, NotationDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : PChar); - // Is called when the parser has found an Error in the DTD -BEGIN - IF Assigned (FOnDtdError) THEN FOnDtdError (Self, ErrorPos); -END; - - -PROCEDURE TCustomXmlScanner.Execute; - // Perform scanning - // Scanning is done synchronously, i.e. you can expect events to be triggered - // in the order of the XML data stream. Execute will finish when the whole XML - // document has been scanned or when the StopParser property has been set to TRUE. -BEGIN - FStopParser := FALSE; - FXmlParser.StartScan; - WHILE FXmlParser.Scan AND (NOT FStopParser) DO - CASE FXmlParser.CurPartType OF - ptNone : ; - ptXmlProlog : WhenXmlProlog (FXmlParser.XmlVersion, FXmlParser.Encoding, FXmlParser.Standalone); - ptComment : WhenComment (StrSFPas (FXmlParser.CurStart, FXmlParser.CurFinal)); - ptPI : WhenPI (FXmlParser.CurName, FXmlParser.CurContent, FXmlParser.CurAttr); - ptDtdc : WhenDtdRead (FXmlParser.RootName); - ptStartTag : WhenStartTag (FXmlParser.CurName, FXmlParser.CurAttr); - ptEmptyTag : WhenEmptyTag (FXmlParser.CurName, FXmlParser.CurAttr); - ptEndTag : WhenEndTag (FXmlParser.CurName); - ptContent : WhenContent (FXmlParser.CurContent); - ptCData : WhenCData (FXmlParser.CurContent); - END; -END; - - -END. +(** +=============================================================================================== +Name : LibXmlParser +=============================================================================================== +Project : All Projects +=============================================================================================== +Subject : Progressive XML Parser for all types of XML Files +=============================================================================================== +Author : Stefan Heymann + Eschenweg 3 + 72076 Tübingen + GERMANY + +E-Mail: stefan@destructor.de +URL: www.destructor.de +=============================================================================================== +Source, Legals ("Licence") +-------------------------- +The official site to get this parser is http://www.destructor.de/ + +Usage and Distribution of this Source Code is ruled by the +"Destructor.de Source code Licence" (DSL) which comes with this file or +can be downloaded at http://www.destructor.de/ + +IN SHORT: Usage and distribution of this source code is free. + You use it completely on your own risk. + +Postcardware +------------ +If you like this code, please send a postcard of your city to my above address. +=============================================================================================== +!!! All parts of this code which are not finished or not conforming exactly to + the XmlSpec are marked with three exclamation marks + +-!- Parts where the parser may be able to detect errors in the document's syntax are + marked with the dash-exlamation mark-dash sequence. +=============================================================================================== +Terminology: +------------ +- Start: Start of a buffer part +- Final: End (last character) of a buffer part +- DTD: Document Type Definition +- DTDc: Document Type Declaration +- XMLSpec: The current W3C XML Recommendation (version 1.0 as of 1998-02-10), Chapter No. +- Cur*: Fields concerning the "Current" part passed back by the "Scan" method +=============================================================================================== +Scanning the XML document +------------------------- +- Create TXmlParser Instance MyXml := TXmlParser.Create; +- Load XML Document MyXml.LoadFromFile (Filename); +- Start Scanning MyXml.StartScan; +- Scan Loop WHILE MyXml.Scan DO +- Test for Part Type CASE MyXml.CurPartType OF +- Handle Parts ... : ;;; +- Handle Parts ... : ;;; +- Handle Parts ... : ;;; + END; +- Destroy MyXml.Free; +=============================================================================================== +Loading the XML document +------------------------ +You can load the XML document from a file with the "LoadFromFile" method. +It is beyond the scope of this parser to perform HTTP or FTP accesses. If you want your +application to handle such requests (URLs), you can load the XML via HTTP or FTP or whatever +protocol and hand over the data buffer using the "LoadFromBuffer" or "SetBuffer" method. +"LoadFromBuffer" loads the internal buffer of TXmlParser with the given null-terminated +string, thereby creating a copy of that buffer. +"SetBuffer" just takes the pointer to another buffer, which means that the given +buffer pointer must be valid while the document is accessed via TXmlParser. +=============================================================================================== +Encodings: +---------- +This XML parser kind of "understands" the following encodings: +- UTF-8 +- ISO-8859-1 +- Windows-1252 + +Any flavor of multi-byte characters (and this includes UTF-16) is not supported. Sorry. + +Every string which has to be passed to the application passes the virtual method +"TranslateEncoding" which translates the string from the current encoding (stored in +"CurEncoding") into the encoding the application wishes to receive. +The "TranslateEncoding" method that is built into TXmlParser assumes that the application +wants to receive Windows ANSI (Windows-1252, about the same as ISO-8859-1) and is able +to convert UTF-8 and ISO-8859-1 encodings. +For other source and target encodings, you will have to override "TranslateEncoding". +=============================================================================================== +Buffer Handling +--------------- +- The document must be loaded completely into a piece of RAM +- All character positions are referenced by PChar pointers +- The TXmlParser instance can either "own" the buffer itself (then, FBufferSize is > 0) + or reference the buffer of another instance or object (then, FBuffersize is 0 and + FBuffer is not NIL) +- The Property DocBuffer passes back a pointer to the first byte of the document. If there + is no document stored (FBuffer is NIL), the DocBuffer returns a pointer to a NULL character. +=============================================================================================== +Whitespace Handling +------------------- +The TXmlParser property "PackSpaces" determines how Whitespace is returned in Text Content: +While PackSpaces is true, all leading and trailing whitespace characters are trimmed of, all +Whitespace is converted to Space #x20 characters and contiguous Whitespace characters are +compressed to one. +If the "Scan" method reports a ptContent part, the application can get the original text +with all whitespace characters by extracting the characters from "CurStart" to "CurFinal". +If the application detects an xml:space attribute, it can set "PackSpaces" accordingly or +use CurStart/CurFinal. +Please note that TXmlParser does _not_ normalize Line Breaks to single LineFeed characters +as the XmlSpec requires (XmlSpec 2.11). +The xml:space attribute is not handled by TXmlParser. This is on behalf of the application. +=============================================================================================== +Non-XML-Conforming +------------------ +TXmlParser does not conform 100 % exactly to the XmlSpec: +- UTF-16 is not supported (XmlSpec 2.2) + (Workaround: Convert UTF-16 to UTF-8 and hand the buffer over to TXmlParser) +- As the parser only works with single byte strings, all Unicode characters > 255 + can currently not be handled correctly. +- Line breaks are not normalized to single Linefeed #x0A characters (XmlSpec 2.11) + (Workaround: The Application can access the text contents on its own [CurStart, CurFinal], + thereby applying every normalization it wishes to) +- The attribute value normalization does not work exactly as defined in the + Second Edition of the XML 1.0 specification. +- See also the code parts marked with three consecutive exclamation marks. These are + parts which are not finished in the current code release. + +This list may be incomplete, so it may grow if I get to know any other points. +As work on the parser proceeds, this list may also shrink. +=============================================================================================== +Things Todo +----------- +- Introduce a new event/callback which is called when there is an unresolvable + entity or character reference +- Support Unicode +- Use Streams instead of reading the whole XML into memory +=============================================================================================== +Change History, Version numbers +------------------------------- +The Date is given in ISO Year-Month-Day (YYYY-MM-DD) order. +Versions are counted from 1.0.0 beginning with the version from 2000-03-16. +Unreleased versions don't get a version number. + +Date Author Version Changes +----------------------------------------------------------------------------------------------- +2000-03-16 HeySt 1.0.0 Start +2000-03-28 HeySt 1.0.1 Initial Publishing of TXmlParser on the destructor.de Web Site +2000-03-30 HeySt 1.0.2 TXmlParser.AnalyzeCData: Call "TranslateEncoding" for CurContent +2000-03-31 HeySt 1.0.3 Deleted the StrPosE function (was not needed anyway) +2000-04-04 HeySt 1.0.4 TDtdElementRec modified: Start/Final for all Elements; + Should be backwards compatible. + AnalyzeDtdc: Set CurPartType to ptDtdc +2000-04-23 HeySt 1.0.5 New class TObjectList. Eliminated reference to the Delphi 5 + "Contnrs" unit so LibXmlParser is Delphi 4 compatible. +2000-07-03 HeySt 1.0.6 TNvpNode: Added Constructor +2000-07-11 HeySt 1.0.7 Removed "Windows" from USES clause + Added three-exclamation-mark comments for Utf8ToAnsi/AnsiToUtf8 + Added three-exclamation-mark comments for CHR function calls +2000-07-23 HeySt 1.0.8 TXmlParser.Clear: CurAttr.Clear; EntityStack.Clear; + (This was not a bug; just defensive programming) +2000-07-29 HeySt 1.0.9 TNvpList: Added methods: Node(Index), Value(Index), Name(Index); +2000-10-07 HeySt Introduced Conditional Defines + Uses Contnrs unit and its TObjectList class again for + Delphi 5 and newer versions +2001-01-30 HeySt Introduced Version Numbering + Made LoadFromFile and LoadFromBuffer BOOLEAN functions + Introduced FileMode parameter for LoadFromFile + BugFix: TAttrList.Analyze: Must add CWhitespace to ExtractName call + Comments worked over +2001-02-28 HeySt 1.0.10 Completely worked over and tested the UTF-8 functions + Fixed a bug in TXmlParser.Scan which caused it to start over when it + was called after the end of scanning, resulting in an endless loop + TEntityStack is now a TObjectList instead of TList +2001-07-03 HeySt 1.0.11 Updated Compiler Version IFDEFs for Kylix +2001-07-11 HeySt 1.0.12 New TCustomXmlScanner component (taken over from LibXmlComps.pas) +2001-07-14 HeySt 1.0.13 Bugfix TCustomXmlScanner.FOnTranslateEncoding +2001-10-22 HeySt Don't clear CurName anymore when the parser finds a CDATA section. +2001-12-03 HeySt 1.0.14 TObjectList.Clear: Make call to INHERITED method (fixes a memory leak) +2001-12-05 HeySt 1.0.15 TObjectList.Clear: removed call to INHERITED method + TObjectList.Destroy: Inserted SetCapacity call. + Reduces need for frequent re-allocation of pointer buffer + Dedicated to my father, Theodor Heymann +2002-06-26 HeySt 1.0.16 TXmlParser.Scan: Fixed a bug with PIs whose name is beginning + with 'xml'. Thanks to Uwe Kamm for submitting this bug. + The CurEncoding property is now always in uppercase letters (the XML + spec wants it to be treated case independently so when it's uppercase + comparisons are faster) +2002-03-04 HeySt 1.0.17 Included an IFDEF for Delphi 7 (VER150) and Kylix + There is a new symbol HAS_CONTNRS_UNIT which is used now to + distinguish between IDEs which come with the Contnrs unit and + those that don't. +*) + +UNIT libxmlparser; + +{$I jedi-sdl.inc} + +INTERFACE + +USES + SysUtils, Classes, + (*$IFDEF HAS_CONTNRS_UNIT *) // The Contnrs Unit was introduced in Delphi 5 + Contnrs, + (*$ENDIF*) + Math; + +CONST + CVersion = '1.0.17'; // This variable will be updated for every release + // (I hope, I won't forget to do it everytime ...) + +TYPE + TPartType = // --- Document Part Types + (ptNone, // Nothing + ptXmlProlog, // XML Prolog XmlSpec 2.8 / 4.3.1 + ptComment, // Comment XmlSpec 2.5 + ptPI, // Processing Instruction XmlSpec 2.6 + ptDtdc, // Document Type Declaration XmlSpec 2.8 + ptStartTag, // Start Tag XmlSpec 3.1 + ptEmptyTag, // Empty-Element Tag XmlSpec 3.1 + ptEndTag, // End Tag XmlSpec 3.1 + ptContent, // Text Content between Tags + ptCData); // CDATA Section XmlSpec 2.7 + + TDtdElemType = // --- DTD Elements + (deElement, // !ELEMENT declaration + deAttList, // !ATTLIST declaration + deEntity, // !ENTITY declaration + deNotation, // !NOTATION declaration + dePI, // PI in DTD + deComment, // Comment in DTD + deError); // Error found in the DTD + +TYPE + TAttrList = CLASS; + TEntityStack = CLASS; + TNvpList = CLASS; + TElemDef = CLASS; + TElemList = CLASS; + TEntityDef = CLASS; + TNotationDef = CLASS; + + TDtdElementRec = RECORD // --- This Record is returned by the DTD parser callback function + Start, Final : PChar; // Start/End of the Element's Declaration + CASE ElementType : TDtdElemType OF // Type of the Element + deElement, // + deAttList : (ElemDef : TElemDef); // + deEntity : (EntityDef : TEntityDef); // + deNotation : (NotationDef : TNotationDef); // + dePI : (Target : PChar; // + Content : PChar; + AttrList : TAttrList); + deError : (Pos : PChar); // Error + // deComment : ((No additional fields here)); // + END; + + TXmlParser = CLASS // --- Internal Properties and Methods + PROTECTED + FBuffer : PChar; // NIL if there is no buffer available + FBufferSize : INTEGER; // 0 if the buffer is not owned by the Document instance + FSource : STRING; // Name of Source of document. Filename for Documents loaded with LoadFromFile + + FXmlVersion : STRING; // XML version from Document header. Default is '1.0' + FEncoding : STRING; // Encoding from Document header. Default is 'UTF-8' + FStandalone : BOOLEAN; // Standalone declaration from Document header. Default is 'yes' + FRootName : STRING; // Name of the Root Element (= DTD name) + FDtdcFinal : PChar; // Pointer to the '>' character terminating the DTD declaration + + FNormalize : BOOLEAN; // If true: Pack Whitespace and don't return empty contents + EntityStack : TEntityStack; // Entity Stack for Parameter and General Entities + FCurEncoding : STRING; // Current Encoding during parsing (always uppercase) + + PROCEDURE AnalyzeProlog; // Analyze XML Prolog or Text Declaration + PROCEDURE AnalyzeComment (Start : PChar; VAR Final : PChar); // Analyze Comments + PROCEDURE AnalyzePI (Start : PChar; VAR Final : PChar); // Analyze Processing Instructions (PI) + PROCEDURE AnalyzeDtdc; // Analyze Document Type Declaration + PROCEDURE AnalyzeDtdElements (Start : PChar; VAR Final : PChar); // Analyze DTD declarations + PROCEDURE AnalyzeTag; // Analyze Start/End/Empty-Element Tags + PROCEDURE AnalyzeCData; // Analyze CDATA Sections + PROCEDURE AnalyzeText (VAR IsDone : BOOLEAN); // Analyze Text Content between Tags + PROCEDURE AnalyzeElementDecl (Start : PChar; VAR Final : PChar); + PROCEDURE AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); + PROCEDURE AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); + PROCEDURE AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); + + PROCEDURE PushPE (VAR Start : PChar); + PROCEDURE ReplaceCharacterEntities (VAR Str : STRING); + PROCEDURE ReplaceParameterEntities (VAR Str : STRING); + PROCEDURE ReplaceGeneralEntities (VAR Str : STRING); + + FUNCTION GetDocBuffer : PChar; // Returns FBuffer or a pointer to a NUL char if Buffer is empty + + PUBLIC // --- Document Properties + PROPERTY XmlVersion : STRING READ FXmlVersion; // XML version from the Document Prolog + PROPERTY Encoding : STRING READ FEncoding; // Document Encoding from Prolog + PROPERTY Standalone : BOOLEAN READ FStandalone; // Standalone Declaration from Prolog + PROPERTY RootName : STRING READ FRootName; // Name of the Root Element + PROPERTY Normalize : BOOLEAN READ FNormalize WRITE FNormalize; // True if Content is to be normalized + PROPERTY Source : STRING READ FSource; // Name of Document Source (Filename) + PROPERTY DocBuffer : PChar READ GetDocBuffer; // Returns document buffer + PUBLIC // --- DTD Objects + Elements : TElemList; // Elements: List of TElemDef (contains Attribute Definitions) + Entities : TNvpList; // General Entities: List of TEntityDef + ParEntities : TNvpList; // Parameter Entities: List of TEntityDef + Notations : TNvpList; // Notations: List of TNotationDef + PUBLIC + CONSTRUCTOR Create; + DESTRUCTOR Destroy; OVERRIDE; + + // --- Document Handling + FUNCTION LoadFromFile (Filename : STRING; + FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; + // Loads Document from given file + FUNCTION LoadFromBuffer (Buffer : PChar) : BOOLEAN; // Loads Document from another buffer + PROCEDURE SetBuffer (Buffer : PChar); // References another buffer + PROCEDURE Clear; // Clear Document + + PUBLIC + // --- Scanning through the document + CurPartType : TPartType; // Current Type + CurName : STRING; // Current Name + CurContent : STRING; // Current Normalized Content + CurStart : PChar; // Current First character + CurFinal : PChar; // Current Last character + CurAttr : TAttrList; // Current Attribute List + PROPERTY CurEncoding : STRING READ FCurEncoding; // Current Encoding + PROCEDURE StartScan; + FUNCTION Scan : BOOLEAN; + + // --- Events / Callbacks + FUNCTION LoadExternalEntity (SystemId, PublicId, + Notation : STRING) : TXmlParser; VIRTUAL; + FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; VIRTUAL; + PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); VIRTUAL; + END; + + TValueType = // --- Attribute Value Type + (vtNormal, // Normal specified Attribute + vtImplied, // #IMPLIED attribute value + vtFixed, // #FIXED attribute value + vtDefault); // Attribute value from default value in !ATTLIST declaration + + TAttrDefault = // --- Attribute Default Type + (adDefault, // Normal default value + adRequired, // #REQUIRED attribute + adImplied, // #IMPLIED attribute + adFixed); // #FIXED attribute + + TAttrType = // --- Type of attribute + (atUnknown, // Unknown type + atCData, // Character data only + atID, // ID + atIdRef, // ID Reference + atIdRefs, // Several ID References, separated by Whitespace + atEntity, // Name of an unparsed Entity + atEntities, // Several unparsed Entity names, separated by Whitespace + atNmToken, // Name Token + atNmTokens, // Several Name Tokens, separated by Whitespace + atNotation, // A selection of Notation names (Unparsed Entity) + atEnumeration); // Enumeration + + TElemType = // --- Element content type + (etEmpty, // Element is always empty + etAny, // Element can have any mixture of PCDATA and any elements + etChildren, // Element must contain only elements + etMixed); // Mixed PCDATA and elements + + (*$IFDEF HAS_CONTNRS_UNIT *) + TObjectList = Contnrs.TObjectList; // Re-Export this identifier + (*$ELSE *) + TObjectList = CLASS (TList) + DESTRUCTOR Destroy; OVERRIDE; + PROCEDURE Delete (Index : INTEGER); + PROCEDURE Clear; OVERRIDE; + END; + (*$ENDIF *) + + TNvpNode = CLASS // Name-Value Pair Node + Name : STRING; + Value : STRING; + CONSTRUCTOR Create (TheName : STRING = ''; TheValue : STRING = ''); + END; + + TNvpList = CLASS (TObjectList) // Name-Value Pair List + PROCEDURE Add (Node : TNvpNode); + FUNCTION Node (Name : STRING) : TNvpNode; OVERLOAD; + FUNCTION Node (Index : INTEGER) : TNvpNode; OVERLOAD; + FUNCTION Value (Name : STRING) : STRING; OVERLOAD; + FUNCTION Value (Index : INTEGER) : STRING; OVERLOAD; + FUNCTION Name (Index : INTEGER) : STRING; + END; + + TAttr = CLASS (TNvpNode) // Attribute of a Start-Tag or Empty-Element-Tag + ValueType : TValueType; + AttrType : TAttrType; + END; + + TAttrList = CLASS (TNvpList) // List of Attributes + PROCEDURE Analyze (Start : PChar; VAR Final : PChar); + END; + + TEntityStack = CLASS (TObjectList) // Stack where current position is stored before parsing entities + PROTECTED + Owner : TXmlParser; + PUBLIC + CONSTRUCTOR Create (TheOwner : TXmlParser); + PROCEDURE Push (LastPos : PChar); OVERLOAD; + PROCEDURE Push (Instance : TObject; LastPos : PChar); OVERLOAD; + FUNCTION Pop : PChar; // Returns next char or NIL if EOF is reached. Frees Instance. + END; + + TAttrDef = CLASS (TNvpNode) // Represents a '; + + // --- Name Constants for the above enumeration types + CPartType_Name : ARRAY [TPartType] OF STRING = + ('', 'XML Prolog', 'Comment', 'PI', + 'DTD Declaration', 'Start Tag', 'Empty Tag', 'End Tag', + 'Text', 'CDATA'); + CValueType_Name : ARRAY [TValueType] OF STRING = ('Normal', 'Implied', 'Fixed', 'Default'); + CAttrDefault_Name : ARRAY [TAttrDefault] OF STRING = ('Default', 'Required', 'Implied', 'Fixed'); + CElemType_Name : ARRAY [TElemType] OF STRING = ('Empty', 'Any', 'Childs only', 'Mixed'); + CAttrType_Name : ARRAY [TAttrType] OF STRING = ('Unknown', 'CDATA', + 'ID', 'IDREF', 'IDREFS', + 'ENTITY', 'ENTITIES', + 'NMTOKEN', 'NMTOKENS', + 'Notation', 'Enumeration'); + +FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; // Convert WS to spaces #x20 +PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); // SetString by Start/Final of buffer +FUNCTION StrSFPas (Start, Finish : PChar) : STRING; // Convert buffer part to Pascal string +FUNCTION TrimWs (Source : STRING) : STRING; // Trim Whitespace + +FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; // Convert Win-1252 to UTF-8 +FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; // Convert UTF-8 to Win-1252 + + +(* +=============================================================================================== +TCustomXmlScanner event based component wrapper for TXmlParser +=============================================================================================== +*) + +TYPE + TCustomXmlScanner = CLASS; + TXmlPrologEvent = PROCEDURE (Sender : TObject; XmlVersion, Encoding: STRING; Standalone : BOOLEAN) OF OBJECT; + TCommentEvent = PROCEDURE (Sender : TObject; Comment : STRING) OF OBJECT; + TPIEvent = PROCEDURE (Sender : TObject; Target, Content: STRING; Attributes : TAttrList) OF OBJECT; + TDtdEvent = PROCEDURE (Sender : TObject; RootElementName : STRING) OF OBJECT; + TStartTagEvent = PROCEDURE (Sender : TObject; TagName : STRING; Attributes : TAttrList) OF OBJECT; + TEndTagEvent = PROCEDURE (Sender : TObject; TagName : STRING) OF OBJECT; + TContentEvent = PROCEDURE (Sender : TObject; Content : STRING) OF OBJECT; + TElementEvent = PROCEDURE (Sender : TObject; ElemDef : TElemDef) OF OBJECT; + TEntityEvent = PROCEDURE (Sender : TObject; EntityDef : TEntityDef) OF OBJECT; + TNotationEvent = PROCEDURE (Sender : TObject; NotationDef : TNotationDef) OF OBJECT; + TErrorEvent = PROCEDURE (Sender : TObject; ErrorPos : PChar) OF OBJECT; + TExternalEvent = PROCEDURE (Sender : TObject; SystemId, PublicId, NotationId : STRING; + VAR Result : TXmlParser) OF OBJECT; + TEncodingEvent = FUNCTION (Sender : TObject; CurrentEncoding, Source : STRING) : STRING OF OBJECT; + + + TCustomXmlScanner = CLASS (TComponent) + PROTECTED + FXmlParser : TXmlParser; + FOnXmlProlog : TXmlPrologEvent; + FOnComment : TCommentEvent; + FOnPI : TPIEvent; + FOnDtdRead : TDtdEvent; + FOnStartTag : TStartTagEvent; + FOnEmptyTag : TStartTagEvent; + FOnEndTag : TEndTagEvent; + FOnContent : TContentEvent; + FOnCData : TContentEvent; + FOnElement : TElementEvent; + FOnAttList : TElementEvent; + FOnEntity : TEntityEvent; + FOnNotation : TNotationEvent; + FOnDtdError : TErrorEvent; + FOnLoadExternal : TExternalEvent; + FOnTranslateEncoding : TEncodingEvent; + FStopParser : BOOLEAN; + FUNCTION GetNormalize : BOOLEAN; + PROCEDURE SetNormalize (Value : BOOLEAN); + + PROCEDURE WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); VIRTUAL; + PROCEDURE WhenComment (Comment : STRING); VIRTUAL; + PROCEDURE WhenPI (Target, Content: STRING; Attributes : TAttrList); VIRTUAL; + PROCEDURE WhenDtdRead (RootElementName : STRING); VIRTUAL; + PROCEDURE WhenStartTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; + PROCEDURE WhenEmptyTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; + PROCEDURE WhenEndTag (TagName : STRING); VIRTUAL; + PROCEDURE WhenContent (Content : STRING); VIRTUAL; + PROCEDURE WhenCData (Content : STRING); VIRTUAL; + PROCEDURE WhenElement (ElemDef : TElemDef); VIRTUAL; + PROCEDURE WhenAttList (ElemDef : TElemDef); VIRTUAL; + PROCEDURE WhenEntity (EntityDef : TEntityDef); VIRTUAL; + PROCEDURE WhenNotation (NotationDef : TNotationDef); VIRTUAL; + PROCEDURE WhenDtdError (ErrorPos : PChar); VIRTUAL; + + PUBLIC + CONSTRUCTOR Create (AOwner: TComponent); OVERRIDE; + DESTRUCTOR Destroy; OVERRIDE; + + PROCEDURE LoadFromFile (Filename : TFilename); // Load XML Document from file + PROCEDURE LoadFromBuffer (Buffer : PChar); // Load XML Document from buffer + PROCEDURE SetBuffer (Buffer : PChar); // Refer to Buffer + FUNCTION GetFilename : TFilename; + + PROCEDURE Execute; // Perform scanning + + PROTECTED + PROPERTY XmlParser : TXmlParser READ FXmlParser; + PROPERTY StopParser : BOOLEAN READ FStopParser WRITE FStopParser; + PROPERTY Filename : TFilename READ GetFilename WRITE LoadFromFile; + PROPERTY Normalize : BOOLEAN READ GetNormalize WRITE SetNormalize; + PROPERTY OnXmlProlog : TXmlPrologEvent READ FOnXmlProlog WRITE FOnXmlProlog; + PROPERTY OnComment : TCommentEvent READ FOnComment WRITE FOnComment; + PROPERTY OnPI : TPIEvent READ FOnPI WRITE FOnPI; + PROPERTY OnDtdRead : TDtdEvent READ FOnDtdRead WRITE FOnDtdRead; + PROPERTY OnStartTag : TStartTagEvent READ FOnStartTag WRITE FOnStartTag; + PROPERTY OnEmptyTag : TStartTagEvent READ FOnEmptyTag WRITE FOnEmptyTag; + PROPERTY OnEndTag : TEndTagEvent READ FOnEndTag WRITE FOnEndTag; + PROPERTY OnContent : TContentEvent READ FOnContent WRITE FOnContent; + PROPERTY OnCData : TContentEvent READ FOnCData WRITE FOnCData; + PROPERTY OnElement : TElementEvent READ FOnElement WRITE FOnElement; + PROPERTY OnAttList : TElementEvent READ FOnAttList WRITE FOnAttList; + PROPERTY OnEntity : TEntityEvent READ FOnEntity WRITE FOnEntity; + PROPERTY OnNotation : TNotationEvent READ FOnNotation WRITE FOnNotation; + PROPERTY OnDtdError : TErrorEvent READ FOnDtdError WRITE FOnDtdError; + PROPERTY OnLoadExternal : TExternalEvent READ FOnLoadExternal WRITE FOnLoadExternal; + PROPERTY OnTranslateEncoding : TEncodingEvent READ FOnTranslateEncoding WRITE FOnTranslateEncoding; + END; + +(* +=============================================================================================== +IMPLEMENTATION +=============================================================================================== +*) + +IMPLEMENTATION + + +(* +=============================================================================================== +Unicode and UTF-8 stuff +=============================================================================================== +*) + +CONST + // --- Character Translation Table for Unicode <-> Win-1252 + WIN1252_UNICODE : ARRAY [$00..$FF] OF WORD = ( + $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, + $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, + $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, + $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, + $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, + $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, + $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, + $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, + $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, + $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, + $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, + $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, + $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, + + $20AC, $0081, $201A, $0192, $201E, $2026, $2020, $2021, $02C6, $2030, + $0160, $2039, $0152, $008D, $017D, $008F, $0090, $2018, $2019, $201C, + $201D, $2022, $2013, $2014, $02DC, $2122, $0161, $203A, $0153, $009D, + $017E, $0178, $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, + $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, $00B0, $00B1, + $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, $00B8, $00B9, $00BA, $00BB, + $00BC, $00BD, $00BE, $00BF, $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, + $00C6, $00C7, $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, + $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, $00D8, $00D9, + $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, $00E0, $00E1, $00E2, $00E3, + $00E4, $00E5, $00E6, $00E7, $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, + $00EE, $00EF, $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, + $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF); + +(* UTF-8 (somewhat simplified) + ----- + Character Range Byte sequence + --------------- -------------------------- (x=Bits from original character) + $0000..$007F 0xxxxxxx + $0080..$07FF 110xxxxx 10xxxxxx + $8000..$FFFF 1110xxxx 10xxxxxx 10xxxxxx + + Example + -------- + Transforming the Unicode character U+00E4 LATIN SMALL LETTER A WITH DIAERESIS ("ä"): + + ISO-8859-1, Decimal 228 + Win1252, Hex $E4 + ANSI Bin 1110 0100 + abcd efgh + + UTF-8 Binary 1100xxab 10cdefgh + Binary 11000011 10100100 + Hex $C3 $A4 + Decimal 195 164 + ANSI Ã ¤ *) + + +FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; + (* Converts the given Windows ANSI (Win1252) String to UTF-8. *) +VAR + I : INTEGER; // Loop counter + U : WORD; // Current Unicode value + Len : INTEGER; // Current real length of "Result" string +BEGIN + SetLength (Result, Length (Source) * 3); // Worst case + Len := 0; + FOR I := 1 TO Length (Source) DO BEGIN + U := WIN1252_UNICODE [ORD (Source [I])]; + CASE U OF + $0000..$007F : BEGIN + INC (Len); + Result [Len] := CHR (U); + END; + $0080..$07FF : BEGIN + INC (Len); + Result [Len] := CHR ($C0 OR (U SHR 6)); + INC (Len); + Result [Len] := CHR ($80 OR (U AND $3F)); + END; + $0800..$FFFF : BEGIN + INC (Len); + Result [Len] := CHR ($E0 OR (U SHR 12)); + INC (Len); + Result [Len] := CHR ($80 OR ((U SHR 6) AND $3F)); + INC (Len); + Result [Len] := CHR ($80 OR (U AND $3F)); + END; + END; + END; + SetLength (Result, Len); +END; + + +FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; + (* Converts the given UTF-8 String to Windows ANSI (Win-1252). + If a character can not be converted, the "UnknownChar" is inserted. *) +VAR + SourceLen : INTEGER; // Length of Source string + I, K : INTEGER; + A : BYTE; // Current ANSI character value + U : WORD; + Ch : CHAR; // Dest char + Len : INTEGER; // Current real length of "Result" string +BEGIN + SourceLen := Length (Source); + SetLength (Result, SourceLen); // Enough room to live + Len := 0; + I := 1; + WHILE I <= SourceLen DO BEGIN + A := ORD (Source [I]); + IF A < $80 THEN BEGIN // Range $0000..$007F + INC (Len); + Result [Len] := Source [I]; + INC (I); + END + ELSE BEGIN // Determine U, Inc I + IF (A AND $E0 = $C0) AND (I < SourceLen) THEN BEGIN // Range $0080..$07FF + U := (WORD (A AND $1F) SHL 6) OR (ORD (Source [I+1]) AND $3F); + INC (I, 2); + END + ELSE IF (A AND $F0 = $E0) AND (I < SourceLen-1) THEN BEGIN // Range $0800..$FFFF + U := (WORD (A AND $0F) SHL 12) OR + (WORD (ORD (Source [I+1]) AND $3F) SHL 6) OR + ( ORD (Source [I+2]) AND $3F); + INC (I, 3); + END + ELSE BEGIN // Unknown/unsupported + INC (I); + FOR K := 7 DOWNTO 0 DO + IF A AND (1 SHL K) = 0 THEN BEGIN + INC (I, (A SHR (K+1))-1); + BREAK; + END; + U := WIN1252_UNICODE [ORD (UnknownChar)]; + END; + Ch := UnknownChar; // Retrieve ANSI char + FOR A := $00 TO $FF DO + IF WIN1252_UNICODE [A] = U THEN BEGIN + Ch := CHR (A); + BREAK; + END; + INC (Len); + Result [Len] := Ch; + END; + END; + SetLength (Result, Len); +END; + + +(* +=============================================================================================== +"Special" Helper Functions + +Don't ask me why. But including these functions makes the parser *DRAMATICALLY* faster +on my K6-233 machine. You can test it yourself just by commenting them out. +They do exactly the same as the Assembler routines defined in SysUtils. +(This is where you can see how great the Delphi compiler really is. The compiled code is +faster than hand-coded assembler!) +=============================================================================================== +--> Just move this line below the StrScan function --> *) + + +FUNCTION StrPos (CONST Str, SearchStr : PChar) : PChar; + // Same functionality as SysUtils.StrPos +VAR + First : CHAR; + Len : INTEGER; +BEGIN + First := SearchStr^; + Len := StrLen (SearchStr); + Result := Str; + REPEAT + IF Result^ = First THEN + IF StrLComp (Result, SearchStr, Len) = 0 THEN BREAK; + IF Result^ = #0 THEN BEGIN + Result := NIL; + BREAK; + END; + INC (Result); + UNTIL FALSE; +END; + + +FUNCTION StrScan (CONST Start : PChar; CONST Ch : CHAR) : PChar; + // Same functionality as SysUtils.StrScan +BEGIN + Result := Start; + WHILE Result^ <> Ch DO BEGIN + IF Result^ = #0 THEN BEGIN + Result := NIL; + EXIT; + END; + INC (Result); + END; +END; + + +(* +=============================================================================================== +Helper Functions +=============================================================================================== +*) + +FUNCTION DelChars (Source : STRING; CharsToDelete : TCharset) : STRING; + // Delete all "CharsToDelete" from the string +VAR + I : INTEGER; +BEGIN + Result := Source; + FOR I := Length (Result) DOWNTO 1 DO + IF Result [I] IN CharsToDelete THEN + Delete (Result, I, 1); +END; + + +FUNCTION TrimWs (Source : STRING) : STRING; + // Trimms off Whitespace characters from both ends of the string +VAR + I : INTEGER; +BEGIN + // --- Trim Left + I := 1; + WHILE (I <= Length (Source)) AND (Source [I] IN CWhitespace) DO + INC (I); + Result := Copy (Source, I, MaxInt); + + // --- Trim Right + I := Length (Result); + WHILE (I > 1) AND (Result [I] IN CWhitespace) DO + DEC (I); + Delete (Result, I+1, Length (Result)-I); +END; + + +FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; + // Converts all Whitespace characters to the Space #x20 character + // If "PackWs" is true, contiguous Whitespace characters are packed to one +VAR + I : INTEGER; +BEGIN + Result := Source; + FOR I := Length (Result) DOWNTO 1 DO + IF (Result [I] IN CWhitespace) THEN + IF PackWs AND (I > 1) AND (Result [I-1] IN CWhitespace) + THEN Delete (Result, I, 1) + ELSE Result [I] := #32; +END; + + +PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); +BEGIN + SetString (S, BufferStart, BufferFinal-BufferStart+1); +END; + + +FUNCTION StrLPas (Start : PChar; Len : INTEGER) : STRING; +BEGIN + SetString (Result, Start, Len); +END; + + +FUNCTION StrSFPas (Start, Finish : PChar) : STRING; +BEGIN + SetString (Result, Start, Finish-Start+1); +END; + + +FUNCTION StrScanE (CONST Source : PChar; CONST CharToScanFor : CHAR) : PChar; + // If "CharToScanFor" is not found, StrScanE returns the last char of the + // buffer instead of NIL +BEGIN + Result := StrScan (Source, CharToScanFor); + IF Result = NIL THEN + Result := StrEnd (Source)-1; +END; + + +PROCEDURE ExtractName (Start : PChar; Terminators : TCharset; VAR Final : PChar); + (* Extracts the complete Name beginning at "Start". + It is assumed that the name is contained in Markup, so the '>' character is + always a Termination. + Start: IN Pointer to first char of name. Is always considered to be valid + Terminators: IN Characters which terminate the name + Final: OUT Pointer to last char of name *) +BEGIN + Final := Start+1; + Include (Terminators, #0); + Include (Terminators, '>'); + WHILE NOT (Final^ IN Terminators) DO + INC (Final); + DEC (Final); +END; + + +PROCEDURE ExtractQuote (Start : PChar; VAR Content : STRING; VAR Final : PChar); + (* Extract a string which is contained in single or double Quotes. + Start: IN Pointer to opening quote + Content: OUT The quoted string + Final: OUT Pointer to closing quote *) +BEGIN + Final := StrScan (Start+1, Start^); + IF Final = NIL THEN BEGIN + Final := StrEnd (Start+1)-1; + SetString (Content, Start+1, Final-Start); + END + ELSE + SetString (Content, Start+1, Final-1-Start); +END; + + +(* +=============================================================================================== +TEntityStackNode +This Node is pushed to the "Entity Stack" whenever the parser parses entity replacement text. +The "Instance" field holds the Instance pointer of an External Entity buffer. When it is +popped, the Instance is freed. +The "Encoding" field holds the name of the Encoding. External Parsed Entities may have +another encoding as the document entity (XmlSpec 4.3.3). So when there is an " 0 THEN BEGIN + ESN := TEntityStackNode (Items [Count-1]); + Result := ESN.LastPos; + IF ESN.Instance <> NIL THEN + ESN.Instance.Free; + IF ESN.Encoding <> '' THEN + Owner.FCurEncoding := ESN.Encoding; // Restore current Encoding + Delete (Count-1); + END + ELSE + Result := NIL; +END; + + +(* +=============================================================================================== +TExternalID +----------- +XmlSpec 4.2.2: ExternalID ::= 'SYSTEM' S SystemLiteral | + 'PUBLIC' S PubidLiteral S SystemLiteral +XmlSpec 4.7: PublicID ::= 'PUBLIC' S PubidLiteral +SystemLiteral and PubidLiteral are quoted +=============================================================================================== +*) + +TYPE + TExternalID = CLASS + PublicId : STRING; + SystemId : STRING; + Final : PChar; + CONSTRUCTOR Create (Start : PChar); + END; + +CONSTRUCTOR TExternalID.Create (Start : PChar); +BEGIN + INHERITED Create; + Final := Start; + IF StrLComp (Start, 'SYSTEM', 6) = 0 THEN BEGIN + WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); + IF NOT (Final^ IN CQuoteChar) THEN EXIT; + ExtractQuote (Final, SystemID, Final); + END + ELSE IF StrLComp (Start, 'PUBLIC', 6) = 0 THEN BEGIN + WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); + IF NOT (Final^ IN CQuoteChar) THEN EXIT; + ExtractQuote (Final, PublicID, Final); + INC (Final); + WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); + IF NOT (Final^ IN CQuoteChar) THEN EXIT; + ExtractQuote (Final, SystemID, Final); + END; +END; + + +(* +=============================================================================================== +TXmlParser +=============================================================================================== +*) + +CONSTRUCTOR TXmlParser.Create; +BEGIN + INHERITED Create; + FBuffer := NIL; + FBufferSize := 0; + Elements := TElemList.Create; + Entities := TNvpList.Create; + ParEntities := TNvpList.Create; + Notations := TNvpList.Create; + CurAttr := TAttrList.Create; + EntityStack := TEntityStack.Create (Self); + Clear; +END; + + +DESTRUCTOR TXmlParser.Destroy; +BEGIN + Clear; + Elements.Free; + Entities.Free; + ParEntities.Free; + Notations.Free; + CurAttr.Free; + EntityStack.Free; + INHERITED Destroy; +END; + + +PROCEDURE TXmlParser.Clear; + // Free Buffer and clear all object attributes +BEGIN + IF (FBufferSize > 0) AND (FBuffer <> NIL) THEN + FreeMem (FBuffer); + FBuffer := NIL; + FBufferSize := 0; + FSource := ''; + FXmlVersion := ''; + FEncoding := ''; + FStandalone := FALSE; + FRootName := ''; + FDtdcFinal := NIL; + FNormalize := TRUE; + Elements.Clear; + Entities.Clear; + ParEntities.Clear; + Notations.Clear; + CurAttr.Clear; + EntityStack.Clear; +END; + + +FUNCTION TXmlParser.LoadFromFile (Filename : STRING; FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; + // Loads Document from given file + // Returns TRUE if successful +VAR + f : FILE; + ReadIn : INTEGER; + OldFileMode : INTEGER; +BEGIN + Result := FALSE; + Clear; + + // --- Open File + OldFileMode := SYSTEM.FileMode; + TRY + SYSTEM.FileMode := FileMode; + TRY + AssignFile (f, Filename); + Reset (f, 1); + EXCEPT + EXIT; + END; + + TRY + // --- Allocate Memory + TRY + FBufferSize := Filesize (f) + 1; + GetMem (FBuffer, FBufferSize); + EXCEPT + Clear; + EXIT; + END; + + // --- Read File + TRY + BlockRead (f, FBuffer^, FBufferSize, ReadIn); + (FBuffer+ReadIn)^ := #0; // NULL termination + EXCEPT + Clear; + EXIT; + END; + FINALLY + CloseFile (f); + END; + + FSource := Filename; + Result := TRUE; + + FINALLY + SYSTEM.FileMode := OldFileMode; + END; +END; + + +FUNCTION TXmlParser.LoadFromBuffer (Buffer : PChar) : BOOLEAN; + // Loads Document from another buffer + // Returns TRUE if successful + // The "Source" property becomes '' if successful +BEGIN + Result := FALSE; + Clear; + FBufferSize := StrLen (Buffer) + 1; + TRY + GetMem (FBuffer, FBufferSize); + EXCEPT + Clear; + EXIT; + END; + StrCopy (FBuffer, Buffer); + FSource := ''; + Result := TRUE; +END; + + +PROCEDURE TXmlParser.SetBuffer (Buffer : PChar); // References another buffer +BEGIN + Clear; + FBuffer := Buffer; + FBufferSize := 0; + FSource := ''; +END; + + +//----------------------------------------------------------------------------------------------- +// Scanning through the document +//----------------------------------------------------------------------------------------------- + +PROCEDURE TXmlParser.StartScan; +BEGIN + CurPartType := ptNone; + CurName := ''; + CurContent := ''; + CurStart := NIL; + CurFinal := NIL; + CurAttr.Clear; + EntityStack.Clear; +END; + + +FUNCTION TXmlParser.Scan : BOOLEAN; + // Scans the next Part + // Returns TRUE if a part could be found, FALSE if there is no part any more + // + // "IsDone" can be set to FALSE by AnalyzeText in order to go to the next part + // if there is no Content due to normalization +VAR + IsDone : BOOLEAN; +BEGIN + REPEAT + IsDone := TRUE; + + // --- Start of next Part + IF CurStart = NIL + THEN CurStart := DocBuffer + ELSE CurStart := CurFinal+1; + CurFinal := CurStart; + + // --- End of Document of Pop off a new part from the Entity stack? + IF CurStart^ = #0 THEN + CurStart := EntityStack.Pop; + + // --- No Document or End Of Document: Terminate Scan + IF (CurStart = NIL) OR (CurStart^ = #0) THEN BEGIN + CurStart := StrEnd (DocBuffer); + CurFinal := CurStart-1; + EntityStack.Clear; + Result := FALSE; + EXIT; + END; + + IF (StrLComp (CurStart, ''); + IF CurFinal <> NIL + THEN INC (CurFinal) + ELSE CurFinal := StrEnd (CurStart)-1; + FCurEncoding := AnsiUpperCase (CurAttr.Value ('encoding')); + IF FCurEncoding = '' THEN + FCurEncoding := 'UTF-8'; // Default XML Encoding is UTF-8 + CurPartType := ptXmlProlog; + CurName := ''; + CurContent := ''; +END; + + +PROCEDURE TXmlParser.AnalyzeComment (Start : PChar; VAR Final : PChar); + // Analyze Comments +BEGIN + Final := StrPos (Start+4, '-->'); + IF Final = NIL + THEN Final := StrEnd (Start)-1 + ELSE INC (Final, 2); + CurPartType := ptComment; +END; + + +PROCEDURE TXmlParser.AnalyzePI (Start : PChar; VAR Final : PChar); + // Analyze Processing Instructions (PI) + // This is also called for Character +VAR + F : PChar; +BEGIN + CurPartType := ptPI; + Final := StrPos (Start+2, '?>'); + IF Final = NIL + THEN Final := StrEnd (Start)-1 + ELSE INC (Final); + ExtractName (Start+2, CWhitespace + ['?', '>'], F); + SetStringSF (CurName, Start+2, F); + SetStringSF (CurContent, F+1, Final-2); + CurAttr.Analyze (F+1, F); +END; + + +PROCEDURE TXmlParser.AnalyzeDtdc; + (* Analyze Document Type Declaration + doctypedecl ::= '' + markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment + PEReference ::= '%' Name ';' + + elementdecl ::= '' + AttlistDecl ::= '' + EntityDecl ::= '' | + '' + NotationDecl ::= '' + PI ::= '' Char* )))? '?>' + Comment ::= '' *) +TYPE + TPhase = (phName, phDtd, phInternal, phFinishing); +VAR + Phase : TPhase; + F : PChar; + ExternalID : TExternalID; + ExternalDTD : TXmlParser; + DER : TDtdElementRec; +BEGIN + DER.Start := CurStart; + EntityStack.Clear; // Clear stack for Parameter Entities + CurPartType := ptDtdc; + + // --- Don't read DTDc twice + IF FDtdcFinal <> NIL THEN BEGIN + CurFinal := FDtdcFinal; + EXIT; + END; + + // --- Scan DTDc + CurFinal := CurStart + 9; // First char after '' : BREAK; + ELSE IF NOT (CurFinal^ IN CWhitespace) THEN BEGIN + CASE Phase OF + phName : IF (CurFinal^ IN CNameStart) THEN BEGIN + ExtractName (CurFinal, CWhitespace + ['[', '>'], F); + SetStringSF (FRootName, CurFinal, F); + CurFinal := F; + Phase := phDtd; + END; + phDtd : IF (StrLComp (CurFinal, 'SYSTEM', 6) = 0) OR + (StrLComp (CurFinal, 'PUBLIC', 6) = 0) THEN BEGIN + ExternalID := TExternalID.Create (CurFinal); + ExternalDTD := LoadExternalEntity (ExternalId.SystemId, ExternalID.PublicId, ''); + F := StrPos (ExternalDtd.DocBuffer, ' NIL THEN + AnalyzeDtdElements (F, F); + ExternalDTD.Free; + CurFinal := ExternalID.Final; + ExternalID.Free; + END; + ELSE BEGIN + DER.ElementType := deError; + DER.Pos := CurFinal; + DER.Final := CurFinal; + DtdElementFound (DER); + END; + END; + + END; + END; + INC (CurFinal); + UNTIL FALSE; + + CurPartType := ptDtdc; + CurName := ''; + CurContent := ''; + + // It is an error in the document if "EntityStack" is not empty now + IF EntityStack.Count > 0 THEN BEGIN + DER.ElementType := deError; + DER.Final := CurFinal; + DER.Pos := CurFinal; + DtdElementFound (DER); + END; + + EntityStack.Clear; // Clear stack for General Entities + FDtdcFinal := CurFinal; +END; + + +PROCEDURE TXmlParser.AnalyzeDtdElements (Start : PChar; VAR Final : PChar); + // Analyze the "Elements" of a DTD contained in the external or + // internal DTD subset. +VAR + DER : TDtdElementRec; +BEGIN + Final := Start; + REPEAT + CASE Final^ OF + '%' : BEGIN + PushPE (Final); + CONTINUE; + END; + #0 : IF EntityStack.Count = 0 THEN + BREAK + ELSE BEGIN + CurFinal := EntityStack.Pop; + CONTINUE; + END; + ']', + '>' : BREAK; + '<' : IF StrLComp (Final, ''); + + // --- Set Default Attribute values for nonexistent attributes + IF (CurPartType = ptStartTag) OR (CurPartType = ptEmptyTag) THEN BEGIN + ElemDef := Elements.Node (CurName); + IF ElemDef <> NIL THEN BEGIN + FOR I := 0 TO ElemDef.Count-1 DO BEGIN + AttrDef := TAttrDef (ElemDef [I]); + Attr := TAttr (CurAttr.Node (AttrDef.Name)); + IF (Attr = NIL) AND (AttrDef.Value <> '') THEN BEGIN + Attr := TAttr.Create (AttrDef.Name, AttrDef.Value); + Attr.ValueType := vtDefault; + CurAttr.Add (Attr); + END; + IF Attr <> NIL THEN BEGIN + CASE AttrDef.DefaultType OF + adDefault : ; + adRequired : ; // -!- It is an error in the document if "Attr.Value" is an empty string + adImplied : Attr.ValueType := vtImplied; + adFixed : BEGIN + Attr.ValueType := vtFixed; + Attr.Value := AttrDef.Value; + END; + END; + Attr.AttrType := AttrDef.AttrType; + END; + END; + END; + + // --- Normalize Attribute Values. XmlSpec: + // - a character reference is processed by appending the referenced character to the attribute value + // - an entity reference is processed by recursively processing the replacement text of the entity + // - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20 to the normalized value, + // except that only a single #x20 is appended for a "#xD#xA" sequence that is part of an external + // parsed entity or the literal entity value of an internal parsed entity + // - other characters are processed by appending them to the normalized value + // If the declared value is not CDATA, then the XML processor must further process the + // normalized attribute value by discarding any leading and trailing space (#x20) characters, + // and by replacing sequences of space (#x20) characters by a single space (#x20) character. + // All attributes for which no declaration has been read should be treated by a + // non-validating parser as if declared CDATA. + // !!! The XML 1.0 SE specification is somewhat different here + // This code does not conform exactly to this specification + FOR I := 0 TO CurAttr.Count-1 DO + WITH TAttr (CurAttr [I]) DO BEGIN + ReplaceGeneralEntities (Value); + ReplaceCharacterEntities (Value); + IF (AttrType <> atCData) AND (AttrType <> atUnknown) + THEN Value := TranslateEncoding (TrimWs (ConvertWs (Value, TRUE))) + ELSE Value := TranslateEncoding (ConvertWs (Value, FALSE)); + END; + END; +END; + + +PROCEDURE TXmlParser.AnalyzeCData; + // Analyze CDATA Sections +BEGIN + CurPartType := ptCData; + CurFinal := StrPos (CurStart, CDEnd); + IF CurFinal = NIL THEN BEGIN + CurFinal := StrEnd (CurStart)-1; + CurContent := TranslateEncoding (StrPas (CurStart+Length (CDStart))); + END + ELSE BEGIN + SetStringSF (CurContent, CurStart+Length (CDStart), CurFinal-1); + INC (CurFinal, Length (CDEnd)-1); + CurContent := TranslateEncoding (CurContent); + END; +END; + + +PROCEDURE TXmlParser.AnalyzeText (VAR IsDone : BOOLEAN); + (* Analyzes Text Content between Tags. CurFinal will point to the last content character. + Content ends at a '<' character or at the end of the document. + Entity References and Character Entity references are resolved. + If PackSpaces is TRUE, contiguous Whitespace Characters will be compressed to + one Space #x20 character, Whitespace at the beginning and end of content will + be trimmed off and content which is or becomes empty is not returned to + the application (in this case, "IsDone" is set to FALSE which causes the + Scan method to proceed directly to the next part. *) + + PROCEDURE ProcessEntity; + (* Is called if there is an ampsersand '&' character found in the document. + IN "CurFinal" points to the ampersand + OUT "CurFinal" points to the first character after the semi-colon ';' *) + VAR + P : PChar; + Name : STRING; + EntityDef : TEntityDef; + ExternalEntity : TXmlParser; + BEGIN + P := StrScan (CurFinal , ';'); + IF P <> NIL THEN BEGIN + SetStringSF (Name, CurFinal+1, P-1); + + // Is it a Character Entity? + IF (CurFinal+1)^ = '#' THEN BEGIN + IF UpCase ((CurFinal+2)^) = 'X' // !!! Can't use "CHR" for Unicode characters > 255: + THEN CurContent := CurContent + CHR (StrToIntDef ('$'+Copy (Name, 3, MaxInt), 32)) + ELSE CurContent := CurContent + CHR (StrToIntDef (Copy (Name, 2, MaxInt), 32)); + CurFinal := P+1; + EXIT; + END + + // Is it a Predefined Entity? + ELSE IF Name = 'lt' THEN BEGIN CurContent := CurContent + '<'; CurFinal := P+1; EXIT; END + ELSE IF Name = 'gt' THEN BEGIN CurContent := CurContent + '>'; CurFinal := P+1; EXIT; END + ELSE IF Name = 'amp' THEN BEGIN CurContent := CurContent + '&'; CurFinal := P+1; EXIT; END + ELSE IF Name = 'apos' THEN BEGIN CurContent := CurContent + ''''; CurFinal := P+1; EXIT; END + ELSE IF Name = 'quot' THEN BEGIN CurContent := CurContent + '"'; CurFinal := P+1; EXIT; END; + + // Replace with Entity from DTD + EntityDef := TEntityDef (Entities.Node (Name)); + IF EntityDef <> NIL THEN BEGIN + IF EntityDef.Value <> '' THEN BEGIN + EntityStack.Push (P+1); + CurFinal := PChar (EntityDef.Value); + END + ELSE BEGIN + ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); + EntityStack.Push (ExternalEntity, P+1); + CurFinal := ExternalEntity.DocBuffer; + END; + END + ELSE BEGIN + CurContent := CurContent + Name; + CurFinal := P+1; + END; + END + ELSE BEGIN + INC (CurFinal); + END; + END; + +VAR + C : INTEGER; +BEGIN + CurFinal := CurStart; + CurPartType := ptContent; + CurContent := ''; + C := 0; + REPEAT + CASE CurFinal^ OF + '&' : BEGIN + CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); + C := 0; + ProcessEntity; + CONTINUE; + END; + #0 : BEGIN + IF EntityStack.Count = 0 THEN + BREAK + ELSE BEGIN + CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); + C := 0; + CurFinal := EntityStack.Pop; + CONTINUE; + END; + END; + '<' : BREAK; + ELSE INC (C); + END; + INC (CurFinal); + UNTIL FALSE; + CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); + DEC (CurFinal); + + IF FNormalize THEN BEGIN + CurContent := ConvertWs (TrimWs (CurContent), TRUE); + IsDone := CurContent <> ''; // IsDone will only get FALSE if PackSpaces is TRUE + END; +END; + + +PROCEDURE TXmlParser.AnalyzeElementDecl (Start : PChar; VAR Final : PChar); + (* Parse ' character + XmlSpec 3.2: + elementdecl ::= '' + contentspec ::= 'EMPTY' | 'ANY' | Mixed | children + Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' | + '(' S? '#PCDATA' S? ')' + children ::= (choice | seq) ('?' | '*' | '+')? + choice ::= '(' S? cp ( S? '|' S? cp )* S? ')' + cp ::= (Name | choice | seq) ('?' | '*' | '+')? + seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' + + More simply: + contentspec ::= EMPTY + ANY + '(#PCDATA)' + '(#PCDATA | A | B)*' + '(A, B, C)' + '(A | B | C)' + '(A?, B*, C+), + '(A, (B | C | D)* )' *) +VAR + Element : TElemDef; + Elem2 : TElemDef; + F : PChar; + DER : TDtdElementRec; +BEGIN + Element := TElemDef.Create; + Final := Start + 9; + DER.Start := Start; + REPEAT + IF Final^ = '>' THEN BREAK; + IF (Final^ IN CNameStart) AND (Element.Name = '') THEN BEGIN + ExtractName (Final, CWhitespace, F); + SetStringSF (Element.Name, Final, F); + Final := F; + F := StrScan (Final+1, '>'); + IF F = NIL THEN BEGIN + Element.Definition := STRING (Final); + Final := StrEnd (Final); + BREAK; + END + ELSE BEGIN + SetStringSF (Element.Definition, Final+1, F-1); + Final := F; + BREAK; + END; + END; + INC (Final); + UNTIL FALSE; + Element.Definition := DelChars (Element.Definition, CWhitespace); + ReplaceParameterEntities (Element.Definition); + IF Element.Definition = 'EMPTY' THEN Element.ElemType := etEmpty + ELSE IF Element.Definition = 'ANY' THEN Element.ElemType := etAny + ELSE IF Copy (Element.Definition, 1, 8) = '(#PCDATA' THEN Element.ElemType := etMixed + ELSE IF Copy (Element.Definition, 1, 1) = '(' THEN Element.ElemType := etChildren + ELSE Element.ElemType := etAny; + + Elem2 := Elements.Node (Element.Name); + IF Elem2 <> NIL THEN + Elements.Delete (Elements.IndexOf (Elem2)); + Elements.Add (Element); + Final := StrScanE (Final, '>'); + DER.ElementType := deElement; + DER.ElemDef := Element; + DER.Final := Final; + DtdElementFound (DER); +END; + + +PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); + (* Parse ' character + XmlSpec 3.3: + AttlistDecl ::= '' + AttDef ::= S Name S AttType S DefaultDecl + AttType ::= StringType | TokenizedType | EnumeratedType + StringType ::= 'CDATA' + TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' + EnumeratedType ::= NotationType | Enumeration + NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' + Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' + DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) + AttValue ::= '"' ([^<&"] | Reference)* '"' | "'" ([^<&'] | Reference)* "'" + Examples: + *) +TYPE + TPhase = (phElementName, phName, phType, phNotationContent, phDefault); +VAR + Phase : TPhase; + F : PChar; + ElementName : STRING; + ElemDef : TElemDef; + AttrDef : TAttrDef; + AttrDef2 : TAttrDef; + Strg : STRING; + DER : TDtdElementRec; +BEGIN + Final := Start + 9; // The character after ' : BREAK; + ELSE CASE Phase OF + phElementName : BEGIN + ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); + SetStringSF (ElementName, Final, F); + Final := F; + ElemDef := Elements.Node (ElementName); + IF ElemDef = NIL THEN BEGIN + ElemDef := TElemDef.Create; + ElemDef.Name := ElementName; + ElemDef.Definition := 'ANY'; + ElemDef.ElemType := etAny; + Elements.Add (ElemDef); + END; + Phase := phName; + END; + phName : BEGIN + AttrDef := TAttrDef.Create; + ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); + SetStringSF (AttrDef.Name, Final, F); + Final := F; + AttrDef2 := TAttrDef (ElemDef.Node (AttrDef.Name)); + IF AttrDef2 <> NIL THEN + ElemDef.Delete (ElemDef.IndexOf (AttrDef2)); + ElemDef.Add (AttrDef); + Phase := phType; + END; + phType : BEGIN + IF Final^ = '(' THEN BEGIN + F := StrScan (Final+1, ')'); + IF F <> NIL + THEN SetStringSF (AttrDef.TypeDef, Final+1, F-1) + ELSE AttrDef.TypeDef := STRING (Final+1); + AttrDef.TypeDef := DelChars (AttrDef.TypeDef, CWhitespace); + AttrDef.AttrType := atEnumeration; + ReplaceParameterEntities (AttrDef.TypeDef); + ReplaceCharacterEntities (AttrDef.TypeDef); + Phase := phDefault; + END + ELSE IF StrLComp (Final, 'NOTATION', 8) = 0 THEN BEGIN + INC (Final, 8); + AttrDef.AttrType := atNotation; + Phase := phNotationContent; + END + ELSE BEGIN + ExtractName (Final, CWhitespace+CQuoteChar+['#'], F); + SetStringSF (AttrDef.TypeDef, Final, F); + IF AttrDef.TypeDef = 'CDATA' THEN AttrDef.AttrType := atCData + ELSE IF AttrDef.TypeDef = 'ID' THEN AttrDef.AttrType := atId + ELSE IF AttrDef.TypeDef = 'IDREF' THEN AttrDef.AttrType := atIdRef + ELSE IF AttrDef.TypeDef = 'IDREFS' THEN AttrDef.AttrType := atIdRefs + ELSE IF AttrDef.TypeDef = 'ENTITY' THEN AttrDef.AttrType := atEntity + ELSE IF AttrDef.TypeDef = 'ENTITIES' THEN AttrDef.AttrType := atEntities + ELSE IF AttrDef.TypeDef = 'NMTOKEN' THEN AttrDef.AttrType := atNmToken + ELSE IF AttrDef.TypeDef = 'NMTOKENS' THEN AttrDef.AttrType := atNmTokens; + Phase := phDefault; + END + END; + phNotationContent : BEGIN + F := StrScan (Final, ')'); + IF F <> NIL THEN + SetStringSF (AttrDef.Notations, Final+1, F-1) + ELSE BEGIN + AttrDef.Notations := STRING (Final+1); + Final := StrEnd (Final); + END; + ReplaceParameterEntities (AttrDef.Notations); + AttrDef.Notations := DelChars (AttrDef.Notations, CWhitespace); + Phase := phDefault; + END; + phDefault : BEGIN + IF Final^ = '#' THEN BEGIN + ExtractName (Final, CWhiteSpace + CQuoteChar, F); + SetStringSF (Strg, Final, F); + Final := F; + ReplaceParameterEntities (Strg); + IF Strg = '#REQUIRED' THEN BEGIN AttrDef.DefaultType := adRequired; Phase := phName; END + ELSE IF Strg = '#IMPLIED' THEN BEGIN AttrDef.DefaultType := adImplied; Phase := phName; END + ELSE IF Strg = '#FIXED' THEN AttrDef.DefaultType := adFixed; + END + ELSE IF (Final^ IN CQuoteChar) THEN BEGIN + ExtractQuote (Final, AttrDef.Value, Final); + ReplaceParameterEntities (AttrDef.Value); + ReplaceCharacterEntities (AttrDef.Value); + Phase := phName; + END; + IF Phase = phName THEN BEGIN + AttrDef := NIL; + END; + END; + + END; + END; + INC (Final); + UNTIL FALSE; + + Final := StrScan (Final, '>'); + + DER.ElementType := deAttList; + DER.ElemDef := ElemDef; + DER.Final := Final; + DtdElementFound (DER); +END; + + +PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); + (* Parse ' character + XmlSpec 4.2: + EntityDecl ::= '' | + '' + EntityDef ::= EntityValue | (ExternalID NDataDecl?) + PEDef ::= EntityValue | ExternalID + NDataDecl ::= S 'NDATA' S Name + EntityValue ::= '"' ([^%&"] | PEReference | EntityRef | CharRef)* '"' | + "'" ([^%&'] | PEReference | EntityRef | CharRef)* "'" + PEReference ::= '%' Name ';' + + Examples + + + + "> + + + Dies ist ein Test-Absatz

"> + *) +TYPE + TPhase = (phName, phContent, phNData, phNotationName, phFinalGT); +VAR + Phase : TPhase; + IsParamEntity : BOOLEAN; + F : PChar; + ExternalID : TExternalID; + EntityDef : TEntityDef; + EntityDef2 : TEntityDef; + DER : TDtdElementRec; +BEGIN + Final := Start + 8; // First char after ' : BREAK; + ELSE CASE Phase OF + phName : IF Final^ IN CNameStart THEN BEGIN + ExtractName (Final, CWhitespace + CQuoteChar, F); + SetStringSF (EntityDef.Name, Final, F); + Final := F; + Phase := phContent; + END; + phContent : IF Final^ IN CQuoteChar THEN BEGIN + ExtractQuote (Final, EntityDef.Value, Final); + Phase := phFinalGT; + END + ELSE IF (StrLComp (Final, 'SYSTEM', 6) = 0) OR + (StrLComp (Final, 'PUBLIC', 6) = 0) THEN BEGIN + ExternalID := TExternalID.Create (Final); + EntityDef.SystemId := ExternalID.SystemId; + EntityDef.PublicId := ExternalID.PublicId; + Final := ExternalID.Final; + Phase := phNData; + ExternalID.Free; + END; + phNData : IF StrLComp (Final, 'NDATA', 5) = 0 THEN BEGIN + INC (Final, 4); + Phase := phNotationName; + END; + phNotationName : IF Final^ IN CNameStart THEN BEGIN + ExtractName (Final, CWhitespace + ['>'], F); + SetStringSF (EntityDef.NotationName, Final, F); + Final := F; + Phase := phFinalGT; + END; + phFinalGT : ; // -!- There is an error in the document if this branch is called + END; + END; + INC (Final); + UNTIL FALSE; + IF IsParamEntity THEN BEGIN + EntityDef2 := TEntityDef (ParEntities.Node (EntityDef.Name)); + IF EntityDef2 <> NIL THEN + ParEntities.Delete (ParEntities.IndexOf (EntityDef2)); + ParEntities.Add (EntityDef); + ReplaceCharacterEntities (EntityDef.Value); + END + ELSE BEGIN + EntityDef2 := TEntityDef (Entities.Node (EntityDef.Name)); + IF EntityDef2 <> NIL THEN + Entities.Delete (Entities.IndexOf (EntityDef2)); + Entities.Add (EntityDef); + ReplaceParameterEntities (EntityDef.Value); // Create replacement texts (see XmlSpec 4.5) + ReplaceCharacterEntities (EntityDef.Value); + END; + Final := StrScanE (Final, '>'); + + DER.ElementType := deEntity; + DER.EntityDef := EntityDef; + DER.Final := Final; + DtdElementFound (DER); +END; + + +PROCEDURE TXmlParser.AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); + // Parse ' character + // XmlSpec 4.7: NotationDecl ::= '' +TYPE + TPhase = (phName, phExtId, phEnd); +VAR + ExternalID : TExternalID; + Phase : TPhase; + F : PChar; + NotationDef : TNotationDef; + DER : TDtdElementRec; +BEGIN + Final := Start + 10; // Character after ', + #0 : BREAK; + ELSE CASE Phase OF + phName : BEGIN + ExtractName (Final, CWhitespace + ['>'], F); + SetStringSF (NotationDef.Name, Final, F); + Final := F; + Phase := phExtId; + END; + phExtId : BEGIN + ExternalID := TExternalID.Create (Final); + NotationDef.Value := ExternalID.SystemId; + NotationDef.PublicId := ExternalID.PublicId; + Final := ExternalId.Final; + ExternalId.Free; + Phase := phEnd; + END; + phEnd : ; // -!- There is an error in the document if this branch is called + END; + END; + INC (Final); + UNTIL FALSE; + Notations.Add (NotationDef); + Final := StrScanE (Final, '>'); + + DER.ElementType := deNotation; + DER.NotationDef := NotationDef; + DER.Final := Final; + DtdElementFound (DER); +END; + + +PROCEDURE TXmlParser.PushPE (VAR Start : PChar); + (* If there is a parameter entity reference found in the data stream, + the current position will be pushed to the entity stack. + Start: IN Pointer to the '%' character starting the PE reference + OUT Pointer to first character of PE replacement text *) +VAR + P : PChar; + EntityDef : TEntityDef; +BEGIN + P := StrScan (Start, ';'); + IF P <> NIL THEN BEGIN + EntityDef := TEntityDef (ParEntities.Node (StrSFPas (Start+1, P-1))); + IF EntityDef <> NIL THEN BEGIN + EntityStack.Push (P+1); + Start := PChar (EntityDef.Value); + END + ELSE + Start := P+1; + END; +END; + + +PROCEDURE TXmlParser.ReplaceCharacterEntities (VAR Str : STRING); + // Replaces all Character Entity References in the String +VAR + Start : INTEGER; + PAmp : PChar; + PSemi : PChar; + PosAmp : INTEGER; + Len : INTEGER; // Length of Entity Reference +BEGIN + IF Str = '' THEN EXIT; + Start := 1; + REPEAT + PAmp := StrPos (PChar (Str) + Start-1, '&#'); + IF PAmp = NIL THEN BREAK; + PSemi := StrScan (PAmp+2, ';'); + IF PSemi = NIL THEN BREAK; + PosAmp := PAmp - PChar (Str) + 1; + Len := PSemi-PAmp+1; + IF CompareText (Str [PosAmp+2], 'x') = 0 // !!! Can't use "CHR" for Unicode characters > 255 + THEN Str [PosAmp] := CHR (StrToIntDef ('$'+Copy (Str, PosAmp+3, Len-4), 0)) + ELSE Str [PosAmp] := CHR (StrToIntDef (Copy (Str, PosAmp+2, Len-3), 32)); + Delete (Str, PosAmp+1, Len-1); + Start := PosAmp + 1; + UNTIL FALSE; +END; + + +PROCEDURE TXmlParser.ReplaceParameterEntities (VAR Str : STRING); + // Recursively replaces all Parameter Entity References in the String + PROCEDURE ReplaceEntities (VAR Str : STRING); + VAR + Start : INTEGER; + PAmp : PChar; + PSemi : PChar; + PosAmp : INTEGER; + Len : INTEGER; + Entity : TEntityDef; + Repl : STRING; // Replacement + BEGIN + IF Str = '' THEN EXIT; + Start := 1; + REPEAT + PAmp := StrPos (PChar (Str)+Start-1, '%'); + IF PAmp = NIL THEN BREAK; + PSemi := StrScan (PAmp+2, ';'); + IF PSemi = NIL THEN BREAK; + PosAmp := PAmp - PChar (Str) + 1; + Len := PSemi-PAmp+1; + Entity := TEntityDef (ParEntities.Node (Copy (Str, PosAmp+1, Len-2))); + IF Entity <> NIL THEN BEGIN + Repl := Entity.Value; + ReplaceEntities (Repl); // Recursion + END + ELSE + Repl := Copy (Str, PosAmp, Len); + Delete (Str, PosAmp, Len); + Insert (Repl, Str, PosAmp); + Start := PosAmp + Length (Repl); + UNTIL FALSE; + END; +BEGIN + ReplaceEntities (Str); +END; + + +PROCEDURE TXmlParser.ReplaceGeneralEntities (VAR Str : STRING); + // Recursively replaces General Entity References in the String + PROCEDURE ReplaceEntities (VAR Str : STRING); + VAR + Start : INTEGER; + PAmp : PChar; + PSemi : PChar; + PosAmp : INTEGER; + Len : INTEGER; + EntityDef : TEntityDef; + EntName : STRING; + Repl : STRING; // Replacement + ExternalEntity : TXmlParser; + BEGIN + IF Str = '' THEN EXIT; + Start := 1; + REPEAT + PAmp := StrPos (PChar (Str)+Start-1, '&'); + IF PAmp = NIL THEN BREAK; + PSemi := StrScan (PAmp+2, ';'); + IF PSemi = NIL THEN BREAK; + PosAmp := PAmp - PChar (Str) + 1; + Len := PSemi-PAmp+1; + EntName := Copy (Str, PosAmp+1, Len-2); + IF EntName = 'lt' THEN Repl := '<' + ELSE IF EntName = 'gt' THEN Repl := '>' + ELSE IF EntName = 'amp' THEN Repl := '&' + ELSE IF EntName = 'apos' THEN Repl := '''' + ELSE IF EntName = 'quot' THEN Repl := '"' + ELSE BEGIN + EntityDef := TEntityDef (Entities.Node (EntName)); + IF EntityDef <> NIL THEN BEGIN + IF EntityDef.Value <> '' THEN // Internal Entity + Repl := EntityDef.Value + ELSE BEGIN // External Entity + ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); + Repl := StrPas (ExternalEntity.DocBuffer); // !!! What if it contains a Text Declaration? + ExternalEntity.Free; + END; + ReplaceEntities (Repl); // Recursion + END + ELSE + Repl := Copy (Str, PosAmp, Len); + END; + Delete (Str, PosAmp, Len); + Insert (Repl, Str, PosAmp); + Start := PosAmp + Length (Repl); + UNTIL FALSE; + END; +BEGIN + ReplaceEntities (Str); +END; + + +FUNCTION TXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser; + // This will be called whenever there is a Parsed External Entity or + // the DTD External Subset to be parsed. + // It has to create a TXmlParser instance and load the desired Entity. + // This instance of LoadExternalEntity assumes that "SystemId" is a valid + // file name (relative to the Document source) and loads this file using + // the LoadFromFile method. +VAR + Filename : STRING; +BEGIN + // --- Convert System ID to complete filename + Filename := StringReplace (SystemId, '/', '\', [rfReplaceAll]); + IF Copy (FSource, 1, 1) <> '<' THEN + IF (Copy (Filename, 1, 2) = '\\') OR (Copy (Filename, 2, 1) = ':') THEN + // Already has an absolute Path + ELSE BEGIN + Filename := ExtractFilePath (FSource) + Filename; + END; + + // --- Load the File + Result := TXmlParser.Create; + Result.LoadFromFile (Filename); +END; + + +FUNCTION TXmlParser.TranslateEncoding (CONST Source : STRING) : STRING; + // The member variable "CurEncoding" always holds the name of the current + // encoding, e.g. 'UTF-8' or 'ISO-8859-1'. + // This virtual method "TranslateEncoding" is responsible for translating + // the content passed in the "Source" parameter to the Encoding which + // is expected by the application. + // This instance of "TranlateEncoding" assumes that the Application expects + // Windows ANSI (Win1252) strings. It is able to transform UTF-8 or ISO-8859-1 + // encodings. + // If you want your application to understand or create other encodings, you + // override this function. +BEGIN + IF CurEncoding = 'UTF-8' + THEN Result := Utf8ToAnsi (Source) + ELSE Result := Source; +END; + + +PROCEDURE TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); + // This method is called for every element which is found in the DTD + // declaration. The variant record TDtdElementRec is passed which + // holds informations about the element. + // You can override this function to handle DTD declarations. + // Note that when you parse the same Document instance a second time, + // the DTD will not get parsed again. +BEGIN +END; + + +FUNCTION TXmlParser.GetDocBuffer: PChar; + // Returns FBuffer or a pointer to a NUL char if Buffer is empty +BEGIN + IF FBuffer = NIL + THEN Result := #0 + ELSE Result := FBuffer; +END; + + +(*$IFNDEF HAS_CONTNRS_UNIT +=============================================================================================== +TObjectList +=============================================================================================== +*) + +DESTRUCTOR TObjectList.Destroy; +BEGIN + Clear; + SetCapacity(0); + INHERITED Destroy; +END; + + +PROCEDURE TObjectList.Delete (Index : INTEGER); +BEGIN + IF (Index < 0) OR (Index >= Count) THEN EXIT; + TObject (Items [Index]).Free; + INHERITED Delete (Index); +END; + + +PROCEDURE TObjectList.Clear; +BEGIN + WHILE Count > 0 DO + Delete (Count-1); +END; + +(*$ENDIF *) + +(* +=============================================================================================== +TNvpNode +-------- +Node base class for the TNvpList +=============================================================================================== +*) + +CONSTRUCTOR TNvpNode.Create (TheName, TheValue : STRING); +BEGIN + INHERITED Create; + Name := TheName; + Value := TheValue; +END; + + +(* +=============================================================================================== +TNvpList +-------- +A generic List of Name-Value Pairs, based on the TObjectList introduced in Delphi 5 +=============================================================================================== +*) + +PROCEDURE TNvpList.Add (Node : TNvpNode); +VAR + I : INTEGER; +BEGIN + FOR I := Count-1 DOWNTO 0 DO + IF Node.Name > TNvpNode (Items [I]).Name THEN BEGIN + Insert (I+1, Node); + EXIT; + END; + Insert (0, Node); +END; + + + +FUNCTION TNvpList.Node (Name : STRING) : TNvpNode; + // Binary search for Node +VAR + L, H : INTEGER; // Low, High Limit + T, C : INTEGER; // Test Index, Comparison result + Last : INTEGER; // Last Test Index +BEGIN + IF Count=0 THEN BEGIN + Result := NIL; + EXIT; + END; + + L := 0; + H := Count; + Last := -1; + REPEAT + T := (L+H) DIV 2; + IF T=Last THEN BREAK; + Result := TNvpNode (Items [T]); + C := CompareStr (Result.Name, Name); + IF C = 0 THEN EXIT + ELSE IF C < 0 THEN L := T + ELSE H := T; + Last := T; + UNTIL FALSE; + Result := NIL; +END; + + +FUNCTION TNvpList.Node (Index : INTEGER) : TNvpNode; +BEGIN + IF (Index < 0) OR (Index >= Count) + THEN Result := NIL + ELSE Result := TNvpNode (Items [Index]); +END; + + +FUNCTION TNvpList.Value (Name : STRING) : STRING; +VAR + Nvp : TNvpNode; +BEGIN + Nvp := TNvpNode (Node (Name)); + IF Nvp <> NIL + THEN Result := Nvp.Value + ELSE Result := ''; +END; + + +FUNCTION TNvpList.Value (Index : INTEGER) : STRING; +BEGIN + IF (Index < 0) OR (Index >= Count) + THEN Result := '' + ELSE Result := TNvpNode (Items [Index]).Value; +END; + + +FUNCTION TNvpList.Name (Index : INTEGER) : STRING; +BEGIN + IF (Index < 0) OR (Index >= Count) + THEN Result := '' + ELSE Result := TNvpNode (Items [Index]).Name; +END; + + +(* +=============================================================================================== +TAttrList +List of Attributes. The "Analyze" method extracts the Attributes from the given Buffer. +Is used for extraction of Attributes in Start-Tags, Empty-Element Tags and the "pseudo" +attributes in XML Prologs, Text Declarations and PIs. +=============================================================================================== +*) + +PROCEDURE TAttrList.Analyze (Start : PChar; VAR Final : PChar); + // Analyze the Buffer for Attribute=Name pairs. + // Terminates when there is a character which is not IN CNameStart + // (e.g. '?>' or '>' or '/>') +TYPE + TPhase = (phName, phEq, phValue); +VAR + Phase : TPhase; + F : PChar; + Name : STRING; + Value : STRING; + Attr : TAttr; +BEGIN + Clear; + Phase := phName; + Final := Start; + REPEAT + IF (Final^ = #0) OR (Final^ = '>') THEN BREAK; + IF NOT (Final^ IN CWhitespace) THEN + CASE Phase OF + phName : BEGIN + IF NOT (Final^ IN CNameStart) THEN EXIT; + ExtractName (Final, CWhitespace + ['=', '/'], F); + SetStringSF (Name, Final, F); + Final := F; + Phase := phEq; + END; + phEq : BEGIN + IF Final^ = '=' THEN + Phase := phValue + END; + phValue : BEGIN + IF Final^ IN CQuoteChar THEN BEGIN + ExtractQuote (Final, Value, F); + Attr := TAttr.Create; + Attr.Name := Name; + Attr.Value := Value; + Attr.ValueType := vtNormal; + Add (Attr); + Final := F; + Phase := phName; + END; + END; + END; + INC (Final); + UNTIL FALSE; +END; + + +(* +=============================================================================================== +TElemList +List of TElemDef nodes. +=============================================================================================== +*) + +FUNCTION TElemList.Node (Name : STRING) : TElemDef; + // Binary search for the Node with the given Name +VAR + L, H : INTEGER; // Low, High Limit + T, C : INTEGER; // Test Index, Comparison result + Last : INTEGER; // Last Test Index +BEGIN + IF Count=0 THEN BEGIN + Result := NIL; + EXIT; + END; + + L := 0; + H := Count; + Last := -1; + REPEAT + T := (L+H) DIV 2; + IF T=Last THEN BREAK; + Result := TElemDef (Items [T]); + C := CompareStr (Result.Name, Name); + IF C = 0 THEN EXIT + ELSE IF C < 0 THEN L := T + ELSE H := T; + Last := T; + UNTIL FALSE; + Result := NIL; +END; + + +PROCEDURE TElemList.Add (Node : TElemDef); +VAR + I : INTEGER; +BEGIN + FOR I := Count-1 DOWNTO 0 DO + IF Node.Name > TElemDef (Items [I]).Name THEN BEGIN + Insert (I+1, Node); + EXIT; + END; + Insert (0, Node); +END; + + +(* +=============================================================================================== +TScannerXmlParser +A TXmlParser descendant for the TCustomXmlScanner component +=============================================================================================== +*) + +TYPE + TScannerXmlParser = CLASS (TXmlParser) + Scanner : TCustomXmlScanner; + CONSTRUCTOR Create (TheScanner : TCustomXmlScanner); + FUNCTION LoadExternalEntity (SystemId, PublicId, + Notation : STRING) : TXmlParser; OVERRIDE; + FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; OVERRIDE; + PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); OVERRIDE; + END; + +CONSTRUCTOR TScannerXmlParser.Create (TheScanner : TCustomXmlScanner); +BEGIN + INHERITED Create; + Scanner := TheScanner; +END; + + +FUNCTION TScannerXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser; +BEGIN + IF Assigned (Scanner.FOnLoadExternal) + THEN Scanner.FOnLoadExternal (Scanner, SystemId, PublicId, Notation, Result) + ELSE Result := INHERITED LoadExternalEntity (SystemId, PublicId, Notation); +END; + + +FUNCTION TScannerXmlParser.TranslateEncoding (CONST Source : STRING) : STRING; +BEGIN + IF Assigned (Scanner.FOnTranslateEncoding) + THEN Result := Scanner.FOnTranslateEncoding (Scanner, CurEncoding, Source) + ELSE Result := INHERITED TranslateEncoding (Source); +END; + + +PROCEDURE TScannerXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); +BEGIN + WITH DtdElementRec DO + CASE ElementType OF + deElement : Scanner.WhenElement (ElemDef); + deAttList : Scanner.WhenAttList (ElemDef); + deEntity : Scanner.WhenEntity (EntityDef); + deNotation : Scanner.WhenNotation (NotationDef); + dePI : Scanner.WhenPI (STRING (Target), STRING (Content), AttrList); + deComment : Scanner.WhenComment (StrSFPas (Start, Final)); + deError : Scanner.WhenDtdError (Pos); + END; +END; + + +(* +=============================================================================================== +TCustomXmlScanner +=============================================================================================== +*) + +CONSTRUCTOR TCustomXmlScanner.Create (AOwner: TComponent); +BEGIN + INHERITED; + FXmlParser := TScannerXmlParser.Create (Self); +END; + + +DESTRUCTOR TCustomXmlScanner.Destroy; +BEGIN + FXmlParser.Free; + INHERITED; +END; + + +PROCEDURE TCustomXmlScanner.LoadFromFile (Filename : TFilename); + // Load XML Document from file +BEGIN + FXmlParser.LoadFromFile (Filename); +END; + + +PROCEDURE TCustomXmlScanner.LoadFromBuffer (Buffer : PChar); + // Load XML Document from buffer +BEGIN + FXmlParser.LoadFromBuffer (Buffer); +END; + + +PROCEDURE TCustomXmlScanner.SetBuffer (Buffer : PChar); + // Refer to Buffer +BEGIN + FXmlParser.SetBuffer (Buffer); +END; + + +FUNCTION TCustomXmlScanner.GetFilename : TFilename; +BEGIN + Result := FXmlParser.Source; +END; + + +FUNCTION TCustomXmlScanner.GetNormalize : BOOLEAN; +BEGIN + Result := FXmlParser.Normalize; +END; + + +PROCEDURE TCustomXmlScanner.SetNormalize (Value : BOOLEAN); +BEGIN + FXmlParser.Normalize := Value; +END; + + +PROCEDURE TCustomXmlScanner.WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); + // Is called when the parser has parsed the declaration of the prolog +BEGIN + IF Assigned (FOnXmlProlog) THEN FOnXmlProlog (Self, XmlVersion, Encoding, Standalone); +END; + + +PROCEDURE TCustomXmlScanner.WhenComment (Comment : STRING); + // Is called when the parser has parsed a +BEGIN + IF Assigned (FOnComment) THEN FOnComment (Self, Comment); +END; + + +PROCEDURE TCustomXmlScanner.WhenPI (Target, Content: STRING; Attributes : TAttrList); + // Is called when the parser has parsed a +BEGIN + IF Assigned (FOnPI) THEN FOnPI (Self, Target, Content, Attributes); +END; + + +PROCEDURE TCustomXmlScanner.WhenDtdRead (RootElementName : STRING); + // Is called when the parser has completely parsed the DTD +BEGIN + IF Assigned (FOnDtdRead) THEN FOnDtdRead (Self, RootElementName); +END; + + +PROCEDURE TCustomXmlScanner.WhenStartTag (TagName : STRING; Attributes : TAttrList); + // Is called when the parser has parsed a start tag like

+BEGIN + IF Assigned (FOnStartTag) THEN FOnStartTag (Self, TagName, Attributes); +END; + + +PROCEDURE TCustomXmlScanner.WhenEmptyTag (TagName : STRING; Attributes : TAttrList); + // Is called when the parser has parsed an Empty Element Tag like
+BEGIN + IF Assigned (FOnEmptyTag) THEN FOnEmptyTag (Self, TagName, Attributes); +END; + + +PROCEDURE TCustomXmlScanner.WhenEndTag (TagName : STRING); + // Is called when the parser has parsed an End Tag like

+BEGIN + IF Assigned (FOnEndTag) THEN FOnEndTag (Self, TagName); +END; + + +PROCEDURE TCustomXmlScanner.WhenContent (Content : STRING); + // Is called when the parser has parsed an element's text content +BEGIN + IF Assigned (FOnContent) THEN FOnContent (Self, Content); +END; + + +PROCEDURE TCustomXmlScanner.WhenCData (Content : STRING); + // Is called when the parser has parsed a CDATA section +BEGIN + IF Assigned (FOnCData) THEN FOnCData (Self, Content); +END; + + +PROCEDURE TCustomXmlScanner.WhenElement (ElemDef : TElemDef); + // Is called when the parser has parsed an definition + // inside the DTD +BEGIN + IF Assigned (FOnElement) THEN FOnElement (Self, ElemDef); +END; + + +PROCEDURE TCustomXmlScanner.WhenAttList (ElemDef : TElemDef); + // Is called when the parser has parsed an definition + // inside the DTD +BEGIN + IF Assigned (FOnAttList) THEN FOnAttList (Self, ElemDef); +END; + + +PROCEDURE TCustomXmlScanner.WhenEntity (EntityDef : TEntityDef); + // Is called when the parser has parsed an definition + // inside the DTD +BEGIN + IF Assigned (FOnEntity) THEN FOnEntity (Self, EntityDef); +END; + + +PROCEDURE TCustomXmlScanner.WhenNotation (NotationDef : TNotationDef); + // Is called when the parser has parsed a definition + // inside the DTD +BEGIN + IF Assigned (FOnNotation) THEN FOnNotation (Self, NotationDef); +END; + + +PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : PChar); + // Is called when the parser has found an Error in the DTD +BEGIN + IF Assigned (FOnDtdError) THEN FOnDtdError (Self, ErrorPos); +END; + + +PROCEDURE TCustomXmlScanner.Execute; + // Perform scanning + // Scanning is done synchronously, i.e. you can expect events to be triggered + // in the order of the XML data stream. Execute will finish when the whole XML + // document has been scanned or when the StopParser property has been set to TRUE. +BEGIN + FStopParser := FALSE; + FXmlParser.StartScan; + WHILE FXmlParser.Scan AND (NOT FStopParser) DO + CASE FXmlParser.CurPartType OF + ptNone : ; + ptXmlProlog : WhenXmlProlog (FXmlParser.XmlVersion, FXmlParser.Encoding, FXmlParser.Standalone); + ptComment : WhenComment (StrSFPas (FXmlParser.CurStart, FXmlParser.CurFinal)); + ptPI : WhenPI (FXmlParser.CurName, FXmlParser.CurContent, FXmlParser.CurAttr); + ptDtdc : WhenDtdRead (FXmlParser.RootName); + ptStartTag : WhenStartTag (FXmlParser.CurName, FXmlParser.CurAttr); + ptEmptyTag : WhenEmptyTag (FXmlParser.CurName, FXmlParser.CurAttr); + ptEndTag : WhenEndTag (FXmlParser.CurName); + ptContent : WhenContent (FXmlParser.CurContent); + ptCData : WhenCData (FXmlParser.CurContent); + END; +END; + + +END. diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas index 461fa261..ad9b24e6 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas @@ -1,189 +1,189 @@ -unit logger; -{ - $Id: logger.pas,v 1.2 2006/11/26 16:58:04 savage Exp $ - -} -{******************************************************************************} -{ } -{ Error Logging Unit } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2000 - 2001 Dominique Louis. } -{ } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ Logging functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2001 - DL : Initial creation } -{ 25/10/2001 - DRE : Added $M+ directive to allow published } -{ in classes. Added a compile directive } -{ around fmShareExclusive as this does not } -{ exist in Free Pascal } -{ } -{******************************************************************************} -{ - $Log: logger.pas,v $ - Revision 1.2 2006/11/26 16:58:04 savage - Modifed to create separate log files. Therefore each instance running from the same directory will have their own individual log file, prepended with a number. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -{$I jedi-sdl.inc} - -{$WEAKPACKAGEUNIT OFF} - -interface - -uses - Classes, - SysUtils; - -type - TLogger = class - private - FFileHandle : TextFile; - FApplicationName : string; - FApplicationPath : string; - protected - - public - constructor Create; - destructor Destroy; override; - function GetApplicationName: string; - function GetApplicationPath: string; - procedure LogError( ErrorMessage : string; Location : string ); - procedure LogWarning( WarningMessage : string; Location : string ); - procedure LogStatus( StatusMessage : string; Location : string ); - published - property ApplicationName : string read GetApplicationName; - property ApplicationPath : string read GetApplicationPath; - end; - -var - Log : TLogger; - -implementation - -{ TLogger } -constructor TLogger.Create; -var - FileName : string; - FileNo : integer; -begin - FApplicationName := ExtractFileName( ParamStr(0) ); - FApplicationPath := ExtractFilePath( ParamStr(0) ); - FileName := FApplicationPath + ChangeFileExt( FApplicationName, '.log' ); - FileNo := 0; - while FileExists( FileName ) do - begin - inc( FileNo ); - FileName := FApplicationPath + IntToStr( FileNo ) + ChangeFileExt( FApplicationName, '.log' ) - end; - AssignFile( FFileHandle, FileName ); - ReWrite( FFileHandle ); - (*inherited Create( FApplicationPath + ChangeFileExt( FApplicationName, '.log' ), - fmCreate {$IFNDEF FPC}or fmShareExclusive{$ENDIF} );*) -end; - -destructor TLogger.Destroy; -begin - CloseFile( FFileHandle ); - inherited; -end; - -function TLogger.GetApplicationName: string; -begin - result := FApplicationName; -end; - -function TLogger.GetApplicationPath: string; -begin - result := FApplicationPath; -end; - -procedure TLogger.LogError(ErrorMessage, Location: string); -var - S : string; -begin - S := '*** ERROR *** : @ ' + TimeToStr(Time) + ' MSG : ' + ErrorMessage + ' IN : ' + Location + #13#10; - WriteLn( FFileHandle, S ); - Flush( FFileHandle ); -end; - -procedure TLogger.LogStatus(StatusMessage, Location: string); -var - S : string; -begin - S := 'STATUS INFO : @ ' + TimeToStr(Time) + ' MSG : ' + StatusMessage + ' IN : ' + Location + #13#10; - WriteLn( FFileHandle, S ); - Flush( FFileHandle ); -end; - -procedure TLogger.LogWarning(WarningMessage, Location: string); -var - S : string; -begin - S := '=== WARNING === : @ ' + TimeToStr(Time) + ' MSG : ' + WarningMessage + ' IN : ' + Location + #13#10; - WriteLn( FFileHandle, S ); - Flush( FFileHandle ); -end; - -initialization -begin - Log := TLogger.Create; - Log.LogStatus( 'Starting Application', 'Initialization' ); -end; - -finalization -begin - Log.LogStatus( 'Terminating Application', 'Finalization' ); - Log.Free; - Log := nil; -end; - -end. +unit logger; +{ + $Id: logger.pas,v 1.2 2006/11/26 16:58:04 savage Exp $ + +} +{******************************************************************************} +{ } +{ Error Logging Unit } +{ } +{ The initial developer of this Pascal code was : } +{ Dominique Louis } +{ } +{ Portions created by Dominique Louis are } +{ Copyright (C) 2000 - 2001 Dominique Louis. } +{ } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ Logging functions... } +{ } +{ } +{ Requires } +{ -------- } +{ SDL.dll on Windows platforms } +{ libSDL-1.1.so.0 on Linux platform } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ 2001 - DL : Initial creation } +{ 25/10/2001 - DRE : Added $M+ directive to allow published } +{ in classes. Added a compile directive } +{ around fmShareExclusive as this does not } +{ exist in Free Pascal } +{ } +{******************************************************************************} +{ + $Log: logger.pas,v $ + Revision 1.2 2006/11/26 16:58:04 savage + Modifed to create separate log files. Therefore each instance running from the same directory will have their own individual log file, prepended with a number. + + Revision 1.1 2004/02/05 00:08:20 savage + Module 1.0 release + + +} + +{$I jedi-sdl.inc} + +{$WEAKPACKAGEUNIT OFF} + +interface + +uses + Classes, + SysUtils; + +type + TLogger = class + private + FFileHandle : TextFile; + FApplicationName : string; + FApplicationPath : string; + protected + + public + constructor Create; + destructor Destroy; override; + function GetApplicationName: string; + function GetApplicationPath: string; + procedure LogError( ErrorMessage : string; Location : string ); + procedure LogWarning( WarningMessage : string; Location : string ); + procedure LogStatus( StatusMessage : string; Location : string ); + published + property ApplicationName : string read GetApplicationName; + property ApplicationPath : string read GetApplicationPath; + end; + +var + Log : TLogger; + +implementation + +{ TLogger } +constructor TLogger.Create; +var + FileName : string; + FileNo : integer; +begin + FApplicationName := ExtractFileName( ParamStr(0) ); + FApplicationPath := ExtractFilePath( ParamStr(0) ); + FileName := FApplicationPath + ChangeFileExt( FApplicationName, '.log' ); + FileNo := 0; + while FileExists( FileName ) do + begin + inc( FileNo ); + FileName := FApplicationPath + IntToStr( FileNo ) + ChangeFileExt( FApplicationName, '.log' ) + end; + AssignFile( FFileHandle, FileName ); + ReWrite( FFileHandle ); + (*inherited Create( FApplicationPath + ChangeFileExt( FApplicationName, '.log' ), + fmCreate {$IFNDEF FPC}or fmShareExclusive{$ENDIF} );*) +end; + +destructor TLogger.Destroy; +begin + CloseFile( FFileHandle ); + inherited; +end; + +function TLogger.GetApplicationName: string; +begin + result := FApplicationName; +end; + +function TLogger.GetApplicationPath: string; +begin + result := FApplicationPath; +end; + +procedure TLogger.LogError(ErrorMessage, Location: string); +var + S : string; +begin + S := '*** ERROR *** : @ ' + TimeToStr(Time) + ' MSG : ' + ErrorMessage + ' IN : ' + Location + #13#10; + WriteLn( FFileHandle, S ); + Flush( FFileHandle ); +end; + +procedure TLogger.LogStatus(StatusMessage, Location: string); +var + S : string; +begin + S := 'STATUS INFO : @ ' + TimeToStr(Time) + ' MSG : ' + StatusMessage + ' IN : ' + Location + #13#10; + WriteLn( FFileHandle, S ); + Flush( FFileHandle ); +end; + +procedure TLogger.LogWarning(WarningMessage, Location: string); +var + S : string; +begin + S := '=== WARNING === : @ ' + TimeToStr(Time) + ' MSG : ' + WarningMessage + ' IN : ' + Location + #13#10; + WriteLn( FFileHandle, S ); + Flush( FFileHandle ); +end; + +initialization +begin + Log := TLogger.Create; + Log.LogStatus( 'Starting Application', 'Initialization' ); +end; + +finalization +begin + Log.LogStatus( 'Terminating Application', 'Finalization' ); + Log.Free; + Log := nil; +end; + +end. \ No newline at end of file diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas index 146e4b30..56863ea5 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas @@ -1,319 +1,319 @@ -unit moduleloader; -{ - $Id: moduleloader.pas,v 1.4 2004/02/20 17:19:10 savage Exp $ - -} -{******************************************************************} -{ } -{ Project JEDI } -{ OS independent Dynamic Loading Helpers } -{ } -{ The initial developer of the this code is } -{ Robert Marquardt INVALID_MODULEHANDLE_VALUE; -end; - -// load the DLL file FileName -// LoadLibraryEx is used to get better control of the loading -// for the allowed values for flags see LoadLibraryEx documentation. - -function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; -begin - if Module = INVALID_MODULEHANDLE_VALUE then - Module := LoadLibraryEx( FileName, 0, Flags); - Result := Module <> INVALID_MODULEHANDLE_VALUE; -end; - -// unload a DLL loaded with LoadModule or LoadModuleEx -// The procedure will not try to unload a handle with -// value INVALID_MODULEHANDLE_VALUE and assigns this value -// to Module after unload. - -procedure UnloadModule(var Module: TModuleHandle); -begin - if Module <> INVALID_MODULEHANDLE_VALUE then - FreeLibrary(Module); - Module := INVALID_MODULEHANDLE_VALUE; -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the DLL Module -// nil is returned if the symbol is not available - -function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := GetProcAddress(Module, SymbolName ); -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the DLL Module -// nil is returned if the symbol is not available. -// as an extra the boolean variable Accu is updated -// by anding in the success of the function. -// This is very handy for rendering a global result -// when accessing a long list of symbols. - -function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := GetProcAddress(Module, SymbolName ); - Accu := Accu and (Result <> nil); -end; - -// get the value of variables exported from a DLL Module -// Delphi cannot access variables in a DLL directly, so -// this function allows to copy the data from the DLL. -// Beware! You are accessing the DLL memory image directly. -// Be sure to access a variable not a function and be sure -// to read the correct amount of data. - -function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Sym^, Buffer, Size); -end; - -// set the value of variables exported from a DLL Module -// Delphi cannot access variables in a DLL directly, so -// this function allows to copy the data to the DLL! -// BEWARE! You are accessing the DLL memory image directly. -// Be sure to access a variable not a function and be sure -// to write the correct amount of data. -// The changes are not persistent. They get lost when the -// DLL is unloaded. - -function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Buffer, Sym^, Size); -end; - -{$ENDIF} - -{$IFDEF Unix} -uses -{$ifdef Linux} - Types, - Libc; -{$else} - dl, - Types, - Baseunix, - Unix; -{$endif} -type - // Handle to a loaded .so - TModuleHandle = Pointer; - -const - // Value designating an unassigned TModuleHandle od a failed loading - INVALID_MODULEHANDLE_VALUE = TModuleHandle(nil); - -function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; -function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; -procedure UnloadModule(var Module: TModuleHandle); -function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; -function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; -function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; - -implementation - -// load the .so file FileName -// the rules for FileName are those of dlopen() -// Returns: True = success, False = failure to load -// Assigns: the handle of the loaded .so to Module -// Warning: if Module has any other value than INVALID_MODULEHANDLE_VALUE -// on entry the function will do nothing but returning success. - -function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; -begin - if Module = INVALID_MODULEHANDLE_VALUE then - Module := dlopen( FileName, RTLD_NOW); - Result := Module <> INVALID_MODULEHANDLE_VALUE; -end; - -// load the .so file FileName -// dlopen() with flags is used to get better control of the loading -// for the allowed values for flags see "man dlopen". - -function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; -begin - if Module = INVALID_MODULEHANDLE_VALUE then - Module := dlopen( FileName, Flags); - Result := Module <> INVALID_MODULEHANDLE_VALUE; -end; - -// unload a .so loaded with LoadModule or LoadModuleEx -// The procedure will not try to unload a handle with -// value INVALID_MODULEHANDLE_VALUE and assigns this value -// to Module after unload. - -procedure UnloadModule(var Module: TModuleHandle); -begin - if Module <> INVALID_MODULEHANDLE_VALUE then - dlclose(Module); - Module := INVALID_MODULEHANDLE_VALUE; -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the .so Module -// nil is returned if the symbol is not available - -function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := dlsym(Module, SymbolName ); -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the .so Module -// nil is returned if the symbol is not available. -// as an extra the boolean variable Accu is updated -// by anding in the success of the function. -// This is very handy for rendering a global result -// when accessing a long list of symbols. - -function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := dlsym(Module, SymbolName ); - Accu := Accu and (Result <> nil); -end; - -// get the value of variables exported from a .so Module -// Delphi cannot access variables in a .so directly, so -// this function allows to copy the data from the .so. -// Beware! You are accessing the .so memory image directly. -// Be sure to access a variable not a function and be sure -// to read the correct amount of data. - -function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Sym^, Buffer, Size); -end; - -// set the value of variables exported from a .so Module -// Delphi cannot access variables in a .so directly, so -// this function allows to copy the data to the .so! -// BEWARE! You are accessing the .so memory image directly. -// Be sure to access a variable not a function and be sure -// to write the correct amount of data. -// The changes are not persistent. They get lost when the -// .so is unloaded. - -function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Buffer, Sym^, Size); -end; -{$ENDIF} - -{$IFDEF __MACH__} // Mach definitions go here -{$ENDIF} - -end. +unit moduleloader; +{ + $Id: moduleloader.pas,v 1.4 2004/02/20 17:19:10 savage Exp $ + +} +{******************************************************************} +{ } +{ Project JEDI } +{ OS independent Dynamic Loading Helpers } +{ } +{ The initial developer of the this code is } +{ Robert Marquardt INVALID_MODULEHANDLE_VALUE; +end; + +// load the DLL file FileName +// LoadLibraryEx is used to get better control of the loading +// for the allowed values for flags see LoadLibraryEx documentation. + +function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; +begin + if Module = INVALID_MODULEHANDLE_VALUE then + Module := LoadLibraryEx( FileName, 0, Flags); + Result := Module <> INVALID_MODULEHANDLE_VALUE; +end; + +// unload a DLL loaded with LoadModule or LoadModuleEx +// The procedure will not try to unload a handle with +// value INVALID_MODULEHANDLE_VALUE and assigns this value +// to Module after unload. + +procedure UnloadModule(var Module: TModuleHandle); +begin + if Module <> INVALID_MODULEHANDLE_VALUE then + FreeLibrary(Module); + Module := INVALID_MODULEHANDLE_VALUE; +end; + +// returns the pointer to the symbol named SymbolName +// if it is exported from the DLL Module +// nil is returned if the symbol is not available + +function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; +begin + Result := nil; + if Module <> INVALID_MODULEHANDLE_VALUE then + Result := GetProcAddress(Module, SymbolName ); +end; + +// returns the pointer to the symbol named SymbolName +// if it is exported from the DLL Module +// nil is returned if the symbol is not available. +// as an extra the boolean variable Accu is updated +// by anding in the success of the function. +// This is very handy for rendering a global result +// when accessing a long list of symbols. + +function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; +begin + Result := nil; + if Module <> INVALID_MODULEHANDLE_VALUE then + Result := GetProcAddress(Module, SymbolName ); + Accu := Accu and (Result <> nil); +end; + +// get the value of variables exported from a DLL Module +// Delphi cannot access variables in a DLL directly, so +// this function allows to copy the data from the DLL. +// Beware! You are accessing the DLL memory image directly. +// Be sure to access a variable not a function and be sure +// to read the correct amount of data. + +function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; +var + Sym: Pointer; +begin + Result := True; + Sym := GetModuleSymbolEx(Module, SymbolName, Result); + if Result then + Move(Sym^, Buffer, Size); +end; + +// set the value of variables exported from a DLL Module +// Delphi cannot access variables in a DLL directly, so +// this function allows to copy the data to the DLL! +// BEWARE! You are accessing the DLL memory image directly. +// Be sure to access a variable not a function and be sure +// to write the correct amount of data. +// The changes are not persistent. They get lost when the +// DLL is unloaded. + +function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; +var + Sym: Pointer; +begin + Result := True; + Sym := GetModuleSymbolEx(Module, SymbolName, Result); + if Result then + Move(Buffer, Sym^, Size); +end; + +{$ENDIF} + +{$IFDEF Unix} +uses +{$ifdef Linux} + Types, + Libc; +{$else} + dl, + Types, + Baseunix, + Unix; +{$endif} +type + // Handle to a loaded .so + TModuleHandle = Pointer; + +const + // Value designating an unassigned TModuleHandle od a failed loading + INVALID_MODULEHANDLE_VALUE = TModuleHandle(nil); + +function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; +function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; +procedure UnloadModule(var Module: TModuleHandle); +function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; +function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; +function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; +function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; + +implementation + +// load the .so file FileName +// the rules for FileName are those of dlopen() +// Returns: True = success, False = failure to load +// Assigns: the handle of the loaded .so to Module +// Warning: if Module has any other value than INVALID_MODULEHANDLE_VALUE +// on entry the function will do nothing but returning success. + +function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; +begin + if Module = INVALID_MODULEHANDLE_VALUE then + Module := dlopen( FileName, RTLD_NOW); + Result := Module <> INVALID_MODULEHANDLE_VALUE; +end; + +// load the .so file FileName +// dlopen() with flags is used to get better control of the loading +// for the allowed values for flags see "man dlopen". + +function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; +begin + if Module = INVALID_MODULEHANDLE_VALUE then + Module := dlopen( FileName, Flags); + Result := Module <> INVALID_MODULEHANDLE_VALUE; +end; + +// unload a .so loaded with LoadModule or LoadModuleEx +// The procedure will not try to unload a handle with +// value INVALID_MODULEHANDLE_VALUE and assigns this value +// to Module after unload. + +procedure UnloadModule(var Module: TModuleHandle); +begin + if Module <> INVALID_MODULEHANDLE_VALUE then + dlclose(Module); + Module := INVALID_MODULEHANDLE_VALUE; +end; + +// returns the pointer to the symbol named SymbolName +// if it is exported from the .so Module +// nil is returned if the symbol is not available + +function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; +begin + Result := nil; + if Module <> INVALID_MODULEHANDLE_VALUE then + Result := dlsym(Module, SymbolName ); +end; + +// returns the pointer to the symbol named SymbolName +// if it is exported from the .so Module +// nil is returned if the symbol is not available. +// as an extra the boolean variable Accu is updated +// by anding in the success of the function. +// This is very handy for rendering a global result +// when accessing a long list of symbols. + +function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; +begin + Result := nil; + if Module <> INVALID_MODULEHANDLE_VALUE then + Result := dlsym(Module, SymbolName ); + Accu := Accu and (Result <> nil); +end; + +// get the value of variables exported from a .so Module +// Delphi cannot access variables in a .so directly, so +// this function allows to copy the data from the .so. +// Beware! You are accessing the .so memory image directly. +// Be sure to access a variable not a function and be sure +// to read the correct amount of data. + +function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; +var + Sym: Pointer; +begin + Result := True; + Sym := GetModuleSymbolEx(Module, SymbolName, Result); + if Result then + Move(Sym^, Buffer, Size); +end; + +// set the value of variables exported from a .so Module +// Delphi cannot access variables in a .so directly, so +// this function allows to copy the data to the .so! +// BEWARE! You are accessing the .so memory image directly. +// Be sure to access a variable not a function and be sure +// to write the correct amount of data. +// The changes are not persistent. They get lost when the +// .so is unloaded. + +function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; +var + Sym: Pointer; +begin + Result := True; + Sym := GetModuleSymbolEx(Module, SymbolName, Result); + if Result then + Move(Buffer, Sym^, Size); +end; +{$ENDIF} + +{$IFDEF __MACH__} // Mach definitions go here +{$ENDIF} + +end. diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas index 2d28a222..4a5d55f0 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas @@ -1,229 +1,229 @@ -unit registryuserpreferences; -{ - $Id: registryuserpreferences.pas,v 1.1 2004/09/30 22:35:47 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Wrapper class for Windows Register and INI Files } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: registryuserpreferences.pas,v $ - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - {$IFDEF REG} - Registry, - {$ELSE} - IniFiles, - {$ENDIF} - Classes, - userpreferences; - -type - TRegistryUserPreferences = class( TUserPreferences ) - private - - protected - function GetSection( const Index : Integer ) : string; virtual; abstract; - function GetIdentifier( const Index : Integer ) : string; virtual; abstract; - function GetDefaultBoolean( const Index : Integer ) : Boolean; override; - function GetBoolean( const Index : Integer ) : Boolean; override; - procedure SetBoolean( const Index : Integer; const Value : Boolean ); override; - function GetDefaultDateTime( const Index : Integer ) : TDateTime; override; - function GetDateTime( const Index : Integer ) : TDateTime; override; - procedure SetDateTime( const Index : Integer; const Value : TDateTime ); override; - function GetDefaultInteger( const Index : Integer ) : Integer; override; - function GetInteger( const Index : Integer ) : Integer; override; - procedure SetInteger( const Index : Integer; const Value : Integer ); override; - function GetDefaultFloat( const Index : Integer ) : single; override; - function GetFloat( const Index : Integer ) : single; override; - procedure SetFloat( const Index : Integer; const Value : single ); override; - function GetDefaultString( const Index : Integer ) : string; override; - function GetString( const Index : Integer ) : string; override; - procedure SetString( const Index : Integer; const Value : string ); override; - public - Registry : {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}; - constructor Create( const FileName : string = '' ); reintroduce; - destructor Destroy; override; - procedure Update; override; - end; - -implementation - -uses - SysUtils; - -{ TRegistryUserPreferences } -constructor TRegistryUserPreferences.Create( const FileName : string ); -var - defFileName : string; -begin - inherited Create; - - if FileName <> '' then - defFileName := FileName - else - defFileName := ChangeFileExt( ParamStr( 0 ), '.ini' ); - - Registry := {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}.Create( defFileName ); -end; - -destructor TRegistryUserPreferences.Destroy; -begin - Update; - Registry.Free; - Registry := nil; - inherited; -end; - -function TRegistryUserPreferences.GetBoolean( const Index : Integer ) : Boolean; -begin - Result := Registry.ReadBool( GetSection( Index ), GetIdentifier( Index ), GetDefaultBoolean( Index ) ); -end; - -function TRegistryUserPreferences.GetDateTime( const Index : Integer ): TDateTime; -begin - Result := Registry.ReadDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultDateTime( Index ){$ENDIF} ); -end; - -function TRegistryUserPreferences.GetDefaultBoolean( const Index : Integer ) : Boolean; -begin - result := false; -end; - -function TRegistryUserPreferences.GetDefaultDateTime( const Index: Integer ) : TDateTime; -begin - result := Now; -end; - -function TRegistryUserPreferences.GetDefaultFloat( const Index: Integer ) : single; -begin - result := 0.0; -end; - -function TRegistryUserPreferences.GetDefaultInteger(const Index : Integer ) : Integer; -begin - result := 0; -end; - -function TRegistryUserPreferences.GetDefaultString( const Index : Integer ) : string; -begin - result := ''; -end; - -function TRegistryUserPreferences.GetFloat( const Index : Integer ): single; -begin - Result := Registry.ReadFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultFloat( Index ){$ENDIF} ); -end; - -function TRegistryUserPreferences.GetInteger( const Index : Integer ) : Integer; -begin - Result := Registry.ReadInteger( GetSection( Index ), GetIdentifier( Index ), GetDefaultInteger( Index ) ); -end; - -function TRegistryUserPreferences.GetString( const Index : Integer ): string; -begin - Result := Registry.ReadString( GetSection( Index ), GetIdentifier( Index ), GetDefaultString( Index ) ); -end; - -procedure TRegistryUserPreferences.SetBoolean( const Index : Integer; const Value : Boolean ); -begin - Registry.WriteBool( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetDateTime( const Index: Integer; const Value: TDateTime ); -begin - Registry.WriteDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetFloat(const Index: Integer; const Value: single); -begin - Registry.WriteFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetInteger( const Index, Value : Integer ); -begin - Registry.WriteInteger( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetString( const Index : Integer; const Value : string ); -begin - Registry.WriteString( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.Update; -begin - {$IFDEF REG} - Registry.CloseKey; - {$ELSE} - Registry.UpdateFile; - {$ENDIF} -end; - -end. +unit registryuserpreferences; +{ + $Id: registryuserpreferences.pas,v 1.1 2004/09/30 22:35:47 savage Exp $ + +} +{******************************************************************************} +{ } +{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } +{ Wrapper class for Windows Register and INI Files } +{ } +{ The initial developer of this Pascal code was : } +{ Dominqiue Louis } +{ } +{ Portions created by Dominqiue Louis are } +{ Copyright (C) 2000 - 2001 Dominqiue Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ } +{ } +{ } +{ } +{ } +{ } +{ } +{ Requires } +{ -------- } +{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } +{ They are available from... } +{ http://www.libsdl.org . } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ September 23 2004 - DL : Initial Creation } +{ + $Log: registryuserpreferences.pas,v $ + Revision 1.1 2004/09/30 22:35:47 savage + Changes, enhancements and additions as required to get SoAoS working. + + +} +{******************************************************************************} + +interface + +uses + {$IFDEF REG} + Registry, + {$ELSE} + IniFiles, + {$ENDIF} + Classes, + userpreferences; + +type + TRegistryUserPreferences = class( TUserPreferences ) + private + + protected + function GetSection( const Index : Integer ) : string; virtual; abstract; + function GetIdentifier( const Index : Integer ) : string; virtual; abstract; + function GetDefaultBoolean( const Index : Integer ) : Boolean; override; + function GetBoolean( const Index : Integer ) : Boolean; override; + procedure SetBoolean( const Index : Integer; const Value : Boolean ); override; + function GetDefaultDateTime( const Index : Integer ) : TDateTime; override; + function GetDateTime( const Index : Integer ) : TDateTime; override; + procedure SetDateTime( const Index : Integer; const Value : TDateTime ); override; + function GetDefaultInteger( const Index : Integer ) : Integer; override; + function GetInteger( const Index : Integer ) : Integer; override; + procedure SetInteger( const Index : Integer; const Value : Integer ); override; + function GetDefaultFloat( const Index : Integer ) : single; override; + function GetFloat( const Index : Integer ) : single; override; + procedure SetFloat( const Index : Integer; const Value : single ); override; + function GetDefaultString( const Index : Integer ) : string; override; + function GetString( const Index : Integer ) : string; override; + procedure SetString( const Index : Integer; const Value : string ); override; + public + Registry : {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}; + constructor Create( const FileName : string = '' ); reintroduce; + destructor Destroy; override; + procedure Update; override; + end; + +implementation + +uses + SysUtils; + +{ TRegistryUserPreferences } +constructor TRegistryUserPreferences.Create( const FileName : string ); +var + defFileName : string; +begin + inherited Create; + + if FileName <> '' then + defFileName := FileName + else + defFileName := ChangeFileExt( ParamStr( 0 ), '.ini' ); + + Registry := {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}.Create( defFileName ); +end; + +destructor TRegistryUserPreferences.Destroy; +begin + Update; + Registry.Free; + Registry := nil; + inherited; +end; + +function TRegistryUserPreferences.GetBoolean( const Index : Integer ) : Boolean; +begin + Result := Registry.ReadBool( GetSection( Index ), GetIdentifier( Index ), GetDefaultBoolean( Index ) ); +end; + +function TRegistryUserPreferences.GetDateTime( const Index : Integer ): TDateTime; +begin + Result := Registry.ReadDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultDateTime( Index ){$ENDIF} ); +end; + +function TRegistryUserPreferences.GetDefaultBoolean( const Index : Integer ) : Boolean; +begin + result := false; +end; + +function TRegistryUserPreferences.GetDefaultDateTime( const Index: Integer ) : TDateTime; +begin + result := Now; +end; + +function TRegistryUserPreferences.GetDefaultFloat( const Index: Integer ) : single; +begin + result := 0.0; +end; + +function TRegistryUserPreferences.GetDefaultInteger(const Index : Integer ) : Integer; +begin + result := 0; +end; + +function TRegistryUserPreferences.GetDefaultString( const Index : Integer ) : string; +begin + result := ''; +end; + +function TRegistryUserPreferences.GetFloat( const Index : Integer ): single; +begin + Result := Registry.ReadFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultFloat( Index ){$ENDIF} ); +end; + +function TRegistryUserPreferences.GetInteger( const Index : Integer ) : Integer; +begin + Result := Registry.ReadInteger( GetSection( Index ), GetIdentifier( Index ), GetDefaultInteger( Index ) ); +end; + +function TRegistryUserPreferences.GetString( const Index : Integer ): string; +begin + Result := Registry.ReadString( GetSection( Index ), GetIdentifier( Index ), GetDefaultString( Index ) ); +end; + +procedure TRegistryUserPreferences.SetBoolean( const Index : Integer; const Value : Boolean ); +begin + Registry.WriteBool( GetSection( Index ), GetIdentifier( Index ), Value ); + inherited; +end; + +procedure TRegistryUserPreferences.SetDateTime( const Index: Integer; const Value: TDateTime ); +begin + Registry.WriteDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); + inherited; +end; + +procedure TRegistryUserPreferences.SetFloat(const Index: Integer; const Value: single); +begin + Registry.WriteFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); + inherited; +end; + +procedure TRegistryUserPreferences.SetInteger( const Index, Value : Integer ); +begin + Registry.WriteInteger( GetSection( Index ), GetIdentifier( Index ), Value ); + inherited; +end; + +procedure TRegistryUserPreferences.SetString( const Index : Integer; const Value : string ); +begin + Registry.WriteString( GetSection( Index ), GetIdentifier( Index ), Value ); + inherited; +end; + +procedure TRegistryUserPreferences.Update; +begin + {$IFDEF REG} + Registry.CloseKey; + {$ELSE} + Registry.UpdateFile; + {$ENDIF} +end; + +end. diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas index bd371c55..b09f19f9 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas @@ -1,155 +1,155 @@ -unit sdl_cpuinfo; -{ - $Id: sdl_cpuinfo.pas,v 1.2 2004/02/18 22:52:53 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ Conversion of the Simple DirectMedia Layer Headers } -{ } -{ Portions created by Sam Lantinga are } -{ Copyright (C) 1997-2004 Sam Lantinga } -{ 5635-34 Springhouse Dr. } -{ Pleasanton, CA 94588 (USA) } -{ } -{ All Rights Reserved. } -{ } -{ The original files are : SDL_cpuinfo.h } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2004 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ - $Log: sdl_cpuinfo.pas,v $ - Revision 1.2 2004/02/18 22:52:53 savage - Forgot to add jedi-sdl.inc file. It's there now. - - Revision 1.1 2004/02/18 22:35:54 savage - Brought sdl.pas up to 1.2.7 compatability - Thus... - Added SDL_GL_STEREO, - SDL_GL_MULTISAMPLEBUFFERS, - SDL_GL_MULTISAMPLESAMPLES - - Add DLL/Shared object functions - function SDL_LoadObject( const sofile : PChar ) : Pointer; - - function SDL_LoadFunction( handle : Pointer; const name : PChar ) : Pointer; - - procedure SDL_UnloadObject( handle : Pointer ); - - Added function to create RWops from const memory: SDL_RWFromConstMem() - function SDL_RWFromConstMem(const mem: Pointer; size: Integer) : PSDL_RWops; - - Ported SDL_cpuinfo.h so Now you can test for Specific CPU types. - - -} -{******************************************************************************} - -interface - -{$I jedi-sdl.inc} - -uses - sdl; - -{* This function returns true if the CPU has the RDTSC instruction - *} -function SDL_HasRDTSC : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasRDTSC'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasRDTSC} - -{* This function returns true if the CPU has MMX features - *} -function SDL_HasMMX : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMX'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasMMX} - -{* This function returns true if the CPU has MMX Ext. features - *} -function SDL_HasMMXExt : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMXExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasMMXExt} - -{* This function returns true if the CPU has 3DNow features - *} -function SDL_Has3DNow : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNow'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_Has3DNow} - -{* This function returns true if the CPU has 3DNow! Ext. features - *} -function SDL_Has3DNowExt : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNowExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_Has3DNowExt} - -{* This function returns true if the CPU has SSE features - *} -function SDL_HasSSE : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasSSE} - -{* This function returns true if the CPU has SSE2 features - *} -function SDL_HasSSE2 : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE2'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasSSE2} - -{* This function returns true if the CPU has AltiVec features - *} -function SDL_HasAltiVec : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasAltiVec'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasAltiVec} - -implementation - -end. +unit sdl_cpuinfo; +{ + $Id: sdl_cpuinfo.pas,v 1.2 2004/02/18 22:52:53 savage Exp $ + +} +{******************************************************************************} +{ } +{ Borland Delphi SDL - Simple DirectMedia Layer } +{ Conversion of the Simple DirectMedia Layer Headers } +{ } +{ Portions created by Sam Lantinga are } +{ Copyright (C) 1997-2004 Sam Lantinga } +{ 5635-34 Springhouse Dr. } +{ Pleasanton, CA 94588 (USA) } +{ } +{ All Rights Reserved. } +{ } +{ The original files are : SDL_cpuinfo.h } +{ } +{ The initial developer of this Pascal code was : } +{ Dominqiue Louis } +{ } +{ Portions created by Dominqiue Louis are } +{ Copyright (C) 2000 - 2004 Dominqiue Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ } +{ } +{ } +{ } +{ } +{ } +{ } +{ Requires } +{ -------- } +{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } +{ They are available from... } +{ http://www.libsdl.org . } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ + $Log: sdl_cpuinfo.pas,v $ + Revision 1.2 2004/02/18 22:52:53 savage + Forgot to add jedi-sdl.inc file. It's there now. + + Revision 1.1 2004/02/18 22:35:54 savage + Brought sdl.pas up to 1.2.7 compatability + Thus... + Added SDL_GL_STEREO, + SDL_GL_MULTISAMPLEBUFFERS, + SDL_GL_MULTISAMPLESAMPLES + + Add DLL/Shared object functions + function SDL_LoadObject( const sofile : PChar ) : Pointer; + + function SDL_LoadFunction( handle : Pointer; const name : PChar ) : Pointer; + + procedure SDL_UnloadObject( handle : Pointer ); + + Added function to create RWops from const memory: SDL_RWFromConstMem() + function SDL_RWFromConstMem(const mem: Pointer; size: Integer) : PSDL_RWops; + + Ported SDL_cpuinfo.h so Now you can test for Specific CPU types. + + +} +{******************************************************************************} + +interface + +{$I jedi-sdl.inc} + +uses + sdl; + +{* This function returns true if the CPU has the RDTSC instruction + *} +function SDL_HasRDTSC : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_HasRDTSC'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_HasRDTSC} + +{* This function returns true if the CPU has MMX features + *} +function SDL_HasMMX : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMX'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_HasMMX} + +{* This function returns true if the CPU has MMX Ext. features + *} +function SDL_HasMMXExt : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMXExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_HasMMXExt} + +{* This function returns true if the CPU has 3DNow features + *} +function SDL_Has3DNow : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNow'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_Has3DNow} + +{* This function returns true if the CPU has 3DNow! Ext. features + *} +function SDL_Has3DNowExt : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNowExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_Has3DNowExt} + +{* This function returns true if the CPU has SSE features + *} +function SDL_HasSSE : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_HasSSE} + +{* This function returns true if the CPU has SSE2 features + *} +function SDL_HasSSE2 : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE2'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_HasSSE2} + +{* This function returns true if the CPU has AltiVec features + *} +function SDL_HasAltiVec : SDL_Bool; +cdecl; external {$IFDEF __GPC__}name 'SDL_HasAltiVec'{$ELSE} SDLLibName{$ENDIF __GPC__}; +{$EXTERNALSYM SDL_HasAltiVec} + +implementation + +end. \ No newline at end of file diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas index cc95751d..9a58ff40 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas @@ -1,202 +1,202 @@ -unit sdlgameinterface; -{ - $Id: sdlgameinterface.pas,v 1.4 2005/08/03 18:57:31 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Game Interface Base class } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: sdlgameinterface.pas,v $ - Revision 1.4 2005/08/03 18:57:31 savage - Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class - - Revision 1.3 2004/10/17 18:41:49 savage - Slight Change to allow Reseting of Input Event handlers - - Revision 1.2 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - sdl, - sdlwindow; - -type - TGameInterfaceClass = class of TGameInterface; - - TGameInterface = class( TObject ) - private - FNextGameInterface : TGameInterfaceClass; - protected - Dragging : Boolean; - Loaded : Boolean; - procedure FreeSurfaces; virtual; - procedure Render; virtual; abstract; - procedure Close; virtual; - procedure Update( aElapsedTime : single ); virtual; - procedure MouseDown( Button : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; - procedure MouseMove( Shift: TSDLMod; CurrentPos : TPoint; RelativePos : TPoint ); virtual; - procedure MouseUp( Button : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; - procedure MouseWheelScroll( WheelDelta : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; - procedure KeyDown( var Key: TSDLKey; Shift: TSDLMod; unicode : UInt16 ); virtual; - public - MainWindow : TSDLCustomWindow; - procedure ResetInputManager; - procedure LoadSurfaces; virtual; - function PointIsInRect( Point : TPoint; x, y, x1, y1 : integer ) : Boolean; - constructor Create( const aMainWindow : TSDLCustomWindow ); - destructor Destroy; override; - property NextGameInterface : TGameInterfaceClass read FNextGameInterface write FNextGameInterface; - end; - -implementation - -{ TGameInterface } -procedure TGameInterface.Close; -begin - FNextGameInterface := nil; -end; - -constructor TGameInterface.Create( const aMainWindow : TSDLCustomWindow ); -begin - inherited Create; - MainWindow := aMainWindow; - FNextGameInterface := TGameInterface; - ResetInputManager; -end; - -destructor TGameInterface.Destroy; -begin - if Loaded then - FreeSurfaces; - inherited; -end; - -procedure TGameInterface.FreeSurfaces; -begin - Loaded := False; -end; - -procedure TGameInterface.KeyDown(var Key: TSDLKey; Shift: TSDLMod; unicode: UInt16); -begin - -end; - -procedure TGameInterface.LoadSurfaces; -begin - Loaded := True; -end; - -procedure TGameInterface.MouseDown(Button: Integer; Shift: TSDLMod; MousePos: TPoint); -begin - Dragging := True; -end; - -procedure TGameInterface.MouseMove(Shift: TSDLMod; CurrentPos, RelativePos: TPoint); -begin - -end; - -procedure TGameInterface.MouseUp(Button: Integer; Shift: TSDLMod; MousePos: TPoint); -begin - Dragging := True; -end; - -procedure TGameInterface.MouseWheelScroll(WheelDelta: Integer; Shift: TSDLMod; MousePos: TPoint); -begin - -end; - -function TGameInterface.PointIsInRect( Point : TPoint; x, y, x1, y1: integer ): Boolean; -begin - if ( Point.x >= x ) - and ( Point.y >= y ) - and ( Point.x <= x1 ) - and ( Point.y <= y1 ) then - result := true - else - result := false; -end; - -procedure TGameInterface.ResetInputManager; -var - temp : TSDLNotifyEvent; -begin - MainWindow.InputManager.Mouse.OnMouseDown := MouseDown; - MainWindow.InputManager.Mouse.OnMouseMove := MouseMove; - MainWindow.InputManager.Mouse.OnMouseUp := MouseUp; - MainWindow.InputManager.Mouse.OnMouseWheel := MouseWheelScroll; - MainWindow.InputManager.KeyBoard.OnKeyDown := KeyDown; - temp := Render; - MainWindow.OnRender := temp; - temp := Close; - MainWindow.OnClose := temp; - MainWindow.OnUpdate := Update; -end; - -procedure TGameInterface.Update(aElapsedTime: single); -begin - -end; - -end. +unit sdlgameinterface; +{ + $Id: sdlgameinterface.pas,v 1.4 2005/08/03 18:57:31 savage Exp $ + +} +{******************************************************************************} +{ } +{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } +{ Game Interface Base class } +{ } +{ The initial developer of this Pascal code was : } +{ Dominqiue Louis } +{ } +{ Portions created by Dominqiue Louis are } +{ Copyright (C) 2000 - 2001 Dominqiue Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ } +{ } +{ } +{ } +{ } +{ } +{ } +{ Requires } +{ -------- } +{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } +{ They are available from... } +{ http://www.libsdl.org . } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ September 23 2004 - DL : Initial Creation } +{ + $Log: sdlgameinterface.pas,v $ + Revision 1.4 2005/08/03 18:57:31 savage + Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class + + Revision 1.3 2004/10/17 18:41:49 savage + Slight Change to allow Reseting of Input Event handlers + + Revision 1.2 2004/09/30 22:35:47 savage + Changes, enhancements and additions as required to get SoAoS working. + + +} +{******************************************************************************} + +interface + +uses + sdl, + sdlwindow; + +type + TGameInterfaceClass = class of TGameInterface; + + TGameInterface = class( TObject ) + private + FNextGameInterface : TGameInterfaceClass; + protected + Dragging : Boolean; + Loaded : Boolean; + procedure FreeSurfaces; virtual; + procedure Render; virtual; abstract; + procedure Close; virtual; + procedure Update( aElapsedTime : single ); virtual; + procedure MouseDown( Button : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; + procedure MouseMove( Shift: TSDLMod; CurrentPos : TPoint; RelativePos : TPoint ); virtual; + procedure MouseUp( Button : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; + procedure MouseWheelScroll( WheelDelta : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; + procedure KeyDown( var Key: TSDLKey; Shift: TSDLMod; unicode : UInt16 ); virtual; + public + MainWindow : TSDLCustomWindow; + procedure ResetInputManager; + procedure LoadSurfaces; virtual; + function PointIsInRect( Point : TPoint; x, y, x1, y1 : integer ) : Boolean; + constructor Create( const aMainWindow : TSDLCustomWindow ); + destructor Destroy; override; + property NextGameInterface : TGameInterfaceClass read FNextGameInterface write FNextGameInterface; + end; + +implementation + +{ TGameInterface } +procedure TGameInterface.Close; +begin + FNextGameInterface := nil; +end; + +constructor TGameInterface.Create( const aMainWindow : TSDLCustomWindow ); +begin + inherited Create; + MainWindow := aMainWindow; + FNextGameInterface := TGameInterface; + ResetInputManager; +end; + +destructor TGameInterface.Destroy; +begin + if Loaded then + FreeSurfaces; + inherited; +end; + +procedure TGameInterface.FreeSurfaces; +begin + Loaded := False; +end; + +procedure TGameInterface.KeyDown(var Key: TSDLKey; Shift: TSDLMod; unicode: UInt16); +begin + +end; + +procedure TGameInterface.LoadSurfaces; +begin + Loaded := True; +end; + +procedure TGameInterface.MouseDown(Button: Integer; Shift: TSDLMod; MousePos: TPoint); +begin + Dragging := True; +end; + +procedure TGameInterface.MouseMove(Shift: TSDLMod; CurrentPos, RelativePos: TPoint); +begin + +end; + +procedure TGameInterface.MouseUp(Button: Integer; Shift: TSDLMod; MousePos: TPoint); +begin + Dragging := True; +end; + +procedure TGameInterface.MouseWheelScroll(WheelDelta: Integer; Shift: TSDLMod; MousePos: TPoint); +begin + +end; + +function TGameInterface.PointIsInRect( Point : TPoint; x, y, x1, y1: integer ): Boolean; +begin + if ( Point.x >= x ) + and ( Point.y >= y ) + and ( Point.x <= x1 ) + and ( Point.y <= y1 ) then + result := true + else + result := false; +end; + +procedure TGameInterface.ResetInputManager; +var + temp : TSDLNotifyEvent; +begin + MainWindow.InputManager.Mouse.OnMouseDown := MouseDown; + MainWindow.InputManager.Mouse.OnMouseMove := MouseMove; + MainWindow.InputManager.Mouse.OnMouseUp := MouseUp; + MainWindow.InputManager.Mouse.OnMouseWheel := MouseWheelScroll; + MainWindow.InputManager.KeyBoard.OnKeyDown := KeyDown; + temp := Render; + MainWindow.OnRender := temp; + temp := Close; + MainWindow.OnClose := temp; + MainWindow.OnUpdate := Update; +end; + +procedure TGameInterface.Update(aElapsedTime: single); +begin + +end; + +end. diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas index 9151168a..4de4ebee 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas @@ -1,5236 +1,5236 @@ -unit sdli386utils; -{ - $Id: sdli386utils.pas,v 1.5 2004/06/02 19:38:53 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ SDL Utility functions } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Tom Jones } -{ } -{ Portions created by Tom Jones are } -{ Copyright (C) 2000 - 2001 Tom Jones. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ Róbert Kisnémeth } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ Helper functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2000 - TJ : Initial creation } -{ } -{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } -{ } -{ Sept 14 2001 - RK : Added flipping routines. } -{ } -{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } -{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } -{ Added PSDLRect() } -{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} -{ Also removed by poor attempt or a dialog box } -{ } -{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } -{ SubSurface, MonoSurface & TexturedSurface } -{ } -{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } -{ types rather that Windows types. This makes it more} -{ portable to Linix. } -{ } -{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } -{ } -{ Oct 27 2001 - JF : Added ScrollY function } -{ } -{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } -{ } -{ Mar 28 2002 - JF : Added SDL_RotateSurface } -{ } -{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } -{ } -{ May 27 2002 - YS : GradientFillRect function } -{ } -{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } -{ & SDL_50Scanline2xBlit } -{ } -{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } -{ } -{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } -{ } -{ November 9 2002 - JF : Added Jason's boolean Surface functions } -{ } -{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } -{ } -{******************************************************************************} -{ - $Log: sdli386utils.pas,v $ - Revision 1.5 2004/06/02 19:38:53 savage - Changes to SDL_GradientFillRect as suggested by - Ángel Eduardo García Hernández. Many thanks. - - Revision 1.4 2004/05/29 23:11:53 savage - Changes to SDL_ScaleSurfaceRect as suggested by - Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. - - Revision 1.3 2004/02/20 22:04:11 savage - Added Changes as mentioned by Rodrigo "Rui" R. (1/2 RRC2Soft) to facilitate FPC compilation and it also works in Delphi. Also syncronized the funcitons so that they are identical to sdlutils.pas, when no assembly version is available. - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -interface - -{$i jedi-sdl.inc} - -uses -{$IFDEF UNIX} - Types, - Xlib, -{$ENDIF} - SysUtils, - sdl; - -type - TGradientStyle = ( gsHorizontal, gsVertical ); - - // Pixel procedures -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; - -procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -// Line procedures -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal );overload; - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ; DashLength, DashSpace : byte ); overload; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -// Surface procedures -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); - -// Flip procedures -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; - -function SDLRect( aRect : TRect ) : TSDL_Rect; overload; - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; - -// Fill Rect routine -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); - -// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : -PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : -boolean; - -// Jason's boolean Surface functions -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; - -implementation - -uses - Math; - -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1, Mod2 : cardinal; - Addr1, Addr2 : cardinal; - BPP : cardinal; - Pitch1, Pitch2 : cardinal; - TransparentColor1, TransparentColor2 : cardinal; - tx, ty : cardinal; - StartTick : cardinal; - Color1, Color2 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - if SrcRect2 = nil then - begin - with Src_Rect2 do - begin - x := 0; - y := 0; - w := SrcSurface2.w; - h := SrcSurface2.h; - end; - end - else - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := cardinal( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - with SrcSurface2^ do - begin - TransparentColor2 := format.colorkey; - Pitch2 := Pitch; - Addr2 := cardinal( Pixels ); - inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); - end; - Mod1 := Pitch1 - ( ScanWidth * BPP ); - Mod2 := Pitch2 - ( ScanWidth * BPP ); - inc( Addr1, BPP * Scan1Start ); - inc( Addr2, BPP * Scan2Start ); - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - inc( Addr2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - inc( Addr2, 2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - Color2 := PLongWord( Addr2 )^ and $00FFFFFF; - if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - inc( Addr2, 3 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - inc( Addr2, 4 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - end; -end; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; -var - bpp : UInt32; - p : PInteger; -begin - bpp := SrcSurface.format.BytesPerPixel; - // Here p is the address to the pixel we want to retrieve - p := Pointer( Uint32( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * - bpp ); - case bpp of - 1 : result := PUint8( p )^; - 2 : result := PUint16( p )^; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] - else - result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] shl 16; - 4 : result := PUint32( p )^; - else - result := 0; // shouldn't happen, but avoids warnings - end; -end; - -procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - Addr, Pitch, BPP : cardinal; -begin - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - BPP := SrcSurface.format.BytesPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - mov ecx, Color - cmp BPP, 1 - jne @Not1BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov [eax], cl - jmp @Quit - @Not1BPP: - cmp BPP, 2 - jne @Not2BPP - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov [eax], cx - jmp @Quit - @Not2BPP: - cmp BPP, 3 - jne @Not3BPP - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov edx, [eax] - and edx, $ff000000 - or edx, ecx - mov [eax], edx - jmp @Quit - @Not3BPP: - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov [eax], ecx - @Quit: - end; -end; - -procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - SrcColor, FinalColor : cardinal; - Addr, Pitch, Bits : cardinal; -begin - if Color = 0 then - exit; - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - Bits := SrcSurface.format.BitsPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - cmp Bits, 8 - jne @Not8bit - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov cl, [eax] - movzx ecx, cl - mov SrcColor, ecx - mov edx, Color - and ecx, 3 - and edx, 3 - add ecx, edx - cmp ecx, 3 - jbe @Skip1_8bit - mov ecx, 3 - @Skip1_8bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $1c - and edx, $1c - add ecx, edx - cmp ecx, $1c - jbe @Skip2_8bit - mov ecx, $1c - @Skip2_8bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $e0 - and edx, $e0 - add ecx, edx - cmp ecx, $e0 - jbe @Skip3_8bit - mov ecx, $e0 - @Skip3_8bit: - or ecx, FinalColor - mov [eax], cl - jmp @Quit - @Not8bit: - cmp Bits, 15 - jne @Not15bit - shl eax, 1 - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - and ecx, $00007fff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - add ecx, edx - cmp ecx, $1f - jbe @Skip1_15bit - mov ecx, $1f - @Skip1_15bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $03e0 - and edx, $03e0 - add ecx, edx - cmp ecx, $03e0 - jbe @Skip2_15bit - mov ecx, $03e0 - @Skip2_15bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $7c00 - and edx, $7c00 - add ecx, edx - cmp ecx, $7c00 - jbe @Skip3_15bit - mov ecx, $7c00 - @Skip3_15bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not15Bit: - cmp Bits, 16 - jne @Not16bit - shl eax, 1 - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - and ecx, $0000ffff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - add ecx, edx - cmp ecx, $1f - jbe @Skip1_16bit - mov ecx, $1f - @Skip1_16bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $07e0 - and edx, $07e0 - add ecx, edx - cmp ecx, $07e0 - jbe @Skip2_16bit - mov ecx, $07e0 - @Skip2_16bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $f800 - and edx, $f800 - add ecx, edx - cmp ecx, $f800 - jbe @Skip3_16bit - mov ecx, $f800 - @Skip3_16bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not16Bit: - cmp Bits, 24 - jne @Not24bit - mov ecx, 0 - add ecx, eax - shl ecx, 1 - add ecx, eax - mov eax, ecx - jmp @32bit - @Not24bit: - shl eax, 2 - @32bit: - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - mov FinalColor, ecx - and FinalColor, $ff000000 - and ecx, $00ffffff - mov SrcColor, ecx - mov edx, Color - and ecx, $000000ff - and edx, $000000ff - add ecx, edx - cmp ecx, $000000ff - jbe @Skip1_32bit - mov ecx, $000000ff - @Skip1_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $0000ff00 - and edx, $0000ff00 - add ecx, edx - cmp ecx, $0000ff00 - jbe @Skip2_32bit - mov ecx, $0000ff00 - @Skip2_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $00ff0000 - and edx, $00ff0000 - add ecx, edx - cmp ecx, $00ff0000 - jbe @Skip3_32bit - mov ecx, $00ff0000 - @Skip3_32bit: - or ecx, FinalColor - mov [eax], ecx - @Quit: - end; -end; - -procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - SrcColor, FinalColor : cardinal; - Addr, Pitch, Bits : cardinal; -begin - if Color = 0 then - exit; - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - Bits := SrcSurface.format.BitsPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - cmp Bits, 8 - jne @Not8bit - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov cl, [eax] - movzx ecx, cl - mov SrcColor, ecx - mov edx, Color - and ecx, 3 - and edx, 3 - sub ecx, edx - jns @Skip1_8bit - mov ecx, 0 - @Skip1_8bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $1c - and edx, $1c - sub ecx, edx - jns @Skip2_8bit - mov ecx, 0 - @Skip2_8bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $e0 - and edx, $e0 - sub ecx, edx - jns @Skip3_8bit - mov ecx, 0 - @Skip3_8bit: - or ecx, FinalColor - mov [eax], cl - jmp @Quit - @Not8bit: - cmp Bits, 15 - jne @Not15bit - shl eax, 1 - add eax, Addr - mov ecx, [eax] - and ecx, $00007fff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - sub ecx, edx - jns @Skip1_15bit - mov ecx, 0 - @Skip1_15bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $03e0 - and edx, $03e0 - sub ecx, edx - jns @Skip2_15bit - mov ecx, 0 - @Skip2_15bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $7c00 - and edx, $7c00 - sub ecx, edx - jns @Skip3_15bit - mov ecx, 0 - @Skip3_15bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not15Bit: - cmp Bits, 16 - jne @Not16bit - shl eax, 1 - add eax, Addr - mov ecx, [eax] - and ecx, $0000ffff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - sub ecx, edx - jns @Skip1_16bit - mov ecx, 0 - @Skip1_16bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $07e0 - and edx, $07e0 - sub ecx, edx - jns @Skip2_16bit - mov ecx, 0 - @Skip2_16bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $f800 - and edx, $f800 - sub ecx, edx - jns @Skip3_16bit - mov ecx, 0 - @Skip3_16bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not16Bit: - cmp Bits, 24 - jne @Not24bit - mov ecx, 0 - add ecx, eax - shl ecx, 1 - add ecx, eax - mov eax, ecx - jmp @32bit - @Not24bit: - shl eax, 2 - @32bit: - add eax, Addr - mov ecx, [eax] - mov FinalColor, ecx - and FinalColor, $ff000000 - and ecx, $00ffffff - mov SrcColor, ecx - mov edx, Color - and ecx, $000000ff - and edx, $000000ff - sub ecx, edx - jns @Skip1_32bit - mov ecx, 0 - @Skip1_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $0000ff00 - and edx, $0000ff00 - sub ecx, edx - jns @Skip2_32bit - mov ecx, 0 - @Skip2_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $00ff0000 - and edx, $00ff0000 - sub ecx, edx - jns @Skip3_32bit - mov ecx, 0 - @Skip3_32bit: - or ecx, FinalColor - mov [eax], ecx - @Quit: - end; -end; - -// Draw a line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// Draw a dashed line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ; DashLength, DashSpace : byte ); overload; -var - dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; -begin - counter := 0; - drawdash := true; //begin line drawing with dash - - //Avoid invalid user-passed dash parameters - if (DashLength < 1) - then DashLength := 1; - if (DashSpace < 1) - then DashSpace := 0; - - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc(counter); - if (counter > DashLength-1) and (DashSpace > 0) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc(counter); - if counter > DashSpace-1 then - begin - drawdash := true; - counter := 0; - end; - end; - - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc(counter); - if (counter > DashLength-1) and (DashSpace > 0) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc(counter); - if counter > DashSpace-1 then - begin - drawdash := true; - counter := 0; - end; - end; - - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. -// In 8 bit color depth mode the procedure works with the default packed -// palette (RRRGGGBB). It handles all clipping. -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - // TransparentColor := format.ColorKey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - mov esp, eax // ESP - source color - mov bl, [edi] // BL := destination color - mov dl, bl // DL := destination color - and ax, $03 // Adding BLUE - and bl, $03 - add al, bl - cmp al, $03 - jbe @Skip1 - mov al, $03 - @Skip1: - mov cl, al - mov eax, esp // Adding GREEN - mov bl, dl - and al, $1c - and bl, $1c - add al, bl - cmp al, $1c - jbe @Skip2 - mov al, $1c - @Skip2: - or cl, al - mov eax, esp // Adding RED - mov bl, dl - and ax, $e0 - and bx, $e0 - add ax, bx - cmp ax, $e0 - jbe @Skip3 - mov al, $e0 - @Skip3: - or cl, al - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $001F // Adding BLUE - and bx, $001F - add ax, bx - cmp ax, $001F - jbe @Skip1 - mov ax, $001F - @Skip1: - mov cx, ax - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $3E0 - and bx, $3E0 - add ax, bx - cmp ax, $3E0 - jbe @Skip2 - mov ax, $3E0 - @Skip2: - or cx, ax - mov eax, esp // Adding RED - mov bx, dx - and ax, $7C00 - and bx, $7C00 - add ax, bx - cmp ax, $7C00 - jbe @Skip3 - mov ax, $7C00 - @Skip3: - or cx, ax - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $1F // Adding BLUE - and bx, $1F - add ax, bx - cmp ax, $1F - jbe @Skip1 - mov ax, $1F - @Skip1: - mov cx, ax - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $7E0 - and bx, $7E0 - add ax, bx - cmp ax, $7E0 - jbe @Skip2 - mov ax, $7E0 - @Skip2: - or cx, ax - mov eax, esp // Adding RED - mov bx, dx - and eax, $F800 - and ebx, $F800 - add eax, ebx - cmp eax, $F800 - jbe @Skip3 - mov ax, $F800 - @Skip3: - or cx, ax - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - add bx, ax - cmp bx, $00ff - jb @Skip - mov bl, $ff - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - add bx, ax - cmp bx, $00ff - jb @Skip - mov bl, $ff - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 then skip everything - mov esp, eax // ESP - source color - mov bl, [edi] // BL := destination color - mov dl, bl // DL := destination color - and al, $03 // Subtract BLUE - and bl, $03 - sub bl, al - jns @Skip1 - mov bl, 0 - @Skip1: - mov cl, bl - mov eax, esp // Subtract GREEN - mov bl, dl - and al, $1c - and bl, $1c - sub bl, al - jns @Skip2 - mov bl, 0 - @Skip2: - or cl, bl - mov eax, esp // Subtract RED - mov bl, dl - and ax, $e0 - and bx, $e0 - sub bx, ax - jns @Skip3 - mov bl, 0 - @Skip3: - or cl, bl - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $001F // Subtract BLUE - and bx, $001F - sub bx, ax - jns @Skip1 - mov bx, 0 - @Skip1: - mov cx, bx - mov eax, esp // Subtract GREEN - mov bx, dx - and ax, $3E0 - and bx, $3E0 - sub bx, ax - jns @Skip2 - mov bx, 0 - @Skip2: - or cx, bx - mov eax, esp // Subtract RED - mov bx, dx - and ax, $7C00 - and bx, $7C00 - sub bx, ax - jns @Skip3 - mov bx, 0 - @Skip3: - or cx, bx - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $1F // Subtracting BLUE - and bx, $1F - sub bx, ax - jns @Skip1 - mov bx, 0 - @Skip1: - mov cx, bx - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $7E0 - and bx, $7E0 - sub bx, ax - jns @Skip2 - mov bx, 0 - @Skip2: - or cx, bx - mov eax, esp // Adding RED - mov bx, dx - and eax, $F800 - and ebx, $F800 - sub ebx, eax - jns @Skip3 - mov bx, 0 - @Skip3: - or cx, bx - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - sub bx, ax - jns @Skip - mov bl, 0 - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - sub bx, ax - jns @Skip - mov bl, 0 - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - SrcTransparentColor : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - SrcTransparentColor := format.colorkey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - movzx eax, al - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 15, 16 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - movzx eax, ax - cmp eax, SrcTransparentColor - je @SkipColor // if AX=Transparent color then skip everything - mov [edi], cx - @SkipColor: - inc esi - inc esi - inc edi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 24 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - and ecx, $00ffffff - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // EAX := source color - and eax, $00ffffff - cmp eax, SrcTransparentColor - je @SkipColor // if EAX=Transparent color then skip everything - mov ebx, [edi] - and ebx, $ff000000 - or ebx, ecx - mov [edi], ecx - @SkipColor: - add esi, 3 - add edi, 3 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp, _esp - mov edi, _edi - mov esi, _esi - mov ebx, _ebx - end; - 32 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // EAX := source color - cmp eax, SrcTransparentColor - je @SkipColor // if EAX=Transparent color then skip everything - mov [edi], ecx - @SkipColor: - add esi, 4 - add edi, 4 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp, _esp - mov edi, _edi - mov esi, _esi - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; -// TextureRect.w and TextureRect.h are not used. -// The TextureSurface's size MUST larger than the drawing rectangle!!! - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TextAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod, TextMod : cardinal; - SrcTransparentColor : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - SrcTransparentColor := format.colorkey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - with Texture^ do - begin - TextAddr := cardinal( Pixels ) + UInt32( TextureRect.y ) * Pitch + - UInt32( TextureRect.x ) * Format.BytesPerPixel; - TextMod := Pitch - Src.w * Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - SDL_LockSurface( Texture ); - case bits of - 8 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ebx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - movzx eax, al - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov al, [ebx] - mov [edi], al - @SkipColor: - inc esi - inc edi - inc ebx - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ebx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx, _ebx - end; - 15, 16 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ecx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AL := source color - movzx eax, ax - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov ax, [ecx] - mov [edi], ax - @SkipColor: - inc esi - inc esi - inc edi - inc edi - inc ecx - inc ecx - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ecx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 24 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ebx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // AL := source color - and eax, $00ffffff - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov eax, [ebx] - and eax, $00ffffff - mov ecx, [edi] - and ecx, $ff000000 - or ecx, eax - mov [edi], eax - @SkipColor: - add esi, 3 - add edi, 3 - add ebx, 3 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ebx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx, _ebx - end; - 32 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ecx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // AL := source color - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov eax, [ecx] - mov [edi], eax - @SkipColor: - add esi, 4 - add edi, 4 - add ecx, 4 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ecx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); - SDL_UnlockSurface( Texture ); -end; - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); -var - xc, yc : cardinal; - rx, wx, ry, wy, ry16 : cardinal; - color : cardinal; - modx, mody : cardinal; -begin - // Warning! No checks for surface pointers!!! - if srcrect = nil then - srcrect := @SrcSurface.clip_rect; - if dstrect = nil then - dstrect := @DstSurface.clip_rect; - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); - mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); - //rx := srcrect.x * 65536; - ry := srcrect.y * 65536; - wy := dstrect.y; - for yc := 0 to dstrect.h - 1 do - begin - rx := srcrect.x * 65536; - wx := dstrect.x; - ry16 := ry shr 16; - for xc := 0 to dstrect.w - 1 do - begin - color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); - SDL_PutPixel( DstSurface, wx, wy, color ); - rx := rx + modx; - inc( wx ); - end; - ry := ry + mody; - inc( wy ); - end; - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; -// Re-map a rectangular area into an area defined by four vertices -// Converted from C to Pascal by KiCHY - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); -const - SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) - THRESH = 1 shl SHIFTS; // Threshold for pixel size value - procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); - var - tm, lm, rm, bm, m : TPoint; - mx, my : cardinal; - cr : cardinal; - begin - // Does the destination area specify a single pixel? - if ( ( abs( ul.x - ur.x ) < THRESH ) and - ( abs( ul.x - lr.x ) < THRESH ) and - ( abs( ul.x - ll.x ) < THRESH ) and - ( abs( ul.y - ur.y ) < THRESH ) and - ( abs( ul.y - lr.y ) < THRESH ) and - ( abs( ul.y - ll.y ) < THRESH ) ) then - begin // Yes - cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); - SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); - end - else - begin // No - // Quarter the source and the destination, and then recurse - tm.x := ( ul.x + ur.x ) shr 1; - tm.y := ( ul.y + ur.y ) shr 1; - bm.x := ( ll.x + lr.x ) shr 1; - bm.y := ( ll.y + lr.y ) shr 1; - lm.x := ( ul.x + ll.x ) shr 1; - lm.y := ( ul.y + ll.y ) shr 1; - rm.x := ( ur.x + lr.x ) shr 1; - rm.y := ( ur.y + lr.y ) shr 1; - m.x := ( tm.x + bm.x ) shr 1; - m.y := ( tm.y + bm.y ) shr 1; - mx := ( x1 + x2 ) shr 1; - my := ( y1 + y2 ) shr 1; - CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); - CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); - CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); - CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); - end; - end; -var - _UL, _UR, _LR, _LL : TPoint; - Rect_x, Rect_y, Rect_w, Rect_h : integer; -begin - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - if SrcRect = nil then - begin - Rect_x := 0; - Rect_y := 0; - Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; - Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; - end - else - begin - Rect_x := SrcRect.x; - Rect_y := SrcRect.y; - Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; - Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; - end; - // Shift all values to help reduce round-off error. - _ul.x := ul.x shl SHIFTS; - _ul.y := ul.y shl SHIFTS; - _ur.x := ur.x shl SHIFTS; - _ur.y := ur.y shl SHIFTS; - _lr.x := lr.x shl SHIFTS; - _lr.y := lr.y shl SHIFTS; - _ll.x := ll.x shl SHIFTS; - _ll.y := ll.y shl SHIFTS; - CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; - -// flips a rectangle vertically on given surface -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -var - TmpRect : TSDL_Rect; - Locked : boolean; - y, FlipLength, RowLength : integer; - Row1, Row2 : Pointer; - OneRow : TByteArray; // Optimize it if you wish -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin // if Rect=nil then we flip the whole surface - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.h shr 1 - 1; - RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - Row1 := pointer( cardinal( DstSurface^.Pixels ) + UInt32( Rect^.y ) * - DstSurface^.Pitch ); - Row2 := pointer( cardinal( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) - * DstSurface^.Pitch ); - for y := 0 to FlipLength do - begin - Move( Row1^, OneRow, RowLength ); - Move( Row2^, Row1^, RowLength ); - Move( OneRow, Row2^, RowLength ); - inc( cardinal( Row1 ), DstSurface^.Pitch ); - dec( cardinal( Row2 ), DstSurface^.Pitch ); - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// flips a rectangle horizontally on given surface -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -type - T24bit = packed array[ 0..2 ] of byte; - T24bitArray = packed array[ 0..8191 ] of T24bit; - P24bitArray = ^T24bitArray; - TLongWordArray = array[ 0..8191 ] of LongWord; - PLongWordArray = ^TLongWordArray; -var - TmpRect : TSDL_Rect; - Row8bit : PByteArray; - Row16bit : PWordArray; - Row24bit : P24bitArray; - Row32bit : PLongWordArray; - y, x, RightSide, FlipLength : integer; - Pixel : cardinal; - Pixel24 : T24bit; - Locked : boolean; -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.w shr 1 - 1; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - case DstSurface^.format.BytesPerPixel of - 1 : - begin - Row8Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row8Bit^[ x ]; - Row8Bit^[ x ] := Row8Bit^[ RightSide ]; - Row8Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row8Bit ), DstSurface^.pitch ); - end; - end; - 2 : - begin - Row16Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row16Bit^[ x ]; - Row16Bit^[ x ] := Row16Bit^[ RightSide ]; - Row16Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row16Bit ), DstSurface^.pitch ); - end; - end; - 3 : - begin - Row24Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel24 := Row24Bit^[ x ]; - Row24Bit^[ x ] := Row24Bit^[ RightSide ]; - Row24Bit^[ RightSide ] := Pixel24; - dec( RightSide ); - end; - inc( cardinal( Row24Bit ), DstSurface^.pitch ); - end; - end; - 4 : - begin - Row32Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row32Bit^[ x ]; - Row32Bit^[ x ] := Row32Bit^[ RightSide ]; - Row32Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row32Bit ), DstSurface^.pitch ); - end; - end; - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. -// But you MUST free it after you don't need it anymore!!! -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; -var - Rect : PSDL_Rect; -begin - New( Rect ); - with Rect^ do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; - Result := Rect; -end; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; -begin - with result do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; -end; - -function SDLRect( aRect : TRect ) : TSDL_Rect; -begin - with aRect do - result := SDLRect( Left, Top, Right - Left, Bottom - Top ); -end; - -procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, - depth : integer ); -var - dx, dy, e, d, dx2 : integer; - src_pitch, dst_pitch : uint16; - src_pixels, dst_pixels : PUint8; -begin - if ( yw >= dst_surface^.h ) then - exit; - dx := ( x2 - x1 ); - dy := ( y2 - y1 ); - dy := dy shl 1; - e := dy - dx; - dx2 := dx shl 1; - src_pitch := Surface^.pitch; - dst_pitch := dst_surface^.pitch; - src_pixels := PUint8( integer( Surface^.pixels ) + yr * src_pitch + y1 * depth ); - dst_pixels := PUint8( integer( dst_surface^.pixels ) + yw * dst_pitch + x1 * - depth ); - for d := 0 to dx - 1 do - begin - move( src_pixels^, dst_pixels^, depth ); - while ( e >= 0 ) do - begin - inc( src_pixels, depth ); - e := e - dx2; - end; - inc( dst_pixels, depth ); - e := e + dy; - end; -end; - -function sign( x : integer ) : integer; -begin - if x > 0 then - result := 1 - else - result := -1; -end; - -// Stretches a part of a surface -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; -var - dst_surface : PSDL_Surface; - dx, dy, e, d, dx2, srcx2, srcy2 : integer; - destx1, desty1 : integer; -begin - srcx2 := srcx1 + SrcW; - srcy2 := srcy1 + SrcH; - result := nil; - destx1 := 0; - desty1 := 0; - dx := abs( integer( Height - desty1 ) ); - dy := abs( integer( SrcY2 - SrcY1 ) ); - e := ( dy shl 1 ) - dx; - dx2 := dx shl 1; - dy := dy shl 1; - dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - - desty1, - SrcSurface^.Format^.BitsPerPixel, - SrcSurface^.Format^.RMask, - SrcSurface^.Format^.GMask, - SrcSurface^.Format^.BMask, - SrcSurface^.Format^.AMask ); - if ( dst_surface^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); - if ( SDL_MustLock( dst_surface ) ) then - if ( SDL_LockSurface( dst_surface ) < 0 ) then - exit; - for d := 0 to dx - 1 do - begin - SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, - SrcSurface^.format^.BytesPerPixel ); - while e >= 0 do - begin - inc( SrcY1 ); - e := e - dx2; - end; - inc( desty1 ); - e := e + dy; - end; - if SDL_MUSTLOCK( dst_surface ) then - SDL_UnlockSurface( dst_surface ); - result := dst_surface; -end; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); -var - r1, r2 : TSDL_Rect; - //buffer: PSDL_Surface; - YPos : Integer; -begin - if ( DstSurface <> nil ) and ( DifY <> 0 ) then - begin - //if DifY > 0 then // going up - //begin - ypos := 0; - r1.x := 0; - r2.x := 0; - r1.w := DstSurface.w; - r2.w := DstSurface.w; - r1.h := DifY; - r2.h := DifY; - while ypos < DstSurface.h do - begin - r1.y := ypos; - r2.y := ypos + DifY; - SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); - ypos := ypos + DifY; - end; - //end - //else - //begin // Going Down - //end; - end; -end; - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); -var - r1, r2 : TSDL_Rect; - buffer : PSDL_Surface; -begin - if ( DstSurface <> nil ) and ( DifX <> 0 ) then - begin - buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, - DstSurface^.h * 2, - DstSurface^.Format^.BitsPerPixel, - DstSurface^.Format^.RMask, - DstSurface^.Format^.GMask, - DstSurface^.Format^.BMask, - DstSurface^.Format^.AMask ); - if buffer <> nil then - begin - if ( buffer^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); - r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); - SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); - SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); - SDL_FreeSurface( buffer ); - end; - end; -end; - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); -var - aSin, aCos : Single; - MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; - Colour, TempTransparentColour : UInt32; - MAXX, MAXY : Integer; -begin - // Rotate the surface to the target surface. - TempTransparentColour := SrcSurface.format.colorkey; - if srcRect.w > srcRect.h then - begin - Width := srcRect.w; - Height := srcRect.w; - end - else - begin - Width := srcRect.h; - Height := srcRect.h; - end; - - maxx := DstSurface.w; - maxy := DstSurface.h; - aCos := cos( Angle ); - aSin := sin( Angle ); - - Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); - Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); - - OX := Width div 2; - OY := Height div 2; ; - MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; - MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; - ROX := ( -( srcRect.w div 2 ) ) + Offsetx; - ROY := ( -( srcRect.h div 2 ) ) + OffsetY; - Tx := ox + round( ROX * aSin - ROY * aCos ); - Ty := oy + round( ROY * aSin + ROX * aCos ); - SX := 0; - for DX := DestX - TX to DestX - TX + ( width ) do - begin - Inc( SX ); - SY := 0; - for DY := DestY - TY to DestY - TY + ( Height ) do - begin - RX := SX - OX; - RY := SY - OY; - NX := round( mx + RX * aSin + RY * aCos ); // - NY := round( my + RY * aSin - RX * aCos ); // - // Used for testing only - //SDL_PutPixel(DstSurface.SDLSurfacePointer,DX,DY,0); - if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then - begin - if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then - begin - if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then - begin - Colour := SDL_GetPixel( SrcSurface, NX, NY ); - if Colour <> TempTransparentColour then - begin - SDL_PutPixel( DstSurface, DX, DY, Colour ); - end; - end; - end; - end; - inc( SY ); - end; - end; -end; - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); -begin - SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); -end; - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; -var - RealRect : TSDL_Rect; - OutOfRange : Boolean; -begin - OutOfRange := false; - if dstrect = nil then - begin - RealRect.x := 0; - RealRect.y := 0; - RealRect.w := DstSurface.w; - RealRect.h := DstSurface.h; - end - else - begin - if dstrect.x < DstSurface.w then - begin - RealRect.x := dstrect.x; - end - else if dstrect.x < 0 then - begin - realrect.x := 0; - end - else - begin - OutOfRange := True; - end; - if dstrect.y < DstSurface.h then - begin - RealRect.y := dstrect.y; - end - else if dstrect.y < 0 then - begin - realrect.y := 0; - end - else - begin - OutOfRange := True; - end; - if OutOfRange = False then - begin - if realrect.x + dstrect.w <= DstSurface.w then - begin - RealRect.w := dstrect.w; - end - else - begin - RealRect.w := dstrect.w - realrect.x; - end; - if realrect.y + dstrect.h <= DstSurface.h then - begin - RealRect.h := dstrect.h; - end - else - begin - RealRect.h := dstrect.h - realrect.y; - end; - end; - end; - if OutOfRange = False then - begin - result := realrect; - end - else - begin - realrect.w := 0; - realrect.h := 0; - realrect.x := 0; - realrect.y := 0; - result := realrect; - end; -end; - -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); -var - FBC : array[ 0..255 ] of Cardinal; - // temp vars - i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; - - TempStepV, TempStepH : Single; - TempLeft, TempTop, TempHeight, TempWidth : integer; - TempRect : TSDL_Rect; - -begin - // calc FBC - YR := StartColor.r; - YG := StartColor.g; - YB := StartColor.b; - SR := YR; - SG := YG; - SB := YB; - DR := EndColor.r - SR; - DG := EndColor.g - SG; - DB := EndColor.b - SB; - - for i := 0 to 255 do - begin - FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); - YR := SR + round( DR / 255 * i ); - YG := SG + round( DG / 255 * i ); - YB := SB + round( DB / 255 * i ); - end; - - // if aStyle = 1 then begin - TempStepH := Rect.w / 255; - TempStepV := Rect.h / 255; - TempHeight := Trunc( TempStepV + 1 ); - TempWidth := Trunc( TempStepH + 1 ); - TempTop := 0; - TempLeft := 0; - TempRect.x := Rect.x; - TempRect.y := Rect.y; - TempRect.h := Rect.h; - TempRect.w := Rect.w; - - case Style of - gsHorizontal : - begin - TempRect.h := TempHeight; - for i := 0 to 255 do - begin - TempRect.y := Rect.y + TempTop; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempTop := Trunc( TempStepV * i ); - end; - end; - gsVertical : - begin - TempRect.w := TempWidth; - for i := 0 to 255 do - begin - TempRect.x := Rect.x + TempLeft; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempLeft := Trunc( TempStepH * i ); - end; - end; - end; -end; - -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BytesPerPixel of - 1 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; - mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 2 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 3 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx], eax - and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 4 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; - mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BytesPerPixel of - 1 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 2 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], eax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 3 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 4 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BitsPerPixel of - 8 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - shr al, 1 - and al, $6d - mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; - mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 15 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - shr ax, 1 - and ax, $3def - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 16 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - shr ax, 1 - and ax, $7bef - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 24 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - shr eax, 1 - and eax, $007f7f7f - and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx], eax - and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 32 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - shr eax, 1 - and eax, $7f7f7f7f - mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; - mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : -boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1: cardinal; - Addr1 : cardinal; - BPP : cardinal; - Pitch1 : cardinal; - TransparentColor1 : cardinal; - tx, ty : cardinal; - StartTick : cardinal; - Color1 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( -Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := cardinal( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - - Mod1 := Pitch1 - ( ScanWidth * BPP ); - - inc( Addr1, BPP * Scan1Start ); - - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - - end; - inc( Addr1, Mod1 ); - - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - - end; - inc( Addr1, Mod1 ); - - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - - if ( Color1 <> TransparentColor1 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - - end; - inc( Addr1, Mod1 ); - - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - - end; - inc( Addr1, Mod1 ); - - end; - end; -end; - -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TransparentColor : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - cmp al, byte ptr TransparentColor - je @SkipColor - or al, [edi] - mov [edi], al - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - or ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - or ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov al, [esi] // AL := source color - or al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov al, [esi] // AL := source color - or al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TransparentColor : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - cmp al, byte ptr TransparentColor - je @SkipColor - and al, [edi] - mov [edi], al - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - and ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - and ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov al, [esi] // AL := source color - and al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov al, [esi] // AL := source color - and al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 > Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; - if Pixel2 and $1C > Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; - if Pixel2 and $03 > Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 > Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; - if Pixel2 and $03E0 > Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; - if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 > Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; - if Pixel2 and $07E0 > Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; - if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 < Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; - if Pixel2 and $1C < Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; - if Pixel2 and $03 < Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 < Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; - if Pixel2 and $03E0 < Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; - if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 < Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; - if Pixel2 and $07E0 < Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; - if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; -var tflag, flag1, flag2: word; - txy, xedge, yedge: Integer; - slope: single; - - function ClipCode(x,y: Integer): word; - begin - Result := 0; - if x < ClipRect.x then Result := 1; - if x >= ClipRect.w + ClipRect.x then Result := Result or 2; - if y < ClipRect.y then Result := Result or 4; - if y >= ClipRect.h + ClipRect.y then Result := Result or 8; - end; - -begin - flag1 := ClipCode(x1,y1); - flag2 := ClipCode(x2,y2); - result := true; - - while true do - begin - if (flag1 or flag2) = 0 then Exit; // all in - - if (flag1 and flag2) <> 0 then - begin - result := false; - Exit; // all out - end; - - if flag2 = 0 then - begin - txy := x1; x1 := x2; x2 := txy; - txy := y1; y1 := y2; y2 := txy; - tflag := flag1; flag1 := flag2; flag2 := tflag; - end; - - if (flag2 and 3) <> 0 then - begin - if (flag2 and 1) <> 0 then - xedge := ClipRect.x - else - xedge := ClipRect.w + ClipRect.x -1; // back 1 pixel otherwise we end up in a loop - - slope := (y2 - y1) / (x2 - x1); - y2 := y1 + Round(slope * (xedge - x1)); - x2 := xedge; - end - else - begin - if (flag2 and 4) <> 0 then - yedge := ClipRect.y - else - yedge := ClipRect.h + ClipRect.y -1; // up 1 pixel otherwise we end up in a loop - - slope := (x2 - x1) / (y2 - y1); - x2 := x1 + Round(slope * (yedge - y1)); - y2 := yedge; - end; - - flag2 := ClipCode(x2, y2); - end; -end; - -end. - - +unit sdli386utils; +{ + $Id: sdli386utils.pas,v 1.5 2004/06/02 19:38:53 savage Exp $ + +} +{******************************************************************************} +{ } +{ Borland Delphi SDL - Simple DirectMedia Layer } +{ SDL Utility functions } +{ } +{ } +{ The initial developer of this Pascal code was : } +{ Tom Jones } +{ } +{ Portions created by Tom Jones are } +{ Copyright (C) 2000 - 2001 Tom Jones. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Dominique Louis } +{ Róbert Kisnémeth } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ Helper functions... } +{ } +{ } +{ Requires } +{ -------- } +{ SDL.dll on Windows platforms } +{ libSDL-1.1.so.0 on Linux platform } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ 2000 - TJ : Initial creation } +{ } +{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } +{ } +{ Sept 14 2001 - RK : Added flipping routines. } +{ } +{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } +{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } +{ Added PSDLRect() } +{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} +{ Also removed by poor attempt or a dialog box } +{ } +{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } +{ SubSurface, MonoSurface & TexturedSurface } +{ } +{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } +{ types rather that Windows types. This makes it more} +{ portable to Linix. } +{ } +{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } +{ } +{ Oct 27 2001 - JF : Added ScrollY function } +{ } +{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } +{ } +{ Mar 28 2002 - JF : Added SDL_RotateSurface } +{ } +{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } +{ } +{ May 27 2002 - YS : GradientFillRect function } +{ } +{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } +{ & SDL_50Scanline2xBlit } +{ } +{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } +{ } +{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } +{ } +{ November 9 2002 - JF : Added Jason's boolean Surface functions } +{ } +{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } +{ } +{******************************************************************************} +{ + $Log: sdli386utils.pas,v $ + Revision 1.5 2004/06/02 19:38:53 savage + Changes to SDL_GradientFillRect as suggested by + Ángel Eduardo García Hernández. Many thanks. + + Revision 1.4 2004/05/29 23:11:53 savage + Changes to SDL_ScaleSurfaceRect as suggested by + Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. + + Revision 1.3 2004/02/20 22:04:11 savage + Added Changes as mentioned by Rodrigo "Rui" R. (1/2 RRC2Soft) to facilitate FPC compilation and it also works in Delphi. Also syncronized the funcitons so that they are identical to sdlutils.pas, when no assembly version is available. + + Revision 1.2 2004/02/14 00:23:39 savage + As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. + + Revision 1.1 2004/02/05 00:08:20 savage + Module 1.0 release + + +} + +interface + +{$i jedi-sdl.inc} + +uses +{$IFDEF UNIX} + Types, + Xlib, +{$ENDIF} + SysUtils, + sdl; + +type + TGradientStyle = ( gsHorizontal, gsVertical ); + + // Pixel procedures +function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : + PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; + +function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; + +procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : + cardinal ); + +procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : + cardinal ); + +procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : + cardinal ); + +// Line procedures +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal );overload; + +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ; DashLength, DashSpace : byte ); overload; + +procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); + +procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); + +// Surface procedures +procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); + +procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; + TextureRect : PSDL_Rect ); + +procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); + +procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); + +// Flip procedures +procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); + +procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); + +function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; + +function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; + +function SDLRect( aRect : TRect ) : TSDL_Rect; overload; + +function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, + Width, Height : integer ) : PSDL_Surface; + +procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); + +procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); + +procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); + +procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); + +function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; + +// Fill Rect routine +procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); + +procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); + +procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); + +// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! +procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); + +procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); + +procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); + +function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : +PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : +boolean; + +// Jason's boolean Surface functions +procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; + +implementation + +uses + Math; + +function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : + PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; +var + Src_Rect1, Src_Rect2 : TSDL_Rect; + right1, bottom1 : integer; + right2, bottom2 : integer; + Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; + Mod1, Mod2 : cardinal; + Addr1, Addr2 : cardinal; + BPP : cardinal; + Pitch1, Pitch2 : cardinal; + TransparentColor1, TransparentColor2 : cardinal; + tx, ty : cardinal; + StartTick : cardinal; + Color1, Color2 : cardinal; +begin + Result := false; + if SrcRect1 = nil then + begin + with Src_Rect1 do + begin + x := 0; + y := 0; + w := SrcSurface1.w; + h := SrcSurface1.h; + end; + end + else + Src_Rect1 := SrcRect1^; + if SrcRect2 = nil then + begin + with Src_Rect2 do + begin + x := 0; + y := 0; + w := SrcSurface2.w; + h := SrcSurface2.h; + end; + end + else + Src_Rect2 := SrcRect2^; + with Src_Rect1 do + begin + Right1 := Left1 + w; + Bottom1 := Top1 + h; + end; + with Src_Rect2 do + begin + Right2 := Left2 + w; + Bottom2 := Top2 + h; + end; + if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= + Top2 ) then + exit; + if Left1 <= Left2 then + begin + // 1. left, 2. right + Scan1Start := Src_Rect1.x + Left2 - Left1; + Scan2Start := Src_Rect2.x; + ScanWidth := Right1 - Left2; + with Src_Rect2 do + if ScanWidth > w then + ScanWidth := w; + end + else + begin + // 1. right, 2. left + Scan1Start := Src_Rect1.x; + Scan2Start := Src_Rect2.x + Left1 - Left2; + ScanWidth := Right2 - Left1; + with Src_Rect1 do + if ScanWidth > w then + ScanWidth := w; + end; + with SrcSurface1^ do + begin + Pitch1 := Pitch; + Addr1 := cardinal( Pixels ); + inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); + with format^ do + begin + BPP := BytesPerPixel; + TransparentColor1 := colorkey; + end; + end; + with SrcSurface2^ do + begin + TransparentColor2 := format.colorkey; + Pitch2 := Pitch; + Addr2 := cardinal( Pixels ); + inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); + end; + Mod1 := Pitch1 - ( ScanWidth * BPP ); + Mod2 := Pitch2 - ( ScanWidth * BPP ); + inc( Addr1, BPP * Scan1Start ); + inc( Addr2, BPP * Scan2Start ); + if Top1 <= Top2 then + begin + // 1. up, 2. down + ScanHeight := Bottom1 - Top2; + if ScanHeight > Src_Rect2.h then + ScanHeight := Src_Rect2.h; + inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); + end + else + begin + // 1. down, 2. up + ScanHeight := Bottom2 - Top1; + if ScanHeight > Src_Rect1.h then + ScanHeight := Src_Rect1.h; + inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); + end; + case BPP of + 1 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> + TransparentColor2 ) then + begin + Result := true; + exit; + end; + inc( Addr1 ); + inc( Addr2 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + 2 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> + TransparentColor2 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 2 ); + inc( Addr2, 2 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + 3 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + Color1 := PLongWord( Addr1 )^ and $00FFFFFF; + Color2 := PLongWord( Addr2 )^ and $00FFFFFF; + if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) + then + begin + Result := true; + exit; + end; + inc( Addr1, 3 ); + inc( Addr2, 3 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + 4 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> + TransparentColor2 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 4 ); + inc( Addr2, 4 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + end; +end; + +function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; +var + bpp : UInt32; + p : PInteger; +begin + bpp := SrcSurface.format.BytesPerPixel; + // Here p is the address to the pixel we want to retrieve + p := Pointer( Uint32( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * + bpp ); + case bpp of + 1 : result := PUint8( p )^; + 2 : result := PUint16( p )^; + 3 : + if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then + result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or + PUInt8Array( p )[ 2 ] + else + result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or + PUInt8Array( p )[ 2 ] shl 16; + 4 : result := PUint32( p )^; + else + result := 0; // shouldn't happen, but avoids warnings + end; +end; + +procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : + cardinal ); +var + Addr, Pitch, BPP : cardinal; +begin + Addr := cardinal( SrcSurface.Pixels ); + Pitch := SrcSurface.Pitch; + BPP := SrcSurface.format.BytesPerPixel; + asm + mov eax, y + mul Pitch // EAX := y * Pitch + add Addr, eax // Addr:= Addr + (y * Pitch) + mov eax, x + mov ecx, Color + cmp BPP, 1 + jne @Not1BPP + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x + mov [eax], cl + jmp @Quit + @Not1BPP: + cmp BPP, 2 + jne @Not2BPP + mul BPP // EAX := x * BPP + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP + mov [eax], cx + jmp @Quit + @Not2BPP: + cmp BPP, 3 + jne @Not3BPP + mul BPP // EAX := x * BPP + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP + mov edx, [eax] + and edx, $ff000000 + or edx, ecx + mov [eax], edx + jmp @Quit + @Not3BPP: + mul BPP // EAX := x * BPP + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP + mov [eax], ecx + @Quit: + end; +end; + +procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : + cardinal ); +var + SrcColor, FinalColor : cardinal; + Addr, Pitch, Bits : cardinal; +begin + if Color = 0 then + exit; + Addr := cardinal( SrcSurface.Pixels ); + Pitch := SrcSurface.Pitch; + Bits := SrcSurface.format.BitsPerPixel; + asm + mov eax, y + mul Pitch // EAX := y * Pitch + add Addr, eax // Addr:= Addr + (y * Pitch) + mov eax, x + cmp Bits, 8 + jne @Not8bit + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x + mov cl, [eax] + movzx ecx, cl + mov SrcColor, ecx + mov edx, Color + and ecx, 3 + and edx, 3 + add ecx, edx + cmp ecx, 3 + jbe @Skip1_8bit + mov ecx, 3 + @Skip1_8bit: + mov FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $1c + and edx, $1c + add ecx, edx + cmp ecx, $1c + jbe @Skip2_8bit + mov ecx, $1c + @Skip2_8bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $e0 + and edx, $e0 + add ecx, edx + cmp ecx, $e0 + jbe @Skip3_8bit + mov ecx, $e0 + @Skip3_8bit: + or ecx, FinalColor + mov [eax], cl + jmp @Quit + @Not8bit: + cmp Bits, 15 + jne @Not15bit + shl eax, 1 + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 + mov ecx, [eax] + and ecx, $00007fff + mov SrcColor, ecx + mov edx, Color + and ecx, $1f + and edx, $1f + add ecx, edx + cmp ecx, $1f + jbe @Skip1_15bit + mov ecx, $1f + @Skip1_15bit: + mov FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $03e0 + and edx, $03e0 + add ecx, edx + cmp ecx, $03e0 + jbe @Skip2_15bit + mov ecx, $03e0 + @Skip2_15bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $7c00 + and edx, $7c00 + add ecx, edx + cmp ecx, $7c00 + jbe @Skip3_15bit + mov ecx, $7c00 + @Skip3_15bit: + or ecx, FinalColor + mov [eax], cx + jmp @Quit + @Not15Bit: + cmp Bits, 16 + jne @Not16bit + shl eax, 1 + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 + mov ecx, [eax] + and ecx, $0000ffff + mov SrcColor, ecx + mov edx, Color + and ecx, $1f + and edx, $1f + add ecx, edx + cmp ecx, $1f + jbe @Skip1_16bit + mov ecx, $1f + @Skip1_16bit: + mov FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $07e0 + and edx, $07e0 + add ecx, edx + cmp ecx, $07e0 + jbe @Skip2_16bit + mov ecx, $07e0 + @Skip2_16bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $f800 + and edx, $f800 + add ecx, edx + cmp ecx, $f800 + jbe @Skip3_16bit + mov ecx, $f800 + @Skip3_16bit: + or ecx, FinalColor + mov [eax], cx + jmp @Quit + @Not16Bit: + cmp Bits, 24 + jne @Not24bit + mov ecx, 0 + add ecx, eax + shl ecx, 1 + add ecx, eax + mov eax, ecx + jmp @32bit + @Not24bit: + shl eax, 2 + @32bit: + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 + mov ecx, [eax] + mov FinalColor, ecx + and FinalColor, $ff000000 + and ecx, $00ffffff + mov SrcColor, ecx + mov edx, Color + and ecx, $000000ff + and edx, $000000ff + add ecx, edx + cmp ecx, $000000ff + jbe @Skip1_32bit + mov ecx, $000000ff + @Skip1_32bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $0000ff00 + and edx, $0000ff00 + add ecx, edx + cmp ecx, $0000ff00 + jbe @Skip2_32bit + mov ecx, $0000ff00 + @Skip2_32bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $00ff0000 + and edx, $00ff0000 + add ecx, edx + cmp ecx, $00ff0000 + jbe @Skip3_32bit + mov ecx, $00ff0000 + @Skip3_32bit: + or ecx, FinalColor + mov [eax], ecx + @Quit: + end; +end; + +procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : + cardinal ); +var + SrcColor, FinalColor : cardinal; + Addr, Pitch, Bits : cardinal; +begin + if Color = 0 then + exit; + Addr := cardinal( SrcSurface.Pixels ); + Pitch := SrcSurface.Pitch; + Bits := SrcSurface.format.BitsPerPixel; + asm + mov eax, y + mul Pitch // EAX := y * Pitch + add Addr, eax // Addr:= Addr + (y * Pitch) + mov eax, x + cmp Bits, 8 + jne @Not8bit + add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x + mov cl, [eax] + movzx ecx, cl + mov SrcColor, ecx + mov edx, Color + and ecx, 3 + and edx, 3 + sub ecx, edx + jns @Skip1_8bit + mov ecx, 0 + @Skip1_8bit: + mov FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $1c + and edx, $1c + sub ecx, edx + jns @Skip2_8bit + mov ecx, 0 + @Skip2_8bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $e0 + and edx, $e0 + sub ecx, edx + jns @Skip3_8bit + mov ecx, 0 + @Skip3_8bit: + or ecx, FinalColor + mov [eax], cl + jmp @Quit + @Not8bit: + cmp Bits, 15 + jne @Not15bit + shl eax, 1 + add eax, Addr + mov ecx, [eax] + and ecx, $00007fff + mov SrcColor, ecx + mov edx, Color + and ecx, $1f + and edx, $1f + sub ecx, edx + jns @Skip1_15bit + mov ecx, 0 + @Skip1_15bit: + mov FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $03e0 + and edx, $03e0 + sub ecx, edx + jns @Skip2_15bit + mov ecx, 0 + @Skip2_15bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $7c00 + and edx, $7c00 + sub ecx, edx + jns @Skip3_15bit + mov ecx, 0 + @Skip3_15bit: + or ecx, FinalColor + mov [eax], cx + jmp @Quit + @Not15Bit: + cmp Bits, 16 + jne @Not16bit + shl eax, 1 + add eax, Addr + mov ecx, [eax] + and ecx, $0000ffff + mov SrcColor, ecx + mov edx, Color + and ecx, $1f + and edx, $1f + sub ecx, edx + jns @Skip1_16bit + mov ecx, 0 + @Skip1_16bit: + mov FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $07e0 + and edx, $07e0 + sub ecx, edx + jns @Skip2_16bit + mov ecx, 0 + @Skip2_16bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $f800 + and edx, $f800 + sub ecx, edx + jns @Skip3_16bit + mov ecx, 0 + @Skip3_16bit: + or ecx, FinalColor + mov [eax], cx + jmp @Quit + @Not16Bit: + cmp Bits, 24 + jne @Not24bit + mov ecx, 0 + add ecx, eax + shl ecx, 1 + add ecx, eax + mov eax, ecx + jmp @32bit + @Not24bit: + shl eax, 2 + @32bit: + add eax, Addr + mov ecx, [eax] + mov FinalColor, ecx + and FinalColor, $ff000000 + and ecx, $00ffffff + mov SrcColor, ecx + mov edx, Color + and ecx, $000000ff + and edx, $000000ff + sub ecx, edx + jns @Skip1_32bit + mov ecx, 0 + @Skip1_32bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $0000ff00 + and edx, $0000ff00 + sub ecx, edx + jns @Skip2_32bit + mov ecx, 0 + @Skip2_32bit: + or FinalColor, ecx + mov ecx, SrcColor + mov edx, Color + and ecx, $00ff0000 + and edx, $00ff0000 + sub ecx, edx + jns @Skip3_32bit + mov ecx, 0 + @Skip3_32bit: + or ecx, FinalColor + mov [eax], ecx + @Quit: + end; +end; + +// Draw a line between x1,y1 and x2,y2 to the given surface +// NOTE: The surface must be locked before calling this! +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); +var + dx, dy, sdx, sdy, x, y, px, py : integer; +begin + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + SDL_PutPixel( DstSurface, px, py, Color ); + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + SDL_PutPixel( DstSurface, px, py, Color ); + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +// Draw a dashed line between x1,y1 and x2,y2 to the given surface +// NOTE: The surface must be locked before calling this! +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ; DashLength, DashSpace : byte ); overload; +var + dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; +begin + counter := 0; + drawdash := true; //begin line drawing with dash + + //Avoid invalid user-passed dash parameters + if (DashLength < 1) + then DashLength := 1; + if (DashSpace < 1) + then DashSpace := 0; + + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + + //Alternate drawing dashes, or leaving spaces + if drawdash then + begin + SDL_PutPixel( DstSurface, px, py, Color ); + inc(counter); + if (counter > DashLength-1) and (DashSpace > 0) then + begin + drawdash := false; + counter := 0; + end; + end + else //space + begin + inc(counter); + if counter > DashSpace-1 then + begin + drawdash := true; + counter := 0; + end; + end; + + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + + //Alternate drawing dashes, or leaving spaces + if drawdash then + begin + SDL_PutPixel( DstSurface, px, py, Color ); + inc(counter); + if (counter > DashLength-1) and (DashSpace > 0) then + begin + drawdash := false; + counter := 0; + end; + end + else //space + begin + inc(counter); + if counter > DashSpace-1 then + begin + drawdash := true; + counter := 0; + end; + end; + + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); +var + dx, dy, sdx, sdy, x, y, px, py : integer; +begin + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + SDL_AddPixel( DstSurface, px, py, Color ); + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + SDL_AddPixel( DstSurface, px, py, Color ); + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); +var + dx, dy, sdx, sdy, x, y, px, py : integer; +begin + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + SDL_SubPixel( DstSurface, px, py, Color ); + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + SDL_SubPixel( DstSurface, px, py, Color ); + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. +// In 8 bit color depth mode the procedure works with the default packed +// palette (RRRGGGBB). It handles all clipping. +procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : cardinal; + // TransparentColor: cardinal; + _ebx, _esi, _edi, _esp : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DstSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DstSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + // TransparentColor := format.ColorKey; + end; + with DstSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DstSurface ); + case bits of + 8 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov al, [esi] // AL := source color + cmp al, 0 + je @SkipColor // if AL=0 or AL=transparent color then skip everything + mov esp, eax // ESP - source color + mov bl, [edi] // BL := destination color + mov dl, bl // DL := destination color + and ax, $03 // Adding BLUE + and bl, $03 + add al, bl + cmp al, $03 + jbe @Skip1 + mov al, $03 + @Skip1: + mov cl, al + mov eax, esp // Adding GREEN + mov bl, dl + and al, $1c + and bl, $1c + add al, bl + cmp al, $1c + jbe @Skip2 + mov al, $1c + @Skip2: + or cl, al + mov eax, esp // Adding RED + mov bl, dl + and ax, $e0 + and bx, $e0 + add ax, bx + cmp ax, $e0 + jbe @Skip3 + mov al, $e0 + @Skip3: + or cl, al + mov [edi], cl + @SkipColor: + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 15 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + mov esp, eax // ESP - source color + mov bx, [edi] // BX := destination color + mov dx, bx // DX := destination color + and ax, $001F // Adding BLUE + and bx, $001F + add ax, bx + cmp ax, $001F + jbe @Skip1 + mov ax, $001F + @Skip1: + mov cx, ax + mov eax, esp // Adding GREEN + mov bx, dx + and ax, $3E0 + and bx, $3E0 + add ax, bx + cmp ax, $3E0 + jbe @Skip2 + mov ax, $3E0 + @Skip2: + or cx, ax + mov eax, esp // Adding RED + mov bx, dx + and ax, $7C00 + and bx, $7C00 + add ax, bx + cmp ax, $7C00 + jbe @Skip3 + mov ax, $7C00 + @Skip3: + or cx, ax + mov [edi], cx + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 16 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + mov esp, eax // ESP - source color + mov bx, [edi] // BX := destination color + mov dx, bx // DX := destination color + and ax, $1F // Adding BLUE + and bx, $1F + add ax, bx + cmp ax, $1F + jbe @Skip1 + mov ax, $1F + @Skip1: + mov cx, ax + mov eax, esp // Adding GREEN + mov bx, dx + and ax, $7E0 + and bx, $7E0 + add ax, bx + cmp ax, $7E0 + jbe @Skip2 + mov ax, $7E0 + @Skip2: + or cx, ax + mov eax, esp // Adding RED + mov bx, dx + and eax, $F800 + and ebx, $F800 + add eax, ebx + cmp eax, $F800 + jbe @Skip3 + mov ax, $F800 + @Skip3: + or cx, ax + mov [edi], cx + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 24 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + add WorkX, ax // WorkX := Src.w * 2 + add WorkX, ax // WorkX := Src.w * 3 + @Loopx: + mov bl, [edi] // BX := destination color + mov al, [esi] // AX := source color + cmp al, 0 + je @Skip // if AL=0 then skip COMPONENT + mov ah, 0 // AX := COLOR COMPONENT + mov bh, 0 + add bx, ax + cmp bx, $00ff + jb @Skip + mov bl, $ff + @Skip: + mov [edi], bl + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 32 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + shl ax, 2 + mov WorkX, ax // WorkX := Src.w * 4 + @Loopx: + mov bl, [edi] // BX := destination color + mov al, [esi] // AX := source color + cmp al, 0 + je @Skip // if AL=0 then skip COMPONENT + mov ah, 0 // AX := COLOR COMPONENT + mov bh, 0 + add bx, ax + cmp bx, $00ff + jb @Skip + mov bl, $ff + @Skip: + mov [edi], bl + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DstSurface ); +end; + +procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : cardinal; + _ebx, _esi, _edi, _esp : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DstSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DstSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + end; + with DstSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := DstSurface.Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DstSurface ); + case bits of + 8 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov al, [esi] // AL := source color + cmp al, 0 + je @SkipColor // if AL=0 then skip everything + mov esp, eax // ESP - source color + mov bl, [edi] // BL := destination color + mov dl, bl // DL := destination color + and al, $03 // Subtract BLUE + and bl, $03 + sub bl, al + jns @Skip1 + mov bl, 0 + @Skip1: + mov cl, bl + mov eax, esp // Subtract GREEN + mov bl, dl + and al, $1c + and bl, $1c + sub bl, al + jns @Skip2 + mov bl, 0 + @Skip2: + or cl, bl + mov eax, esp // Subtract RED + mov bl, dl + and ax, $e0 + and bx, $e0 + sub bx, ax + jns @Skip3 + mov bl, 0 + @Skip3: + or cl, bl + mov [edi], cl + @SkipColor: + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 15 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + mov esp, eax // ESP - source color + mov bx, [edi] // BX := destination color + mov dx, bx // DX := destination color + and ax, $001F // Subtract BLUE + and bx, $001F + sub bx, ax + jns @Skip1 + mov bx, 0 + @Skip1: + mov cx, bx + mov eax, esp // Subtract GREEN + mov bx, dx + and ax, $3E0 + and bx, $3E0 + sub bx, ax + jns @Skip2 + mov bx, 0 + @Skip2: + or cx, bx + mov eax, esp // Subtract RED + mov bx, dx + and ax, $7C00 + and bx, $7C00 + sub bx, ax + jns @Skip3 + mov bx, 0 + @Skip3: + or cx, bx + mov [edi], cx + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 16 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + mov esp, eax // ESP - source color + mov bx, [edi] // BX := destination color + mov dx, bx // DX := destination color + and ax, $1F // Subtracting BLUE + and bx, $1F + sub bx, ax + jns @Skip1 + mov bx, 0 + @Skip1: + mov cx, bx + mov eax, esp // Adding GREEN + mov bx, dx + and ax, $7E0 + and bx, $7E0 + sub bx, ax + jns @Skip2 + mov bx, 0 + @Skip2: + or cx, bx + mov eax, esp // Adding RED + mov bx, dx + and eax, $F800 + and ebx, $F800 + sub ebx, eax + jns @Skip3 + mov bx, 0 + @Skip3: + or cx, bx + mov [edi], cx + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 24 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + add WorkX, ax // WorkX := Src.w * 2 + add WorkX, ax // WorkX := Src.w * 3 + @Loopx: + mov bl, [edi] // BX := destination color + mov al, [esi] // AX := source color + cmp al, 0 + je @Skip // if AL=0 then skip COMPONENT + mov ah, 0 // AX := COLOR COMPONENT + mov bh, 0 + sub bx, ax + jns @Skip + mov bl, 0 + @Skip: + mov [edi], bl + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 32 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + shl ax, 2 + mov WorkX, ax // WorkX := Src.w * 4 + @Loopx: + mov bl, [edi] // BX := destination color + mov al, [esi] // AX := source color + cmp al, 0 + je @Skip // if AL=0 then skip COMPONENT + mov ah, 0 // AX := COLOR COMPONENT + mov bh, 0 + sub bx, ax + jns @Skip + mov bl, 0 + @Skip: + mov [edi], bl + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DstSurface ); +end; + +procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : cardinal; + _ebx, _esi, _edi, _esp : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + SrcTransparentColor : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DstSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DstSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + SrcTransparentColor := format.colorkey; + end; + with DstSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := DstSurface.Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DstSurface ); + case bits of + 8 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + mov ecx, Color + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov al, [esi] // AL := source color + movzx eax, al + cmp eax, SrcTransparentColor + je @SkipColor // if AL=Transparent color then skip everything + mov [edi], cl + @SkipColor: + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + end; + 15, 16 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + mov ecx, Color + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + movzx eax, ax + cmp eax, SrcTransparentColor + je @SkipColor // if AX=Transparent color then skip everything + mov [edi], cx + @SkipColor: + inc esi + inc esi + inc edi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + end; + 24 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov _ebx, ebx + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + mov ecx, Color + and ecx, $00ffffff + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov eax, [esi] // EAX := source color + and eax, $00ffffff + cmp eax, SrcTransparentColor + je @SkipColor // if EAX=Transparent color then skip everything + mov ebx, [edi] + and ebx, $ff000000 + or ebx, ecx + mov [edi], ecx + @SkipColor: + add esi, 3 + add edi, 3 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp, _esp + mov edi, _edi + mov esi, _esi + mov ebx, _ebx + end; + 32 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + mov ecx, Color + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov eax, [esi] // EAX := source color + cmp eax, SrcTransparentColor + je @SkipColor // if EAX=Transparent color then skip everything + mov [edi], ecx + @SkipColor: + add esi, 4 + add edi, 4 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp, _esp + mov edi, _edi + mov esi, _esi + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DstSurface ); +end; +// TextureRect.w and TextureRect.h are not used. +// The TextureSurface's size MUST larger than the drawing rectangle!!! + +procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; + TextureRect : PSDL_Rect ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr, TextAddr : cardinal; + _ebx, _esi, _edi, _esp : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod, TextMod : cardinal; + SrcTransparentColor : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DstSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DstSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + SrcTransparentColor := format.colorkey; + end; + with DstSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := DstSurface.Format.BitsPerPixel; + end; + with Texture^ do + begin + TextAddr := cardinal( Pixels ) + UInt32( TextureRect.y ) * Pitch + + UInt32( TextureRect.x ) * Format.BytesPerPixel; + TextMod := Pitch - Src.w * Format.BytesPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DstSurface ); + SDL_LockSurface( Texture ); + case bits of + 8 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov _ebx, ebx + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ebx, TextAddr + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov al, [esi] // AL := source color + movzx eax, al + cmp eax, SrcTransparentColor + je @SkipColor // if AL=Transparent color then skip everything + mov al, [ebx] + mov [edi], al + @SkipColor: + inc esi + inc edi + inc ebx + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + add ebx, TextMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx, _ebx + end; + 15, 16 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ecx, TextAddr + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AL := source color + movzx eax, ax + cmp eax, SrcTransparentColor + je @SkipColor // if AL=Transparent color then skip everything + mov ax, [ecx] + mov [edi], ax + @SkipColor: + inc esi + inc esi + inc edi + inc edi + inc ecx + inc ecx + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + add ecx, TextMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + end; + 24 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov _ebx, ebx + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ebx, TextAddr + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov eax, [esi] // AL := source color + and eax, $00ffffff + cmp eax, SrcTransparentColor + je @SkipColor // if AL=Transparent color then skip everything + mov eax, [ebx] + and eax, $00ffffff + mov ecx, [edi] + and ecx, $ff000000 + or ecx, eax + mov [edi], eax + @SkipColor: + add esi, 3 + add edi, 3 + add ebx, 3 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + add ebx, TextMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx, _ebx + end; + 32 : + asm + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ecx, TextAddr + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov eax, [esi] // AL := source color + cmp eax, SrcTransparentColor + je @SkipColor // if AL=Transparent color then skip everything + mov eax, [ecx] + mov [edi], eax + @SkipColor: + add esi, 4 + add edi, 4 + add ecx, 4 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + add ecx, TextMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DstSurface ); + SDL_UnlockSurface( Texture ); +end; + +procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); +var + xc, yc : cardinal; + rx, wx, ry, wy, ry16 : cardinal; + color : cardinal; + modx, mody : cardinal; +begin + // Warning! No checks for surface pointers!!! + if srcrect = nil then + srcrect := @SrcSurface.clip_rect; + if dstrect = nil then + dstrect := @DstSurface.clip_rect; + if SDL_MustLock( SrcSurface ) then + SDL_LockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_LockSurface( DstSurface ); + modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); + mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); + //rx := srcrect.x * 65536; + ry := srcrect.y * 65536; + wy := dstrect.y; + for yc := 0 to dstrect.h - 1 do + begin + rx := srcrect.x * 65536; + wx := dstrect.x; + ry16 := ry shr 16; + for xc := 0 to dstrect.w - 1 do + begin + color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); + SDL_PutPixel( DstSurface, wx, wy, color ); + rx := rx + modx; + inc( wx ); + end; + ry := ry + mody; + inc( wy ); + end; + if SDL_MustLock( SrcSurface ) then + SDL_UnlockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_UnlockSurface( DstSurface ); +end; +// Re-map a rectangular area into an area defined by four vertices +// Converted from C to Pascal by KiCHY + +procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); +const + SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) + THRESH = 1 shl SHIFTS; // Threshold for pixel size value + procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); + var + tm, lm, rm, bm, m : TPoint; + mx, my : cardinal; + cr : cardinal; + begin + // Does the destination area specify a single pixel? + if ( ( abs( ul.x - ur.x ) < THRESH ) and + ( abs( ul.x - lr.x ) < THRESH ) and + ( abs( ul.x - ll.x ) < THRESH ) and + ( abs( ul.y - ur.y ) < THRESH ) and + ( abs( ul.y - lr.y ) < THRESH ) and + ( abs( ul.y - ll.y ) < THRESH ) ) then + begin // Yes + cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); + SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); + end + else + begin // No + // Quarter the source and the destination, and then recurse + tm.x := ( ul.x + ur.x ) shr 1; + tm.y := ( ul.y + ur.y ) shr 1; + bm.x := ( ll.x + lr.x ) shr 1; + bm.y := ( ll.y + lr.y ) shr 1; + lm.x := ( ul.x + ll.x ) shr 1; + lm.y := ( ul.y + ll.y ) shr 1; + rm.x := ( ur.x + lr.x ) shr 1; + rm.y := ( ur.y + lr.y ) shr 1; + m.x := ( tm.x + bm.x ) shr 1; + m.y := ( tm.y + bm.y ) shr 1; + mx := ( x1 + x2 ) shr 1; + my := ( y1 + y2 ) shr 1; + CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); + CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); + CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); + CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); + end; + end; +var + _UL, _UR, _LR, _LL : TPoint; + Rect_x, Rect_y, Rect_w, Rect_h : integer; +begin + if SDL_MustLock( SrcSurface ) then + SDL_LockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_LockSurface( DstSurface ); + if SrcRect = nil then + begin + Rect_x := 0; + Rect_y := 0; + Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; + Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; + end + else + begin + Rect_x := SrcRect.x; + Rect_y := SrcRect.y; + Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; + Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; + end; + // Shift all values to help reduce round-off error. + _ul.x := ul.x shl SHIFTS; + _ul.y := ul.y shl SHIFTS; + _ur.x := ur.x shl SHIFTS; + _ur.y := ur.y shl SHIFTS; + _lr.x := lr.x shl SHIFTS; + _lr.y := lr.y shl SHIFTS; + _ll.x := ll.x shl SHIFTS; + _ll.y := ll.y shl SHIFTS; + CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); + if SDL_MustLock( SrcSurface ) then + SDL_UnlockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_UnlockSurface( DstSurface ); +end; + +// flips a rectangle vertically on given surface +procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); +var + TmpRect : TSDL_Rect; + Locked : boolean; + y, FlipLength, RowLength : integer; + Row1, Row2 : Pointer; + OneRow : TByteArray; // Optimize it if you wish +begin + if DstSurface <> nil then + begin + if Rect = nil then + begin // if Rect=nil then we flip the whole surface + TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); + Rect := @TmpRect; + end; + FlipLength := Rect^.h shr 1 - 1; + RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; + if SDL_MustLock( DstSurface ) then + begin + Locked := true; + SDL_LockSurface( DstSurface ); + end + else + Locked := false; + Row1 := pointer( cardinal( DstSurface^.Pixels ) + UInt32( Rect^.y ) * + DstSurface^.Pitch ); + Row2 := pointer( cardinal( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) + * DstSurface^.Pitch ); + for y := 0 to FlipLength do + begin + Move( Row1^, OneRow, RowLength ); + Move( Row2^, Row1^, RowLength ); + Move( OneRow, Row2^, RowLength ); + inc( cardinal( Row1 ), DstSurface^.Pitch ); + dec( cardinal( Row2 ), DstSurface^.Pitch ); + end; + if Locked then + SDL_UnlockSurface( DstSurface ); + end; +end; + +// flips a rectangle horizontally on given surface +procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); +type + T24bit = packed array[ 0..2 ] of byte; + T24bitArray = packed array[ 0..8191 ] of T24bit; + P24bitArray = ^T24bitArray; + TLongWordArray = array[ 0..8191 ] of LongWord; + PLongWordArray = ^TLongWordArray; +var + TmpRect : TSDL_Rect; + Row8bit : PByteArray; + Row16bit : PWordArray; + Row24bit : P24bitArray; + Row32bit : PLongWordArray; + y, x, RightSide, FlipLength : integer; + Pixel : cardinal; + Pixel24 : T24bit; + Locked : boolean; +begin + if DstSurface <> nil then + begin + if Rect = nil then + begin + TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); + Rect := @TmpRect; + end; + FlipLength := Rect^.w shr 1 - 1; + if SDL_MustLock( DstSurface ) then + begin + Locked := true; + SDL_LockSurface( DstSurface ); + end + else + Locked := false; + case DstSurface^.format.BytesPerPixel of + 1 : + begin + Row8Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel := Row8Bit^[ x ]; + Row8Bit^[ x ] := Row8Bit^[ RightSide ]; + Row8Bit^[ RightSide ] := Pixel; + dec( RightSide ); + end; + inc( cardinal( Row8Bit ), DstSurface^.pitch ); + end; + end; + 2 : + begin + Row16Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel := Row16Bit^[ x ]; + Row16Bit^[ x ] := Row16Bit^[ RightSide ]; + Row16Bit^[ RightSide ] := Pixel; + dec( RightSide ); + end; + inc( cardinal( Row16Bit ), DstSurface^.pitch ); + end; + end; + 3 : + begin + Row24Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel24 := Row24Bit^[ x ]; + Row24Bit^[ x ] := Row24Bit^[ RightSide ]; + Row24Bit^[ RightSide ] := Pixel24; + dec( RightSide ); + end; + inc( cardinal( Row24Bit ), DstSurface^.pitch ); + end; + end; + 4 : + begin + Row32Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel := Row32Bit^[ x ]; + Row32Bit^[ x ] := Row32Bit^[ RightSide ]; + Row32Bit^[ RightSide ] := Pixel; + dec( RightSide ); + end; + inc( cardinal( Row32Bit ), DstSurface^.pitch ); + end; + end; + end; + if Locked then + SDL_UnlockSurface( DstSurface ); + end; +end; + +// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. +// But you MUST free it after you don't need it anymore!!! +function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; +var + Rect : PSDL_Rect; +begin + New( Rect ); + with Rect^ do + begin + x := aLeft; + y := aTop; + w := aWidth; + h := aHeight; + end; + Result := Rect; +end; + +function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; +begin + with result do + begin + x := aLeft; + y := aTop; + w := aWidth; + h := aHeight; + end; +end; + +function SDLRect( aRect : TRect ) : TSDL_Rect; +begin + with aRect do + result := SDLRect( Left, Top, Right - Left, Bottom - Top ); +end; + +procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, + depth : integer ); +var + dx, dy, e, d, dx2 : integer; + src_pitch, dst_pitch : uint16; + src_pixels, dst_pixels : PUint8; +begin + if ( yw >= dst_surface^.h ) then + exit; + dx := ( x2 - x1 ); + dy := ( y2 - y1 ); + dy := dy shl 1; + e := dy - dx; + dx2 := dx shl 1; + src_pitch := Surface^.pitch; + dst_pitch := dst_surface^.pitch; + src_pixels := PUint8( integer( Surface^.pixels ) + yr * src_pitch + y1 * depth ); + dst_pixels := PUint8( integer( dst_surface^.pixels ) + yw * dst_pitch + x1 * + depth ); + for d := 0 to dx - 1 do + begin + move( src_pixels^, dst_pixels^, depth ); + while ( e >= 0 ) do + begin + inc( src_pixels, depth ); + e := e - dx2; + end; + inc( dst_pixels, depth ); + e := e + dy; + end; +end; + +function sign( x : integer ) : integer; +begin + if x > 0 then + result := 1 + else + result := -1; +end; + +// Stretches a part of a surface +function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, + Width, Height : integer ) : PSDL_Surface; +var + dst_surface : PSDL_Surface; + dx, dy, e, d, dx2, srcx2, srcy2 : integer; + destx1, desty1 : integer; +begin + srcx2 := srcx1 + SrcW; + srcy2 := srcy1 + SrcH; + result := nil; + destx1 := 0; + desty1 := 0; + dx := abs( integer( Height - desty1 ) ); + dy := abs( integer( SrcY2 - SrcY1 ) ); + e := ( dy shl 1 ) - dx; + dx2 := dx shl 1; + dy := dy shl 1; + dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - + desty1, + SrcSurface^.Format^.BitsPerPixel, + SrcSurface^.Format^.RMask, + SrcSurface^.Format^.GMask, + SrcSurface^.Format^.BMask, + SrcSurface^.Format^.AMask ); + if ( dst_surface^.format^.BytesPerPixel = 1 ) then + SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); + SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); + if ( SDL_MustLock( dst_surface ) ) then + if ( SDL_LockSurface( dst_surface ) < 0 ) then + exit; + for d := 0 to dx - 1 do + begin + SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, + SrcSurface^.format^.BytesPerPixel ); + while e >= 0 do + begin + inc( SrcY1 ); + e := e - dx2; + end; + inc( desty1 ); + e := e + dy; + end; + if SDL_MUSTLOCK( dst_surface ) then + SDL_UnlockSurface( dst_surface ); + result := dst_surface; +end; + +procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); +var + r1, r2 : TSDL_Rect; + //buffer: PSDL_Surface; + YPos : Integer; +begin + if ( DstSurface <> nil ) and ( DifY <> 0 ) then + begin + //if DifY > 0 then // going up + //begin + ypos := 0; + r1.x := 0; + r2.x := 0; + r1.w := DstSurface.w; + r2.w := DstSurface.w; + r1.h := DifY; + r2.h := DifY; + while ypos < DstSurface.h do + begin + r1.y := ypos; + r2.y := ypos + DifY; + SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); + ypos := ypos + DifY; + end; + //end + //else + //begin // Going Down + //end; + end; +end; + +procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); +var + r1, r2 : TSDL_Rect; + buffer : PSDL_Surface; +begin + if ( DstSurface <> nil ) and ( DifX <> 0 ) then + begin + buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, + DstSurface^.h * 2, + DstSurface^.Format^.BitsPerPixel, + DstSurface^.Format^.RMask, + DstSurface^.Format^.GMask, + DstSurface^.Format^.BMask, + DstSurface^.Format^.AMask ); + if buffer <> nil then + begin + if ( buffer^.format^.BytesPerPixel = 1 ) then + SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); + r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); + r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); + SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); + SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); + SDL_FreeSurface( buffer ); + end; + end; +end; + +procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); +var + aSin, aCos : Single; + MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; + Colour, TempTransparentColour : UInt32; + MAXX, MAXY : Integer; +begin + // Rotate the surface to the target surface. + TempTransparentColour := SrcSurface.format.colorkey; + if srcRect.w > srcRect.h then + begin + Width := srcRect.w; + Height := srcRect.w; + end + else + begin + Width := srcRect.h; + Height := srcRect.h; + end; + + maxx := DstSurface.w; + maxy := DstSurface.h; + aCos := cos( Angle ); + aSin := sin( Angle ); + + Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); + Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); + + OX := Width div 2; + OY := Height div 2; ; + MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; + MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; + ROX := ( -( srcRect.w div 2 ) ) + Offsetx; + ROY := ( -( srcRect.h div 2 ) ) + OffsetY; + Tx := ox + round( ROX * aSin - ROY * aCos ); + Ty := oy + round( ROY * aSin + ROX * aCos ); + SX := 0; + for DX := DestX - TX to DestX - TX + ( width ) do + begin + Inc( SX ); + SY := 0; + for DY := DestY - TY to DestY - TY + ( Height ) do + begin + RX := SX - OX; + RY := SY - OY; + NX := round( mx + RX * aSin + RY * aCos ); // + NY := round( my + RY * aSin - RX * aCos ); // + // Used for testing only + //SDL_PutPixel(DstSurface.SDLSurfacePointer,DX,DY,0); + if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then + begin + if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then + begin + if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then + begin + Colour := SDL_GetPixel( SrcSurface, NX, NY ); + if Colour <> TempTransparentColour then + begin + SDL_PutPixel( DstSurface, DX, DY, Colour ); + end; + end; + end; + end; + inc( SY ); + end; + end; +end; + +procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); +begin + SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); +end; + +function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; +var + RealRect : TSDL_Rect; + OutOfRange : Boolean; +begin + OutOfRange := false; + if dstrect = nil then + begin + RealRect.x := 0; + RealRect.y := 0; + RealRect.w := DstSurface.w; + RealRect.h := DstSurface.h; + end + else + begin + if dstrect.x < DstSurface.w then + begin + RealRect.x := dstrect.x; + end + else if dstrect.x < 0 then + begin + realrect.x := 0; + end + else + begin + OutOfRange := True; + end; + if dstrect.y < DstSurface.h then + begin + RealRect.y := dstrect.y; + end + else if dstrect.y < 0 then + begin + realrect.y := 0; + end + else + begin + OutOfRange := True; + end; + if OutOfRange = False then + begin + if realrect.x + dstrect.w <= DstSurface.w then + begin + RealRect.w := dstrect.w; + end + else + begin + RealRect.w := dstrect.w - realrect.x; + end; + if realrect.y + dstrect.h <= DstSurface.h then + begin + RealRect.h := dstrect.h; + end + else + begin + RealRect.h := dstrect.h - realrect.y; + end; + end; + end; + if OutOfRange = False then + begin + result := realrect; + end + else + begin + realrect.w := 0; + realrect.h := 0; + realrect.x := 0; + realrect.y := 0; + result := realrect; + end; +end; + +procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); +var + RealRect : TSDL_Rect; + Addr : pointer; + ModX, BPP : cardinal; + x, y, R, G, B, SrcColor : cardinal; +begin + RealRect := ValidateSurfaceRect( DstSurface, DstRect ); + if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then + begin + SDL_LockSurface( DstSurface ); + BPP := DstSurface.format.BytesPerPixel; + with DstSurface^ do + begin + Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); + ModX := Pitch - UInt32( RealRect.w ) * BPP; + end; + case DstSurface.format.BitsPerPixel of + 8 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $E0 + Color and $E0; + G := SrcColor and $1C + Color and $1C; + B := SrcColor and $03 + Color and $03; + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 15 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $7C00 + Color and $7C00; + G := SrcColor and $03E0 + Color and $03E0; + B := SrcColor and $001F + Color and $001F; + if R > $7C00 then + R := $7C00; + if G > $03E0 then + G := $03E0; + if B > $001F then + B := $001F; + PUInt16( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 16 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $F800 + Color and $F800; + G := SrcColor and $07C0 + Color and $07C0; + B := SrcColor and $001F + Color and $001F; + if R > $F800 then + R := $F800; + if G > $07C0 then + G := $07C0; + if B > $001F then + B := $001F; + PUInt16( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 24 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 + Color and $00FF0000; + G := SrcColor and $0000FF00 + Color and $0000FF00; + B := SrcColor and $000000FF + Color and $000000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 32 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 + Color and $00FF0000; + G := SrcColor and $0000FF00 + Color and $0000FF00; + B := SrcColor and $000000FF + Color and $000000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + end; + SDL_UnlockSurface( DstSurface ); + end; +end; + +procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); +var + RealRect : TSDL_Rect; + Addr : pointer; + ModX, BPP : cardinal; + x, y, R, G, B, SrcColor : cardinal; +begin + RealRect := ValidateSurfaceRect( DstSurface, DstRect ); + if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then + begin + SDL_LockSurface( DstSurface ); + BPP := DstSurface.format.BytesPerPixel; + with DstSurface^ do + begin + Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); + ModX := Pitch - UInt32( RealRect.w ) * BPP; + end; + case DstSurface.format.BitsPerPixel of + 8 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $E0 - Color and $E0; + G := SrcColor and $1C - Color and $1C; + B := SrcColor and $03 - Color and $03; + if R > $E0 then + R := 0; + if G > $1C then + G := 0; + if B > $03 then + B := 0; + PUInt8( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 15 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $7C00 - Color and $7C00; + G := SrcColor and $03E0 - Color and $03E0; + B := SrcColor and $001F - Color and $001F; + if R > $7C00 then + R := 0; + if G > $03E0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 16 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $F800 - Color and $F800; + G := SrcColor and $07C0 - Color and $07C0; + B := SrcColor and $001F - Color and $001F; + if R > $F800 then + R := 0; + if G > $07C0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 24 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 - Color and $00FF0000; + G := SrcColor and $0000FF00 - Color and $0000FF00; + B := SrcColor and $000000FF - Color and $000000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + 32 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 - Color and $00FF0000; + G := SrcColor and $0000FF00 - Color and $0000FF00; + B := SrcColor and $000000FF - Color and $000000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( Addr )^ := R or G or B; + inc( UInt32( Addr ), BPP ); + end; + inc( UInt32( Addr ), ModX ); + end; + end; + end; + SDL_UnlockSurface( DstSurface ); + end; +end; + +procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); +var + FBC : array[ 0..255 ] of Cardinal; + // temp vars + i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; + + TempStepV, TempStepH : Single; + TempLeft, TempTop, TempHeight, TempWidth : integer; + TempRect : TSDL_Rect; + +begin + // calc FBC + YR := StartColor.r; + YG := StartColor.g; + YB := StartColor.b; + SR := YR; + SG := YG; + SB := YB; + DR := EndColor.r - SR; + DG := EndColor.g - SG; + DB := EndColor.b - SB; + + for i := 0 to 255 do + begin + FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); + YR := SR + round( DR / 255 * i ); + YG := SG + round( DG / 255 * i ); + YB := SB + round( DB / 255 * i ); + end; + + // if aStyle = 1 then begin + TempStepH := Rect.w / 255; + TempStepV := Rect.h / 255; + TempHeight := Trunc( TempStepV + 1 ); + TempWidth := Trunc( TempStepH + 1 ); + TempTop := 0; + TempLeft := 0; + TempRect.x := Rect.x; + TempRect.y := Rect.y; + TempRect.h := Rect.h; + TempRect.w := Rect.w; + + case Style of + gsHorizontal : + begin + TempRect.h := TempHeight; + for i := 0 to 255 do + begin + TempRect.y := Rect.y + TempTop; + SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); + TempTop := Trunc( TempStepV * i ); + end; + end; + gsVertical : + begin + TempRect.w := TempWidth; + for i := 0 to 255 do + begin + TempRect.x := Rect.x + TempLeft; + SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); + TempLeft := Trunc( TempStepH * i ); + end; + end; + end; +end; + +procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); +var + ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; + SrcPitch, DestPitch, x, y, w, h : UInt32; +begin + if ( Src = nil ) or ( Dest = nil ) then + exit; + if ( Src.w shl 1 ) < Dest.w then + exit; + if ( Src.h shl 1 ) < Dest.h then + exit; + + if SDL_MustLock( Src ) then + SDL_LockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_LockSurface( Dest ); + + ReadRow := UInt32( Src.Pixels ); + WriteRow := UInt32( Dest.Pixels ); + + SrcPitch := Src.pitch; + DestPitch := Dest.pitch; + + w := Src.w; + h := Src.h; + + case Src.format.BytesPerPixel of + 1 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; + mov [edx], al + mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; + mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; + mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; + + inc ecx // inc(ReadAddr); + add edx, 2 // inc(WriteAddr, 2); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 2 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; + mov [edx], ax + mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; + mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; + mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; + + add ecx, 2 // inc(ReadAddr, 2); + add edx, 4 // inc(WriteAddr, 4); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 3 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + and eax, $00ffffff + and dword ptr [edx], $ff000000 + or [edx], eax + and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + 3], eax + and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + ebx], eax + and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + ebx + 3], eax + + add ecx, 3 // inc(ReadAddr, 3); + add edx, 6 // inc(WriteAddr, 6); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 4 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; + mov [edx], eax + mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; + mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; + mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; + + add ecx, 4 // inc(ReadAddr, 4); + add edx, 8 // inc(WriteAddr, 8); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + end; + + if SDL_MustLock( Src ) then + SDL_UnlockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_UnlockSurface( Dest ); +end; + +procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); +var + ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; + SrcPitch, DestPitch, x, y, w, h : UInt32; +begin + if ( Src = nil ) or ( Dest = nil ) then + exit; + if ( Src.w shl 1 ) < Dest.w then + exit; + if ( Src.h shl 1 ) < Dest.h then + exit; + + if SDL_MustLock( Src ) then + SDL_LockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_LockSurface( Dest ); + + ReadRow := UInt32( Src.Pixels ); + WriteRow := UInt32( Dest.Pixels ); + + SrcPitch := Src.pitch; + DestPitch := Dest.pitch; + + w := Src.w; + h := Src.h; + + case Src.format.BytesPerPixel of + 1 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + + @LoopX: + mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; + mov [edx], al + mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; + + inc ecx // inc(ReadAddr); + add edx, 2 // inc(WriteAddr, 2); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 2 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + + @LoopX: + mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; + mov [edx], ax + mov [edx + 2], eax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; + + add ecx, 2 // inc(ReadAddr, 2); + add edx, 4 // inc(WriteAddr, 4); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 3 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + + @LoopX: + mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + and eax, $00ffffff + and dword ptr [edx], $ff000000 + or [edx], eax + and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + 3], eax + + add ecx, 3 // inc(ReadAddr, 3); + add edx, 6 // inc(WriteAddr, 6); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 4 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + + @LoopX: + mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; + mov [edx], eax + mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; + + add ecx, 4 // inc(ReadAddr, 4); + add edx, 8 // inc(WriteAddr, 8); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + end; + + if SDL_MustLock( Src ) then + SDL_UnlockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_UnlockSurface( Dest ); +end; + +procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); +var + ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; + SrcPitch, DestPitch, x, y, w, h : UInt32; +begin + if ( Src = nil ) or ( Dest = nil ) then + exit; + if ( Src.w shl 1 ) < Dest.w then + exit; + if ( Src.h shl 1 ) < Dest.h then + exit; + + if SDL_MustLock( Src ) then + SDL_LockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_LockSurface( Dest ); + + ReadRow := UInt32( Src.Pixels ); + WriteRow := UInt32( Dest.Pixels ); + + SrcPitch := Src.pitch; + DestPitch := Dest.pitch; + + w := Src.w; + h := Src.h; + + case Src.format.BitsPerPixel of + 8 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; + mov [edx], al + mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; + shr al, 1 + and al, $6d + mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; + mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; + + inc ecx // inc(ReadAddr); + add edx, 2 // inc(WriteAddr, 2); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 15 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; + mov [edx], ax + mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; + shr ax, 1 + and ax, $3def + mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; + mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; + + add ecx, 2 // inc(ReadAddr, 2); + add edx, 4 // inc(WriteAddr, 4); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 16 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; + mov [edx], ax + mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; + shr ax, 1 + and ax, $7bef + mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; + mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; + + add ecx, 2 // inc(ReadAddr, 2); + add edx, 4 // inc(WriteAddr, 4); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 24 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + and eax, $00ffffff + and dword ptr [edx], $ff000000 + or [edx], eax + and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + 3], eax + shr eax, 1 + and eax, $007f7f7f + and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + ebx], eax + and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); + or [edx + ebx + 3], eax + + add ecx, 3 // inc(ReadAddr, 3); + add edx, 6 // inc(WriteAddr, 6); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + 32 : + asm + push ebx + mov eax, h // for y := 1 to Src.h do + mov y, eax + @LoopY: + mov eax, ReadRow // ReadAddr := ReadRow; + mov ReadAddr, eax + + mov eax, WriteRow // WriteAddr := WriteRow; + mov WriteAddr, eax + + mov eax, w // for x := 1 to Src.w do + mov x, eax + + mov ecx, ReadAddr + mov edx, WriteAddr + mov ebx, DestPitch + + @LoopX: + mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; + mov [edx], eax + mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; + shr eax, 1 + and eax, $7f7f7f7f + mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; + mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; + + add ecx, 4 // inc(ReadAddr, 4); + add edx, 8 // inc(WriteAddr, 8); + + dec x + jnz @LoopX + + mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); + add ReadRow, eax + + mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); + add WriteRow, eax + add WriteRow, eax + + dec y + jnz @LoopY + pop ebx + end; + end; + + if SDL_MustLock( Src ) then + SDL_UnlockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_UnlockSurface( Dest ); +end; + +function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : +boolean; +var + Src_Rect1, Src_Rect2 : TSDL_Rect; + right1, bottom1 : integer; + right2, bottom2 : integer; + Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; + Mod1: cardinal; + Addr1 : cardinal; + BPP : cardinal; + Pitch1 : cardinal; + TransparentColor1 : cardinal; + tx, ty : cardinal; + StartTick : cardinal; + Color1 : cardinal; +begin + Result := false; + if SrcRect1 = nil then + begin + with Src_Rect1 do + begin + x := 0; + y := 0; + w := SrcSurface1.w; + h := SrcSurface1.h; + end; + end + else + Src_Rect1 := SrcRect1^; + + Src_Rect2 := SrcRect2^; + with Src_Rect1 do + begin + Right1 := Left1 + w; + Bottom1 := Top1 + h; + end; + with Src_Rect2 do + begin + Right2 := Left2 + w; + Bottom2 := Top2 + h; + end; + if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( +Bottom1 <= + Top2 ) then + exit; + if Left1 <= Left2 then + begin + // 1. left, 2. right + Scan1Start := Src_Rect1.x + Left2 - Left1; + Scan2Start := Src_Rect2.x; + ScanWidth := Right1 - Left2; + with Src_Rect2 do + if ScanWidth > w then + ScanWidth := w; + end + else + begin + // 1. right, 2. left + Scan1Start := Src_Rect1.x; + Scan2Start := Src_Rect2.x + Left1 - Left2; + ScanWidth := Right2 - Left1; + with Src_Rect1 do + if ScanWidth > w then + ScanWidth := w; + end; + with SrcSurface1^ do + begin + Pitch1 := Pitch; + Addr1 := cardinal( Pixels ); + inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); + with format^ do + begin + BPP := BytesPerPixel; + TransparentColor1 := colorkey; + end; + end; + + Mod1 := Pitch1 - ( ScanWidth * BPP ); + + inc( Addr1, BPP * Scan1Start ); + + if Top1 <= Top2 then + begin + // 1. up, 2. down + ScanHeight := Bottom1 - Top2; + if ScanHeight > Src_Rect2.h then + ScanHeight := Src_Rect2.h; + inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); + end + else + begin + // 1. down, 2. up + ScanHeight := Bottom2 - Top1; + if ScanHeight > Src_Rect1.h then + ScanHeight := Src_Rect1.h; + + end; + case BPP of + 1 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PByte( Addr1 )^ <> TransparentColor1 ) then + begin + Result := true; + exit; + end; + inc( Addr1 ); + + end; + inc( Addr1, Mod1 ); + + end; + 2 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PWord( Addr1 )^ <> TransparentColor1 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 2 ); + + end; + inc( Addr1, Mod1 ); + + end; + 3 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + Color1 := PLongWord( Addr1 )^ and $00FFFFFF; + + if ( Color1 <> TransparentColor1 ) + then + begin + Result := true; + exit; + end; + inc( Addr1, 3 ); + + end; + inc( Addr1, Mod1 ); + + end; + 4 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 4 ); + + end; + inc( Addr1, Mod1 ); + + end; + end; +end; + +procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr, TransparentColor : cardinal; + // TransparentColor: cardinal; + _ebx, _esi, _edi, _esp : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov al, [esi] // AL := source color + cmp al, 0 + je @SkipColor // if AL=0 or AL=transparent color then skip everything + cmp al, byte ptr TransparentColor + je @SkipColor + or al, [edi] + mov [edi], al + @SkipColor: + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 15 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + cmp ax, word ptr TransparentColor + je @SkipColor + or ax, [edi] + mov [edi], ax + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 16 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + cmp ax, word ptr TransparentColor + je @SkipColor + or ax, [edi] + mov [edi], ax + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 24 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + add WorkX, ax // WorkX := Src.w * 2 + add WorkX, ax // WorkX := Src.w * 3 + @Loopx: + mov al, [esi] // AL := source color + or al, [edi] + mov [edi], al + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 32 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + shl ax, 2 + mov WorkX, ax // WorkX := Src.w * 4 + @Loopx: + mov al, [esi] // AL := source color + or al, [edi] + mov [edi], al + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + +procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr, TransparentColor : cardinal; + // TransparentColor: cardinal; + _ebx, _esi, _edi, _esp : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov al, [esi] // AL := source color + cmp al, 0 + je @SkipColor // if AL=0 or AL=transparent color then skip everything + cmp al, byte ptr TransparentColor + je @SkipColor + and al, [edi] + mov [edi], al + @SkipColor: + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 15 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + cmp ax, word ptr TransparentColor + je @SkipColor + and ax, [edi] + mov [edi], ax + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 16 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + @Loopx: + mov ax, [esi] // AX := source color + cmp ax, 0 + je @SkipColor // if AX=0 then skip everything + cmp ax, word ptr TransparentColor + je @SkipColor + and ax, [edi] + mov [edi], ax + @SkipColor: + add esi, 2 + add edi, 2 + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 24 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + mov WorkX, ax // WorkX := Src.w + add WorkX, ax // WorkX := Src.w * 2 + add WorkX, ax // WorkX := Src.w * 3 + @Loopx: + mov al, [esi] // AL := source color + and al, [edi] + mov [edi], al + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + 32 : + asm + mov _ebx, ebx + mov _esi, esi + mov _edi, edi + mov _esp, esp + mov esi, SrcAddr // ESI - Source Offset + mov edi, DestAddr // EDI - Destination Offset + mov ax, Src.h // WorkY := Src.h + mov WorkY, ax + @LoopY: + mov ax, Src.w + shl ax, 2 + mov WorkX, ax // WorkX := Src.w * 4 + @Loopx: + mov al, [esi] // AL := source color + and al, [edi] + mov [edi], al + inc esi + inc edi + dec WorkX + jnz @LoopX + add esi, SrcMod + add edi, DestMod + dec WorkY + jnz @LoopY + mov esp,_esp + mov edi,_edi + mov esi,_esi + mov ebx,_ebx + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + + +procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + if Pixel2 > 0 then + begin + if Pixel2 and $E0 > Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; + if Pixel2 and $1C > Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; + if Pixel2 and $03 > Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; + + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( DestAddr )^ := R or G or B; + end + else + PUInt8( DestAddr )^ := Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $7C00 > Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; + if Pixel2 and $03E0 > Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; + if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $F800 > Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; + if Pixel2 and $07E0 > Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; + if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; + if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); + end + else + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; + if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := R or G or B; + end + else + PUInt32( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + + +procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : cardinal; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + if Pixel2 > 0 then + begin + if Pixel2 and $E0 < Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; + if Pixel2 and $1C < Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; + if Pixel2 and $03 < Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; + + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( DestAddr )^ := R or G or B; + end + else + PUInt8( DestAddr )^ := Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $7C00 < Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; + if Pixel2 and $03E0 < Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; + if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $F800 < Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; + if Pixel2 and $07E0 < Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; + if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; + if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); + end + else + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; + if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := R or G or B; + end + else + PUInt32( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + +function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; +var tflag, flag1, flag2: word; + txy, xedge, yedge: Integer; + slope: single; + + function ClipCode(x,y: Integer): word; + begin + Result := 0; + if x < ClipRect.x then Result := 1; + if x >= ClipRect.w + ClipRect.x then Result := Result or 2; + if y < ClipRect.y then Result := Result or 4; + if y >= ClipRect.h + ClipRect.y then Result := Result or 8; + end; + +begin + flag1 := ClipCode(x1,y1); + flag2 := ClipCode(x2,y2); + result := true; + + while true do + begin + if (flag1 or flag2) = 0 then Exit; // all in + + if (flag1 and flag2) <> 0 then + begin + result := false; + Exit; // all out + end; + + if flag2 = 0 then + begin + txy := x1; x1 := x2; x2 := txy; + txy := y1; y1 := y2; y2 := txy; + tflag := flag1; flag1 := flag2; flag2 := tflag; + end; + + if (flag2 and 3) <> 0 then + begin + if (flag2 and 1) <> 0 then + xedge := ClipRect.x + else + xedge := ClipRect.w + ClipRect.x -1; // back 1 pixel otherwise we end up in a loop + + slope := (y2 - y1) / (x2 - x1); + y2 := y1 + Round(slope * (xedge - x1)); + x2 := xedge; + end + else + begin + if (flag2 and 4) <> 0 then + yedge := ClipRect.y + else + yedge := ClipRect.h + ClipRect.y -1; // up 1 pixel otherwise we end up in a loop + + slope := (x2 - x1) / (y2 - y1); + x2 := x1 + Round(slope * (yedge - y1)); + y2 := yedge; + end; + + flag2 := ClipCode(x2, y2); + end; +end; + +end. + + diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas index e1b2347e..094f4e0f 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas @@ -1,923 +1,923 @@ -unit sdlinput; -{ - $Id: sdlinput.pas,v 1.9 2007/08/22 21:18:43 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ SDL Input Wrapper } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2003 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ SDL Mouse, Keyboard and Joystick wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ March 12 2003 - DL : Initial creation } -{ } -{ February 02 2004 - DL : Added Custom Cursor Support to the Mouse class } -{ - $Log: sdlinput.pas,v $ - Revision 1.9 2007/08/22 21:18:43 savage - Thanks to Dean for his MouseDelta patch. - - Revision 1.8 2005/08/03 18:57:32 savage - Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class - - Revision 1.7 2004/09/30 22:32:04 savage - Updated with slightly different header comments - - Revision 1.6 2004/09/12 21:52:58 savage - Slight changes to fix some issues with the sdl classes. - - Revision 1.5 2004/05/10 21:11:49 savage - changes required to help get SoAoS off the ground. - - Revision 1.4 2004/05/03 22:38:40 savage - Added the ability to enable or disable certain inputs @ runtime. Basically it just does not call UpdateInput if Enabled = false. - Can also disable and enable input devices via the InputManager. - - Revision 1.3 2004/04/28 21:27:01 savage - Updated Joystick code and event handlers. Needs testing... - - Revision 1.2 2004/02/14 22:36:29 savage - Fixed inconsistencies of using LoadLibrary and LoadModule. - Now all units make use of LoadModule rather than LoadLibrary and other dynamic proc procedures. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} -{******************************************************************************} - -interface - -{$i jedi-sdl.inc} - -uses - Classes, - sdl; - -type - TSDLInputType = ( itJoystick , itKeyBoard, itMouse ); - TSDLInputTypes = set of TSDLInputType; - - TSDLCustomInput = class( TObject ) - private - FEnabled: Boolean; - public - constructor Create; - function UpdateInput( event: TSDL_EVENT ) : Boolean; virtual; abstract; - property Enabled : Boolean read FEnabled write FEnabled; - end; - - TSDLJoyAxisMoveEvent = procedure ( Which: UInt8; Axis: UInt8; Value: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLJoyBallMoveEvent = procedure ( Which: UInt8; Ball: UInt8; RelativePos: TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLJoyHatMoveEvent = procedure ( Which: UInt8; Hat: UInt8; Value: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLJoyButtonEvent = procedure ( Which: UInt8; Button: UInt8; State: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - - TSDLJoyStick = class( TSDLCustomInput ) - private - FJoystick : PSDL_Joystick; - FJoystickIndex : Integer; - FJoyAxisMoveEvent : TSDLJoyAxisMoveEvent; - FJoyBallMoveEvent : TSDLJoyBallMoveEvent; - FJoyHatMoveEvent : TSDLJoyHatMoveEvent; - FJoyButtonDownEvent : TSDLJoyButtonEvent; - FJoyButtonUpEvent : TSDLJoyButtonEvent; - procedure DoAxisMove( Event : TSDL_Event ); - procedure DoBallMove( Event : TSDL_Event ); - procedure DoHatMove( Event : TSDL_Event ); - procedure DoButtonDown( Event : TSDL_Event ); - procedure DoButtonUp( Event : TSDL_Event ); - function GetName: PChar; - function GetNumAxes: integer; - function GetNumBalls: integer; - function GetNumButtons: integer; - function GetNumHats: integer; - public - constructor Create( Index : Integer ); - destructor Destroy; override; - procedure Open; - procedure Close; - function UpdateInput( Event: TSDL_EVENT ) : Boolean; override; - property Name : PChar read GetName; - property NumAxes : integer read GetNumAxes; - property NumBalls : integer read GetNumBalls; - property NumButtons : integer read GetNumButtons; - property NumHats : integer read GetNumHats; - property OnAxisMove : TSDLJoyAxisMoveEvent read FJoyAxisMoveEvent write FJoyAxisMoveEvent; - property OnBallMove : TSDLJoyBallMoveEvent read FJoyBallMoveEvent write FJoyBallMoveEvent; - property OnHatMove : TSDLJoyHatMoveEvent read FJoyHatMoveEvent write FJoyHatMoveEvent; - property OnButtonDown : TSDLJoyButtonEvent read FJoyButtonDownEvent write FJoyButtonDownEvent; - property OnButtonUp : TSDLJoyButtonEvent read FJoyButtonUpEvent write FJoyButtonUpEvent; - end; - - TSDLJoySticks = class( TObject ) - private - FNumOfJoySticks: Integer; - FJoyStickList : TList; - function GetJoyStick(Index: integer): TSDLJoyStick; - procedure SetJoyStick(Index: integer; const Value: TSDLJoyStick); - public - constructor Create; - destructor Destroy; override; - function UpdateInput( event: TSDL_EVENT ) : Boolean; - property NumOfJoySticks : Integer read FNumOfJoySticks write FNumOfJoySticks; - property JoySticks[ Index : integer ] : TSDLJoyStick read GetJoyStick write SetJoyStick; - end; - - TSDLKeyBoardEvent = procedure ( var Key: TSDLKey; Shift: TSDLMod; unicode : UInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - TSDLKeyBoard = class( TSDLCustomInput ) - private - FKeys : PKeyStateArr; - FOnKeyUp: TSDLKeyBoardEvent; - FOnKeyDown: TSDLKeyBoardEvent; - procedure DoKeyDown( keysym : PSDL_keysym ); - procedure DoKeyUp( keysym : PSDL_keysym ); - public - function IsKeyDown( Key : TSDLKey ) : Boolean; - function IsKeyUp( Key : TSDLKey ) : Boolean; - function UpdateInput( event: TSDL_EVENT ) : Boolean; override; - property Keys : PKeyStateArr read FKeys write FKeys; - property OnKeyDown : TSDLKeyBoardEvent read FOnKeyDown write FOnKeyDown; - property OnKeyUp : TSDLKeyBoardEvent read FOnKeyUp write FOnKeyUp; - end; - - TSDLMouseButtonEvent = procedure ( Button : Integer; Shift: TSDLMod; MousePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLMouseMoveEvent = procedure ( Shift: TSDLMod; CurrentPos : TPoint; RelativePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLMouseWheelEvent = procedure ( WheelDelta : Integer; Shift: TSDLMod; MousePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - TSDLCustomCursor = class( TObject ) - private - FFileName : string; - FHotPoint: TPoint; - procedure SetFileName(const aValue: string ); - function ScanForChar( str : string; ch : Char; startPos : Integer; lookFor : Boolean ) : Integer; - public - constructor Create( const aFileName : string; aHotPoint: TPoint ); - procedure LoadFromFile( const aFileName : string ); virtual; abstract; - procedure LoadFromStream( aStream : TStream ); virtual; abstract; - procedure Show; virtual; abstract; - property FileName : string read FFileName write SetFileName; - property HotPoint : TPoint read FHotPoint write FHotPoint; - end; - - TSDLXPMCursor = class( TSDLCustomCursor ) - private - FCursor : PSDL_Cursor; - procedure FreeCursor; - public - destructor Destroy; override; - procedure LoadFromFile( const aFileName : string ); override; - procedure LoadFromStream( aStream : TStream ); override; - procedure Show; override; - end; - - TSDLCursorList = class( TStringList ) - protected - function GetObject( aIndex : Integer ): TSDLCustomCursor; reintroduce; - procedure PutObject( aIndex : Integer; AObject : TSDLCustomCursor); reintroduce; - public - constructor Create; - function AddCursor(const aName : string; aObject : TSDLCustomCursor): Integer; virtual; - end; - - TSDLMouse = class( TSDLCustomInput ) - private - FDragging : Boolean; - FMousePos : TPoint; - FOnMouseUp: TSDLMouseButtonEvent; - FOnMouseDown: TSDLMouseButtonEvent; - FOnMouseMove: TSDLMouseMoveEvent; - FOnMouseWheel: TSDLMouseWheelEvent; - FCursorList : TSDLCursorList; // Cursor Pointer - procedure DoMouseMove( Event: TSDL_Event ); - procedure DoMouseDown( Event: TSDL_Event ); - procedure DoMouseUp( Event: TSDL_Event ); - procedure DoMouseWheelScroll( Event: TSDL_Event ); - function GetMousePosition: TPoint; - procedure SetMousePosition(const Value: TPoint); - function GetMouseDelta: TPoint; - public - destructor Destroy; override; - function UpdateInput( event: TSDL_EVENT ) : Boolean; override; - function MouseIsDown( Button : Integer ) : Boolean; - function MouseIsUp( Button : Integer ) : Boolean; - procedure ShowCursor; - procedure HideCursor; - property OnMouseDown : TSDLMouseButtonEvent read FOnMouseDown write FOnMouseDown; - property OnMouseUp : TSDLMouseButtonEvent read FOnMouseUp write FOnMouseUp; - property OnMouseMove : TSDLMouseMoveEvent read FOnMouseMove write FOnMouseMove; - property OnMouseWheel : TSDLMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; - property MousePosition : TPoint read GetMousePosition write SetMousePosition; - property MouseDelta: TPoint read GetMouseDelta; - property Cursors : TSDLCursorList read FCursorList write FCursorList; - end; - - TSDLInputManager = class( TObject ) - private - FKeyBoard : TSDLKeyBoard; - FMouse : TSDLMouse; - FJoystick : TSDLJoysticks; - public - constructor Create( InitInputs : TSDLInputTypes ); - destructor Destroy; override; - procedure Disable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer = 0 ); - procedure Enable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer = 0 ); - function UpdateInputs( event: TSDL_EVENT ) : Boolean; - property KeyBoard : TSDLKeyBoard read FKeyBoard write FKeyBoard; - property Mouse : TSDLMouse read FMouse write FMouse; - property JoyStick : TSDLJoysticks read FJoyStick write FJoyStick; - end; - -implementation - -uses - SysUtils; - -{ TSDLCustomInput } -constructor TSDLCustomInput.Create; -begin - inherited; - FEnabled := true; -end; - -{ TSDLJoysticks } -constructor TSDLJoysticks.Create; -var - i : integer; -begin - inherited; - if ( SDL_WasInit( SDL_INIT_JOYSTICK ) = 0 ) then - SDL_InitSubSystem( SDL_INIT_JOYSTICK ); - FNumOfJoySticks := SDL_NumJoysticks; - FJoyStickList := TList.Create; - for i := 0 to FNumOfJoySticks - 1 do - begin - FJoyStickList.Add( TSDLJoyStick.Create( i ) ); - end; -end; - -destructor TSDLJoysticks.Destroy; -var - i : integer; -begin - if FJoyStickList.Count > 0 then - begin - for i := 0 to FJoyStickList.Count - 1 do - begin - TSDLJoyStick( FJoyStickList.Items[i] ).Free; - end; - end; - SDL_QuitSubSystem( SDL_INIT_JOYSTICK ); - inherited; -end; - -function TSDLJoySticks.GetJoyStick(Index: integer): TSDLJoyStick; -begin - Result := TSDLJoyStick( FJoyStickList[ Index ] ); -end; - -procedure TSDLJoySticks.SetJoyStick(Index: integer; - const Value: TSDLJoyStick); -begin - FJoyStickList[ Index ] := @Value; -end; - -function TSDLJoysticks.UpdateInput(event: TSDL_EVENT): Boolean; -var - i : integer; -begin - result := false; - if FJoyStickList.Count > 0 then - begin - for i := 0 to FJoyStickList.Count - 1 do - begin - TSDLJoyStick( FJoyStickList.Items[i] ).UpdateInput( event ); - end; - end; -end; - -{ TSDLKeyBoard } -procedure TSDLKeyBoard.DoKeyDown(keysym: PSDL_keysym); -begin - if Assigned( FOnKeyDown ) then - FOnKeyDown( keysym.sym , keysym.modifier, keysym.unicode ); -end; - -procedure TSDLKeyBoard.DoKeyUp(keysym: PSDL_keysym); -begin - if Assigned( FOnKeyUp ) then - FOnKeyUp( keysym.sym , keysym.modifier, keysym.unicode ); -end; - -function TSDLKeyBoard.IsKeyDown( Key: TSDLKey ): Boolean; -begin - SDL_PumpEvents; - - // Populate Keys array - FKeys := PKeyStateArr( SDL_GetKeyState( nil ) ); - Result := ( FKeys[Key] = SDL_PRESSED ); -end; - -function TSDLKeyBoard.IsKeyUp( Key: TSDLKey ): Boolean; -begin - SDL_PumpEvents; - - // Populate Keys array - FKeys := PKeyStateArr( SDL_GetKeyState( nil ) ); - Result := ( FKeys[Key] = SDL_RELEASED ); -end; - -function TSDLKeyBoard.UpdateInput(event: TSDL_EVENT): Boolean; -begin - result := false; - if ( FEnabled ) then - begin - case event.type_ of - SDL_KEYDOWN : - begin - // handle key presses - DoKeyDown( @event.key.keysym ); - result := true; - end; - - SDL_KEYUP : - begin - // handle key releases - DoKeyUp( @event.key.keysym ); - result := true; - end; - end; - end; -end; - -{ TSDLMouse } -destructor TSDLMouse.Destroy; -begin - - inherited; -end; - -procedure TSDLMouse.DoMouseDown( Event: TSDL_Event ); -var - CurrentPos : TPoint; -begin - FDragging := true; - if Assigned( FOnMouseDown ) then - begin - CurrentPos.x := event.button.x; - CurrentPos.y := event.button.y; - FOnMouseDown( event.button.button, SDL_GetModState, CurrentPos ); - end; -end; - -procedure TSDLMouse.DoMouseMove( Event: TSDL_Event ); -var - CurrentPos, RelativePos : TPoint; -begin - if Assigned( FOnMouseMove ) then - begin - CurrentPos.x := event.motion.x; - CurrentPos.y := event.motion.y; - RelativePos.x := event.motion.xrel; - RelativePos.y := event.motion.yrel; - FOnMouseMove( SDL_GetModState, CurrentPos, RelativePos ); - end; -end; - -procedure TSDLMouse.DoMouseUp( event: TSDL_EVENT ); -var - Point : TPoint; -begin - FDragging := false; - if Assigned( FOnMouseUp ) then - begin - Point.x := event.button.x; - Point.y := event.button.y; - FOnMouseUp( event.button.button, SDL_GetModState, Point ); - end; -end; - -procedure TSDLMouse.DoMouseWheelScroll( event: TSDL_EVENT ); -var - Point : TPoint; -begin - if Assigned( FOnMouseWheel ) then - begin - Point.x := event.button.x; - Point.y := event.button.y; - if ( event.button.button = SDL_BUTTON_WHEELUP ) then - FOnMouseWheel( SDL_BUTTON_WHEELUP, SDL_GetModState, Point ) - else - FOnMouseWheel( SDL_BUTTON_WHEELDOWN, SDL_GetModState, Point ); - end; -end; - -function TSDLMouse.GetMouseDelta: TPoint; -begin - SDL_PumpEvents; - - SDL_GetRelativeMouseState( Result.X, Result.Y ); -end; - -function TSDLMouse.GetMousePosition: TPoint; -begin - SDL_PumpEvents; - - SDL_GetMouseState( FMousePos.X, FMousePos.Y ); - Result := FMousePos; -end; - -procedure TSDLMouse.HideCursor; -begin - SDL_ShowCursor( SDL_DISABLE ); -end; - -function TSDLMouse.MouseIsDown(Button: Integer): Boolean; -begin - SDL_PumpEvents; - - Result := ( SDL_GetMouseState( FMousePos.X, FMousePos.Y ) and SDL_BUTTON( Button ) = 0 ); -end; - -function TSDLMouse.MouseIsUp(Button: Integer): Boolean; -begin - SDL_PumpEvents; - - Result := not ( SDL_GetMouseState( FMousePos.X, FMousePos.Y ) and SDL_BUTTON( Button ) = 0 ); -end; - -procedure TSDLMouse.SetMousePosition(const Value: TPoint); -begin - SDL_WarpMouse( Value.x, Value.y ); -end; - -procedure TSDLMouse.ShowCursor; -begin - SDL_ShowCursor( SDL_ENABLE ); -end; - -function TSDLMouse.UpdateInput(event: TSDL_EVENT): Boolean; -begin - result := false; - if ( FEnabled ) then - begin - case event.type_ of - SDL_MOUSEMOTION : - begin - // handle Mouse Move - DoMouseMove( event ); - end; - - SDL_MOUSEBUTTONDOWN : - begin - // handle Mouse Down - if ( event.button.button = SDL_BUTTON_WHEELUP ) - or ( event.button.button = SDL_BUTTON_WHEELDOWN ) then - DoMouseWheelScroll( event ) - else - DoMouseDown( event ); - end; - - SDL_MOUSEBUTTONUP : - begin - // handle Mouse Up - if ( event.button.button = SDL_BUTTON_WHEELUP ) - or ( event.button.button = SDL_BUTTON_WHEELDOWN ) then - DoMouseWheelScroll( event ) - else - DoMouseUp( event ); - end; - end; - end; -end; - -{ TSDLInputManager } -constructor TSDLInputManager.Create(InitInputs: TSDLInputTypes); -begin - inherited Create; - if itJoystick in InitInputs then - FJoystick := TSDLJoysticks.Create; - - if itKeyBoard in InitInputs then - FKeyBoard := TSDLKeyBoard.Create; - - if itMouse in InitInputs then - FMouse := TSDLMouse.Create; -end; - -destructor TSDLInputManager.Destroy; -begin - if FJoystick <> nil then - FreeAndNil( FJoystick ); - if FKeyBoard <> nil then - FreeAndNil( FKeyBoard ); - if FMouse <> nil then - FreeAndNil( FMouse ); - inherited; -end; - -procedure TSDLInputManager.Disable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer ); -begin - if itJoystick in InitInputs then - FJoystick.JoySticks[ JoyStickNumber ].Enabled := false; - - if itKeyBoard in InitInputs then - FKeyBoard.Enabled := false; - - if itMouse in InitInputs then - FMouse.Enabled := false; -end; - -procedure TSDLInputManager.Enable( InitInputs: TSDLInputTypes; JoyStickNumber: Integer ); -begin - if itJoystick in InitInputs then - FJoystick.JoySticks[ JoyStickNumber ].Enabled := true; - - if itKeyBoard in InitInputs then - FKeyBoard.Enabled := true; - - if itMouse in InitInputs then - FMouse.Enabled := true; -end; - -function TSDLInputManager.UpdateInputs( event: TSDL_EVENT ): Boolean; -begin - Result := false; - if ( FJoystick <> nil ) then - Result := FJoystick.UpdateInput( event ); - if ( FKeyBoard <> nil ) then - Result := FKeyBoard.UpdateInput( event ); - if ( FMouse <> nil ) then - Result := FMouse.UpdateInput( event ); -end; - -{ TSDLJoyStick } -procedure TSDLJoyStick.Close; -begin - SDL_JoystickClose( @FJoystick ); -end; - -constructor TSDLJoyStick.Create( Index : Integer ); -begin - inherited Create; - FJoystick := nil; - FJoystickIndex := Index; -end; - -destructor TSDLJoyStick.Destroy; -begin - if FJoystick <> nil then - Close; - inherited; -end; - -procedure TSDLJoyStick.DoAxisMove(Event: TSDL_Event); -begin - if Assigned( FJoyAxisMoveEvent ) then - begin - FJoyAxisMoveEvent( Event.jaxis.which, Event.jaxis.axis, Event.jaxis.value ); - end -end; - -procedure TSDLJoyStick.DoBallMove(Event: TSDL_Event); -var - BallPoint : TPoint; -begin - if Assigned( FJoyBallMoveEvent ) then - begin - BallPoint.x := Event.jball.xrel; - BallPoint.y := Event.jball.yrel; - FJoyBallMoveEvent( Event.jball.which, Event.jball.ball, BallPoint ); - end; -end; - -procedure TSDLJoyStick.DoButtonDown(Event: TSDL_Event); -begin - if Assigned( FJoyButtonDownEvent ) then - begin - if ( Event.jbutton.state = SDL_PRESSED ) then - FJoyButtonDownEvent( Event.jbutton.which, Event.jbutton.button, Event.jbutton.state ); - end; -end; - -procedure TSDLJoyStick.DoButtonUp(Event: TSDL_Event); -begin - if Assigned( FJoyButtonUpEvent ) then - begin - if ( Event.jbutton.state = SDL_RELEASED ) then - FJoyButtonUpEvent( Event.jbutton.which, Event.jbutton.button, Event.jbutton.state ); - end -end; - -procedure TSDLJoyStick.DoHatMove(Event: TSDL_Event); -begin - if Assigned( FJoyHatMoveEvent ) then - begin - FJoyHatMoveEvent( Event.jhat.which, Event.jhat.hat, Event.jhat.value ); - end; -end; - -function TSDLJoyStick.GetName: PChar; -begin - result := FJoystick.name; -end; - -function TSDLJoyStick.GetNumAxes: integer; -begin - result := FJoystick.naxes; -end; - -function TSDLJoyStick.GetNumBalls: integer; -begin - result := FJoystick.nballs; -end; - -function TSDLJoyStick.GetNumButtons: integer; -begin - result := FJoystick.nbuttons; -end; - -function TSDLJoyStick.GetNumHats: integer; -begin - result := FJoystick.nhats; -end; - -procedure TSDLJoyStick.Open; -begin - FJoystick := SDL_JoyStickOpen( FJoystickIndex ); -end; - -function TSDLJoyStick.UpdateInput(Event: TSDL_EVENT): Boolean; -begin - Result := false; - - if ( FEnabled ) then - begin - case event.type_ of - SDL_JOYAXISMOTION : - begin - DoAxisMove( Event ); - end; - - SDL_JOYBALLMOTION : - begin - DoBallMove( Event ); - end; - - SDL_JOYHATMOTION : - begin - DoHatMove( Event ); - end; - - SDL_JOYBUTTONDOWN : - begin - DoButtonDown( Event ); - end; - - SDL_JOYBUTTONUP : - begin - DoButtonUp( Event ); - end; - end; - end; -end; - -{ TSDLCustomCursor } - -constructor TSDLCustomCursor.Create(const aFileName: string; aHotPoint: TPoint); -begin - inherited Create; - FHotPoint := aHotPoint; - LoadFromFile( aFileName ); -end; - -function TSDLCustomCursor.ScanForChar(str: string; ch: Char; - startPos: Integer; lookFor: Boolean): Integer; -begin - Result := -1; - while ( ( ( str[ startPos ] = ch ) <> lookFor ) and ( startPos < Length( str ) ) ) do - inc( startPos ); - if startPos <> Length( str ) then - Result := startPos; -end; - -procedure TSDLCustomCursor.SetFileName(const aValue: string); -begin - LoadFromFile( aValue ); -end; - -{ TSDLXPMCursor } - -destructor TSDLXPMCursor.Destroy; -begin - FreeCursor; - inherited; -end; - -procedure TSDLXPMCursor.FreeCursor; -begin - if FCursor <> nil then - begin - SDL_FreeCursor( FCursor ); - FFileName := ''; - end; -end; - -procedure TSDLXPMCursor.LoadFromFile(const aFileName: string); -var - xpmFile : Textfile; - step : Integer; - holdPos : Integer; - counter : Integer; - dimensions : array[ 1..3 ] of Integer; - clr, clrNone, clrBlack, clrWhite : Char; - data, mask : array of UInt8; - i, col : Integer; - LineString : string; -begin - FreeCursor; - AssignFile( xpmFile, aFileName ); - Reset( xpmFile ); - step := 0; - i := -1; - clrBlack := 'X'; - clrWhite := ','; - clrNone := ' '; - counter := 0; - while not ( eof( xpmFile ) ) do - begin - Readln( xpmFile, LineString ); - // scan for strings - if LineString[ 1 ] = '"' then - begin - case step of - 0 : // Get dimensions (should be width height number-of-colors ???) - begin - HoldPos := 2; - counter := ScanForChar( LineString, ' ', HoldPos, False ); - counter := ScanForChar( LineString, ' ', counter, True ); - dimensions[ 1 ] := StrToInt( Copy( LineString, HoldPos, counter - HoldPos ) ); - counter := ScanForChar( LineString, ' ', counter, False ); - holdPos := counter; - counter := ScanForChar( LineString, ' ', counter, True ); - dimensions[ 2 ] := StrToInt( Copy( LineString, holdPos, counter - HoldPos ) ); - counter := ScanForChar( LineString, ' ', counter, False ); - holdPos := counter; - counter := ScanForChar( LineString, ' ', counter, True ); - dimensions[ 3 ] := StrToInt( Copy( LineString, holdPos, counter - HoldPos ) ); - step := 1; - SetLength( data, ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ); - SetLength( mask, ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ); - //Log.LogStatus( 'Length = ' + IntToStr( ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ), 'LoadCursorFromFile' ); - end; - 1 : // get the symbols for transparent, black and white - begin - // get the symbol for the color - clr := LineString[ 2 ]; - // look for the 'c' symbol - counter := ScanForChar( LineString, 'c', 3, True ); - inc( counter ); - counter := ScanForChar( LineString, ' ', counter, False ); - if LowerCase( Copy( LineString, counter, 4 ) ) = 'none' then - begin - clrNone := clr; - end; - if LowerCase( Copy( LineString, counter, 7 ) ) = '#ffffff' then - begin - clrWhite := clr; - end; - if LowerCase( Copy( LineString, counter, 7 ) ) = '#000000' then - begin - clrBlack := clr; - end; - dec( dimensions[ 3 ] ); - if dimensions[ 3 ] = 0 then - begin - step := 2; - counter := 0; - end; - end; - 2 : // get cursor information -- modified from the SDL - // documentation of SDL_CreateCursor. - begin - for col := 1 to dimensions[1] do - begin - if ( ( col mod 8 ) <> 1 ) then - begin - data[ i ] := data[ i ] shl 1; - mask[ i ] := mask[ i ] shl 1; - end - else - begin - inc( i ); - data[ i ] := 0; - mask[ i ] := 0; - end; - if LineString[ col ] = clrWhite then - begin - mask[ i ] := mask[ i ] or $01; - end - else if LineString[ col ] = clrBlack then - begin - data[ i ] := data[ i ] or $01; - mask[ i ] := mask[ i ] or $01; - end - else if LineString[ col + 1 ] = clrNone then - begin - // - end; - end; - inc(counter); - if counter = dimensions[2] then - step := 4; - end; - end; - end; - end; - CloseFile( xpmFile ); - FCursor := SDL_CreateCursor( PUInt8( data ), PUInt8( mask ), dimensions[ 1 ], dimensions[ 2 ], FHotPoint.x, FHotPoint.y ); -end; - -procedure TSDLXPMCursor.LoadFromStream(aStream: TStream); -begin - inherited; - -end; - -procedure TSDLXPMCursor.Show; -begin - inherited; - SDL_SetCursor( FCursor ); -end; - -{ TSDLCursorList } -function TSDLCursorList.AddCursor(const aName : string; aObject : TSDLCustomCursor): Integer; -begin - result := inherited AddObject( aName, aObject ); -end; - -constructor TSDLCursorList.Create; -begin - inherited; - Duplicates := dupIgnore; -end; - -function TSDLCursorList.GetObject(aIndex: Integer): TSDLCustomCursor; -begin - result := TSDLCustomCursor( inherited GetObject( aIndex ) ); -end; - -procedure TSDLCursorList.PutObject(aIndex: Integer; aObject: TSDLCustomCursor); -begin - inherited PutObject( aIndex, aObject ); -end; - -end. +unit sdlinput; +{ + $Id: sdlinput.pas,v 1.9 2007/08/22 21:18:43 savage Exp $ + +} +{******************************************************************************} +{ } +{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } +{ SDL Input Wrapper } +{ } +{ } +{ The initial developer of this Pascal code was : } +{ Dominique Louis } +{ } +{ Portions created by Dominique Louis are } +{ Copyright (C) 2003 - 2100 Dominique Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Dominique Louis } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ SDL Mouse, Keyboard and Joystick wrapper } +{ } +{ } +{ Requires } +{ -------- } +{ SDL.dll on Windows platforms } +{ libSDL-1.1.so.0 on Linux platform } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ March 12 2003 - DL : Initial creation } +{ } +{ February 02 2004 - DL : Added Custom Cursor Support to the Mouse class } +{ + $Log: sdlinput.pas,v $ + Revision 1.9 2007/08/22 21:18:43 savage + Thanks to Dean for his MouseDelta patch. + + Revision 1.8 2005/08/03 18:57:32 savage + Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class + + Revision 1.7 2004/09/30 22:32:04 savage + Updated with slightly different header comments + + Revision 1.6 2004/09/12 21:52:58 savage + Slight changes to fix some issues with the sdl classes. + + Revision 1.5 2004/05/10 21:11:49 savage + changes required to help get SoAoS off the ground. + + Revision 1.4 2004/05/03 22:38:40 savage + Added the ability to enable or disable certain inputs @ runtime. Basically it just does not call UpdateInput if Enabled = false. + Can also disable and enable input devices via the InputManager. + + Revision 1.3 2004/04/28 21:27:01 savage + Updated Joystick code and event handlers. Needs testing... + + Revision 1.2 2004/02/14 22:36:29 savage + Fixed inconsistencies of using LoadLibrary and LoadModule. + Now all units make use of LoadModule rather than LoadLibrary and other dynamic proc procedures. + + Revision 1.1 2004/02/05 00:08:20 savage + Module 1.0 release + + +} +{******************************************************************************} + +interface + +{$i jedi-sdl.inc} + +uses + Classes, + sdl; + +type + TSDLInputType = ( itJoystick , itKeyBoard, itMouse ); + TSDLInputTypes = set of TSDLInputType; + + TSDLCustomInput = class( TObject ) + private + FEnabled: Boolean; + public + constructor Create; + function UpdateInput( event: TSDL_EVENT ) : Boolean; virtual; abstract; + property Enabled : Boolean read FEnabled write FEnabled; + end; + + TSDLJoyAxisMoveEvent = procedure ( Which: UInt8; Axis: UInt8; Value: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLJoyBallMoveEvent = procedure ( Which: UInt8; Ball: UInt8; RelativePos: TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLJoyHatMoveEvent = procedure ( Which: UInt8; Hat: UInt8; Value: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLJoyButtonEvent = procedure ( Which: UInt8; Button: UInt8; State: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; + + + TSDLJoyStick = class( TSDLCustomInput ) + private + FJoystick : PSDL_Joystick; + FJoystickIndex : Integer; + FJoyAxisMoveEvent : TSDLJoyAxisMoveEvent; + FJoyBallMoveEvent : TSDLJoyBallMoveEvent; + FJoyHatMoveEvent : TSDLJoyHatMoveEvent; + FJoyButtonDownEvent : TSDLJoyButtonEvent; + FJoyButtonUpEvent : TSDLJoyButtonEvent; + procedure DoAxisMove( Event : TSDL_Event ); + procedure DoBallMove( Event : TSDL_Event ); + procedure DoHatMove( Event : TSDL_Event ); + procedure DoButtonDown( Event : TSDL_Event ); + procedure DoButtonUp( Event : TSDL_Event ); + function GetName: PChar; + function GetNumAxes: integer; + function GetNumBalls: integer; + function GetNumButtons: integer; + function GetNumHats: integer; + public + constructor Create( Index : Integer ); + destructor Destroy; override; + procedure Open; + procedure Close; + function UpdateInput( Event: TSDL_EVENT ) : Boolean; override; + property Name : PChar read GetName; + property NumAxes : integer read GetNumAxes; + property NumBalls : integer read GetNumBalls; + property NumButtons : integer read GetNumButtons; + property NumHats : integer read GetNumHats; + property OnAxisMove : TSDLJoyAxisMoveEvent read FJoyAxisMoveEvent write FJoyAxisMoveEvent; + property OnBallMove : TSDLJoyBallMoveEvent read FJoyBallMoveEvent write FJoyBallMoveEvent; + property OnHatMove : TSDLJoyHatMoveEvent read FJoyHatMoveEvent write FJoyHatMoveEvent; + property OnButtonDown : TSDLJoyButtonEvent read FJoyButtonDownEvent write FJoyButtonDownEvent; + property OnButtonUp : TSDLJoyButtonEvent read FJoyButtonUpEvent write FJoyButtonUpEvent; + end; + + TSDLJoySticks = class( TObject ) + private + FNumOfJoySticks: Integer; + FJoyStickList : TList; + function GetJoyStick(Index: integer): TSDLJoyStick; + procedure SetJoyStick(Index: integer; const Value: TSDLJoyStick); + public + constructor Create; + destructor Destroy; override; + function UpdateInput( event: TSDL_EVENT ) : Boolean; + property NumOfJoySticks : Integer read FNumOfJoySticks write FNumOfJoySticks; + property JoySticks[ Index : integer ] : TSDLJoyStick read GetJoyStick write SetJoyStick; + end; + + TSDLKeyBoardEvent = procedure ( var Key: TSDLKey; Shift: TSDLMod; unicode : UInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; + + TSDLKeyBoard = class( TSDLCustomInput ) + private + FKeys : PKeyStateArr; + FOnKeyUp: TSDLKeyBoardEvent; + FOnKeyDown: TSDLKeyBoardEvent; + procedure DoKeyDown( keysym : PSDL_keysym ); + procedure DoKeyUp( keysym : PSDL_keysym ); + public + function IsKeyDown( Key : TSDLKey ) : Boolean; + function IsKeyUp( Key : TSDLKey ) : Boolean; + function UpdateInput( event: TSDL_EVENT ) : Boolean; override; + property Keys : PKeyStateArr read FKeys write FKeys; + property OnKeyDown : TSDLKeyBoardEvent read FOnKeyDown write FOnKeyDown; + property OnKeyUp : TSDLKeyBoardEvent read FOnKeyUp write FOnKeyUp; + end; + + TSDLMouseButtonEvent = procedure ( Button : Integer; Shift: TSDLMod; MousePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLMouseMoveEvent = procedure ( Shift: TSDLMod; CurrentPos : TPoint; RelativePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLMouseWheelEvent = procedure ( WheelDelta : Integer; Shift: TSDLMod; MousePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; + + TSDLCustomCursor = class( TObject ) + private + FFileName : string; + FHotPoint: TPoint; + procedure SetFileName(const aValue: string ); + function ScanForChar( str : string; ch : Char; startPos : Integer; lookFor : Boolean ) : Integer; + public + constructor Create( const aFileName : string; aHotPoint: TPoint ); + procedure LoadFromFile( const aFileName : string ); virtual; abstract; + procedure LoadFromStream( aStream : TStream ); virtual; abstract; + procedure Show; virtual; abstract; + property FileName : string read FFileName write SetFileName; + property HotPoint : TPoint read FHotPoint write FHotPoint; + end; + + TSDLXPMCursor = class( TSDLCustomCursor ) + private + FCursor : PSDL_Cursor; + procedure FreeCursor; + public + destructor Destroy; override; + procedure LoadFromFile( const aFileName : string ); override; + procedure LoadFromStream( aStream : TStream ); override; + procedure Show; override; + end; + + TSDLCursorList = class( TStringList ) + protected + function GetObject( aIndex : Integer ): TSDLCustomCursor; reintroduce; + procedure PutObject( aIndex : Integer; AObject : TSDLCustomCursor); reintroduce; + public + constructor Create; + function AddCursor(const aName : string; aObject : TSDLCustomCursor): Integer; virtual; + end; + + TSDLMouse = class( TSDLCustomInput ) + private + FDragging : Boolean; + FMousePos : TPoint; + FOnMouseUp: TSDLMouseButtonEvent; + FOnMouseDown: TSDLMouseButtonEvent; + FOnMouseMove: TSDLMouseMoveEvent; + FOnMouseWheel: TSDLMouseWheelEvent; + FCursorList : TSDLCursorList; // Cursor Pointer + procedure DoMouseMove( Event: TSDL_Event ); + procedure DoMouseDown( Event: TSDL_Event ); + procedure DoMouseUp( Event: TSDL_Event ); + procedure DoMouseWheelScroll( Event: TSDL_Event ); + function GetMousePosition: TPoint; + procedure SetMousePosition(const Value: TPoint); + function GetMouseDelta: TPoint; + public + destructor Destroy; override; + function UpdateInput( event: TSDL_EVENT ) : Boolean; override; + function MouseIsDown( Button : Integer ) : Boolean; + function MouseIsUp( Button : Integer ) : Boolean; + procedure ShowCursor; + procedure HideCursor; + property OnMouseDown : TSDLMouseButtonEvent read FOnMouseDown write FOnMouseDown; + property OnMouseUp : TSDLMouseButtonEvent read FOnMouseUp write FOnMouseUp; + property OnMouseMove : TSDLMouseMoveEvent read FOnMouseMove write FOnMouseMove; + property OnMouseWheel : TSDLMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; + property MousePosition : TPoint read GetMousePosition write SetMousePosition; + property MouseDelta: TPoint read GetMouseDelta; + property Cursors : TSDLCursorList read FCursorList write FCursorList; + end; + + TSDLInputManager = class( TObject ) + private + FKeyBoard : TSDLKeyBoard; + FMouse : TSDLMouse; + FJoystick : TSDLJoysticks; + public + constructor Create( InitInputs : TSDLInputTypes ); + destructor Destroy; override; + procedure Disable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer = 0 ); + procedure Enable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer = 0 ); + function UpdateInputs( event: TSDL_EVENT ) : Boolean; + property KeyBoard : TSDLKeyBoard read FKeyBoard write FKeyBoard; + property Mouse : TSDLMouse read FMouse write FMouse; + property JoyStick : TSDLJoysticks read FJoyStick write FJoyStick; + end; + +implementation + +uses + SysUtils; + +{ TSDLCustomInput } +constructor TSDLCustomInput.Create; +begin + inherited; + FEnabled := true; +end; + +{ TSDLJoysticks } +constructor TSDLJoysticks.Create; +var + i : integer; +begin + inherited; + if ( SDL_WasInit( SDL_INIT_JOYSTICK ) = 0 ) then + SDL_InitSubSystem( SDL_INIT_JOYSTICK ); + FNumOfJoySticks := SDL_NumJoysticks; + FJoyStickList := TList.Create; + for i := 0 to FNumOfJoySticks - 1 do + begin + FJoyStickList.Add( TSDLJoyStick.Create( i ) ); + end; +end; + +destructor TSDLJoysticks.Destroy; +var + i : integer; +begin + if FJoyStickList.Count > 0 then + begin + for i := 0 to FJoyStickList.Count - 1 do + begin + TSDLJoyStick( FJoyStickList.Items[i] ).Free; + end; + end; + SDL_QuitSubSystem( SDL_INIT_JOYSTICK ); + inherited; +end; + +function TSDLJoySticks.GetJoyStick(Index: integer): TSDLJoyStick; +begin + Result := TSDLJoyStick( FJoyStickList[ Index ] ); +end; + +procedure TSDLJoySticks.SetJoyStick(Index: integer; + const Value: TSDLJoyStick); +begin + FJoyStickList[ Index ] := @Value; +end; + +function TSDLJoysticks.UpdateInput(event: TSDL_EVENT): Boolean; +var + i : integer; +begin + result := false; + if FJoyStickList.Count > 0 then + begin + for i := 0 to FJoyStickList.Count - 1 do + begin + TSDLJoyStick( FJoyStickList.Items[i] ).UpdateInput( event ); + end; + end; +end; + +{ TSDLKeyBoard } +procedure TSDLKeyBoard.DoKeyDown(keysym: PSDL_keysym); +begin + if Assigned( FOnKeyDown ) then + FOnKeyDown( keysym.sym , keysym.modifier, keysym.unicode ); +end; + +procedure TSDLKeyBoard.DoKeyUp(keysym: PSDL_keysym); +begin + if Assigned( FOnKeyUp ) then + FOnKeyUp( keysym.sym , keysym.modifier, keysym.unicode ); +end; + +function TSDLKeyBoard.IsKeyDown( Key: TSDLKey ): Boolean; +begin + SDL_PumpEvents; + + // Populate Keys array + FKeys := PKeyStateArr( SDL_GetKeyState( nil ) ); + Result := ( FKeys[Key] = SDL_PRESSED ); +end; + +function TSDLKeyBoard.IsKeyUp( Key: TSDLKey ): Boolean; +begin + SDL_PumpEvents; + + // Populate Keys array + FKeys := PKeyStateArr( SDL_GetKeyState( nil ) ); + Result := ( FKeys[Key] = SDL_RELEASED ); +end; + +function TSDLKeyBoard.UpdateInput(event: TSDL_EVENT): Boolean; +begin + result := false; + if ( FEnabled ) then + begin + case event.type_ of + SDL_KEYDOWN : + begin + // handle key presses + DoKeyDown( @event.key.keysym ); + result := true; + end; + + SDL_KEYUP : + begin + // handle key releases + DoKeyUp( @event.key.keysym ); + result := true; + end; + end; + end; +end; + +{ TSDLMouse } +destructor TSDLMouse.Destroy; +begin + + inherited; +end; + +procedure TSDLMouse.DoMouseDown( Event: TSDL_Event ); +var + CurrentPos : TPoint; +begin + FDragging := true; + if Assigned( FOnMouseDown ) then + begin + CurrentPos.x := event.button.x; + CurrentPos.y := event.button.y; + FOnMouseDown( event.button.button, SDL_GetModState, CurrentPos ); + end; +end; + +procedure TSDLMouse.DoMouseMove( Event: TSDL_Event ); +var + CurrentPos, RelativePos : TPoint; +begin + if Assigned( FOnMouseMove ) then + begin + CurrentPos.x := event.motion.x; + CurrentPos.y := event.motion.y; + RelativePos.x := event.motion.xrel; + RelativePos.y := event.motion.yrel; + FOnMouseMove( SDL_GetModState, CurrentPos, RelativePos ); + end; +end; + +procedure TSDLMouse.DoMouseUp( event: TSDL_EVENT ); +var + Point : TPoint; +begin + FDragging := false; + if Assigned( FOnMouseUp ) then + begin + Point.x := event.button.x; + Point.y := event.button.y; + FOnMouseUp( event.button.button, SDL_GetModState, Point ); + end; +end; + +procedure TSDLMouse.DoMouseWheelScroll( event: TSDL_EVENT ); +var + Point : TPoint; +begin + if Assigned( FOnMouseWheel ) then + begin + Point.x := event.button.x; + Point.y := event.button.y; + if ( event.button.button = SDL_BUTTON_WHEELUP ) then + FOnMouseWheel( SDL_BUTTON_WHEELUP, SDL_GetModState, Point ) + else + FOnMouseWheel( SDL_BUTTON_WHEELDOWN, SDL_GetModState, Point ); + end; +end; + +function TSDLMouse.GetMouseDelta: TPoint; +begin + SDL_PumpEvents; + + SDL_GetRelativeMouseState( Result.X, Result.Y ); +end; + +function TSDLMouse.GetMousePosition: TPoint; +begin + SDL_PumpEvents; + + SDL_GetMouseState( FMousePos.X, FMousePos.Y ); + Result := FMousePos; +end; + +procedure TSDLMouse.HideCursor; +begin + SDL_ShowCursor( SDL_DISABLE ); +end; + +function TSDLMouse.MouseIsDown(Button: Integer): Boolean; +begin + SDL_PumpEvents; + + Result := ( SDL_GetMouseState( FMousePos.X, FMousePos.Y ) and SDL_BUTTON( Button ) = 0 ); +end; + +function TSDLMouse.MouseIsUp(Button: Integer): Boolean; +begin + SDL_PumpEvents; + + Result := not ( SDL_GetMouseState( FMousePos.X, FMousePos.Y ) and SDL_BUTTON( Button ) = 0 ); +end; + +procedure TSDLMouse.SetMousePosition(const Value: TPoint); +begin + SDL_WarpMouse( Value.x, Value.y ); +end; + +procedure TSDLMouse.ShowCursor; +begin + SDL_ShowCursor( SDL_ENABLE ); +end; + +function TSDLMouse.UpdateInput(event: TSDL_EVENT): Boolean; +begin + result := false; + if ( FEnabled ) then + begin + case event.type_ of + SDL_MOUSEMOTION : + begin + // handle Mouse Move + DoMouseMove( event ); + end; + + SDL_MOUSEBUTTONDOWN : + begin + // handle Mouse Down + if ( event.button.button = SDL_BUTTON_WHEELUP ) + or ( event.button.button = SDL_BUTTON_WHEELDOWN ) then + DoMouseWheelScroll( event ) + else + DoMouseDown( event ); + end; + + SDL_MOUSEBUTTONUP : + begin + // handle Mouse Up + if ( event.button.button = SDL_BUTTON_WHEELUP ) + or ( event.button.button = SDL_BUTTON_WHEELDOWN ) then + DoMouseWheelScroll( event ) + else + DoMouseUp( event ); + end; + end; + end; +end; + +{ TSDLInputManager } +constructor TSDLInputManager.Create(InitInputs: TSDLInputTypes); +begin + inherited Create; + if itJoystick in InitInputs then + FJoystick := TSDLJoysticks.Create; + + if itKeyBoard in InitInputs then + FKeyBoard := TSDLKeyBoard.Create; + + if itMouse in InitInputs then + FMouse := TSDLMouse.Create; +end; + +destructor TSDLInputManager.Destroy; +begin + if FJoystick <> nil then + FreeAndNil( FJoystick ); + if FKeyBoard <> nil then + FreeAndNil( FKeyBoard ); + if FMouse <> nil then + FreeAndNil( FMouse ); + inherited; +end; + +procedure TSDLInputManager.Disable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer ); +begin + if itJoystick in InitInputs then + FJoystick.JoySticks[ JoyStickNumber ].Enabled := false; + + if itKeyBoard in InitInputs then + FKeyBoard.Enabled := false; + + if itMouse in InitInputs then + FMouse.Enabled := false; +end; + +procedure TSDLInputManager.Enable( InitInputs: TSDLInputTypes; JoyStickNumber: Integer ); +begin + if itJoystick in InitInputs then + FJoystick.JoySticks[ JoyStickNumber ].Enabled := true; + + if itKeyBoard in InitInputs then + FKeyBoard.Enabled := true; + + if itMouse in InitInputs then + FMouse.Enabled := true; +end; + +function TSDLInputManager.UpdateInputs( event: TSDL_EVENT ): Boolean; +begin + Result := false; + if ( FJoystick <> nil ) then + Result := FJoystick.UpdateInput( event ); + if ( FKeyBoard <> nil ) then + Result := FKeyBoard.UpdateInput( event ); + if ( FMouse <> nil ) then + Result := FMouse.UpdateInput( event ); +end; + +{ TSDLJoyStick } +procedure TSDLJoyStick.Close; +begin + SDL_JoystickClose( @FJoystick ); +end; + +constructor TSDLJoyStick.Create( Index : Integer ); +begin + inherited Create; + FJoystick := nil; + FJoystickIndex := Index; +end; + +destructor TSDLJoyStick.Destroy; +begin + if FJoystick <> nil then + Close; + inherited; +end; + +procedure TSDLJoyStick.DoAxisMove(Event: TSDL_Event); +begin + if Assigned( FJoyAxisMoveEvent ) then + begin + FJoyAxisMoveEvent( Event.jaxis.which, Event.jaxis.axis, Event.jaxis.value ); + end +end; + +procedure TSDLJoyStick.DoBallMove(Event: TSDL_Event); +var + BallPoint : TPoint; +begin + if Assigned( FJoyBallMoveEvent ) then + begin + BallPoint.x := Event.jball.xrel; + BallPoint.y := Event.jball.yrel; + FJoyBallMoveEvent( Event.jball.which, Event.jball.ball, BallPoint ); + end; +end; + +procedure TSDLJoyStick.DoButtonDown(Event: TSDL_Event); +begin + if Assigned( FJoyButtonDownEvent ) then + begin + if ( Event.jbutton.state = SDL_PRESSED ) then + FJoyButtonDownEvent( Event.jbutton.which, Event.jbutton.button, Event.jbutton.state ); + end; +end; + +procedure TSDLJoyStick.DoButtonUp(Event: TSDL_Event); +begin + if Assigned( FJoyButtonUpEvent ) then + begin + if ( Event.jbutton.state = SDL_RELEASED ) then + FJoyButtonUpEvent( Event.jbutton.which, Event.jbutton.button, Event.jbutton.state ); + end +end; + +procedure TSDLJoyStick.DoHatMove(Event: TSDL_Event); +begin + if Assigned( FJoyHatMoveEvent ) then + begin + FJoyHatMoveEvent( Event.jhat.which, Event.jhat.hat, Event.jhat.value ); + end; +end; + +function TSDLJoyStick.GetName: PChar; +begin + result := FJoystick.name; +end; + +function TSDLJoyStick.GetNumAxes: integer; +begin + result := FJoystick.naxes; +end; + +function TSDLJoyStick.GetNumBalls: integer; +begin + result := FJoystick.nballs; +end; + +function TSDLJoyStick.GetNumButtons: integer; +begin + result := FJoystick.nbuttons; +end; + +function TSDLJoyStick.GetNumHats: integer; +begin + result := FJoystick.nhats; +end; + +procedure TSDLJoyStick.Open; +begin + FJoystick := SDL_JoyStickOpen( FJoystickIndex ); +end; + +function TSDLJoyStick.UpdateInput(Event: TSDL_EVENT): Boolean; +begin + Result := false; + + if ( FEnabled ) then + begin + case event.type_ of + SDL_JOYAXISMOTION : + begin + DoAxisMove( Event ); + end; + + SDL_JOYBALLMOTION : + begin + DoBallMove( Event ); + end; + + SDL_JOYHATMOTION : + begin + DoHatMove( Event ); + end; + + SDL_JOYBUTTONDOWN : + begin + DoButtonDown( Event ); + end; + + SDL_JOYBUTTONUP : + begin + DoButtonUp( Event ); + end; + end; + end; +end; + +{ TSDLCustomCursor } + +constructor TSDLCustomCursor.Create(const aFileName: string; aHotPoint: TPoint); +begin + inherited Create; + FHotPoint := aHotPoint; + LoadFromFile( aFileName ); +end; + +function TSDLCustomCursor.ScanForChar(str: string; ch: Char; + startPos: Integer; lookFor: Boolean): Integer; +begin + Result := -1; + while ( ( ( str[ startPos ] = ch ) <> lookFor ) and ( startPos < Length( str ) ) ) do + inc( startPos ); + if startPos <> Length( str ) then + Result := startPos; +end; + +procedure TSDLCustomCursor.SetFileName(const aValue: string); +begin + LoadFromFile( aValue ); +end; + +{ TSDLXPMCursor } + +destructor TSDLXPMCursor.Destroy; +begin + FreeCursor; + inherited; +end; + +procedure TSDLXPMCursor.FreeCursor; +begin + if FCursor <> nil then + begin + SDL_FreeCursor( FCursor ); + FFileName := ''; + end; +end; + +procedure TSDLXPMCursor.LoadFromFile(const aFileName: string); +var + xpmFile : Textfile; + step : Integer; + holdPos : Integer; + counter : Integer; + dimensions : array[ 1..3 ] of Integer; + clr, clrNone, clrBlack, clrWhite : Char; + data, mask : array of UInt8; + i, col : Integer; + LineString : string; +begin + FreeCursor; + AssignFile( xpmFile, aFileName ); + Reset( xpmFile ); + step := 0; + i := -1; + clrBlack := 'X'; + clrWhite := ','; + clrNone := ' '; + counter := 0; + while not ( eof( xpmFile ) ) do + begin + Readln( xpmFile, LineString ); + // scan for strings + if LineString[ 1 ] = '"' then + begin + case step of + 0 : // Get dimensions (should be width height number-of-colors ???) + begin + HoldPos := 2; + counter := ScanForChar( LineString, ' ', HoldPos, False ); + counter := ScanForChar( LineString, ' ', counter, True ); + dimensions[ 1 ] := StrToInt( Copy( LineString, HoldPos, counter - HoldPos ) ); + counter := ScanForChar( LineString, ' ', counter, False ); + holdPos := counter; + counter := ScanForChar( LineString, ' ', counter, True ); + dimensions[ 2 ] := StrToInt( Copy( LineString, holdPos, counter - HoldPos ) ); + counter := ScanForChar( LineString, ' ', counter, False ); + holdPos := counter; + counter := ScanForChar( LineString, ' ', counter, True ); + dimensions[ 3 ] := StrToInt( Copy( LineString, holdPos, counter - HoldPos ) ); + step := 1; + SetLength( data, ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ); + SetLength( mask, ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ); + //Log.LogStatus( 'Length = ' + IntToStr( ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ), 'LoadCursorFromFile' ); + end; + 1 : // get the symbols for transparent, black and white + begin + // get the symbol for the color + clr := LineString[ 2 ]; + // look for the 'c' symbol + counter := ScanForChar( LineString, 'c', 3, True ); + inc( counter ); + counter := ScanForChar( LineString, ' ', counter, False ); + if LowerCase( Copy( LineString, counter, 4 ) ) = 'none' then + begin + clrNone := clr; + end; + if LowerCase( Copy( LineString, counter, 7 ) ) = '#ffffff' then + begin + clrWhite := clr; + end; + if LowerCase( Copy( LineString, counter, 7 ) ) = '#000000' then + begin + clrBlack := clr; + end; + dec( dimensions[ 3 ] ); + if dimensions[ 3 ] = 0 then + begin + step := 2; + counter := 0; + end; + end; + 2 : // get cursor information -- modified from the SDL + // documentation of SDL_CreateCursor. + begin + for col := 1 to dimensions[1] do + begin + if ( ( col mod 8 ) <> 1 ) then + begin + data[ i ] := data[ i ] shl 1; + mask[ i ] := mask[ i ] shl 1; + end + else + begin + inc( i ); + data[ i ] := 0; + mask[ i ] := 0; + end; + if LineString[ col ] = clrWhite then + begin + mask[ i ] := mask[ i ] or $01; + end + else if LineString[ col ] = clrBlack then + begin + data[ i ] := data[ i ] or $01; + mask[ i ] := mask[ i ] or $01; + end + else if LineString[ col + 1 ] = clrNone then + begin + // + end; + end; + inc(counter); + if counter = dimensions[2] then + step := 4; + end; + end; + end; + end; + CloseFile( xpmFile ); + FCursor := SDL_CreateCursor( PUInt8( data ), PUInt8( mask ), dimensions[ 1 ], dimensions[ 2 ], FHotPoint.x, FHotPoint.y ); +end; + +procedure TSDLXPMCursor.LoadFromStream(aStream: TStream); +begin + inherited; + +end; + +procedure TSDLXPMCursor.Show; +begin + inherited; + SDL_SetCursor( FCursor ); +end; + +{ TSDLCursorList } +function TSDLCursorList.AddCursor(const aName : string; aObject : TSDLCustomCursor): Integer; +begin + result := inherited AddObject( aName, aObject ); +end; + +constructor TSDLCursorList.Create; +begin + inherited; + Duplicates := dupIgnore; +end; + +function TSDLCursorList.GetObject(aIndex: Integer): TSDLCustomCursor; +begin + result := TSDLCustomCursor( inherited GetObject( aIndex ) ); +end; + +procedure TSDLCursorList.PutObject(aIndex: Integer; aObject: TSDLCustomCursor); +begin + inherited PutObject( aIndex, aObject ); +end; + +end. diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas index 64009176..8ba3946f 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas @@ -1,216 +1,216 @@ -unit sdlstreams; -{ - $Id: sdlstreams.pas,v 1.1 2004/02/05 00:08:20 savage Exp $ - -} -{******************************************************************} -{ } -{ SDL - Simple DirectMedia Layer } -{ Copyright (C) 1997, 1998, 1999, 2000, 2001 Sam Lantinga } -{ } -{ Portions created by Chris Bruner are } -{ Copyright (C) 2002 Chris Bruner. } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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/NPL/NPL-1_1Final.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. } -{ } -{ Description } -{ ----------- } -{ Shows how to use OpenGL to do 2D and 3D with the SDL libraries } -{ } -{ } -{ Requires } -{ -------- } -{ SDL runtime libary somewhere in your path } -{ The Latest SDL runtime can be found on http://www.libsdl.org } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ January 11 2002 - CB : Software embraced and extended by } -{ Chris Bruner of Crystal Software } -{ (Canada) Inc. } -{ } -{ February 11 2002 - DL : Added FreePascal support as suggested } -{ by "QuePasha Pepe" } -{ } -{******************************************************************} -{ - $Log: sdlstreams.pas,v $ - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -{$i jedi-sdl.inc} - -interface - -uses - Classes, - SysUtils, - sdl, - sdlutils; - -{$IFDEF FPC} -type - EinvalidContainer=class(Exception); - {$ENDIF} - -function LoadSDLBMPFromStream( Stream : TStream ) : PSDL_Surface; -procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); -function SDL_Swap16( D : UInt16 ) : Uint16; -function SDL_Swap32( D : UInt32 ) : Uint32; -function SDLStreamSetup( stream : TStream ) : PSDL_RWops; -// this only closes the SDL_RWops part of the stream, not the stream itself -procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); - -implementation - -function SDL_Swap16( D : UInt16 ) : Uint16; -begin - Result := ( D shl 8 ) or ( D shr 8 ); -end; - -function SDL_Swap32( D : UInt32 ) : Uint32; -begin - Result := ( ( D shl 24 ) or ( ( D shl 8 ) and $00FF0000 ) or ( ( D shr 8 ) and $0000FF00 ) or ( D shr 24 ) ); -end; - -(*function SDL_Swap64(D : UInt64) : Uint64; -var hi,lo : Uint32; -begin - // Separate into high and low 32-bit resultues and swap them - lo := Uint32(D and $0FFFFFFFF); // bloody pascal is too tight in it's type checking! - D := D shr 32; - hi = Uint32((D and $FFFFFFFF)); - result = SDL_Swap32(lo); - result := result shl 32; - result := result or SDL_Swap32(hi); -end; -*) - -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 SDLStreamWrite( context : PSDL_RWops; Ptr : Pointer; - size : Integer; num : Integer ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamWrite on nil' ); - try - Result := stream.Write( Ptr^, Size * num ) div size; - except - Result := -1; - end; -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; - -function SDLStreamSetup( stream : TStream ) : PSDL_RWops; -begin - result := SDL_AllocRW; - if ( result = nil ) then - raise EInvalidContainer.Create( 'could not create SDLStream on nil' ); - result.unknown := TUnknown( stream ); - result.seek := SDLStreamSeek; - result.read := SDLStreamRead; - result.write := SDLStreamWrite; - result.close := SDLStreamClose; - Result.type_ := 2; // TUnknown -end; - -// this only closes the SDL part of the stream, not the context - -procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); -begin - SDL_FreeRW( SDL_RWops ); -end; - -function LoadSDLBMPFromStream( stream : TStream ) : PSDL_Surface; -var - SDL_RWops : PSDL_RWops; -begin - SDL_RWops := SDLStreamSetup( stream ); - result := SDL_LoadBMP_RW( SDL_RWops, 0 ); - SDLStreamCloseRWops( SDL_RWops ); -end; - -procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); -var - SDL_RWops : PSDL_RWops; -begin - SDL_RWops := SDLStreamSetup( stream ); - SDL_SaveBMP_RW( SDL_Surface, SDL_RWops, 0 ); - SDLStreamCloseRWops( SDL_RWops ); -end; - -end. - +unit sdlstreams; +{ + $Id: sdlstreams.pas,v 1.1 2004/02/05 00:08:20 savage Exp $ + +} +{******************************************************************} +{ } +{ SDL - Simple DirectMedia Layer } +{ Copyright (C) 1997, 1998, 1999, 2000, 2001 Sam Lantinga } +{ } +{ Portions created by Chris Bruner are } +{ Copyright (C) 2002 Chris Bruner. } +{ } +{ Contributor(s) } +{ -------------- } +{ } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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/NPL/NPL-1_1Final.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. } +{ } +{ Description } +{ ----------- } +{ Shows how to use OpenGL to do 2D and 3D with the SDL libraries } +{ } +{ } +{ Requires } +{ -------- } +{ SDL runtime libary somewhere in your path } +{ The Latest SDL runtime can be found on http://www.libsdl.org } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ January 11 2002 - CB : Software embraced and extended by } +{ Chris Bruner of Crystal Software } +{ (Canada) Inc. } +{ } +{ February 11 2002 - DL : Added FreePascal support as suggested } +{ by "QuePasha Pepe" } +{ } +{******************************************************************} +{ + $Log: sdlstreams.pas,v $ + Revision 1.1 2004/02/05 00:08:20 savage + Module 1.0 release + + +} + +{$i jedi-sdl.inc} + +interface + +uses + Classes, + SysUtils, + sdl, + sdlutils; + +{$IFDEF FPC} +type + EinvalidContainer=class(Exception); + {$ENDIF} + +function LoadSDLBMPFromStream( Stream : TStream ) : PSDL_Surface; +procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); +function SDL_Swap16( D : UInt16 ) : Uint16; +function SDL_Swap32( D : UInt32 ) : Uint32; +function SDLStreamSetup( stream : TStream ) : PSDL_RWops; +// this only closes the SDL_RWops part of the stream, not the stream itself +procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); + +implementation + +function SDL_Swap16( D : UInt16 ) : Uint16; +begin + Result := ( D shl 8 ) or ( D shr 8 ); +end; + +function SDL_Swap32( D : UInt32 ) : Uint32; +begin + Result := ( ( D shl 24 ) or ( ( D shl 8 ) and $00FF0000 ) or ( ( D shr 8 ) and $0000FF00 ) or ( D shr 24 ) ); +end; + +(*function SDL_Swap64(D : UInt64) : Uint64; +var hi,lo : Uint32; +begin + // Separate into high and low 32-bit resultues and swap them + lo := Uint32(D and $0FFFFFFFF); // bloody pascal is too tight in it's type checking! + D := D shr 32; + hi = Uint32((D and $FFFFFFFF)); + result = SDL_Swap32(lo); + result := result shl 32; + result := result or SDL_Swap32(hi); +end; +*) + +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 SDLStreamWrite( context : PSDL_RWops; Ptr : Pointer; + size : Integer; num : Integer ) : Integer; cdecl; +var + stream : TStream; +begin + stream := TStream( context.unknown ); + if ( stream = nil ) then + raise EInvalidContainer.Create( 'SDLStreamWrite on nil' ); + try + Result := stream.Write( Ptr^, Size * num ) div size; + except + Result := -1; + end; +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; + +function SDLStreamSetup( stream : TStream ) : PSDL_RWops; +begin + result := SDL_AllocRW; + if ( result = nil ) then + raise EInvalidContainer.Create( 'could not create SDLStream on nil' ); + result.unknown := TUnknown( stream ); + result.seek := SDLStreamSeek; + result.read := SDLStreamRead; + result.write := SDLStreamWrite; + result.close := SDLStreamClose; + Result.type_ := 2; // TUnknown +end; + +// this only closes the SDL part of the stream, not the context + +procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); +begin + SDL_FreeRW( SDL_RWops ); +end; + +function LoadSDLBMPFromStream( stream : TStream ) : PSDL_Surface; +var + SDL_RWops : PSDL_RWops; +begin + SDL_RWops := SDLStreamSetup( stream ); + result := SDL_LoadBMP_RW( SDL_RWops, 0 ); + SDLStreamCloseRWops( SDL_RWops ); +end; + +procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); +var + SDL_RWops : PSDL_RWops; +begin + SDL_RWops := SDLStreamSetup( stream ); + SDL_SaveBMP_RW( SDL_Surface, SDL_RWops, 0 ); + SDLStreamCloseRWops( SDL_RWops ); +end; + +end. + diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas index 8e00dd6f..a479b493 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas @@ -1,197 +1,197 @@ -unit sdlticks; -{ - $Id: sdlticks.pas,v 1.2 2006/11/08 08:22:48 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ SDL GetTicks Class Wrapper } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2004 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ SDL Window Wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: sdlticks.pas,v $ - Revision 1.2 2006/11/08 08:22:48 savage - updates tp sdlgameinterface and sdlticks functions. - - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - -} -{******************************************************************************} - -interface - -uses - sdl; - -type - TSDLTicks = class - private - FStartTime : UInt32; - FTicksPerSecond : UInt32; - FElapsedLastTime : UInt32; - FFPSLastTime : UInt32; - FLockFPSLastTime : UInt32; - public - constructor Create; - destructor Destroy; override; // destructor - - {***************************************************************************** - Init - If the hi-res timer is present, the tick rate is stored and the function - returns true. Otherwise, the function returns false, and the timer should - not be used. - *****************************************************************************} - function Init : boolean; - - {*************************************************************************** - GetGetElapsedSeconds - Returns the Elapsed time, since the function was last called. - ***************************************************************************} - function GetElapsedSeconds : Single; - - {*************************************************************************** - GetFPS - Returns the average frames per second. - If this is not called every frame, the client should track the number - of frames itself, and reset the value after this is called. - ***************************************************************************} - function GetFPS : single; - - {*************************************************************************** - LockFPS - Used to lock the frame rate to a set amount. This will block until enough - time has passed to ensure that the fps won't go over the requested amount. - Note that this can only keep the fps from going above the specified level; - it can still drop below it. It is assumed that if used, this function will - be called every frame. The value returned is the instantaneous fps, which - will be less than or equal to the targetFPS. - ***************************************************************************} - procedure LockFPS( targetFPS : Byte ); - end; - -implementation - -{ TSDLTicks } -constructor TSDLTicks.Create; -begin - inherited; - FTicksPerSecond := 1000; -end; - -destructor TSDLTicks.Destroy; -begin - inherited; -end; - -function TSDLTicks.GetElapsedSeconds : Single; -var - currentTime : Cardinal; -begin - currentTime := SDL_GetTicks; - - result := ( currentTime - FElapsedLastTime ) / FTicksPerSecond; - - // reset the timer - FElapsedLastTime := currentTime; -end; - -function TSDLTicks.GetFPS : Single; -var - currentTime, FrameTime : UInt32; - fps : single; -begin - currentTime := SDL_GetTicks; - - FrameTime := ( currentTime - FFPSLastTime ); - - if FrameTime = 0 then - FrameTime := 1; - - fps := FTicksPerSecond / FrameTime; - - // reset the timer - FFPSLastTime := currentTime; - result := fps; -end; - -function TSDLTicks.Init : boolean; -begin - FStartTime := SDL_GetTicks; - FElapsedLastTime := FStartTime; - FFPSLastTime := FStartTime; - FLockFPSLastTime := FStartTime; - result := true; -end; - -procedure TSDLTicks.LockFPS( targetFPS : Byte ); -var - currentTime : UInt32; - targetTime : single; -begin - if ( targetFPS = 0 ) then - targetFPS := 1; - - targetTime := FTicksPerSecond / targetFPS; - - // delay to maintain a constant frame rate - repeat - currentTime := SDL_GetTicks; - until ( ( currentTime - FLockFPSLastTime ) > targetTime ); - - // reset the timer - FLockFPSLastTime := currentTime; -end; - -end. - +unit sdlticks; +{ + $Id: sdlticks.pas,v 1.2 2006/11/08 08:22:48 savage Exp $ + +} +{******************************************************************************} +{ } +{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } +{ SDL GetTicks Class Wrapper } +{ } +{ } +{ The initial developer of this Pascal code was : } +{ Dominique Louis } +{ } +{ Portions created by Dominique Louis are } +{ Copyright (C) 2004 - 2100 Dominique Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Dominique Louis } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ SDL Window Wrapper } +{ } +{ } +{ Requires } +{ -------- } +{ SDL.dll on Windows platforms } +{ libSDL-1.1.so.0 on Linux platform } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ } +{ September 23 2004 - DL : Initial Creation } +{ + $Log: sdlticks.pas,v $ + Revision 1.2 2006/11/08 08:22:48 savage + updates tp sdlgameinterface and sdlticks functions. + + Revision 1.1 2004/09/30 22:35:47 savage + Changes, enhancements and additions as required to get SoAoS working. + +} +{******************************************************************************} + +interface + +uses + sdl; + +type + TSDLTicks = class + private + FStartTime : UInt32; + FTicksPerSecond : UInt32; + FElapsedLastTime : UInt32; + FFPSLastTime : UInt32; + FLockFPSLastTime : UInt32; + public + constructor Create; + destructor Destroy; override; // destructor + + {***************************************************************************** + Init + If the hi-res timer is present, the tick rate is stored and the function + returns true. Otherwise, the function returns false, and the timer should + not be used. + *****************************************************************************} + function Init : boolean; + + {*************************************************************************** + GetGetElapsedSeconds + Returns the Elapsed time, since the function was last called. + ***************************************************************************} + function GetElapsedSeconds : Single; + + {*************************************************************************** + GetFPS + Returns the average frames per second. + If this is not called every frame, the client should track the number + of frames itself, and reset the value after this is called. + ***************************************************************************} + function GetFPS : single; + + {*************************************************************************** + LockFPS + Used to lock the frame rate to a set amount. This will block until enough + time has passed to ensure that the fps won't go over the requested amount. + Note that this can only keep the fps from going above the specified level; + it can still drop below it. It is assumed that if used, this function will + be called every frame. The value returned is the instantaneous fps, which + will be less than or equal to the targetFPS. + ***************************************************************************} + procedure LockFPS( targetFPS : Byte ); + end; + +implementation + +{ TSDLTicks } +constructor TSDLTicks.Create; +begin + inherited; + FTicksPerSecond := 1000; +end; + +destructor TSDLTicks.Destroy; +begin + inherited; +end; + +function TSDLTicks.GetElapsedSeconds : Single; +var + currentTime : Cardinal; +begin + currentTime := SDL_GetTicks; + + result := ( currentTime - FElapsedLastTime ) / FTicksPerSecond; + + // reset the timer + FElapsedLastTime := currentTime; +end; + +function TSDLTicks.GetFPS : Single; +var + currentTime, FrameTime : UInt32; + fps : single; +begin + currentTime := SDL_GetTicks; + + FrameTime := ( currentTime - FFPSLastTime ); + + if FrameTime = 0 then + FrameTime := 1; + + fps := FTicksPerSecond / FrameTime; + + // reset the timer + FFPSLastTime := currentTime; + result := fps; +end; + +function TSDLTicks.Init : boolean; +begin + FStartTime := SDL_GetTicks; + FElapsedLastTime := FStartTime; + FFPSLastTime := FStartTime; + FLockFPSLastTime := FStartTime; + result := true; +end; + +procedure TSDLTicks.LockFPS( targetFPS : Byte ); +var + currentTime : UInt32; + targetTime : single; +begin + if ( targetFPS = 0 ) then + targetFPS := 1; + + targetTime := FTicksPerSecond / targetFPS; + + // delay to maintain a constant frame rate + repeat + currentTime := SDL_GetTicks; + until ( ( currentTime - FLockFPSLastTime ) > targetTime ); + + // reset the timer + FLockFPSLastTime := currentTime; +end; + +end. + \ No newline at end of file diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas index 7fbed878..e01f3cdb 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas @@ -1,4363 +1,4363 @@ -unit sdlutils; -{ - $Id: sdlutils.pas,v 1.5 2006/11/19 18:56:44 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ SDL Utility functions } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Tom Jones } -{ } -{ Portions created by Tom Jones are } -{ Copyright (C) 2000 - 2001 Tom Jones. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ Róbert Kisnémeth } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ Helper functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2000 - TJ : Initial creation } -{ } -{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } -{ } -{ Sept 14 2001 - RK : Added flipping routines. } -{ } -{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } -{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } -{ Added PSDLRect() } -{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} -{ Also removed by poor attempt or a dialog box } -{ } -{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } -{ SubSurface, MonoSurface & TexturedSurface } -{ } -{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } -{ types rather that Windows types. This makes it more} -{ portable to Linix. } -{ } -{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } -{ } -{ Oct 27 2001 - JF : Added ScrollY function } -{ } -{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } -{ } -{ Mar 28 2002 - JF : Added SDL_RotateSurface } -{ } -{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } -{ } -{ May 27 2002 - YS : GradientFillRect function } -{ } -{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } -{ & SDL_50Scanline2xBlit } -{ } -{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } -{ } -{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } -{ } -{ November 9 2002 - JF : Added Jason's boolean Surface functions } -{ } -{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } -{ } -{ April 26 2003 - SS : Incorporated JF's changes to SDL_ClipLine } -{ Fixed SDL_ClipLine bug for non-zero cliprect x, y } -{ Added overloaded SDL_DrawLine for dashed lines } -{ } -{******************************************************************************} -{ - $Log: sdlutils.pas,v $ - Revision 1.5 2006/11/19 18:56:44 savage - Removed Hints and Warnings. - - Revision 1.4 2004/06/02 19:38:53 savage - Changes to SDL_GradientFillRect as suggested by - Ángel Eduardo García Hernández. Many thanks. - - Revision 1.3 2004/05/29 23:11:54 savage - Changes to SDL_ScaleSurfaceRect as suggested by - Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -interface - -{$I jedi-sdl.inc} - -uses -{$IFDEF UNIX} - Types, -{$IFNDEF DARWIN} - Xlib, -{$ENDIF} -{$ENDIF} - SysUtils, - sdl; - -type - TGradientStyle = ( gsHorizontal, gsVertical ); - -// Pixel procedures -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : integer; y : integer ) : Uint32; - -procedure SDL_PutPixel( DstSurface : PSDL_Surface; x : integer; y : integer; pixel : - Uint32 ); - -procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); - -procedure SDL_SubPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); - -// Line procedures -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); overload; - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal; DashLength, DashSpace : byte ); overload; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -// Surface procedures -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); - -// Flip procedures -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; - -function SDLRect( aRect : TRect ) : TSDL_Rect; overload; - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; - -// Fill Rect routine -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); - -// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); - -// -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : - PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : - boolean; - -// Jason's boolean Surface functions -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -function SDL_ClipLine( var x1, y1, x2, y2 : Integer; ClipRect : PSDL_Rect ) : boolean; - -implementation - -uses - Math; - -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1, Mod2 : cardinal; - Addr1, Addr2 : PtrUInt; - BPP : cardinal; - Pitch1, Pitch2 : cardinal; - TransparentColor1, TransparentColor2 : cardinal; - tx, ty : cardinal; -// StartTick : cardinal; // Auto Removed, Unused Variable - Color1, Color2 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - if SrcRect2 = nil then - begin - with Src_Rect2 do - begin - x := 0; - y := 0; - w := SrcSurface2.w; - h := SrcSurface2.h; - end; - end - else - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := PtrUInt( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - with SrcSurface2^ do - begin - TransparentColor2 := format.colorkey; - Pitch2 := Pitch; - Addr2 := PtrUInt( Pixels ); - inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); - end; - Mod1 := Pitch1 - ( ScanWidth * BPP ); - Mod2 := Pitch2 - ( ScanWidth * BPP ); - inc( Addr1, BPP * Scan1Start ); - inc( Addr2, BPP * Scan2Start ); - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - inc( Addr2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - inc( Addr2, 2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - Color2 := PLongWord( Addr2 )^ and $00FFFFFF; - if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - inc( Addr2, 3 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - inc( Addr2, 4 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - end; -end; - -procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); -var - SrcColor : cardinal; - Addr : PtrUInt; - R, G, B : cardinal; -begin - if Color = 0 then - exit; - with DstSurface^ do - begin - Addr := PtrUInt( Pixels ) + y * Pitch + x * format.BytesPerPixel; - SrcColor := PUInt32( Addr )^; - case format.BitsPerPixel of - 8 : - begin - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - end; - 15 : - begin - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - end; - 16 : - begin - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - end; - 24 : - begin - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - end; - 32 : - begin - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - end; - end; - end; -end; - -procedure SDL_SubPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); -var - SrcColor : cardinal; - Addr : PtrUInt; - R, G, B : cardinal; -begin - if Color = 0 then - exit; - with DstSurface^ do - begin - Addr := PtrUInt( Pixels ) + y * Pitch + x * format.BytesPerPixel; - SrcColor := PUInt32( Addr )^; - case format.BitsPerPixel of - 8 : - begin - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - end; - 15 : - begin - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - end; - 16 : - begin - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - end; - 24 : - begin - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - end; - 32 : - begin - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - end; - end; - end; -end; -// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. -// In 8 bit color depth mode the procedure works with the default packed -// palette (RRRGGGBB). It handles all clipping. - -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $E0 + Pixel2 and $E0; - G := Pixel1 and $1C + Pixel2 and $1C; - B := Pixel1 and $03 + Pixel2 and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $7C00 + Pixel2 and $7C00; - G := Pixel1 and $03E0 + Pixel2 and $03E0; - B := Pixel1 and $001F + Pixel2 and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $F800 + Pixel2 and $F800; - G := Pixel1 and $07E0 + Pixel2 and $07E0; - B := Pixel1 and $001F + Pixel2 and $001F; - if R > $F800 then - R := $F800; - if G > $07E0 then - G := $07E0; - if B > $001F then - B := $001F; - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - R := Pixel1 and $FF0000 + Pixel2 and $FF0000; - G := Pixel1 and $00FF00 + Pixel2 and $00FF00; - B := Pixel1 and $0000FF + Pixel2 and $0000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $FF0000 + Pixel2 and $FF0000; - G := Pixel1 and $00FF00 + Pixel2 and $00FF00; - B := Pixel1 and $0000FF + Pixel2 and $0000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; -//{*_ebx, *}{*_esi, *}{*_edi, _esp*} : cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DestSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $E0 - Pixel1 and $E0; - G := Pixel2 and $1C - Pixel1 and $1C; - B := Pixel2 and $03 - Pixel1 and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( DestAddr )^ := R or G or B; - end; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $7C00 - Pixel1 and $7C00; - G := Pixel2 and $03E0 - Pixel1 and $03E0; - B := Pixel2 and $001F - Pixel1 and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( DestAddr )^ := R or G or B; - end; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $F800 - Pixel1 and $F800; - G := Pixel2 and $07E0 - Pixel1 and $07E0; - B := Pixel2 and $001F - Pixel1 and $001F; - if R > $F800 then - R := 0; - if G > $07E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( DestAddr )^ := R or G or B; - end; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - R := Pixel2 and $FF0000 - Pixel1 and $FF0000; - G := Pixel2 and $00FF00 - Pixel1 and $00FF00; - B := Pixel2 and $0000FF - Pixel1 and $0000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $FF0000 - Pixel1 and $FF0000; - G := Pixel2 and $00FF00 - Pixel1 and $00FF00; - B := Pixel2 and $0000FF - Pixel1 and $0000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel2; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; -//{*_ebx, *}{*_esi, *}{*_edi, _esp*} : cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - TransparentColor, SrcColor : cardinal; - BPP : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - BPP := DestSurface.Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case BPP of - 1 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt8( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt8( DestAddr )^ := SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 2 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt16( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt16( DestAddr )^ := SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 3 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^ and $FFFFFF; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := ( PUInt32( DestAddr )^ and $FFFFFF ) or SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 4 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; -// TextureRect.w and TextureRect.h are not used. -// The TextureSurface's size MUST larger than the drawing rectangle!!! - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TextAddr : PtrUInt; -//{*_ebx, *}{*_esi, *}{*_edi, _esp*}: cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) - WorkX, WorkY : word; - SrcMod, DestMod, TextMod : cardinal; -SrcColor, TransparentColor{*, TextureColor*} : cardinal; // Auto Removed, Unused Variable (TextureColor) - BPP : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - BPP := DestSurface.Format.BitsPerPixel; - end; - with Texture^ do - begin - TextAddr := PtrUInt( Pixels ) + UInt32( TextureRect.y ) * Pitch + - UInt32( TextureRect.x ) * Format.BytesPerPixel; - TextMod := Pitch - Src.w * Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - SDL_LockSurface( Texture ); - WorkY := Src.h; - case BPP of - 1 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt8( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt8( DestAddr )^ := PUint8( TextAddr )^; - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - 2 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt16( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt16( DestAddr )^ := PUInt16( TextAddr )^; - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - 3 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^ and $FFFFFF; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := ( PUInt32( DestAddr )^ and $FFFFFF ) or ( PUInt32( TextAddr )^ and $FFFFFF ); - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - 4 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := PUInt32( TextAddr )^; - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); - SDL_UnlockSurface( Texture ); -end; - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); -var - xc, yc : cardinal; - rx, wx, ry, wy, ry16 : cardinal; - color : cardinal; - modx, mody : cardinal; -begin - // Warning! No checks for surface pointers!!! - if srcrect = nil then - srcrect := @SrcSurface.clip_rect; - if dstrect = nil then - dstrect := @DstSurface.clip_rect; - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); - mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); - //rx := srcrect.x * 65536; - ry := srcrect.y * 65536; - wy := dstrect.y; - for yc := 0 to dstrect.h - 1 do - begin - rx := srcrect.x * 65536; - wx := dstrect.x; - ry16 := ry shr 16; - for xc := 0 to dstrect.w - 1 do - begin - color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); - SDL_PutPixel( DstSurface, wx, wy, color ); - rx := rx + modx; - inc( wx ); - end; - ry := ry + mody; - inc( wy ); - end; - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; -// Re-map a rectangular area into an area defined by four vertices -// Converted from C to Pascal by KiCHY - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); -const - SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) - THRESH = 1 shl SHIFTS; // Threshold for pixel size value - procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); - var - tm, lm, rm, bm, m : TPoint; - mx, my : cardinal; - cr : cardinal; - begin - // Does the destination area specify a single pixel? - if ( ( abs( ul.x - ur.x ) < THRESH ) and - ( abs( ul.x - lr.x ) < THRESH ) and - ( abs( ul.x - ll.x ) < THRESH ) and - ( abs( ul.y - ur.y ) < THRESH ) and - ( abs( ul.y - lr.y ) < THRESH ) and - ( abs( ul.y - ll.y ) < THRESH ) ) then - begin // Yes - cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); - SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); - end - else - begin // No - // Quarter the source and the destination, and then recurse - tm.x := ( ul.x + ur.x ) shr 1; - tm.y := ( ul.y + ur.y ) shr 1; - bm.x := ( ll.x + lr.x ) shr 1; - bm.y := ( ll.y + lr.y ) shr 1; - lm.x := ( ul.x + ll.x ) shr 1; - lm.y := ( ul.y + ll.y ) shr 1; - rm.x := ( ur.x + lr.x ) shr 1; - rm.y := ( ur.y + lr.y ) shr 1; - m.x := ( tm.x + bm.x ) shr 1; - m.y := ( tm.y + bm.y ) shr 1; - mx := ( x1 + x2 ) shr 1; - my := ( y1 + y2 ) shr 1; - CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); - CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); - CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); - CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); - end; - end; -var - _UL, _UR, _LR, _LL : TPoint; - Rect_x, Rect_y, Rect_w, Rect_h : integer; -begin - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - if SrcRect = nil then - begin - Rect_x := 0; - Rect_y := 0; - Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; - Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; - end - else - begin - Rect_x := SrcRect.x; - Rect_y := SrcRect.y; - Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; - Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; - end; - // Shift all values to help reduce round-off error. - _ul.x := ul.x shl SHIFTS; - _ul.y := ul.y shl SHIFTS; - _ur.x := ur.x shl SHIFTS; - _ur.y := ur.y shl SHIFTS; - _lr.x := lr.x shl SHIFTS; - _lr.y := lr.y shl SHIFTS; - _ll.x := ll.x shl SHIFTS; - _ll.y := ll.y shl SHIFTS; - CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; - -// Draw a line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// Draw a dashed line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal; DashLength, DashSpace : byte ); overload; -var - dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; -begin - counter := 0; - drawdash := true; //begin line drawing with dash - - //Avoid invalid user-passed dash parameters - if ( DashLength < 1 ) - then - DashLength := 1; - if ( DashSpace < 1 ) - then - DashSpace := 0; - - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc( counter ); - if ( counter > DashLength - 1 ) and ( DashSpace > 0 ) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc( counter ); - if counter > DashSpace - 1 then - begin - drawdash := true; - counter := 0; - end; - end; - - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc( counter ); - if ( counter > DashLength - 1 ) and ( DashSpace > 0 ) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc( counter ); - if counter > DashSpace - 1 then - begin - drawdash := true; - counter := 0; - end; - end; - - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// flips a rectangle vertically on given surface - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -var - TmpRect : TSDL_Rect; - Locked : boolean; - y, FlipLength, RowLength : integer; - Row1, Row2 : Pointer; - OneRow : TByteArray; // Optimize it if you wish -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin // if Rect=nil then we flip the whole surface - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.h shr 1 - 1; - RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - Row1 := pointer( PtrUInt( DstSurface^.Pixels ) + UInt32( Rect^.y ) * - DstSurface^.Pitch ); - Row2 := pointer( PtrUInt( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) - * DstSurface^.Pitch ); - for y := 0 to FlipLength do - begin - Move( Row1^, OneRow, RowLength ); - Move( Row2^, Row1^, RowLength ); - Move( OneRow, Row2^, RowLength ); - inc( PtrUInt( Row1 ), DstSurface^.Pitch ); - dec( PtrUInt( Row2 ), DstSurface^.Pitch ); - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// flips a rectangle horizontally on given surface - -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -type - T24bit = packed array[ 0..2 ] of byte; - T24bitArray = packed array[ 0..8191 ] of T24bit; - P24bitArray = ^T24bitArray; - TLongWordArray = array[ 0..8191 ] of LongWord; - PLongWordArray = ^TLongWordArray; -var - TmpRect : TSDL_Rect; - Row8bit : PByteArray; - Row16bit : PWordArray; - Row24bit : P24bitArray; - Row32bit : PLongWordArray; - y, x, RightSide, FlipLength : integer; - Pixel : cardinal; - Pixel24 : T24bit; - Locked : boolean; -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.w shr 1 - 1; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - case DstSurface^.format.BytesPerPixel of - 1 : - begin - Row8Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row8Bit^[ x ]; - Row8Bit^[ x ] := Row8Bit^[ RightSide ]; - Row8Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( PtrUInt( Row8Bit ), DstSurface^.pitch ); - end; - end; - 2 : - begin - Row16Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row16Bit^[ x ]; - Row16Bit^[ x ] := Row16Bit^[ RightSide ]; - Row16Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( PtrUInt( Row16Bit ), DstSurface^.pitch ); - end; - end; - 3 : - begin - Row24Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel24 := Row24Bit^[ x ]; - Row24Bit^[ x ] := Row24Bit^[ RightSide ]; - Row24Bit^[ RightSide ] := Pixel24; - dec( RightSide ); - end; - inc( PtrUInt( Row24Bit ), DstSurface^.pitch ); - end; - end; - 4 : - begin - Row32Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row32Bit^[ x ]; - Row32Bit^[ x ] := Row32Bit^[ RightSide ]; - Row32Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( PtrUInt( Row32Bit ), DstSurface^.pitch ); - end; - end; - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. -// But you MUST free it after you don't need it anymore!!! - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; -var - Rect : PSDL_Rect; -begin - New( Rect ); - with Rect^ do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; - Result := Rect; -end; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; -begin - with result do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; -end; - -function SDLRect( aRect : TRect ) : TSDL_Rect; -begin - with aRect do - result := SDLRect( Left, Top, Right - Left, Bottom - Top ); -end; - -procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, - depth : integer ); -var - dx, dy, e, d, dx2 : integer; - src_pitch, dst_pitch : uint16; - src_pixels, dst_pixels : PUint8; -begin - if ( yw >= dst_surface^.h ) then - exit; - dx := ( x2 - x1 ); - dy := ( y2 - y1 ); - dy := dy shl 1; - e := dy - dx; - dx2 := dx shl 1; - src_pitch := Surface^.pitch; - dst_pitch := dst_surface^.pitch; - src_pixels := PUint8( PtrUInt( Surface^.pixels ) + yr * src_pitch + y1 * depth ); - dst_pixels := PUint8( PtrUInt( dst_surface^.pixels ) + yw * dst_pitch + x1 * - depth ); - for d := 0 to dx - 1 do - begin - move( src_pixels^, dst_pixels^, depth ); - while ( e >= 0 ) do - begin - inc( src_pixels, depth ); - e := e - dx2; - end; - inc( dst_pixels, depth ); - e := e + dy; - end; -end; - -function sign( x : integer ) : integer; -begin - if x > 0 then - result := 1 - else - result := -1; -end; - -// Stretches a part of a surface - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; -var - dst_surface : PSDL_Surface; - dx, dy, e, d, dx2, srcx2, srcy2 : integer; - destx1, desty1 : integer; -begin - srcx2 := srcx1 + SrcW; - srcy2 := srcy1 + SrcH; - result := nil; - destx1 := 0; - desty1 := 0; - dx := abs( integer( Height - desty1 ) ); - dy := abs( integer( SrcY2 - SrcY1 ) ); - e := ( dy shl 1 ) - dx; - dx2 := dx shl 1; - dy := dy shl 1; - dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - - desty1, - SrcSurface^.Format^.BitsPerPixel, - SrcSurface^.Format^.RMask, - SrcSurface^.Format^.GMask, - SrcSurface^.Format^.BMask, - SrcSurface^.Format^.AMask ); - if ( dst_surface^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); - if ( SDL_MustLock( dst_surface ) ) then - if ( SDL_LockSurface( dst_surface ) < 0 ) then - exit; - for d := 0 to dx - 1 do - begin - SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, - SrcSurface^.format^.BytesPerPixel ); - while e >= 0 do - begin - inc( SrcY1 ); - e := e - dx2; - end; - inc( desty1 ); - e := e + dy; - end; - if SDL_MUSTLOCK( dst_surface ) then - SDL_UnlockSurface( dst_surface ); - result := dst_surface; -end; - -procedure SDL_MoveLine( Surface : PSDL_Surface; x1, x2, y1, xofs, depth : integer ); -var - src_pixels, dst_pixels : PUint8; - i : integer; -begin - src_pixels := PUint8( PtrUInt( Surface^.pixels ) + Surface^.w * y1 * depth + x2 * - depth ); - dst_pixels := PUint8( PtrUInt( Surface^.pixels ) + Surface^.w * y1 * depth + ( x2 - + xofs ) * depth ); - for i := x2 downto x1 do - begin - move( src_pixels^, dst_pixels^, depth ); - dec( src_pixels ); - dec( dst_pixels ); - end; -end; -{ Return the pixel value at (x, y) -NOTE: The surface must be locked before calling this! } - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : integer; y : integer ) : Uint32; -var - bpp : UInt32; - p : PInteger; -begin - bpp := SrcSurface.format.BytesPerPixel; - // Here p is the address to the pixel we want to retrieve - p := Pointer( PtrUInt( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * - bpp ); - case bpp of - 1 : result := PUint8( p )^; - 2 : result := PUint16( p )^; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] - else - result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] shl 16; - 4 : result := PUint32( p )^; - else - result := 0; // shouldn't happen, but avoids warnings - end; -end; -{ Set the pixel at (x, y) to the given value - NOTE: The surface must be locked before calling this! } - -procedure SDL_PutPixel( DstSurface : PSDL_Surface; x : integer; y : integer; pixel : - Uint32 ); -var - bpp : UInt32; - p : PInteger; -begin - bpp := DstSurface.format.BytesPerPixel; - p := Pointer( PtrUInt( DstSurface.pixels ) + UInt32( y ) * DstSurface.pitch + UInt32( x ) - * bpp ); - case bpp of - 1 : PUint8( p )^ := pixel; - 2 : PUint16( p )^ := pixel; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - begin - PUInt8Array( p )[ 0 ] := ( pixel shr 16 ) and $FF; - PUInt8Array( p )[ 1 ] := ( pixel shr 8 ) and $FF; - PUInt8Array( p )[ 2 ] := pixel and $FF; - end - else - begin - PUInt8Array( p )[ 0 ] := pixel and $FF; - PUInt8Array( p )[ 1 ] := ( pixel shr 8 ) and $FF; - PUInt8Array( p )[ 2 ] := ( pixel shr 16 ) and $FF; - end; - 4 : - PUint32( p )^ := pixel; - end; -end; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); -var - r1, r2 : TSDL_Rect; - //buffer: PSDL_Surface; - YPos : Integer; -begin - if ( DstSurface <> nil ) and ( DifY <> 0 ) then - begin - //if DifY > 0 then // going up - //begin - ypos := 0; - r1.x := 0; - r2.x := 0; - r1.w := DstSurface.w; - r2.w := DstSurface.w; - r1.h := DifY; - r2.h := DifY; - while ypos < DstSurface.h do - begin - r1.y := ypos; - r2.y := ypos + DifY; - SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); - ypos := ypos + DifY; - end; - //end - //else - //begin // Going Down - //end; - end; -end; - -{procedure SDL_ScrollY(Surface: PSDL_Surface; DifY: integer); -var - r1, r2: TSDL_Rect; - buffer: PSDL_Surface; -begin - if (Surface <> nil) and (Dify <> 0) then - begin - buffer := SDL_CreateRGBSurface(SDL_HWSURFACE, (Surface^.w - DifY) * 2, - Surface^.h * 2, - Surface^.Format^.BitsPerPixel, 0, 0, 0, 0); - if buffer <> nil then - begin - if (buffer^.format^.BytesPerPixel = 1) then - SDL_SetColors(buffer, @Surface^.format^.palette^.colors^[0], 0, 256); - r1 := SDLRect(0, DifY, buffer^.w, buffer^.h); - r2 := SDLRect(0, 0, buffer^.w, buffer^.h); - SDL_BlitSurface(Surface, @r1, buffer, @r2); - SDL_BlitSurface(buffer, @r2, Surface, @r2); - SDL_FreeSurface(buffer); - end; - end; -end;} - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); -var - r1, r2 : TSDL_Rect; - buffer : PSDL_Surface; -begin - if ( DstSurface <> nil ) and ( DifX <> 0 ) then - begin - buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, - DstSurface^.h * 2, - DstSurface^.Format^.BitsPerPixel, - DstSurface^.Format^.RMask, - DstSurface^.Format^.GMask, - DstSurface^.Format^.BMask, - DstSurface^.Format^.AMask ); - if buffer <> nil then - begin - if ( buffer^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); - r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); - SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); - SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); - SDL_FreeSurface( buffer ); - end; - end; -end; - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); -var - aSin, aCos : Single; - MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; - Colour, TempTransparentColour : UInt32; - MAXX, MAXY : Integer; -begin - // Rotate the surface to the target surface. - TempTransparentColour := SrcSurface.format.colorkey; - {if srcRect.w > srcRect.h then - begin - Width := srcRect.w; - Height := srcRect.w; - end - else - begin - Width := srcRect.h; - Height := srcRect.h; - end; } - - maxx := DstSurface.w; - maxy := DstSurface.h; - aCos := cos( Angle ); - aSin := sin( Angle ); - - Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); - Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); - - OX := Width div 2; - OY := Height div 2; ; - MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; - MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; - ROX := ( -( srcRect.w div 2 ) ) + Offsetx; - ROY := ( -( srcRect.h div 2 ) ) + OffsetY; - Tx := ox + round( ROX * aSin - ROY * aCos ); - Ty := oy + round( ROY * aSin + ROX * aCos ); - SX := 0; - for DX := DestX - TX to DestX - TX + ( width ) do - begin - Inc( SX ); - SY := 0; - for DY := DestY - TY to DestY - TY + ( Height ) do - begin - RX := SX - OX; - RY := SY - OY; - NX := round( mx + RX * aSin + RY * aCos ); // - NY := round( my + RY * aSin - RX * aCos ); // - // Used for testing only - //SDL_PutPixel(DestSurface.SDLSurfacePointer,DX,DY,0); - if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then - begin - if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then - begin - if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then - begin - Colour := SDL_GetPixel( SrcSurface, NX, NY ); - if Colour <> TempTransparentColour then - begin - SDL_PutPixel( DstSurface, DX, DY, Colour ); - end; - end; - end; - end; - inc( SY ); - end; - end; -end; - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); -begin - SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); -end; - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; -var - RealRect : TSDL_Rect; - OutOfRange : Boolean; -begin - OutOfRange := false; - if dstrect = nil then - begin - RealRect.x := 0; - RealRect.y := 0; - RealRect.w := DstSurface.w; - RealRect.h := DstSurface.h; - end - else - begin - if dstrect.x < DstSurface.w then - begin - RealRect.x := dstrect.x; - end - else if dstrect.x < 0 then - begin - realrect.x := 0; - end - else - begin - OutOfRange := True; - end; - if dstrect.y < DstSurface.h then - begin - RealRect.y := dstrect.y; - end - else if dstrect.y < 0 then - begin - realrect.y := 0; - end - else - begin - OutOfRange := True; - end; - if OutOfRange = False then - begin - if realrect.x + dstrect.w <= DstSurface.w then - begin - RealRect.w := dstrect.w; - end - else - begin - RealRect.w := dstrect.w - realrect.x; - end; - if realrect.y + dstrect.h <= DstSurface.h then - begin - RealRect.h := dstrect.h; - end - else - begin - RealRect.h := dstrect.h - realrect.y; - end; - end; - end; - if OutOfRange = False then - begin - result := realrect; - end - else - begin - realrect.w := 0; - realrect.h := 0; - realrect.x := 0; - realrect.y := 0; - result := realrect; - end; -end; - -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( PtrUInt( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( PtrUInt( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); -var - FBC : array[ 0..255 ] of Cardinal; - // temp vars - i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; - - TempStepV, TempStepH : Single; - TempLeft, TempTop, TempHeight, TempWidth : integer; - TempRect : TSDL_Rect; - -begin - // calc FBC - YR := StartColor.r; - YG := StartColor.g; - YB := StartColor.b; - SR := YR; - SG := YG; - SB := YB; - DR := EndColor.r - SR; - DG := EndColor.g - SG; - DB := EndColor.b - SB; - - for i := 0 to 255 do - begin - FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); - YR := SR + round( DR / 255 * i ); - YG := SG + round( DG / 255 * i ); - YB := SB + round( DB / 255 * i ); - end; - - // if aStyle = 1 then begin - TempStepH := Rect.w / 255; - TempStepV := Rect.h / 255; - TempHeight := Trunc( TempStepV + 1 ); - TempWidth := Trunc( TempStepH + 1 ); - TempTop := 0; - TempLeft := 0; - TempRect.x := Rect.x; - TempRect.y := Rect.y; - TempRect.h := Rect.h; - TempRect.w := Rect.w; - - case Style of - gsHorizontal : - begin - TempRect.h := TempHeight; - for i := 0 to 255 do - begin - TempRect.y := Rect.y + TempTop; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempTop := Trunc( TempStepV * i ); - end; - end; - gsVertical : - begin - TempRect.w := TempWidth; - for i := 0 to 255 do - begin - TempRect.x := Rect.x + TempLeft; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempLeft := Trunc( TempStepH * i ); - end; - end; - end; -end; - -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; - SrcPitch, DestPitch, x, y : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := PtrUInt( Src.Pixels ); - WriteRow := PtrUInt( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - case Src.format.BytesPerPixel of - 1 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt8( WriteAddr )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + 1 )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + DestPitch )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + DestPitch + 1 )^ := PUInt8( ReadAddr )^; - inc( ReadAddr ); - inc( WriteAddr, 2 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 2 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt16( WriteAddr )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + 2 )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + DestPitch )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + DestPitch + 2 )^ := PUInt16( ReadAddr )^; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 3 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + 3 )^ := ( PUInt32( WriteAddr + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + DestPitch )^ := ( PUInt32( WriteAddr + DestPitch )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + DestPitch + 3 )^ := ( PUInt32( WriteAddr + DestPitch + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - inc( ReadAddr, 3 ); - inc( WriteAddr, 6 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 4 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + 4 )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + DestPitch )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + DestPitch + 4 )^ := PUInt32( ReadAddr )^; - inc( ReadAddr, 4 ); - inc( WriteAddr, 8 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; - SrcPitch, DestPitch, x, y : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := PtrUInt( Src.Pixels ); - WriteRow := PtrUInt( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - case Src.format.BytesPerPixel of - 1 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt8( WriteAddr )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + 1 )^ := PUInt8( ReadAddr )^; - inc( ReadAddr ); - inc( WriteAddr, 2 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 2 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt16( WriteAddr )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + 2 )^ := PUInt16( ReadAddr )^; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 3 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + 3 )^ := ( PUInt32( WriteAddr + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - inc( ReadAddr, 3 ); - inc( WriteAddr, 6 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 4 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + 4 )^ := PUInt32( ReadAddr )^; - inc( ReadAddr, 4 ); - inc( WriteAddr, 8 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; - SrcPitch, DestPitch, x, y, Color : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := PtrUInt( Src.Pixels ); - WriteRow := PtrUInt( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - case Src.format.BitsPerPixel of - 8 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt8( ReadAddr )^; - PUInt8( WriteAddr )^ := Color; - PUInt8( WriteAddr + 1 )^ := Color; - Color := ( Color shr 1 ) and $6D; {%01101101} - PUInt8( WriteAddr + DestPitch )^ := Color; - PUInt8( WriteAddr + DestPitch + 1 )^ := Color; - inc( ReadAddr ); - inc( WriteAddr, 2 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 15 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt16( ReadAddr )^; - PUInt16( WriteAddr )^ := Color; - PUInt16( WriteAddr + 2 )^ := Color; - Color := ( Color shr 1 ) and $3DEF; {%0011110111101111} - PUInt16( WriteAddr + DestPitch )^ := Color; - PUInt16( WriteAddr + DestPitch + 2 )^ := Color; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 16 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt16( ReadAddr )^; - PUInt16( WriteAddr )^ := Color; - PUInt16( WriteAddr + 2 )^ := Color; - Color := ( Color shr 1 ) and $7BEF; {%0111101111101111} - PUInt16( WriteAddr + DestPitch )^ := Color; - PUInt16( WriteAddr + DestPitch + 2 )^ := Color; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 24 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr )^ := Color; - PUInt32( WriteAddr + 3 )^ := Color; - Color := ( Color shr 1 ) and $007F7F7F; {%011111110111111101111111} - PUInt32( WriteAddr + DestPitch )^ := Color; - PUInt32( WriteAddr + DestPitch + 3 )^ := Color; - inc( ReadAddr, 3 ); - inc( WriteAddr, 6 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 32 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt32( ReadAddr )^; - PUInt32( WriteAddr )^ := Color; - PUInt32( WriteAddr + 4 )^ := Color; - Color := ( Color shr 1 ) and $7F7F7F7F; - PUInt32( WriteAddr + DestPitch )^ := Color; - PUInt32( WriteAddr + DestPitch + 4 )^ := Color; - inc( ReadAddr, 4 ); - inc( WriteAddr, 8 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : - PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : - boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, {Scan2Start,} ScanWidth, ScanHeight : cardinal; - Mod1 : cardinal; - Addr1 : PtrUInt; - BPP : cardinal; - Pitch1 : cardinal; - TransparentColor1 : cardinal; - tx, ty : cardinal; -// StartTick : cardinal; // Auto Removed, Unused Variable - Color1 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - //Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - //Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := PtrUInt( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - - Mod1 := Pitch1 - ( ScanWidth * BPP ); - - inc( Addr1, BPP * Scan1Start ); - - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - - end; - inc( Addr1, Mod1 ); - - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - - end; - inc( Addr1, Mod1 ); - - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - - if ( Color1 <> TransparentColor1 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - - end; - inc( Addr1, Mod1 ); - - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - - end; - inc( Addr1, Mod1 ); - - end; - end; -end; - -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var -{*R, *}{*G, *}{*B, *}Pixel1, Pixel2, TransparentColor : cardinal; // Auto Removed, Unused Variable (R) // Auto Removed, Unused Variable (G) // Auto Removed, Unused Variable (B) - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - PUInt8( DestAddr )^ := Pixel2 or Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 or Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 or Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel2 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - - PUInt32( DestAddr )^ := Pixel2 or Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var -{*R, *}{*G, *}{*B, *}Pixel1, Pixel2, TransparentColor : cardinal; // Auto Removed, Unused Variable (R) // Auto Removed, Unused Variable (G) // Auto Removed, Unused Variable (B) - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - PUInt8( DestAddr )^ := Pixel2 and Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 and Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 and Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel2 and Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - - PUInt32( DestAddr )^ := Pixel2 and Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 > Pixel1 and $E0 then - R := Pixel2 and $E0 - else - R := Pixel1 and $E0; - if Pixel2 and $1C > Pixel1 and $1C then - G := Pixel2 and $1C - else - G := Pixel1 and $1C; - if Pixel2 and $03 > Pixel1 and $03 then - B := Pixel2 and $03 - else - B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 > Pixel1 and $7C00 then - R := Pixel2 and $7C00 - else - R := Pixel1 and $7C00; - if Pixel2 and $03E0 > Pixel1 and $03E0 then - G := Pixel2 and $03E0 - else - G := Pixel1 and $03E0; - if Pixel2 and $001F > Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 > Pixel1 and $F800 then - R := Pixel2 and $F800 - else - R := Pixel1 and $F800; - if Pixel2 and $07E0 > Pixel1 and $07E0 then - G := Pixel2 and $07E0 - else - G := Pixel1 and $07E0; - if Pixel2 and $001F > Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 < Pixel1 and $E0 then - R := Pixel2 and $E0 - else - R := Pixel1 and $E0; - if Pixel2 and $1C < Pixel1 and $1C then - G := Pixel2 and $1C - else - G := Pixel1 and $1C; - if Pixel2 and $03 < Pixel1 and $03 then - B := Pixel2 and $03 - else - B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 < Pixel1 and $7C00 then - R := Pixel2 and $7C00 - else - R := Pixel1 and $7C00; - if Pixel2 and $03E0 < Pixel1 and $03E0 then - G := Pixel2 and $03E0 - else - G := Pixel1 and $03E0; - if Pixel2 and $001F < Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 < Pixel1 and $F800 then - R := Pixel2 and $F800 - else - R := Pixel1 and $F800; - if Pixel2 and $07E0 < Pixel1 and $07E0 then - G := Pixel2 and $07E0 - else - G := Pixel1 and $07E0; - if Pixel2 and $001F < Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -// Will clip the x1,x2,y1,x2 params to the ClipRect provided - -function SDL_ClipLine( var x1, y1, x2, y2 : Integer; ClipRect : PSDL_Rect ) : boolean; -var - tflag, flag1, flag2 : word; - txy, xedge, yedge : Integer; - slope : single; - - function ClipCode( x, y : Integer ) : word; - begin - Result := 0; - if x < ClipRect.x then - Result := 1; - if x >= ClipRect.w + ClipRect.x then - Result := Result or 2; - if y < ClipRect.y then - Result := Result or 4; - if y >= ClipRect.h + ClipRect.y then - Result := Result or 8; - end; - -begin - flag1 := ClipCode( x1, y1 ); - flag2 := ClipCode( x2, y2 ); - result := true; - - while true do - begin - if ( flag1 or flag2 ) = 0 then - Exit; // all in - - if ( flag1 and flag2 ) <> 0 then - begin - result := false; - Exit; // all out - end; - - if flag2 = 0 then - begin - txy := x1; x1 := x2; x2 := txy; - txy := y1; y1 := y2; y2 := txy; - tflag := flag1; flag1 := flag2; flag2 := tflag; - end; - - if ( flag2 and 3 ) <> 0 then - begin - if ( flag2 and 1 ) <> 0 then - xedge := ClipRect.x - else - xedge := ClipRect.w + ClipRect.x - 1; // back 1 pixel otherwise we end up in a loop - - slope := ( y2 - y1 ) / ( x2 - x1 ); - y2 := y1 + Round( slope * ( xedge - x1 ) ); - x2 := xedge; - end - else - begin - if ( flag2 and 4 ) <> 0 then - yedge := ClipRect.y - else - yedge := ClipRect.h + ClipRect.y - 1; // up 1 pixel otherwise we end up in a loop - - slope := ( x2 - x1 ) / ( y2 - y1 ); - x2 := x1 + Round( slope * ( yedge - y1 ) ); - y2 := yedge; - end; - - flag2 := ClipCode( x2, y2 ); - end; -end; - -end. - +unit sdlutils; +{ + $Id: sdlutils.pas,v 1.5 2006/11/19 18:56:44 savage Exp $ + +} +{******************************************************************************} +{ } +{ Borland Delphi SDL - Simple DirectMedia Layer } +{ SDL Utility functions } +{ } +{ } +{ The initial developer of this Pascal code was : } +{ Tom Jones } +{ } +{ Portions created by Tom Jones are } +{ Copyright (C) 2000 - 2001 Tom Jones. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Dominique Louis } +{ Róbert Kisnémeth } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ Helper functions... } +{ } +{ } +{ Requires } +{ -------- } +{ SDL.dll on Windows platforms } +{ libSDL-1.1.so.0 on Linux platform } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ 2000 - TJ : Initial creation } +{ } +{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } +{ } +{ Sept 14 2001 - RK : Added flipping routines. } +{ } +{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } +{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } +{ Added PSDLRect() } +{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} +{ Also removed by poor attempt or a dialog box } +{ } +{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } +{ SubSurface, MonoSurface & TexturedSurface } +{ } +{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } +{ types rather that Windows types. This makes it more} +{ portable to Linix. } +{ } +{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } +{ } +{ Oct 27 2001 - JF : Added ScrollY function } +{ } +{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } +{ } +{ Mar 28 2002 - JF : Added SDL_RotateSurface } +{ } +{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } +{ } +{ May 27 2002 - YS : GradientFillRect function } +{ } +{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } +{ & SDL_50Scanline2xBlit } +{ } +{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } +{ } +{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } +{ } +{ November 9 2002 - JF : Added Jason's boolean Surface functions } +{ } +{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } +{ } +{ April 26 2003 - SS : Incorporated JF's changes to SDL_ClipLine } +{ Fixed SDL_ClipLine bug for non-zero cliprect x, y } +{ Added overloaded SDL_DrawLine for dashed lines } +{ } +{******************************************************************************} +{ + $Log: sdlutils.pas,v $ + Revision 1.5 2006/11/19 18:56:44 savage + Removed Hints and Warnings. + + Revision 1.4 2004/06/02 19:38:53 savage + Changes to SDL_GradientFillRect as suggested by + Ángel Eduardo García Hernández. Many thanks. + + Revision 1.3 2004/05/29 23:11:54 savage + Changes to SDL_ScaleSurfaceRect as suggested by + Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. + + Revision 1.2 2004/02/14 00:23:39 savage + As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. + + Revision 1.1 2004/02/05 00:08:20 savage + Module 1.0 release + + +} + +interface + +{$I jedi-sdl.inc} + +uses +{$IFDEF UNIX} + Types, +{$IFNDEF DARWIN} + Xlib, +{$ENDIF} +{$ENDIF} + SysUtils, + sdl; + +type + TGradientStyle = ( gsHorizontal, gsVertical ); + +// Pixel procedures +function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : + PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; + +function SDL_GetPixel( SrcSurface : PSDL_Surface; x : integer; y : integer ) : Uint32; + +procedure SDL_PutPixel( DstSurface : PSDL_Surface; x : integer; y : integer; pixel : + Uint32 ); + +procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : + cardinal ); + +procedure SDL_SubPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : + cardinal ); + +// Line procedures +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); overload; + +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal; DashLength, DashSpace : byte ); overload; + +procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); + +procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); + +// Surface procedures +procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); + +procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; + TextureRect : PSDL_Rect ); + +procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); + +procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); + +// Flip procedures +procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); + +procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); + +function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; + +function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; + +function SDLRect( aRect : TRect ) : TSDL_Rect; overload; + +function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, + Width, Height : integer ) : PSDL_Surface; + +procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); + +procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); + +procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); + +procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); + +function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; + +// Fill Rect routine +procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); + +procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); + +procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); + +// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! +procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); + +procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); + +procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); + +// +function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : + PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : + boolean; + +// Jason's boolean Surface functions +procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + + +procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); + +function SDL_ClipLine( var x1, y1, x2, y2 : Integer; ClipRect : PSDL_Rect ) : boolean; + +implementation + +uses + Math; + +function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : + PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; +var + Src_Rect1, Src_Rect2 : TSDL_Rect; + right1, bottom1 : integer; + right2, bottom2 : integer; + Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; + Mod1, Mod2 : cardinal; + Addr1, Addr2 : PtrUInt; + BPP : cardinal; + Pitch1, Pitch2 : cardinal; + TransparentColor1, TransparentColor2 : cardinal; + tx, ty : cardinal; +// StartTick : cardinal; // Auto Removed, Unused Variable + Color1, Color2 : cardinal; +begin + Result := false; + if SrcRect1 = nil then + begin + with Src_Rect1 do + begin + x := 0; + y := 0; + w := SrcSurface1.w; + h := SrcSurface1.h; + end; + end + else + Src_Rect1 := SrcRect1^; + if SrcRect2 = nil then + begin + with Src_Rect2 do + begin + x := 0; + y := 0; + w := SrcSurface2.w; + h := SrcSurface2.h; + end; + end + else + Src_Rect2 := SrcRect2^; + with Src_Rect1 do + begin + Right1 := Left1 + w; + Bottom1 := Top1 + h; + end; + with Src_Rect2 do + begin + Right2 := Left2 + w; + Bottom2 := Top2 + h; + end; + if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= + Top2 ) then + exit; + if Left1 <= Left2 then + begin + // 1. left, 2. right + Scan1Start := Src_Rect1.x + Left2 - Left1; + Scan2Start := Src_Rect2.x; + ScanWidth := Right1 - Left2; + with Src_Rect2 do + if ScanWidth > w then + ScanWidth := w; + end + else + begin + // 1. right, 2. left + Scan1Start := Src_Rect1.x; + Scan2Start := Src_Rect2.x + Left1 - Left2; + ScanWidth := Right2 - Left1; + with Src_Rect1 do + if ScanWidth > w then + ScanWidth := w; + end; + with SrcSurface1^ do + begin + Pitch1 := Pitch; + Addr1 := PtrUInt( Pixels ); + inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); + with format^ do + begin + BPP := BytesPerPixel; + TransparentColor1 := colorkey; + end; + end; + with SrcSurface2^ do + begin + TransparentColor2 := format.colorkey; + Pitch2 := Pitch; + Addr2 := PtrUInt( Pixels ); + inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); + end; + Mod1 := Pitch1 - ( ScanWidth * BPP ); + Mod2 := Pitch2 - ( ScanWidth * BPP ); + inc( Addr1, BPP * Scan1Start ); + inc( Addr2, BPP * Scan2Start ); + if Top1 <= Top2 then + begin + // 1. up, 2. down + ScanHeight := Bottom1 - Top2; + if ScanHeight > Src_Rect2.h then + ScanHeight := Src_Rect2.h; + inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); + end + else + begin + // 1. down, 2. up + ScanHeight := Bottom2 - Top1; + if ScanHeight > Src_Rect1.h then + ScanHeight := Src_Rect1.h; + inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); + end; + case BPP of + 1 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> + TransparentColor2 ) then + begin + Result := true; + exit; + end; + inc( Addr1 ); + inc( Addr2 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + 2 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> + TransparentColor2 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 2 ); + inc( Addr2, 2 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + 3 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + Color1 := PLongWord( Addr1 )^ and $00FFFFFF; + Color2 := PLongWord( Addr2 )^ and $00FFFFFF; + if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) + then + begin + Result := true; + exit; + end; + inc( Addr1, 3 ); + inc( Addr2, 3 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + 4 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> + TransparentColor2 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 4 ); + inc( Addr2, 4 ); + end; + inc( Addr1, Mod1 ); + inc( Addr2, Mod2 ); + end; + end; +end; + +procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : + cardinal ); +var + SrcColor : cardinal; + Addr : PtrUInt; + R, G, B : cardinal; +begin + if Color = 0 then + exit; + with DstSurface^ do + begin + Addr := PtrUInt( Pixels ) + y * Pitch + x * format.BytesPerPixel; + SrcColor := PUInt32( Addr )^; + case format.BitsPerPixel of + 8 : + begin + R := SrcColor and $E0 + Color and $E0; + G := SrcColor and $1C + Color and $1C; + B := SrcColor and $03 + Color and $03; + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( Addr )^ := R or G or B; + end; + 15 : + begin + R := SrcColor and $7C00 + Color and $7C00; + G := SrcColor and $03E0 + Color and $03E0; + B := SrcColor and $001F + Color and $001F; + if R > $7C00 then + R := $7C00; + if G > $03E0 then + G := $03E0; + if B > $001F then + B := $001F; + PUInt16( Addr )^ := R or G or B; + end; + 16 : + begin + R := SrcColor and $F800 + Color and $F800; + G := SrcColor and $07C0 + Color and $07C0; + B := SrcColor and $001F + Color and $001F; + if R > $F800 then + R := $F800; + if G > $07C0 then + G := $07C0; + if B > $001F then + B := $001F; + PUInt16( Addr )^ := R or G or B; + end; + 24 : + begin + R := SrcColor and $00FF0000 + Color and $00FF0000; + G := SrcColor and $0000FF00 + Color and $0000FF00; + B := SrcColor and $000000FF + Color and $000000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; + end; + 32 : + begin + R := SrcColor and $00FF0000 + Color and $00FF0000; + G := SrcColor and $0000FF00 + Color and $0000FF00; + B := SrcColor and $000000FF + Color and $000000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( Addr )^ := R or G or B; + end; + end; + end; +end; + +procedure SDL_SubPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : + cardinal ); +var + SrcColor : cardinal; + Addr : PtrUInt; + R, G, B : cardinal; +begin + if Color = 0 then + exit; + with DstSurface^ do + begin + Addr := PtrUInt( Pixels ) + y * Pitch + x * format.BytesPerPixel; + SrcColor := PUInt32( Addr )^; + case format.BitsPerPixel of + 8 : + begin + R := SrcColor and $E0 - Color and $E0; + G := SrcColor and $1C - Color and $1C; + B := SrcColor and $03 - Color and $03; + if R > $E0 then + R := 0; + if G > $1C then + G := 0; + if B > $03 then + B := 0; + PUInt8( Addr )^ := R or G or B; + end; + 15 : + begin + R := SrcColor and $7C00 - Color and $7C00; + G := SrcColor and $03E0 - Color and $03E0; + B := SrcColor and $001F - Color and $001F; + if R > $7C00 then + R := 0; + if G > $03E0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( Addr )^ := R or G or B; + end; + 16 : + begin + R := SrcColor and $F800 - Color and $F800; + G := SrcColor and $07C0 - Color and $07C0; + B := SrcColor and $001F - Color and $001F; + if R > $F800 then + R := 0; + if G > $07C0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( Addr )^ := R or G or B; + end; + 24 : + begin + R := SrcColor and $00FF0000 - Color and $00FF0000; + G := SrcColor and $0000FF00 - Color and $0000FF00; + B := SrcColor and $000000FF - Color and $000000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; + end; + 32 : + begin + R := SrcColor and $00FF0000 - Color and $00FF0000; + G := SrcColor and $0000FF00 - Color and $0000FF00; + B := SrcColor and $000000FF - Color and $000000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( Addr )^ := R or G or B; + end; + end; + end; +end; +// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. +// In 8 bit color depth mode the procedure works with the default packed +// palette (RRRGGGBB). It handles all clipping. + +procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel1 and $E0 + Pixel2 and $E0; + G := Pixel1 and $1C + Pixel2 and $1C; + B := Pixel1 and $03 + Pixel2 and $03; + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( DestAddr )^ := R or G or B; + end + else + PUInt8( DestAddr )^ := Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel1 and $7C00 + Pixel2 and $7C00; + G := Pixel1 and $03E0 + Pixel2 and $03E0; + B := Pixel1 and $001F + Pixel2 and $001F; + if R > $7C00 then + R := $7C00; + if G > $03E0 then + G := $03E0; + if B > $001F then + B := $001F; + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel1 and $F800 + Pixel2 and $F800; + G := Pixel1 and $07E0 + Pixel2 and $07E0; + B := Pixel1 and $001F + Pixel2 and $001F; + if R > $F800 then + R := $F800; + if G > $07E0 then + G := $07E0; + if B > $001F then + B := $001F; + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + if Pixel2 > 0 then + begin + R := Pixel1 and $FF0000 + Pixel2 and $FF0000; + G := Pixel1 and $00FF00 + Pixel2 and $00FF00; + B := Pixel1 and $0000FF + Pixel2 and $0000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); + end + else + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel1 and $FF0000 + Pixel2 and $FF0000; + G := Pixel1 and $00FF00 + Pixel2 and $00FF00; + B := Pixel1 and $0000FF + Pixel2 and $0000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( DestAddr )^ := R or G or B; + end + else + PUInt32( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + +procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; +//{*_ebx, *}{*_esi, *}{*_edi, _esp*} : cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := DestSurface.Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel2 and $E0 - Pixel1 and $E0; + G := Pixel2 and $1C - Pixel1 and $1C; + B := Pixel2 and $03 - Pixel1 and $03; + if R > $E0 then + R := 0; + if G > $1C then + G := 0; + if B > $03 then + B := 0; + PUInt8( DestAddr )^ := R or G or B; + end; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel2 and $7C00 - Pixel1 and $7C00; + G := Pixel2 and $03E0 - Pixel1 and $03E0; + B := Pixel2 and $001F - Pixel1 and $001F; + if R > $7C00 then + R := 0; + if G > $03E0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( DestAddr )^ := R or G or B; + end; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel2 and $F800 - Pixel1 and $F800; + G := Pixel2 and $07E0 - Pixel1 and $07E0; + B := Pixel2 and $001F - Pixel1 and $001F; + if R > $F800 then + R := 0; + if G > $07E0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( DestAddr )^ := R or G or B; + end; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + if Pixel2 > 0 then + begin + R := Pixel2 and $FF0000 - Pixel1 and $FF0000; + G := Pixel2 and $00FF00 - Pixel1 and $00FF00; + B := Pixel2 and $0000FF - Pixel1 and $0000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); + end; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + if Pixel2 > 0 then + begin + R := Pixel2 and $FF0000 - Pixel1 and $FF0000; + G := Pixel2 and $00FF00 - Pixel1 and $00FF00; + B := Pixel2 and $0000FF - Pixel1 and $0000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( DestAddr )^ := R or G or B; + end + else + PUInt32( DestAddr )^ := Pixel2; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + +procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; +//{*_ebx, *}{*_esi, *}{*_edi, _esp*} : cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + TransparentColor, SrcColor : cardinal; + BPP : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + BPP := DestSurface.Format.BytesPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case BPP of + 1 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt8( SrcAddr )^; + if SrcColor <> TransparentColor then + PUInt8( DestAddr )^ := SrcColor; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 2 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt16( SrcAddr )^; + if SrcColor <> TransparentColor then + PUInt16( DestAddr )^ := SrcColor; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 3 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt32( SrcAddr )^ and $FFFFFF; + if SrcColor <> TransparentColor then + PUInt32( DestAddr )^ := ( PUInt32( DestAddr )^ and $FFFFFF ) or SrcColor; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 4 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt32( SrcAddr )^; + if SrcColor <> TransparentColor then + PUInt32( DestAddr )^ := SrcColor; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; +// TextureRect.w and TextureRect.h are not used. +// The TextureSurface's size MUST larger than the drawing rectangle!!! + +procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; + TextureRect : PSDL_Rect ); +var + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr, TextAddr : PtrUInt; +//{*_ebx, *}{*_esi, *}{*_edi, _esp*}: cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) + WorkX, WorkY : word; + SrcMod, DestMod, TextMod : cardinal; +SrcColor, TransparentColor{*, TextureColor*} : cardinal; // Auto Removed, Unused Variable (TextureColor) + BPP : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + BPP := DestSurface.Format.BitsPerPixel; + end; + with Texture^ do + begin + TextAddr := PtrUInt( Pixels ) + UInt32( TextureRect.y ) * Pitch + + UInt32( TextureRect.x ) * Format.BytesPerPixel; + TextMod := Pitch - Src.w * Format.BytesPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + SDL_LockSurface( Texture ); + WorkY := Src.h; + case BPP of + 1 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt8( SrcAddr )^; + if SrcColor <> TransparentColor then + PUInt8( DestAddr )^ := PUint8( TextAddr )^; + inc( SrcAddr ); + inc( DestAddr ); + inc( TextAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + inc( TextAddr, TextMod ); + dec( WorkY ); + until WorkY = 0; + end; + 2 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt16( SrcAddr )^; + if SrcColor <> TransparentColor then + PUInt16( DestAddr )^ := PUInt16( TextAddr )^; + inc( SrcAddr ); + inc( DestAddr ); + inc( TextAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + inc( TextAddr, TextMod ); + dec( WorkY ); + until WorkY = 0; + end; + 3 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt32( SrcAddr )^ and $FFFFFF; + if SrcColor <> TransparentColor then + PUInt32( DestAddr )^ := ( PUInt32( DestAddr )^ and $FFFFFF ) or ( PUInt32( TextAddr )^ and $FFFFFF ); + inc( SrcAddr ); + inc( DestAddr ); + inc( TextAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + inc( TextAddr, TextMod ); + dec( WorkY ); + until WorkY = 0; + end; + 4 : + begin + repeat + WorkX := Src.w; + repeat + SrcColor := PUInt32( SrcAddr )^; + if SrcColor <> TransparentColor then + PUInt32( DestAddr )^ := PUInt32( TextAddr )^; + inc( SrcAddr ); + inc( DestAddr ); + inc( TextAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + inc( TextAddr, TextMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); + SDL_UnlockSurface( Texture ); +end; + +procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); +var + xc, yc : cardinal; + rx, wx, ry, wy, ry16 : cardinal; + color : cardinal; + modx, mody : cardinal; +begin + // Warning! No checks for surface pointers!!! + if srcrect = nil then + srcrect := @SrcSurface.clip_rect; + if dstrect = nil then + dstrect := @DstSurface.clip_rect; + if SDL_MustLock( SrcSurface ) then + SDL_LockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_LockSurface( DstSurface ); + modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); + mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); + //rx := srcrect.x * 65536; + ry := srcrect.y * 65536; + wy := dstrect.y; + for yc := 0 to dstrect.h - 1 do + begin + rx := srcrect.x * 65536; + wx := dstrect.x; + ry16 := ry shr 16; + for xc := 0 to dstrect.w - 1 do + begin + color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); + SDL_PutPixel( DstSurface, wx, wy, color ); + rx := rx + modx; + inc( wx ); + end; + ry := ry + mody; + inc( wy ); + end; + if SDL_MustLock( SrcSurface ) then + SDL_UnlockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_UnlockSurface( DstSurface ); +end; +// Re-map a rectangular area into an area defined by four vertices +// Converted from C to Pascal by KiCHY + +procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); +const + SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) + THRESH = 1 shl SHIFTS; // Threshold for pixel size value + procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); + var + tm, lm, rm, bm, m : TPoint; + mx, my : cardinal; + cr : cardinal; + begin + // Does the destination area specify a single pixel? + if ( ( abs( ul.x - ur.x ) < THRESH ) and + ( abs( ul.x - lr.x ) < THRESH ) and + ( abs( ul.x - ll.x ) < THRESH ) and + ( abs( ul.y - ur.y ) < THRESH ) and + ( abs( ul.y - lr.y ) < THRESH ) and + ( abs( ul.y - ll.y ) < THRESH ) ) then + begin // Yes + cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); + SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); + end + else + begin // No + // Quarter the source and the destination, and then recurse + tm.x := ( ul.x + ur.x ) shr 1; + tm.y := ( ul.y + ur.y ) shr 1; + bm.x := ( ll.x + lr.x ) shr 1; + bm.y := ( ll.y + lr.y ) shr 1; + lm.x := ( ul.x + ll.x ) shr 1; + lm.y := ( ul.y + ll.y ) shr 1; + rm.x := ( ur.x + lr.x ) shr 1; + rm.y := ( ur.y + lr.y ) shr 1; + m.x := ( tm.x + bm.x ) shr 1; + m.y := ( tm.y + bm.y ) shr 1; + mx := ( x1 + x2 ) shr 1; + my := ( y1 + y2 ) shr 1; + CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); + CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); + CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); + CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); + end; + end; +var + _UL, _UR, _LR, _LL : TPoint; + Rect_x, Rect_y, Rect_w, Rect_h : integer; +begin + if SDL_MustLock( SrcSurface ) then + SDL_LockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_LockSurface( DstSurface ); + if SrcRect = nil then + begin + Rect_x := 0; + Rect_y := 0; + Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; + Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; + end + else + begin + Rect_x := SrcRect.x; + Rect_y := SrcRect.y; + Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; + Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; + end; + // Shift all values to help reduce round-off error. + _ul.x := ul.x shl SHIFTS; + _ul.y := ul.y shl SHIFTS; + _ur.x := ur.x shl SHIFTS; + _ur.y := ur.y shl SHIFTS; + _lr.x := lr.x shl SHIFTS; + _lr.y := lr.y shl SHIFTS; + _ll.x := ll.x shl SHIFTS; + _ll.y := ll.y shl SHIFTS; + CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); + if SDL_MustLock( SrcSurface ) then + SDL_UnlockSurface( SrcSurface ); + if SDL_MustLock( DstSurface ) then + SDL_UnlockSurface( DstSurface ); +end; + +// Draw a line between x1,y1 and x2,y2 to the given surface +// NOTE: The surface must be locked before calling this! + +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); +var + dx, dy, sdx, sdy, x, y, px, py : integer; +begin + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + SDL_PutPixel( DstSurface, px, py, Color ); + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + SDL_PutPixel( DstSurface, px, py, Color ); + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +// Draw a dashed line between x1,y1 and x2,y2 to the given surface +// NOTE: The surface must be locked before calling this! + +procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal; DashLength, DashSpace : byte ); overload; +var + dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; +begin + counter := 0; + drawdash := true; //begin line drawing with dash + + //Avoid invalid user-passed dash parameters + if ( DashLength < 1 ) + then + DashLength := 1; + if ( DashSpace < 1 ) + then + DashSpace := 0; + + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + + //Alternate drawing dashes, or leaving spaces + if drawdash then + begin + SDL_PutPixel( DstSurface, px, py, Color ); + inc( counter ); + if ( counter > DashLength - 1 ) and ( DashSpace > 0 ) then + begin + drawdash := false; + counter := 0; + end; + end + else //space + begin + inc( counter ); + if counter > DashSpace - 1 then + begin + drawdash := true; + counter := 0; + end; + end; + + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + + //Alternate drawing dashes, or leaving spaces + if drawdash then + begin + SDL_PutPixel( DstSurface, px, py, Color ); + inc( counter ); + if ( counter > DashLength - 1 ) and ( DashSpace > 0 ) then + begin + drawdash := false; + counter := 0; + end; + end + else //space + begin + inc( counter ); + if counter > DashSpace - 1 then + begin + drawdash := true; + counter := 0; + end; + end; + + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); +var + dx, dy, sdx, sdy, x, y, px, py : integer; +begin + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + SDL_AddPixel( DstSurface, px, py, Color ); + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + SDL_AddPixel( DstSurface, px, py, Color ); + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : + cardinal ); +var + dx, dy, sdx, sdy, x, y, px, py : integer; +begin + dx := x2 - x1; + dy := y2 - y1; + if dx < 0 then + sdx := -1 + else + sdx := 1; + if dy < 0 then + sdy := -1 + else + sdy := 1; + dx := sdx * dx + 1; + dy := sdy * dy + 1; + x := 0; + y := 0; + px := x1; + py := y1; + if dx >= dy then + begin + for x := 0 to dx - 1 do + begin + SDL_SubPixel( DstSurface, px, py, Color ); + y := y + dy; + if y >= dx then + begin + y := y - dx; + py := py + sdy; + end; + px := px + sdx; + end; + end + else + begin + for y := 0 to dy - 1 do + begin + SDL_SubPixel( DstSurface, px, py, Color ); + x := x + dx; + if x >= dy then + begin + x := x - dy; + px := px + sdx; + end; + py := py + sdy; + end; + end; +end; + +// flips a rectangle vertically on given surface + +procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); +var + TmpRect : TSDL_Rect; + Locked : boolean; + y, FlipLength, RowLength : integer; + Row1, Row2 : Pointer; + OneRow : TByteArray; // Optimize it if you wish +begin + if DstSurface <> nil then + begin + if Rect = nil then + begin // if Rect=nil then we flip the whole surface + TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); + Rect := @TmpRect; + end; + FlipLength := Rect^.h shr 1 - 1; + RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; + if SDL_MustLock( DstSurface ) then + begin + Locked := true; + SDL_LockSurface( DstSurface ); + end + else + Locked := false; + Row1 := pointer( PtrUInt( DstSurface^.Pixels ) + UInt32( Rect^.y ) * + DstSurface^.Pitch ); + Row2 := pointer( PtrUInt( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) + * DstSurface^.Pitch ); + for y := 0 to FlipLength do + begin + Move( Row1^, OneRow, RowLength ); + Move( Row2^, Row1^, RowLength ); + Move( OneRow, Row2^, RowLength ); + inc( PtrUInt( Row1 ), DstSurface^.Pitch ); + dec( PtrUInt( Row2 ), DstSurface^.Pitch ); + end; + if Locked then + SDL_UnlockSurface( DstSurface ); + end; +end; + +// flips a rectangle horizontally on given surface + +procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); +type + T24bit = packed array[ 0..2 ] of byte; + T24bitArray = packed array[ 0..8191 ] of T24bit; + P24bitArray = ^T24bitArray; + TLongWordArray = array[ 0..8191 ] of LongWord; + PLongWordArray = ^TLongWordArray; +var + TmpRect : TSDL_Rect; + Row8bit : PByteArray; + Row16bit : PWordArray; + Row24bit : P24bitArray; + Row32bit : PLongWordArray; + y, x, RightSide, FlipLength : integer; + Pixel : cardinal; + Pixel24 : T24bit; + Locked : boolean; +begin + if DstSurface <> nil then + begin + if Rect = nil then + begin + TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); + Rect := @TmpRect; + end; + FlipLength := Rect^.w shr 1 - 1; + if SDL_MustLock( DstSurface ) then + begin + Locked := true; + SDL_LockSurface( DstSurface ); + end + else + Locked := false; + case DstSurface^.format.BytesPerPixel of + 1 : + begin + Row8Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel := Row8Bit^[ x ]; + Row8Bit^[ x ] := Row8Bit^[ RightSide ]; + Row8Bit^[ RightSide ] := Pixel; + dec( RightSide ); + end; + inc( PtrUInt( Row8Bit ), DstSurface^.pitch ); + end; + end; + 2 : + begin + Row16Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel := Row16Bit^[ x ]; + Row16Bit^[ x ] := Row16Bit^[ RightSide ]; + Row16Bit^[ RightSide ] := Pixel; + dec( RightSide ); + end; + inc( PtrUInt( Row16Bit ), DstSurface^.pitch ); + end; + end; + 3 : + begin + Row24Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel24 := Row24Bit^[ x ]; + Row24Bit^[ x ] := Row24Bit^[ RightSide ]; + Row24Bit^[ RightSide ] := Pixel24; + dec( RightSide ); + end; + inc( PtrUInt( Row24Bit ), DstSurface^.pitch ); + end; + end; + 4 : + begin + Row32Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * + DstSurface^.pitch ); + for y := 1 to Rect^.h do + begin + RightSide := Rect^.w - 1; + for x := 0 to FlipLength do + begin + Pixel := Row32Bit^[ x ]; + Row32Bit^[ x ] := Row32Bit^[ RightSide ]; + Row32Bit^[ RightSide ] := Pixel; + dec( RightSide ); + end; + inc( PtrUInt( Row32Bit ), DstSurface^.pitch ); + end; + end; + end; + if Locked then + SDL_UnlockSurface( DstSurface ); + end; +end; + +// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. +// But you MUST free it after you don't need it anymore!!! + +function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; +var + Rect : PSDL_Rect; +begin + New( Rect ); + with Rect^ do + begin + x := aLeft; + y := aTop; + w := aWidth; + h := aHeight; + end; + Result := Rect; +end; + +function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; +begin + with result do + begin + x := aLeft; + y := aTop; + w := aWidth; + h := aHeight; + end; +end; + +function SDLRect( aRect : TRect ) : TSDL_Rect; +begin + with aRect do + result := SDLRect( Left, Top, Right - Left, Bottom - Top ); +end; + +procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, + depth : integer ); +var + dx, dy, e, d, dx2 : integer; + src_pitch, dst_pitch : uint16; + src_pixels, dst_pixels : PUint8; +begin + if ( yw >= dst_surface^.h ) then + exit; + dx := ( x2 - x1 ); + dy := ( y2 - y1 ); + dy := dy shl 1; + e := dy - dx; + dx2 := dx shl 1; + src_pitch := Surface^.pitch; + dst_pitch := dst_surface^.pitch; + src_pixels := PUint8( PtrUInt( Surface^.pixels ) + yr * src_pitch + y1 * depth ); + dst_pixels := PUint8( PtrUInt( dst_surface^.pixels ) + yw * dst_pitch + x1 * + depth ); + for d := 0 to dx - 1 do + begin + move( src_pixels^, dst_pixels^, depth ); + while ( e >= 0 ) do + begin + inc( src_pixels, depth ); + e := e - dx2; + end; + inc( dst_pixels, depth ); + e := e + dy; + end; +end; + +function sign( x : integer ) : integer; +begin + if x > 0 then + result := 1 + else + result := -1; +end; + +// Stretches a part of a surface + +function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, + Width, Height : integer ) : PSDL_Surface; +var + dst_surface : PSDL_Surface; + dx, dy, e, d, dx2, srcx2, srcy2 : integer; + destx1, desty1 : integer; +begin + srcx2 := srcx1 + SrcW; + srcy2 := srcy1 + SrcH; + result := nil; + destx1 := 0; + desty1 := 0; + dx := abs( integer( Height - desty1 ) ); + dy := abs( integer( SrcY2 - SrcY1 ) ); + e := ( dy shl 1 ) - dx; + dx2 := dx shl 1; + dy := dy shl 1; + dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - + desty1, + SrcSurface^.Format^.BitsPerPixel, + SrcSurface^.Format^.RMask, + SrcSurface^.Format^.GMask, + SrcSurface^.Format^.BMask, + SrcSurface^.Format^.AMask ); + if ( dst_surface^.format^.BytesPerPixel = 1 ) then + SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); + SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); + if ( SDL_MustLock( dst_surface ) ) then + if ( SDL_LockSurface( dst_surface ) < 0 ) then + exit; + for d := 0 to dx - 1 do + begin + SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, + SrcSurface^.format^.BytesPerPixel ); + while e >= 0 do + begin + inc( SrcY1 ); + e := e - dx2; + end; + inc( desty1 ); + e := e + dy; + end; + if SDL_MUSTLOCK( dst_surface ) then + SDL_UnlockSurface( dst_surface ); + result := dst_surface; +end; + +procedure SDL_MoveLine( Surface : PSDL_Surface; x1, x2, y1, xofs, depth : integer ); +var + src_pixels, dst_pixels : PUint8; + i : integer; +begin + src_pixels := PUint8( PtrUInt( Surface^.pixels ) + Surface^.w * y1 * depth + x2 * + depth ); + dst_pixels := PUint8( PtrUInt( Surface^.pixels ) + Surface^.w * y1 * depth + ( x2 + + xofs ) * depth ); + for i := x2 downto x1 do + begin + move( src_pixels^, dst_pixels^, depth ); + dec( src_pixels ); + dec( dst_pixels ); + end; +end; +{ Return the pixel value at (x, y) +NOTE: The surface must be locked before calling this! } + +function SDL_GetPixel( SrcSurface : PSDL_Surface; x : integer; y : integer ) : Uint32; +var + bpp : UInt32; + p : PInteger; +begin + bpp := SrcSurface.format.BytesPerPixel; + // Here p is the address to the pixel we want to retrieve + p := Pointer( PtrUInt( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * + bpp ); + case bpp of + 1 : result := PUint8( p )^; + 2 : result := PUint16( p )^; + 3 : + if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then + result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or + PUInt8Array( p )[ 2 ] + else + result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or + PUInt8Array( p )[ 2 ] shl 16; + 4 : result := PUint32( p )^; + else + result := 0; // shouldn't happen, but avoids warnings + end; +end; +{ Set the pixel at (x, y) to the given value + NOTE: The surface must be locked before calling this! } + +procedure SDL_PutPixel( DstSurface : PSDL_Surface; x : integer; y : integer; pixel : + Uint32 ); +var + bpp : UInt32; + p : PInteger; +begin + bpp := DstSurface.format.BytesPerPixel; + p := Pointer( PtrUInt( DstSurface.pixels ) + UInt32( y ) * DstSurface.pitch + UInt32( x ) + * bpp ); + case bpp of + 1 : PUint8( p )^ := pixel; + 2 : PUint16( p )^ := pixel; + 3 : + if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then + begin + PUInt8Array( p )[ 0 ] := ( pixel shr 16 ) and $FF; + PUInt8Array( p )[ 1 ] := ( pixel shr 8 ) and $FF; + PUInt8Array( p )[ 2 ] := pixel and $FF; + end + else + begin + PUInt8Array( p )[ 0 ] := pixel and $FF; + PUInt8Array( p )[ 1 ] := ( pixel shr 8 ) and $FF; + PUInt8Array( p )[ 2 ] := ( pixel shr 16 ) and $FF; + end; + 4 : + PUint32( p )^ := pixel; + end; +end; + +procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); +var + r1, r2 : TSDL_Rect; + //buffer: PSDL_Surface; + YPos : Integer; +begin + if ( DstSurface <> nil ) and ( DifY <> 0 ) then + begin + //if DifY > 0 then // going up + //begin + ypos := 0; + r1.x := 0; + r2.x := 0; + r1.w := DstSurface.w; + r2.w := DstSurface.w; + r1.h := DifY; + r2.h := DifY; + while ypos < DstSurface.h do + begin + r1.y := ypos; + r2.y := ypos + DifY; + SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); + ypos := ypos + DifY; + end; + //end + //else + //begin // Going Down + //end; + end; +end; + +{procedure SDL_ScrollY(Surface: PSDL_Surface; DifY: integer); +var + r1, r2: TSDL_Rect; + buffer: PSDL_Surface; +begin + if (Surface <> nil) and (Dify <> 0) then + begin + buffer := SDL_CreateRGBSurface(SDL_HWSURFACE, (Surface^.w - DifY) * 2, + Surface^.h * 2, + Surface^.Format^.BitsPerPixel, 0, 0, 0, 0); + if buffer <> nil then + begin + if (buffer^.format^.BytesPerPixel = 1) then + SDL_SetColors(buffer, @Surface^.format^.palette^.colors^[0], 0, 256); + r1 := SDLRect(0, DifY, buffer^.w, buffer^.h); + r2 := SDLRect(0, 0, buffer^.w, buffer^.h); + SDL_BlitSurface(Surface, @r1, buffer, @r2); + SDL_BlitSurface(buffer, @r2, Surface, @r2); + SDL_FreeSurface(buffer); + end; + end; +end;} + +procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); +var + r1, r2 : TSDL_Rect; + buffer : PSDL_Surface; +begin + if ( DstSurface <> nil ) and ( DifX <> 0 ) then + begin + buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, + DstSurface^.h * 2, + DstSurface^.Format^.BitsPerPixel, + DstSurface^.Format^.RMask, + DstSurface^.Format^.GMask, + DstSurface^.Format^.BMask, + DstSurface^.Format^.AMask ); + if buffer <> nil then + begin + if ( buffer^.format^.BytesPerPixel = 1 ) then + SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); + r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); + r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); + SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); + SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); + SDL_FreeSurface( buffer ); + end; + end; +end; + +procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); +var + aSin, aCos : Single; + MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; + Colour, TempTransparentColour : UInt32; + MAXX, MAXY : Integer; +begin + // Rotate the surface to the target surface. + TempTransparentColour := SrcSurface.format.colorkey; + {if srcRect.w > srcRect.h then + begin + Width := srcRect.w; + Height := srcRect.w; + end + else + begin + Width := srcRect.h; + Height := srcRect.h; + end; } + + maxx := DstSurface.w; + maxy := DstSurface.h; + aCos := cos( Angle ); + aSin := sin( Angle ); + + Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); + Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); + + OX := Width div 2; + OY := Height div 2; ; + MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; + MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; + ROX := ( -( srcRect.w div 2 ) ) + Offsetx; + ROY := ( -( srcRect.h div 2 ) ) + OffsetY; + Tx := ox + round( ROX * aSin - ROY * aCos ); + Ty := oy + round( ROY * aSin + ROX * aCos ); + SX := 0; + for DX := DestX - TX to DestX - TX + ( width ) do + begin + Inc( SX ); + SY := 0; + for DY := DestY - TY to DestY - TY + ( Height ) do + begin + RX := SX - OX; + RY := SY - OY; + NX := round( mx + RX * aSin + RY * aCos ); // + NY := round( my + RY * aSin - RX * aCos ); // + // Used for testing only + //SDL_PutPixel(DestSurface.SDLSurfacePointer,DX,DY,0); + if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then + begin + if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then + begin + if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then + begin + Colour := SDL_GetPixel( SrcSurface, NX, NY ); + if Colour <> TempTransparentColour then + begin + SDL_PutPixel( DstSurface, DX, DY, Colour ); + end; + end; + end; + end; + inc( SY ); + end; + end; +end; + +procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : + PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); +begin + SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); +end; + +function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; +var + RealRect : TSDL_Rect; + OutOfRange : Boolean; +begin + OutOfRange := false; + if dstrect = nil then + begin + RealRect.x := 0; + RealRect.y := 0; + RealRect.w := DstSurface.w; + RealRect.h := DstSurface.h; + end + else + begin + if dstrect.x < DstSurface.w then + begin + RealRect.x := dstrect.x; + end + else if dstrect.x < 0 then + begin + realrect.x := 0; + end + else + begin + OutOfRange := True; + end; + if dstrect.y < DstSurface.h then + begin + RealRect.y := dstrect.y; + end + else if dstrect.y < 0 then + begin + realrect.y := 0; + end + else + begin + OutOfRange := True; + end; + if OutOfRange = False then + begin + if realrect.x + dstrect.w <= DstSurface.w then + begin + RealRect.w := dstrect.w; + end + else + begin + RealRect.w := dstrect.w - realrect.x; + end; + if realrect.y + dstrect.h <= DstSurface.h then + begin + RealRect.h := dstrect.h; + end + else + begin + RealRect.h := dstrect.h - realrect.y; + end; + end; + end; + if OutOfRange = False then + begin + result := realrect; + end + else + begin + realrect.w := 0; + realrect.h := 0; + realrect.x := 0; + realrect.y := 0; + result := realrect; + end; +end; + +procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); +var + RealRect : TSDL_Rect; + Addr : pointer; + ModX, BPP : cardinal; + x, y, R, G, B, SrcColor : cardinal; +begin + RealRect := ValidateSurfaceRect( DstSurface, DstRect ); + if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then + begin + SDL_LockSurface( DstSurface ); + BPP := DstSurface.format.BytesPerPixel; + with DstSurface^ do + begin + Addr := pointer( PtrUInt( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); + ModX := Pitch - UInt32( RealRect.w ) * BPP; + end; + case DstSurface.format.BitsPerPixel of + 8 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $E0 + Color and $E0; + G := SrcColor and $1C + Color and $1C; + B := SrcColor and $03 + Color and $03; + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 15 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $7C00 + Color and $7C00; + G := SrcColor and $03E0 + Color and $03E0; + B := SrcColor and $001F + Color and $001F; + if R > $7C00 then + R := $7C00; + if G > $03E0 then + G := $03E0; + if B > $001F then + B := $001F; + PUInt16( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 16 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $F800 + Color and $F800; + G := SrcColor and $07C0 + Color and $07C0; + B := SrcColor and $001F + Color and $001F; + if R > $F800 then + R := $F800; + if G > $07C0 then + G := $07C0; + if B > $001F then + B := $001F; + PUInt16( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 24 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 + Color and $00FF0000; + G := SrcColor and $0000FF00 + Color and $0000FF00; + B := SrcColor and $000000FF + Color and $000000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 32 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 + Color and $00FF0000; + G := SrcColor and $0000FF00 + Color and $0000FF00; + B := SrcColor and $000000FF + Color and $000000FF; + if R > $FF0000 then + R := $FF0000; + if G > $00FF00 then + G := $00FF00; + if B > $0000FF then + B := $0000FF; + PUInt32( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + end; + SDL_UnlockSurface( DstSurface ); + end; +end; + +procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); +var + RealRect : TSDL_Rect; + Addr : pointer; + ModX, BPP : cardinal; + x, y, R, G, B, SrcColor : cardinal; +begin + RealRect := ValidateSurfaceRect( DstSurface, DstRect ); + if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then + begin + SDL_LockSurface( DstSurface ); + BPP := DstSurface.format.BytesPerPixel; + with DstSurface^ do + begin + Addr := pointer( PtrUInt( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); + ModX := Pitch - UInt32( RealRect.w ) * BPP; + end; + case DstSurface.format.BitsPerPixel of + 8 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $E0 - Color and $E0; + G := SrcColor and $1C - Color and $1C; + B := SrcColor and $03 - Color and $03; + if R > $E0 then + R := 0; + if G > $1C then + G := 0; + if B > $03 then + B := 0; + PUInt8( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 15 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $7C00 - Color and $7C00; + G := SrcColor and $03E0 - Color and $03E0; + B := SrcColor and $001F - Color and $001F; + if R > $7C00 then + R := 0; + if G > $03E0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 16 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $F800 - Color and $F800; + G := SrcColor and $07C0 - Color and $07C0; + B := SrcColor and $001F - Color and $001F; + if R > $F800 then + R := 0; + if G > $07C0 then + G := 0; + if B > $001F then + B := 0; + PUInt16( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 24 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 - Color and $00FF0000; + G := SrcColor and $0000FF00 - Color and $0000FF00; + B := SrcColor and $000000FF - Color and $000000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + 32 : + begin + for y := 0 to RealRect.h - 1 do + begin + for x := 0 to RealRect.w - 1 do + begin + SrcColor := PUInt32( Addr )^; + R := SrcColor and $00FF0000 - Color and $00FF0000; + G := SrcColor and $0000FF00 - Color and $0000FF00; + B := SrcColor and $000000FF - Color and $000000FF; + if R > $FF0000 then + R := 0; + if G > $00FF00 then + G := 0; + if B > $0000FF then + B := 0; + PUInt32( Addr )^ := R or G or B; + inc( PtrUInt( Addr ), BPP ); + end; + inc( PtrUInt( Addr ), ModX ); + end; + end; + end; + SDL_UnlockSurface( DstSurface ); + end; +end; + +procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); +var + FBC : array[ 0..255 ] of Cardinal; + // temp vars + i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; + + TempStepV, TempStepH : Single; + TempLeft, TempTop, TempHeight, TempWidth : integer; + TempRect : TSDL_Rect; + +begin + // calc FBC + YR := StartColor.r; + YG := StartColor.g; + YB := StartColor.b; + SR := YR; + SG := YG; + SB := YB; + DR := EndColor.r - SR; + DG := EndColor.g - SG; + DB := EndColor.b - SB; + + for i := 0 to 255 do + begin + FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); + YR := SR + round( DR / 255 * i ); + YG := SG + round( DG / 255 * i ); + YB := SB + round( DB / 255 * i ); + end; + + // if aStyle = 1 then begin + TempStepH := Rect.w / 255; + TempStepV := Rect.h / 255; + TempHeight := Trunc( TempStepV + 1 ); + TempWidth := Trunc( TempStepH + 1 ); + TempTop := 0; + TempLeft := 0; + TempRect.x := Rect.x; + TempRect.y := Rect.y; + TempRect.h := Rect.h; + TempRect.w := Rect.w; + + case Style of + gsHorizontal : + begin + TempRect.h := TempHeight; + for i := 0 to 255 do + begin + TempRect.y := Rect.y + TempTop; + SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); + TempTop := Trunc( TempStepV * i ); + end; + end; + gsVertical : + begin + TempRect.w := TempWidth; + for i := 0 to 255 do + begin + TempRect.x := Rect.x + TempLeft; + SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); + TempLeft := Trunc( TempStepH * i ); + end; + end; + end; +end; + +procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); +var + ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; + SrcPitch, DestPitch, x, y : UInt32; +begin + if ( Src = nil ) or ( Dest = nil ) then + exit; + if ( Src.w shl 1 ) < Dest.w then + exit; + if ( Src.h shl 1 ) < Dest.h then + exit; + + if SDL_MustLock( Src ) then + SDL_LockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_LockSurface( Dest ); + + ReadRow := PtrUInt( Src.Pixels ); + WriteRow := PtrUInt( Dest.Pixels ); + + SrcPitch := Src.pitch; + DestPitch := Dest.pitch; + + case Src.format.BytesPerPixel of + 1 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt8( WriteAddr )^ := PUInt8( ReadAddr )^; + PUInt8( WriteAddr + 1 )^ := PUInt8( ReadAddr )^; + PUInt8( WriteAddr + DestPitch )^ := PUInt8( ReadAddr )^; + PUInt8( WriteAddr + DestPitch + 1 )^ := PUInt8( ReadAddr )^; + inc( ReadAddr ); + inc( WriteAddr, 2 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 2 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt16( WriteAddr )^ := PUInt16( ReadAddr )^; + PUInt16( WriteAddr + 2 )^ := PUInt16( ReadAddr )^; + PUInt16( WriteAddr + DestPitch )^ := PUInt16( ReadAddr )^; + PUInt16( WriteAddr + DestPitch + 2 )^ := PUInt16( ReadAddr )^; + inc( ReadAddr, 2 ); + inc( WriteAddr, 4 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 3 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt32( WriteAddr )^ := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + PUInt32( WriteAddr + 3 )^ := ( PUInt32( WriteAddr + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + PUInt32( WriteAddr + DestPitch )^ := ( PUInt32( WriteAddr + DestPitch )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + PUInt32( WriteAddr + DestPitch + 3 )^ := ( PUInt32( WriteAddr + DestPitch + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + inc( ReadAddr, 3 ); + inc( WriteAddr, 6 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 4 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt32( WriteAddr )^ := PUInt32( ReadAddr )^; + PUInt32( WriteAddr + 4 )^ := PUInt32( ReadAddr )^; + PUInt32( WriteAddr + DestPitch )^ := PUInt32( ReadAddr )^; + PUInt32( WriteAddr + DestPitch + 4 )^ := PUInt32( ReadAddr )^; + inc( ReadAddr, 4 ); + inc( WriteAddr, 8 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + end; + + if SDL_MustLock( Src ) then + SDL_UnlockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_UnlockSurface( Dest ); +end; + +procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); +var + ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; + SrcPitch, DestPitch, x, y : UInt32; +begin + if ( Src = nil ) or ( Dest = nil ) then + exit; + if ( Src.w shl 1 ) < Dest.w then + exit; + if ( Src.h shl 1 ) < Dest.h then + exit; + + if SDL_MustLock( Src ) then + SDL_LockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_LockSurface( Dest ); + + ReadRow := PtrUInt( Src.Pixels ); + WriteRow := PtrUInt( Dest.Pixels ); + + SrcPitch := Src.pitch; + DestPitch := Dest.pitch; + + case Src.format.BytesPerPixel of + 1 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt8( WriteAddr )^ := PUInt8( ReadAddr )^; + PUInt8( WriteAddr + 1 )^ := PUInt8( ReadAddr )^; + inc( ReadAddr ); + inc( WriteAddr, 2 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 2 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt16( WriteAddr )^ := PUInt16( ReadAddr )^; + PUInt16( WriteAddr + 2 )^ := PUInt16( ReadAddr )^; + inc( ReadAddr, 2 ); + inc( WriteAddr, 4 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 3 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt32( WriteAddr )^ := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + PUInt32( WriteAddr + 3 )^ := ( PUInt32( WriteAddr + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + inc( ReadAddr, 3 ); + inc( WriteAddr, 6 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 4 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + PUInt32( WriteAddr )^ := PUInt32( ReadAddr )^; + PUInt32( WriteAddr + 4 )^ := PUInt32( ReadAddr )^; + inc( ReadAddr, 4 ); + inc( WriteAddr, 8 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + end; + + if SDL_MustLock( Src ) then + SDL_UnlockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_UnlockSurface( Dest ); +end; + +procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); +var + ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; + SrcPitch, DestPitch, x, y, Color : UInt32; +begin + if ( Src = nil ) or ( Dest = nil ) then + exit; + if ( Src.w shl 1 ) < Dest.w then + exit; + if ( Src.h shl 1 ) < Dest.h then + exit; + + if SDL_MustLock( Src ) then + SDL_LockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_LockSurface( Dest ); + + ReadRow := PtrUInt( Src.Pixels ); + WriteRow := PtrUInt( Dest.Pixels ); + + SrcPitch := Src.pitch; + DestPitch := Dest.pitch; + + case Src.format.BitsPerPixel of + 8 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + Color := PUInt8( ReadAddr )^; + PUInt8( WriteAddr )^ := Color; + PUInt8( WriteAddr + 1 )^ := Color; + Color := ( Color shr 1 ) and $6D; {%01101101} + PUInt8( WriteAddr + DestPitch )^ := Color; + PUInt8( WriteAddr + DestPitch + 1 )^ := Color; + inc( ReadAddr ); + inc( WriteAddr, 2 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 15 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + Color := PUInt16( ReadAddr )^; + PUInt16( WriteAddr )^ := Color; + PUInt16( WriteAddr + 2 )^ := Color; + Color := ( Color shr 1 ) and $3DEF; {%0011110111101111} + PUInt16( WriteAddr + DestPitch )^ := Color; + PUInt16( WriteAddr + DestPitch + 2 )^ := Color; + inc( ReadAddr, 2 ); + inc( WriteAddr, 4 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 16 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + Color := PUInt16( ReadAddr )^; + PUInt16( WriteAddr )^ := Color; + PUInt16( WriteAddr + 2 )^ := Color; + Color := ( Color shr 1 ) and $7BEF; {%0111101111101111} + PUInt16( WriteAddr + DestPitch )^ := Color; + PUInt16( WriteAddr + DestPitch + 2 )^ := Color; + inc( ReadAddr, 2 ); + inc( WriteAddr, 4 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 24 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + Color := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); + PUInt32( WriteAddr )^ := Color; + PUInt32( WriteAddr + 3 )^ := Color; + Color := ( Color shr 1 ) and $007F7F7F; {%011111110111111101111111} + PUInt32( WriteAddr + DestPitch )^ := Color; + PUInt32( WriteAddr + DestPitch + 3 )^ := Color; + inc( ReadAddr, 3 ); + inc( WriteAddr, 6 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + 32 : for y := 1 to Src.h do + begin + ReadAddr := ReadRow; + WriteAddr := WriteRow; + for x := 1 to Src.w do + begin + Color := PUInt32( ReadAddr )^; + PUInt32( WriteAddr )^ := Color; + PUInt32( WriteAddr + 4 )^ := Color; + Color := ( Color shr 1 ) and $7F7F7F7F; + PUInt32( WriteAddr + DestPitch )^ := Color; + PUInt32( WriteAddr + DestPitch + 4 )^ := Color; + inc( ReadAddr, 4 ); + inc( WriteAddr, 8 ); + end; + inc( PtrUInt( ReadRow ), SrcPitch ); + inc( PtrUInt( WriteRow ), DestPitch * 2 ); + end; + end; + + if SDL_MustLock( Src ) then + SDL_UnlockSurface( Src ); + if SDL_MustLock( Dest ) then + SDL_UnlockSurface( Dest ); +end; + +function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : + PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : + boolean; +var + Src_Rect1, Src_Rect2 : TSDL_Rect; + right1, bottom1 : integer; + right2, bottom2 : integer; + Scan1Start, {Scan2Start,} ScanWidth, ScanHeight : cardinal; + Mod1 : cardinal; + Addr1 : PtrUInt; + BPP : cardinal; + Pitch1 : cardinal; + TransparentColor1 : cardinal; + tx, ty : cardinal; +// StartTick : cardinal; // Auto Removed, Unused Variable + Color1 : cardinal; +begin + Result := false; + if SrcRect1 = nil then + begin + with Src_Rect1 do + begin + x := 0; + y := 0; + w := SrcSurface1.w; + h := SrcSurface1.h; + end; + end + else + Src_Rect1 := SrcRect1^; + + Src_Rect2 := SrcRect2^; + with Src_Rect1 do + begin + Right1 := Left1 + w; + Bottom1 := Top1 + h; + end; + with Src_Rect2 do + begin + Right2 := Left2 + w; + Bottom2 := Top2 + h; + end; + if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= Top2 ) then + exit; + if Left1 <= Left2 then + begin + // 1. left, 2. right + Scan1Start := Src_Rect1.x + Left2 - Left1; + //Scan2Start := Src_Rect2.x; + ScanWidth := Right1 - Left2; + with Src_Rect2 do + if ScanWidth > w then + ScanWidth := w; + end + else + begin + // 1. right, 2. left + Scan1Start := Src_Rect1.x; + //Scan2Start := Src_Rect2.x + Left1 - Left2; + ScanWidth := Right2 - Left1; + with Src_Rect1 do + if ScanWidth > w then + ScanWidth := w; + end; + with SrcSurface1^ do + begin + Pitch1 := Pitch; + Addr1 := PtrUInt( Pixels ); + inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); + with format^ do + begin + BPP := BytesPerPixel; + TransparentColor1 := colorkey; + end; + end; + + Mod1 := Pitch1 - ( ScanWidth * BPP ); + + inc( Addr1, BPP * Scan1Start ); + + if Top1 <= Top2 then + begin + // 1. up, 2. down + ScanHeight := Bottom1 - Top2; + if ScanHeight > Src_Rect2.h then + ScanHeight := Src_Rect2.h; + inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); + end + else + begin + // 1. down, 2. up + ScanHeight := Bottom2 - Top1; + if ScanHeight > Src_Rect1.h then + ScanHeight := Src_Rect1.h; + + end; + case BPP of + 1 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PByte( Addr1 )^ <> TransparentColor1 ) then + begin + Result := true; + exit; + end; + inc( Addr1 ); + + end; + inc( Addr1, Mod1 ); + + end; + 2 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PWord( Addr1 )^ <> TransparentColor1 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 2 ); + + end; + inc( Addr1, Mod1 ); + + end; + 3 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + Color1 := PLongWord( Addr1 )^ and $00FFFFFF; + + if ( Color1 <> TransparentColor1 ) + then + begin + Result := true; + exit; + end; + inc( Addr1, 3 ); + + end; + inc( Addr1, Mod1 ); + + end; + 4 : + for ty := 1 to ScanHeight do + begin + for tx := 1 to ScanWidth do + begin + if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then + begin + Result := true; + exit; + end; + inc( Addr1, 4 ); + + end; + inc( Addr1, Mod1 ); + + end; + end; +end; + +procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var +{*R, *}{*G, *}{*B, *}Pixel1, Pixel2, TransparentColor : cardinal; // Auto Removed, Unused Variable (R) // Auto Removed, Unused Variable (G) // Auto Removed, Unused Variable (B) + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + PUInt8( DestAddr )^ := Pixel2 or Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + + PUInt16( DestAddr )^ := Pixel2 or Pixel1; + + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + + PUInt16( DestAddr )^ := Pixel2 or Pixel1; + + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel2 or Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + + PUInt32( DestAddr )^ := Pixel2 or Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + +procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var +{*R, *}{*G, *}{*B, *}Pixel1, Pixel2, TransparentColor : cardinal; // Auto Removed, Unused Variable (R) // Auto Removed, Unused Variable (G) // Auto Removed, Unused Variable (B) + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + PUInt8( DestAddr )^ := Pixel2 and Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + + PUInt16( DestAddr )^ := Pixel2 and Pixel1; + + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + + PUInt16( DestAddr )^ := Pixel2 and Pixel1; + + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel2 and Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + + PUInt32( DestAddr )^ := Pixel2 and Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + + + +procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + if Pixel2 > 0 then + begin + if Pixel2 and $E0 > Pixel1 and $E0 then + R := Pixel2 and $E0 + else + R := Pixel1 and $E0; + if Pixel2 and $1C > Pixel1 and $1C then + G := Pixel2 and $1C + else + G := Pixel1 and $1C; + if Pixel2 and $03 > Pixel1 and $03 then + B := Pixel2 and $03 + else + B := Pixel1 and $03; + + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( DestAddr )^ := R or G or B; + end + else + PUInt8( DestAddr )^ := Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $7C00 > Pixel1 and $7C00 then + R := Pixel2 and $7C00 + else + R := Pixel1 and $7C00; + if Pixel2 and $03E0 > Pixel1 and $03E0 then + G := Pixel2 and $03E0 + else + G := Pixel1 and $03E0; + if Pixel2 and $001F > Pixel1 and $001F then + B := Pixel2 and $001F + else + B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $F800 > Pixel1 and $F800 then + R := Pixel2 and $F800 + else + R := Pixel1 and $F800; + if Pixel2 and $07E0 > Pixel1 and $07E0 then + G := Pixel2 and $07E0 + else + G := Pixel1 and $07E0; + if Pixel2 and $001F > Pixel1 and $001F then + B := Pixel2 and $001F + else + B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 > Pixel1 and $FF0000 then + R := Pixel2 and $FF0000 + else + R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 > Pixel1 and $00FF00 then + G := Pixel2 and $00FF00 + else + G := Pixel1 and $00FF00; + if Pixel2 and $0000FF > Pixel1 and $0000FF then + B := Pixel2 and $0000FF + else + B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); + end + else + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 > Pixel1 and $FF0000 then + R := Pixel2 and $FF0000 + else + R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 > Pixel1 and $00FF00 then + G := Pixel2 and $00FF00 + else + G := Pixel1 and $00FF00; + if Pixel2 and $0000FF > Pixel1 and $0000FF then + B := Pixel2 and $0000FF + else + B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := R or G or B; + end + else + PUInt32( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + + +procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; + DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); +var + R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; + Src, Dest : TSDL_Rect; + Diff : integer; + SrcAddr, DestAddr : PtrUInt; + WorkX, WorkY : word; + SrcMod, DestMod : cardinal; + Bits : cardinal; +begin + if ( SrcSurface = nil ) or ( DestSurface = nil ) then + exit; // Remove this to make it faster + if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then + exit; // Remove this to make it faster + if SrcRect = nil then + begin + with Src do + begin + x := 0; + y := 0; + w := SrcSurface.w; + h := SrcSurface.h; + end; + end + else + Src := SrcRect^; + if DestRect = nil then + begin + Dest.x := 0; + Dest.y := 0; + end + else + Dest := DestRect^; + Dest.w := Src.w; + Dest.h := Src.h; + with DestSurface.Clip_Rect do + begin + // Source's right side is greater than the dest.cliprect + if Dest.x + Src.w > x + w then + begin + smallint( Src.w ) := x + w - Dest.x; + smallint( Dest.w ) := x + w - Dest.x; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's bottom side is greater than the dest.clip + if Dest.y + Src.h > y + h then + begin + smallint( Src.h ) := y + h - Dest.y; + smallint( Dest.h ) := y + h - Dest.y; + if smallint( Dest.h ) < 1 then + exit; + end; + // Source's left side is less than the dest.clip + if Dest.x < x then + begin + Diff := x - Dest.x; + Src.x := Src.x + Diff; + smallint( Src.w ) := smallint( Src.w ) - Diff; + Dest.x := x; + smallint( Dest.w ) := smallint( Dest.w ) - Diff; + if smallint( Dest.w ) < 1 then + exit; + end; + // Source's Top side is less than the dest.clip + if Dest.y < y then + begin + Diff := y - Dest.y; + Src.y := Src.y + Diff; + smallint( Src.h ) := smallint( Src.h ) - Diff; + Dest.y := y; + smallint( Dest.h ) := smallint( Dest.h ) - Diff; + if smallint( Dest.h ) < 1 then + exit; + end; + end; + with SrcSurface^ do + begin + SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * + Format.BytesPerPixel; + SrcMod := Pitch - Src.w * Format.BytesPerPixel; + TransparentColor := Format.colorkey; + end; + with DestSurface^ do + begin + DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * + Format.BytesPerPixel; + DestMod := Pitch - Dest.w * Format.BytesPerPixel; + Bits := Format.BitsPerPixel; + end; + SDL_LockSurface( SrcSurface ); + SDL_LockSurface( DestSurface ); + WorkY := Src.h; + case bits of + 8 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt8( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt8( DestAddr )^; + if Pixel2 > 0 then + begin + if Pixel2 and $E0 < Pixel1 and $E0 then + R := Pixel2 and $E0 + else + R := Pixel1 and $E0; + if Pixel2 and $1C < Pixel1 and $1C then + G := Pixel2 and $1C + else + G := Pixel1 and $1C; + if Pixel2 and $03 < Pixel1 and $03 then + B := Pixel2 and $03 + else + B := Pixel1 and $03; + + if R > $E0 then + R := $E0; + if G > $1C then + G := $1C; + if B > $03 then + B := $03; + PUInt8( DestAddr )^ := R or G or B; + end + else + PUInt8( DestAddr )^ := Pixel1; + end; + inc( SrcAddr ); + inc( DestAddr ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 15 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $7C00 < Pixel1 and $7C00 then + R := Pixel2 and $7C00 + else + R := Pixel1 and $7C00; + if Pixel2 and $03E0 < Pixel1 and $03E0 then + G := Pixel2 and $03E0 + else + G := Pixel1 and $03E0; + if Pixel2 and $001F < Pixel1 and $001F then + B := Pixel2 and $001F + else + B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 16 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt16( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt16( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $F800 < Pixel1 and $F800 then + R := Pixel2 and $F800 + else + R := Pixel1 and $F800; + if Pixel2 and $07E0 < Pixel1 and $07E0 then + G := Pixel2 and $07E0 + else + G := Pixel1 and $07E0; + if Pixel2 and $001F < Pixel1 and $001F then + B := Pixel2 and $001F + else + B := Pixel1 and $001F; + + PUInt16( DestAddr )^ := R or G or B; + end + else + PUInt16( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 2 ); + inc( DestAddr, 2 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 24 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 < Pixel1 and $FF0000 then + R := Pixel2 and $FF0000 + else + R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 < Pixel1 and $00FF00 then + G := Pixel2 and $00FF00 + else + G := Pixel1 and $00FF00; + if Pixel2 and $0000FF < Pixel1 and $0000FF then + B := Pixel2 and $0000FF + else + B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); + end + else + PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; + end; + inc( SrcAddr, 3 ); + inc( DestAddr, 3 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + 32 : + begin + repeat + WorkX := Src.w; + repeat + Pixel1 := PUInt32( SrcAddr )^; + if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then + begin + Pixel2 := PUInt32( DestAddr )^; + if Pixel2 > 0 then + begin + + if Pixel2 and $FF0000 < Pixel1 and $FF0000 then + R := Pixel2 and $FF0000 + else + R := Pixel1 and $FF0000; + if Pixel2 and $00FF00 < Pixel1 and $00FF00 then + G := Pixel2 and $00FF00 + else + G := Pixel1 and $00FF00; + if Pixel2 and $0000FF < Pixel1 and $0000FF then + B := Pixel2 and $0000FF + else + B := Pixel1 and $0000FF; + + PUInt32( DestAddr )^ := R or G or B; + end + else + PUInt32( DestAddr )^ := Pixel1; + end; + inc( SrcAddr, 4 ); + inc( DestAddr, 4 ); + dec( WorkX ); + until WorkX = 0; + inc( SrcAddr, SrcMod ); + inc( DestAddr, DestMod ); + dec( WorkY ); + until WorkY = 0; + end; + end; + SDL_UnlockSurface( SrcSurface ); + SDL_UnlockSurface( DestSurface ); +end; + +// Will clip the x1,x2,y1,x2 params to the ClipRect provided + +function SDL_ClipLine( var x1, y1, x2, y2 : Integer; ClipRect : PSDL_Rect ) : boolean; +var + tflag, flag1, flag2 : word; + txy, xedge, yedge : Integer; + slope : single; + + function ClipCode( x, y : Integer ) : word; + begin + Result := 0; + if x < ClipRect.x then + Result := 1; + if x >= ClipRect.w + ClipRect.x then + Result := Result or 2; + if y < ClipRect.y then + Result := Result or 4; + if y >= ClipRect.h + ClipRect.y then + Result := Result or 8; + end; + +begin + flag1 := ClipCode( x1, y1 ); + flag2 := ClipCode( x2, y2 ); + result := true; + + while true do + begin + if ( flag1 or flag2 ) = 0 then + Exit; // all in + + if ( flag1 and flag2 ) <> 0 then + begin + result := false; + Exit; // all out + end; + + if flag2 = 0 then + begin + txy := x1; x1 := x2; x2 := txy; + txy := y1; y1 := y2; y2 := txy; + tflag := flag1; flag1 := flag2; flag2 := tflag; + end; + + if ( flag2 and 3 ) <> 0 then + begin + if ( flag2 and 1 ) <> 0 then + xedge := ClipRect.x + else + xedge := ClipRect.w + ClipRect.x - 1; // back 1 pixel otherwise we end up in a loop + + slope := ( y2 - y1 ) / ( x2 - x1 ); + y2 := y1 + Round( slope * ( xedge - x1 ) ); + x2 := xedge; + end + else + begin + if ( flag2 and 4 ) <> 0 then + yedge := ClipRect.y + else + yedge := ClipRect.h + ClipRect.y - 1; // up 1 pixel otherwise we end up in a loop + + slope := ( x2 - x1 ) / ( y2 - y1 ); + x2 := x1 + Round( slope * ( yedge - y1 ) ); + y2 := yedge; + end; + + flag2 := ClipCode( x2, y2 ); + end; +end; + +end. + diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas index ba60714b..99eea304 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas @@ -1,566 +1,566 @@ -unit sdlwindow; -{ - $Id: sdlwindow.pas,v 1.9 2006/10/22 18:55:25 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ SDL Window Wrapper } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2004 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ SDL Window Wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ January 31 2003 - DL : Initial creation } -{ } -{ - $Log: sdlwindow.pas,v $ - Revision 1.9 2006/10/22 18:55:25 savage - Slight Change to handle OpenGL context - - Revision 1.8 2005/08/03 18:57:32 savage - Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class - - Revision 1.7 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - Revision 1.6 2004/09/12 21:52:58 savage - Slight changes to fix some issues with the sdl classes. - - Revision 1.5 2004/05/10 21:11:49 savage - changes required to help get SoAoS off the ground. - - Revision 1.4 2004/05/01 14:59:27 savage - Updated code - - Revision 1.3 2004/04/23 10:45:28 savage - Changes made by Dean Ellis to work more modularly. - - Revision 1.2 2004/03/31 10:06:41 savage - Changed so that it now compiles, but is untested. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - -} -{******************************************************************************} - -interface - -{$i jedi-sdl.inc} - -uses - Classes, - sdl, - sdlinput, - sdlticks; - -type - TSDLNotifyEvent = procedure {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLUpdateEvent = procedure( aElapsedTime : single ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLResizeEvent = procedure( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLUserEvent = procedure( aType : UInt8; aCode : integer; aData1 : Pointer; aData2 : Pointer ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLActiveEvent = procedure( aGain: UInt8; aState: UInt8 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - TSDLBaseWindow = class( TObject ) - private - FDisplaySurface : PSDL_Surface; - FVideoFlags : Uint32; - FOnDestroy: TSDLNotifyEvent; - FOnCreate: TSDLNotifyEvent; - FOnShow: TSDLNotifyEvent; - FOnResize: TSDLResizeEvent; - FOnUpdate: TSDLUpdateEvent; - FOnRender: TSDLNotifyEvent; - FOnClose: TSDLNotifyEvent; - FLoaded: Boolean; - FRendering: Boolean; - FHeight: integer; - FBitDepth: integer; - FWidth: integer; - FInputManager: TSDLInputManager; - FCaptionText : PChar; - FIconName : PChar; - FOnActive: TSDLActiveEvent; - FOnQuit: TSDLNotifyEvent; - FOnExpose: TSDLNotifyEvent; - FOnUser: TSDLUserEvent; - FTimer : TSDLTicks; - protected - procedure DoActive( aGain: UInt8; aState: UInt8 ); - procedure DoCreate; - procedure DoClose; - procedure DoDestroy; - procedure DoUpdate( aElapsedTime : single ); - procedure DoQuit; - procedure DoRender; - procedure DoResize( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); - procedure DoShow; - procedure DoUser( aType : UInt8; aCode : integer; aData1 : Pointer; aData2 : Pointer ); - procedure DoExpose; - procedure Render; virtual; - procedure Update( aElapsedTime : single ); virtual; - procedure InitialiseObjects; virtual; - procedure RestoreObjects; virtual; - procedure DeleteObjects; virtual; - function Flip : integer; virtual; - property OnActive : TSDLActiveEvent read FOnActive write FOnActive; - property OnClose: TSDLNotifyEvent read FOnClose write FOnClose; - property OnDestroy : TSDLNotifyEvent read FOnDestroy write FOnDestroy; - property OnCreate : TSDLNotifyEvent read FOnCreate write FOnCreate; - property OnUpdate: TSDLUpdateEvent read FOnUpdate write FOnUpdate; - property OnQuit : TSDLNotifyEvent read FOnQuit write FOnQuit; - property OnResize : TSDLResizeEvent read FOnResize write FOnResize; - property OnRender: TSDLNotifyEvent read FOnRender write FOnRender; - property OnShow : TSDLNotifyEvent read FOnShow write FOnShow; - property OnUser : TSDLUserEvent read FOnUser write FOnUser; - property OnExpose : TSDLNotifyEvent read FOnExpose write FOnExpose; - property DisplaySurface: PSDL_Surface read FDisplaySurface; - public - property InputManager : TSDLInputManager read FInputManager; - property Loaded : Boolean read FLoaded; - property Width : integer read FWidth; - property Height : integer read FHeight; - property BitDepth : integer read FBitDepth; - property Rendering : Boolean read FRendering write FRendering; - procedure SetCaption( const aCaptionText : string; const aIconName : string ); - procedure GetCaption( var aCaptionText : string; var aIconName : string ); - procedure SetIcon( aIcon : PSDL_Surface; aMask: UInt8 ); - procedure ActivateVideoMode; - constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); virtual; - destructor Destroy; override; - procedure InitialiseEnvironment; - function Show : Boolean; virtual; - end; - - TSDLCustomWindow = class( TSDLBaseWindow ) - public - property OnCreate; - property OnDestroy; - property OnClose; - property OnShow; - property OnResize; - property OnRender; - property OnUpdate; - property DisplaySurface; - end; - - TSDL2DWindow = class( TSDLCustomWindow ) - public - constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 = SDL_DOUBLEBUF or SDL_SWSURFACE); override; - procedure Render; override; - procedure Update( aElapsedTime : single ); override; - procedure InitialiseObjects; override; - procedure RestoreObjects; override; - procedure DeleteObjects; override; - function Flip : integer; override; - end; - - TSDL3DWindow = class( TSDLCustomWindow ) - public - constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 = SDL_OPENGL or SDL_DOUBLEBUF); override; - function Flip : integer; override; - procedure Render; override; - procedure Update( aElapsedTime : single ); override; - procedure InitialiseObjects; override; - procedure RestoreObjects; override; - procedure DeleteObjects; override; - end; - - - -implementation - -uses - logger, - SysUtils; - -{ TSDLBaseWindow } -procedure TSDLBaseWindow.ActivateVideoMode; -begin - FDisplaySurface := SDL_SetVideoMode( FWidth, FHeight, FBitDepth, FVideoFlags); - if (FDisplaySurface = nil) then - begin - Log.LogError( Format('Could not set video mode: %s', [SDL_GetError]), 'Main'); - exit; - end; - - SetCaption( 'Made with JEDI-SDL', 'JEDI-SDL Icon' ); -end; - -constructor TSDLBaseWindow.Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); -begin - inherited Create; - SDL_Init(SDL_INIT_EVERYTHING); - FInputManager := TSDLInputManager.Create( [ itJoystick, itKeyBoard, itMouse ]); - FTimer := TSDLTicks.Create; - - FWidth := aWidth; - FHeight := aHeight; - FBitDepth := aBitDepth; - FVideoFlags := aVideoFlags; - - DoCreate; -end; - -procedure TSDLBaseWindow.DeleteObjects; -begin - FLoaded := False; -end; - -destructor TSDLBaseWindow.Destroy; -begin - DoDestroy; - if FLoaded then - DeleteObjects; - if FInputManager <> nil then - FreeAndNil( FInputManager ); - if FTimer <> nil then - FreeAndNil( FTimer ); - if FDisplaySurface <> nil then - SDL_FreeSurface( FDisplaySurface ); - inherited Destroy; - SDL_Quit; -end; - -procedure TSDLBaseWindow.DoActive(aGain, aState: UInt8); -begin - if Assigned( FOnActive ) then - begin - FOnActive( aGain, aState ); - end; -end; - -procedure TSDLBaseWindow.DoClose; -begin - if Assigned( FOnClose ) then - begin - FOnClose; - end; -end; - -procedure TSDLBaseWindow.DoCreate; -begin - if Assigned( FOnCreate ) then - begin - FOnCreate; - end; -end; - -procedure TSDLBaseWindow.DoDestroy; -begin - if Assigned( FOnDestroy ) then - begin - FOnDestroy; - end; -end; - -procedure TSDLBaseWindow.DoExpose; -begin - if Assigned( FOnExpose ) then - begin - FOnExpose; - end; -end; - -procedure TSDLBaseWindow.DoUpdate( aElapsedTime : single ); -begin - if Assigned( FOnUpdate ) then - begin - FOnUpdate( aElapsedTime ); - end; -end; - -procedure TSDLBaseWindow.DoQuit; -begin - FRendering := false; - if Assigned( FOnQuit ) then - begin - FOnQuit; - end; -end; - -procedure TSDLBaseWindow.DoRender; -begin - if Assigned( FOnRender ) then - begin - FOnRender; - end; -end; - -procedure TSDLBaseWindow.DoResize( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); -begin - // resize to the new size - SDL_FreeSurface(FDisplaySurface); - FWidth := aWidth; - FHeight := aHeight; - FBitDepth := aBitDepth; - FVideoFlags := aVideoFlags; - FDisplaySurface := SDL_SetVideoMode(aWidth, aHeight, aBitDepth, aVideoFlags); - if Assigned( FOnResize ) then - begin - FOnResize( aWidth, aHeight, aBitDepth, aVideoFlags ); - end; -end; - -procedure TSDLBaseWindow.DoShow; -begin - if Assigned( FOnShow ) then - begin - FOnShow; - end; -end; - -procedure TSDLBaseWindow.DoUser(aType: UInt8; aCode: integer; aData1, aData2: Pointer); -begin - if Assigned( FOnUser ) then - begin - FOnUser( aType, aCode, aData1, aData2 ); - end; -end; - -function TSDLBaseWindow.Flip : integer; -begin - result := 0; -end; - -procedure TSDLBaseWindow.GetCaption( var aCaptionText : string; var aIconName : string ); -begin - aCaptionText := string( FCaptionText ); - aIconName := string( FIconName ); -end; - -procedure TSDLBaseWindow.InitialiseEnvironment; -begin - InitialiseObjects; - RestoreObjects; -end; - -procedure TSDLBaseWindow.InitialiseObjects; -begin - FLoaded := True; -end; - -procedure TSDLBaseWindow.Update( aElapsedTime : single ); -begin - DoUpdate( aElapsedTime ); -end; - -procedure TSDLBaseWindow.Render; -begin - DoRender; -end; - -procedure TSDLBaseWindow.RestoreObjects; -begin - FLoaded := false; -end; - -procedure TSDLBaseWindow.SetCaption( const aCaptionText : string; const aIconName : string ); -begin - if FCaptionText <> aCaptionText then - begin - FCaptionText := PChar( aCaptionText ); - FIconName := PChar( aIconName ); - SDL_WM_SetCaption( FCaptionText, FIconName ); - end; -end; - -procedure TSDLBaseWindow.SetIcon(aIcon: PSDL_Surface; aMask: UInt8); -begin - SDL_WM_SetIcon( aIcon, aMask ); -end; - -function TSDLBaseWindow.Show : Boolean; -var - eBaseWindowEvent : TSDL_Event; -begin - DoShow; - - FTimer.Init; - - FRendering := true; - // repeat until we are told not to render - while FRendering do - begin - // wait for an event - while SDL_PollEvent( @eBaseWindowEvent ) > 0 do - begin - - // check for a quit event - case eBaseWindowEvent.type_ of - SDL_ACTIVEEVENT : - begin - DoActive( eBaseWindowEvent.active.gain, eBaseWindowEvent.active.state ); - end; - - SDL_QUITEV : - begin - DoQuit; - DoClose; - end; - - SDL_USEREVENT : - begin - DoUser( eBaseWindowEvent.user.type_, eBaseWindowEvent.user.code, eBaseWindowEvent.user.data1, eBaseWindowEvent.user.data2 ); - end; - - SDL_VIDEOEXPOSE : - begin - DoExpose; - end; - - SDL_VIDEORESIZE : - begin - DoResize( eBaseWindowEvent.resize.w, eBaseWindowEvent.resize.h, FDisplaySurface.format.BitsPerPixel, FVideoflags ); - end; - - - end; - InputManager.UpdateInputs( eBaseWindowEvent ); - end; - // Prepare the Next Frame - Update( FTimer.GetElapsedSeconds ); - // Display the Next Frame - Render; - // Flip the surfaces - Flip; - end; - - Result := FRendering; -end; - -{ TSDL2DWindow } - -constructor TSDL2DWindow.Create(aWidth, aHeight, aBitDepth: integer; aVideoFlags: Uint32); -begin - // make sure double buffer is always included in the video flags - inherited Create(aWidth,aHeight, aBitDepth, aVideoFlags or SDL_DOUBLEBUF); -end; - -procedure TSDL2DWindow.DeleteObjects; -begin - inherited; - -end; - -function TSDL2DWindow.Flip: integer; -begin - // let's show the back buffer - result := SDL_Flip( FDisplaySurface ); -end; - -procedure TSDL2DWindow.InitialiseObjects; -begin - inherited; - -end; - -procedure TSDL2DWindow.Update( aElapsedTime : single ); -begin - inherited; - -end; - -procedure TSDL2DWindow.Render; -begin - inherited; - -end; - -procedure TSDL2DWindow.RestoreObjects; -begin - inherited; - -end; - -{ TSDL3DWindow } - -constructor TSDL3DWindow.Create(aWidth, - aHeight, aBitDepth: integer; aVideoFlags: Uint32); -begin - // make sure opengl is always included in the video flags - inherited Create(aWidth,aHeight, aBitDepth, aVideoFlags or SDL_OPENGL or SDL_DOUBLEBUF); -end; - -procedure TSDL3DWindow.DeleteObjects; -begin - inherited; - -end; - -function TSDL3DWindow.Flip : integer; -begin - SDL_GL_SwapBuffers; - result := 0; -end; - -procedure TSDL3DWindow.InitialiseObjects; -begin - inherited; - -end; - -procedure TSDL3DWindow.Update( aElapsedTime : single ); -begin - inherited; - -end; - -procedure TSDL3DWindow.Render; -begin - inherited; - -end; - -procedure TSDL3DWindow.RestoreObjects; -begin - inherited; - -end; - -end. +unit sdlwindow; +{ + $Id: sdlwindow.pas,v 1.9 2006/10/22 18:55:25 savage Exp $ + +} +{******************************************************************************} +{ } +{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } +{ SDL Window Wrapper } +{ } +{ } +{ The initial developer of this Pascal code was : } +{ Dominique Louis } +{ } +{ Portions created by Dominique Louis are } +{ Copyright (C) 2004 - 2100 Dominique Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ Dominique Louis } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ SDL Window Wrapper } +{ } +{ } +{ Requires } +{ -------- } +{ SDL.dll on Windows platforms } +{ libSDL-1.1.so.0 on Linux platform } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ January 31 2003 - DL : Initial creation } +{ } +{ + $Log: sdlwindow.pas,v $ + Revision 1.9 2006/10/22 18:55:25 savage + Slight Change to handle OpenGL context + + Revision 1.8 2005/08/03 18:57:32 savage + Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class + + Revision 1.7 2004/09/30 22:35:47 savage + Changes, enhancements and additions as required to get SoAoS working. + + Revision 1.6 2004/09/12 21:52:58 savage + Slight changes to fix some issues with the sdl classes. + + Revision 1.5 2004/05/10 21:11:49 savage + changes required to help get SoAoS off the ground. + + Revision 1.4 2004/05/01 14:59:27 savage + Updated code + + Revision 1.3 2004/04/23 10:45:28 savage + Changes made by Dean Ellis to work more modularly. + + Revision 1.2 2004/03/31 10:06:41 savage + Changed so that it now compiles, but is untested. + + Revision 1.1 2004/02/05 00:08:20 savage + Module 1.0 release + +} +{******************************************************************************} + +interface + +{$i jedi-sdl.inc} + +uses + Classes, + sdl, + sdlinput, + sdlticks; + +type + TSDLNotifyEvent = procedure {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLUpdateEvent = procedure( aElapsedTime : single ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLResizeEvent = procedure( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLUserEvent = procedure( aType : UInt8; aCode : integer; aData1 : Pointer; aData2 : Pointer ) {$IFNDEF NOT_OO}of object{$ENDIF}; + TSDLActiveEvent = procedure( aGain: UInt8; aState: UInt8 ) {$IFNDEF NOT_OO}of object{$ENDIF}; + + TSDLBaseWindow = class( TObject ) + private + FDisplaySurface : PSDL_Surface; + FVideoFlags : Uint32; + FOnDestroy: TSDLNotifyEvent; + FOnCreate: TSDLNotifyEvent; + FOnShow: TSDLNotifyEvent; + FOnResize: TSDLResizeEvent; + FOnUpdate: TSDLUpdateEvent; + FOnRender: TSDLNotifyEvent; + FOnClose: TSDLNotifyEvent; + FLoaded: Boolean; + FRendering: Boolean; + FHeight: integer; + FBitDepth: integer; + FWidth: integer; + FInputManager: TSDLInputManager; + FCaptionText : PChar; + FIconName : PChar; + FOnActive: TSDLActiveEvent; + FOnQuit: TSDLNotifyEvent; + FOnExpose: TSDLNotifyEvent; + FOnUser: TSDLUserEvent; + FTimer : TSDLTicks; + protected + procedure DoActive( aGain: UInt8; aState: UInt8 ); + procedure DoCreate; + procedure DoClose; + procedure DoDestroy; + procedure DoUpdate( aElapsedTime : single ); + procedure DoQuit; + procedure DoRender; + procedure DoResize( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); + procedure DoShow; + procedure DoUser( aType : UInt8; aCode : integer; aData1 : Pointer; aData2 : Pointer ); + procedure DoExpose; + procedure Render; virtual; + procedure Update( aElapsedTime : single ); virtual; + procedure InitialiseObjects; virtual; + procedure RestoreObjects; virtual; + procedure DeleteObjects; virtual; + function Flip : integer; virtual; + property OnActive : TSDLActiveEvent read FOnActive write FOnActive; + property OnClose: TSDLNotifyEvent read FOnClose write FOnClose; + property OnDestroy : TSDLNotifyEvent read FOnDestroy write FOnDestroy; + property OnCreate : TSDLNotifyEvent read FOnCreate write FOnCreate; + property OnUpdate: TSDLUpdateEvent read FOnUpdate write FOnUpdate; + property OnQuit : TSDLNotifyEvent read FOnQuit write FOnQuit; + property OnResize : TSDLResizeEvent read FOnResize write FOnResize; + property OnRender: TSDLNotifyEvent read FOnRender write FOnRender; + property OnShow : TSDLNotifyEvent read FOnShow write FOnShow; + property OnUser : TSDLUserEvent read FOnUser write FOnUser; + property OnExpose : TSDLNotifyEvent read FOnExpose write FOnExpose; + property DisplaySurface: PSDL_Surface read FDisplaySurface; + public + property InputManager : TSDLInputManager read FInputManager; + property Loaded : Boolean read FLoaded; + property Width : integer read FWidth; + property Height : integer read FHeight; + property BitDepth : integer read FBitDepth; + property Rendering : Boolean read FRendering write FRendering; + procedure SetCaption( const aCaptionText : string; const aIconName : string ); + procedure GetCaption( var aCaptionText : string; var aIconName : string ); + procedure SetIcon( aIcon : PSDL_Surface; aMask: UInt8 ); + procedure ActivateVideoMode; + constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); virtual; + destructor Destroy; override; + procedure InitialiseEnvironment; + function Show : Boolean; virtual; + end; + + TSDLCustomWindow = class( TSDLBaseWindow ) + public + property OnCreate; + property OnDestroy; + property OnClose; + property OnShow; + property OnResize; + property OnRender; + property OnUpdate; + property DisplaySurface; + end; + + TSDL2DWindow = class( TSDLCustomWindow ) + public + constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 = SDL_DOUBLEBUF or SDL_SWSURFACE); override; + procedure Render; override; + procedure Update( aElapsedTime : single ); override; + procedure InitialiseObjects; override; + procedure RestoreObjects; override; + procedure DeleteObjects; override; + function Flip : integer; override; + end; + + TSDL3DWindow = class( TSDLCustomWindow ) + public + constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 = SDL_OPENGL or SDL_DOUBLEBUF); override; + function Flip : integer; override; + procedure Render; override; + procedure Update( aElapsedTime : single ); override; + procedure InitialiseObjects; override; + procedure RestoreObjects; override; + procedure DeleteObjects; override; + end; + + + +implementation + +uses + logger, + SysUtils; + +{ TSDLBaseWindow } +procedure TSDLBaseWindow.ActivateVideoMode; +begin + FDisplaySurface := SDL_SetVideoMode( FWidth, FHeight, FBitDepth, FVideoFlags); + if (FDisplaySurface = nil) then + begin + Log.LogError( Format('Could not set video mode: %s', [SDL_GetError]), 'Main'); + exit; + end; + + SetCaption( 'Made with JEDI-SDL', 'JEDI-SDL Icon' ); +end; + +constructor TSDLBaseWindow.Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); +begin + inherited Create; + SDL_Init(SDL_INIT_EVERYTHING); + FInputManager := TSDLInputManager.Create( [ itJoystick, itKeyBoard, itMouse ]); + FTimer := TSDLTicks.Create; + + FWidth := aWidth; + FHeight := aHeight; + FBitDepth := aBitDepth; + FVideoFlags := aVideoFlags; + + DoCreate; +end; + +procedure TSDLBaseWindow.DeleteObjects; +begin + FLoaded := False; +end; + +destructor TSDLBaseWindow.Destroy; +begin + DoDestroy; + if FLoaded then + DeleteObjects; + if FInputManager <> nil then + FreeAndNil( FInputManager ); + if FTimer <> nil then + FreeAndNil( FTimer ); + if FDisplaySurface <> nil then + SDL_FreeSurface( FDisplaySurface ); + inherited Destroy; + SDL_Quit; +end; + +procedure TSDLBaseWindow.DoActive(aGain, aState: UInt8); +begin + if Assigned( FOnActive ) then + begin + FOnActive( aGain, aState ); + end; +end; + +procedure TSDLBaseWindow.DoClose; +begin + if Assigned( FOnClose ) then + begin + FOnClose; + end; +end; + +procedure TSDLBaseWindow.DoCreate; +begin + if Assigned( FOnCreate ) then + begin + FOnCreate; + end; +end; + +procedure TSDLBaseWindow.DoDestroy; +begin + if Assigned( FOnDestroy ) then + begin + FOnDestroy; + end; +end; + +procedure TSDLBaseWindow.DoExpose; +begin + if Assigned( FOnExpose ) then + begin + FOnExpose; + end; +end; + +procedure TSDLBaseWindow.DoUpdate( aElapsedTime : single ); +begin + if Assigned( FOnUpdate ) then + begin + FOnUpdate( aElapsedTime ); + end; +end; + +procedure TSDLBaseWindow.DoQuit; +begin + FRendering := false; + if Assigned( FOnQuit ) then + begin + FOnQuit; + end; +end; + +procedure TSDLBaseWindow.DoRender; +begin + if Assigned( FOnRender ) then + begin + FOnRender; + end; +end; + +procedure TSDLBaseWindow.DoResize( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); +begin + // resize to the new size + SDL_FreeSurface(FDisplaySurface); + FWidth := aWidth; + FHeight := aHeight; + FBitDepth := aBitDepth; + FVideoFlags := aVideoFlags; + FDisplaySurface := SDL_SetVideoMode(aWidth, aHeight, aBitDepth, aVideoFlags); + if Assigned( FOnResize ) then + begin + FOnResize( aWidth, aHeight, aBitDepth, aVideoFlags ); + end; +end; + +procedure TSDLBaseWindow.DoShow; +begin + if Assigned( FOnShow ) then + begin + FOnShow; + end; +end; + +procedure TSDLBaseWindow.DoUser(aType: UInt8; aCode: integer; aData1, aData2: Pointer); +begin + if Assigned( FOnUser ) then + begin + FOnUser( aType, aCode, aData1, aData2 ); + end; +end; + +function TSDLBaseWindow.Flip : integer; +begin + result := 0; +end; + +procedure TSDLBaseWindow.GetCaption( var aCaptionText : string; var aIconName : string ); +begin + aCaptionText := string( FCaptionText ); + aIconName := string( FIconName ); +end; + +procedure TSDLBaseWindow.InitialiseEnvironment; +begin + InitialiseObjects; + RestoreObjects; +end; + +procedure TSDLBaseWindow.InitialiseObjects; +begin + FLoaded := True; +end; + +procedure TSDLBaseWindow.Update( aElapsedTime : single ); +begin + DoUpdate( aElapsedTime ); +end; + +procedure TSDLBaseWindow.Render; +begin + DoRender; +end; + +procedure TSDLBaseWindow.RestoreObjects; +begin + FLoaded := false; +end; + +procedure TSDLBaseWindow.SetCaption( const aCaptionText : string; const aIconName : string ); +begin + if FCaptionText <> aCaptionText then + begin + FCaptionText := PChar( aCaptionText ); + FIconName := PChar( aIconName ); + SDL_WM_SetCaption( FCaptionText, FIconName ); + end; +end; + +procedure TSDLBaseWindow.SetIcon(aIcon: PSDL_Surface; aMask: UInt8); +begin + SDL_WM_SetIcon( aIcon, aMask ); +end; + +function TSDLBaseWindow.Show : Boolean; +var + eBaseWindowEvent : TSDL_Event; +begin + DoShow; + + FTimer.Init; + + FRendering := true; + // repeat until we are told not to render + while FRendering do + begin + // wait for an event + while SDL_PollEvent( @eBaseWindowEvent ) > 0 do + begin + + // check for a quit event + case eBaseWindowEvent.type_ of + SDL_ACTIVEEVENT : + begin + DoActive( eBaseWindowEvent.active.gain, eBaseWindowEvent.active.state ); + end; + + SDL_QUITEV : + begin + DoQuit; + DoClose; + end; + + SDL_USEREVENT : + begin + DoUser( eBaseWindowEvent.user.type_, eBaseWindowEvent.user.code, eBaseWindowEvent.user.data1, eBaseWindowEvent.user.data2 ); + end; + + SDL_VIDEOEXPOSE : + begin + DoExpose; + end; + + SDL_VIDEORESIZE : + begin + DoResize( eBaseWindowEvent.resize.w, eBaseWindowEvent.resize.h, FDisplaySurface.format.BitsPerPixel, FVideoflags ); + end; + + + end; + InputManager.UpdateInputs( eBaseWindowEvent ); + end; + // Prepare the Next Frame + Update( FTimer.GetElapsedSeconds ); + // Display the Next Frame + Render; + // Flip the surfaces + Flip; + end; + + Result := FRendering; +end; + +{ TSDL2DWindow } + +constructor TSDL2DWindow.Create(aWidth, aHeight, aBitDepth: integer; aVideoFlags: Uint32); +begin + // make sure double buffer is always included in the video flags + inherited Create(aWidth,aHeight, aBitDepth, aVideoFlags or SDL_DOUBLEBUF); +end; + +procedure TSDL2DWindow.DeleteObjects; +begin + inherited; + +end; + +function TSDL2DWindow.Flip: integer; +begin + // let's show the back buffer + result := SDL_Flip( FDisplaySurface ); +end; + +procedure TSDL2DWindow.InitialiseObjects; +begin + inherited; + +end; + +procedure TSDL2DWindow.Update( aElapsedTime : single ); +begin + inherited; + +end; + +procedure TSDL2DWindow.Render; +begin + inherited; + +end; + +procedure TSDL2DWindow.RestoreObjects; +begin + inherited; + +end; + +{ TSDL3DWindow } + +constructor TSDL3DWindow.Create(aWidth, + aHeight, aBitDepth: integer; aVideoFlags: Uint32); +begin + // make sure opengl is always included in the video flags + inherited Create(aWidth,aHeight, aBitDepth, aVideoFlags or SDL_OPENGL or SDL_DOUBLEBUF); +end; + +procedure TSDL3DWindow.DeleteObjects; +begin + inherited; + +end; + +function TSDL3DWindow.Flip : integer; +begin + SDL_GL_SwapBuffers; + result := 0; +end; + +procedure TSDL3DWindow.InitialiseObjects; +begin + inherited; + +end; + +procedure TSDL3DWindow.Update( aElapsedTime : single ); +begin + inherited; + +end; + +procedure TSDL3DWindow.Render; +begin + inherited; + +end; + +procedure TSDL3DWindow.RestoreObjects; +begin + inherited; + +end; + +end. diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas index 97e26520..aed326d1 100644 --- a/Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas @@ -1,159 +1,159 @@ -unit userpreferences; -{ - $Id: userpreferences.pas,v 1.1 2004/09/30 22:35:47 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Base Class for User Preferences } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ 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. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: userpreferences.pas,v $ - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - Classes; - -type - TUserPreferences = class - private - FAutoSave: Boolean; - procedure CheckAutoSave; - protected - function GetDefaultBoolean( const Index : Integer ) : Boolean; virtual; abstract; - function GetBoolean( const Index : Integer ) : Boolean; virtual; abstract; - procedure SetBoolean( const Index : Integer; const Value : Boolean ); virtual; - function GetDefaultDateTime( const Index : Integer ) : TDateTime; virtual; abstract; - function GetDateTime( const Index : Integer ) : TDateTime; virtual; abstract; - procedure SetDateTime( const Index : Integer; const Value : TDateTime ); virtual; - function GetDefaultInteger( const Index : Integer ) : Integer; virtual; abstract; - function GetInteger( const Index : Integer ) : Integer; virtual; abstract; - procedure SetInteger( const Index : Integer; const Value : Integer ); virtual; - function GetDefaultFloat( const Index : Integer ) : single; virtual; abstract; - function GetFloat( const Index : Integer ) : single; virtual; abstract; - procedure SetFloat( const Index : Integer; const Value : single ); virtual; - function GetDefaultString( const Index : Integer ) : string; virtual; abstract; - function GetString( const Index : Integer ) : string; virtual; abstract; - procedure SetString( const Index : Integer; const Value : string ); virtual; - function GetDefaultBinaryStream( const Index : Integer ) : TStream; virtual; abstract; - function GetBinaryStream( const Index : Integer ) : TStream; virtual; abstract; - procedure SetBinaryStream( const Index : Integer; const Value : TStream ); virtual; - public - procedure Update; virtual; abstract; - constructor Create; virtual; - destructor Destroy; override; - property AutoSave : Boolean read FAutoSave write FAutoSave; - end; - -implementation - -{ TUserPreferences } -procedure TUserPreferences.CheckAutoSave; -begin - if FAutoSave then - Update; -end; - -constructor TUserPreferences.Create; -begin - inherited; - FAutoSave := false; -end; - -destructor TUserPreferences.Destroy; -begin - - inherited; -end; - -procedure TUserPreferences.SetBinaryStream( const Index : Integer; const Value : TStream ); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetBoolean(const Index: Integer; const Value: Boolean); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetDateTime(const Index: Integer; const Value: TDateTime); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetFloat(const Index: Integer; const Value: single); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetInteger(const Index, Value: Integer); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetString(const Index: Integer; const Value: string); -begin - CheckAutoSave; -end; - -end. +unit userpreferences; +{ + $Id: userpreferences.pas,v 1.1 2004/09/30 22:35:47 savage Exp $ + +} +{******************************************************************************} +{ } +{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } +{ Base Class for User Preferences } +{ } +{ The initial developer of this Pascal code was : } +{ Dominqiue Louis } +{ } +{ Portions created by Dominqiue Louis are } +{ Copyright (C) 2000 - 2001 Dominqiue Louis. } +{ } +{ } +{ Contributor(s) } +{ -------------- } +{ } +{ } +{ Obtained through: } +{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } +{ } +{ You may retrieve the latest version of this file at the Project } +{ JEDI home page, located at http://delphi-jedi.org } +{ } +{ 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. } +{ } +{ Description } +{ ----------- } +{ } +{ } +{ } +{ } +{ } +{ } +{ } +{ Requires } +{ -------- } +{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } +{ They are available from... } +{ http://www.libsdl.org . } +{ } +{ Programming Notes } +{ ----------------- } +{ } +{ } +{ } +{ } +{ Revision History } +{ ---------------- } +{ September 23 2004 - DL : Initial Creation } +{ + $Log: userpreferences.pas,v $ + Revision 1.1 2004/09/30 22:35:47 savage + Changes, enhancements and additions as required to get SoAoS working. + + +} +{******************************************************************************} + +interface + +uses + Classes; + +type + TUserPreferences = class + private + FAutoSave: Boolean; + procedure CheckAutoSave; + protected + function GetDefaultBoolean( const Index : Integer ) : Boolean; virtual; abstract; + function GetBoolean( const Index : Integer ) : Boolean; virtual; abstract; + procedure SetBoolean( const Index : Integer; const Value : Boolean ); virtual; + function GetDefaultDateTime( const Index : Integer ) : TDateTime; virtual; abstract; + function GetDateTime( const Index : Integer ) : TDateTime; virtual; abstract; + procedure SetDateTime( const Index : Integer; const Value : TDateTime ); virtual; + function GetDefaultInteger( const Index : Integer ) : Integer; virtual; abstract; + function GetInteger( const Index : Integer ) : Integer; virtual; abstract; + procedure SetInteger( const Index : Integer; const Value : Integer ); virtual; + function GetDefaultFloat( const Index : Integer ) : single; virtual; abstract; + function GetFloat( const Index : Integer ) : single; virtual; abstract; + procedure SetFloat( const Index : Integer; const Value : single ); virtual; + function GetDefaultString( const Index : Integer ) : string; virtual; abstract; + function GetString( const Index : Integer ) : string; virtual; abstract; + procedure SetString( const Index : Integer; const Value : string ); virtual; + function GetDefaultBinaryStream( const Index : Integer ) : TStream; virtual; abstract; + function GetBinaryStream( const Index : Integer ) : TStream; virtual; abstract; + procedure SetBinaryStream( const Index : Integer; const Value : TStream ); virtual; + public + procedure Update; virtual; abstract; + constructor Create; virtual; + destructor Destroy; override; + property AutoSave : Boolean read FAutoSave write FAutoSave; + end; + +implementation + +{ TUserPreferences } +procedure TUserPreferences.CheckAutoSave; +begin + if FAutoSave then + Update; +end; + +constructor TUserPreferences.Create; +begin + inherited; + FAutoSave := false; +end; + +destructor TUserPreferences.Destroy; +begin + + inherited; +end; + +procedure TUserPreferences.SetBinaryStream( const Index : Integer; const Value : TStream ); +begin + CheckAutoSave; +end; + +procedure TUserPreferences.SetBoolean(const Index: Integer; const Value: Boolean); +begin + CheckAutoSave; +end; + +procedure TUserPreferences.SetDateTime(const Index: Integer; const Value: TDateTime); +begin + CheckAutoSave; +end; + +procedure TUserPreferences.SetFloat(const Index: Integer; const Value: single); +begin + CheckAutoSave; +end; + +procedure TUserPreferences.SetInteger(const Index, Value: Integer); +begin + CheckAutoSave; +end; + +procedure TUserPreferences.SetString(const Index: Integer; const Value: string); +begin + CheckAutoSave; +end; + +end. -- cgit v1.2.3