diff options
Diffstat (limited to 'Game/Code/lib/JEDI-SDL/SDL')
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt | 27 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc | 337 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas | 2690 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas | 176 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas | 319 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas | 229 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdl.pas | 4118 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas | 155 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas | 195 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas | 5236 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas | 692 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas | 216 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas | 196 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas | 4256 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas | 564 | ||||
| -rw-r--r-- | Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas | 159 |
16 files changed, 19565 insertions, 0 deletions
diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt b/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt new file mode 100644 index 00000000..76d63a9d --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/Readme.txt @@ -0,0 +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
+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 new file mode 100644 index 00000000..48a789fd --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/jedi-sdl.inc @@ -0,0 +1,337 @@ +{
+ $Id: jedi-sdl.inc,v 1.9 2004/12/23 23:42:17 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 <http://www.bigfoot.com/~African_Chief/> }
+{ }
+{ Portions created by Prof. Abimbola Olowofoyeku are }
+{ Copyright (C) 2000 - 2100 Prof. Abimbola Olowofoyeku. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Prof. Abimbola Olowofoyeku <http://www.bigfoot.com/~African_Chief/> }
+{ Dominqiue Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.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}
+{$ENDIF ver90}
+
+{$IFDEF ver100}
+ {$DEFINE Delphi} {Delphi 3.x}
+ {$DEFINE Delphi32}
+ {$DEFINE WIN32}
+{$ENDIF ver100}
+
+{$IFDEF ver93}
+ {$DEFINE Delphi} {C++ Builder 1.x}
+ {$DEFINE Delphi32}
+{$ENDIF ver93}
+
+{$IFDEF ver110}
+ {$DEFINE Delphi} {C++ Builder 3.x}
+ {$DEFINE Delphi32}
+{$ENDIF ver110}
+
+{$IFDEF ver120}
+ {$DEFINE Delphi} {Delphi 4.x}
+ {$DEFINE Delphi32}
+ {$DEFINE Has_Int64}
+{$ENDIF ver120}
+
+{$IFDEF ver130}
+ {$DEFINE Delphi} {Delphi 5.x}
+ {$DEFINE Delphi32}
+ {$DEFINE Has_Int64}
+{$ENDIF ver130}
+
+{$IFDEF ver140}
+ {$DEFINE Delphi} {Delphi 6.x}
+ {$DEFINE Delphi32}
+ {$DEFINE Has_Int64}
+{$ENDIF ver140}
+
+{$IFDEF ver150}
+ {$DEFINE Delphi} {Delphi 7.x}
+ {$DEFINE Delphi32}
+ {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7}
+ {$DEFINE Has_Int64}
+{$ENDIF ver150}
+
+{$IFDEF ver160}
+ {$DEFINE Delphi} {Delphi 8??}
+ {$DEFINE Delphi32}
+ {$DEFINE Has_Int64}
+{$ENDIF ver160}
+
+{$IFDEF ver170}
+ {$DEFINE Delphi} {Delphi 9??}
+ {$DEFINE Delphi32}
+ {$WARN UNSAFE_TYPE OFF} {Disable warning for unsafe types in Delphi 7}
+ {$DEFINE Has_Int64}
+{$ENDIF ver170}
+
+{$IFDEF UNIX}
+ {$ifdef VER150}
+ {$define KYLIX}
+ {$endif}
+
+ {$ifdef VER140}
+ {$define KYLIX}
+ {$endif}
+
+ {$ifdef VER140}
+ {$define KYLIX}
+ {$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}
+{$ENDIF Delphi}
+
+{$IFDEF FPC}
+ {$MODE Delphi} { use Delphi compatibility mode }
+ {$H+}
+ {$PACKRECORDS 4} // Added for record
+ {$MACRO ON} // Added For OpenGL
+ {$THREADING on}
+ {$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}
+{$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}
diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas new file mode 100644 index 00000000..54841840 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas @@ -0,0 +1,2690 @@ +(**
+===============================================================================================
+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}
+
+{$ALIGN ON}
+
+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, // <!ELEMENT>
+ deAttList : (ElemDef : TElemDef); // <!ATTLIST>
+ deEntity : (EntityDef : TEntityDef); // <!ENTITY>
+ deNotation : (NotationDef : TNotationDef); // <!NOTATION>
+ dePI : (Target : PChar; // <?PI ?>
+ Content : PChar;
+ AttrList : TAttrList);
+ deError : (Pos : PChar); // Error
+ // deComment : ((No additional fields here)); // <!-- Comment -->
+ 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 <!ATTLIST Definition. "Value" is the default value
+ TypeDef : STRING; // Type definition from the DTD
+ Notations : STRING; // Notation List, separated by pipe symbols '|'
+ AttrType : TAttrType; // Attribute Type
+ DefaultType : TAttrDefault; // Default Type
+ END;
+
+ TElemDef = CLASS (TNvpList) // Represents a <!ELEMENT Definition. Is a list of TAttrDef-Nodes
+ Name : STRING; // Element name
+ ElemType : TElemType; // Element type
+ Definition : STRING; // Element definition from DTD
+ END;
+
+ TElemList = CLASS (TObjectList) // List of TElemDef nodes
+ FUNCTION Node (Name : STRING) : TElemDef;
+ PROCEDURE Add (Node : TElemDef);
+ END;
+
+ TEntityDef = CLASS (TNvpNode) // Represents a <!ENTITY Definition.
+ SystemId : STRING;
+ PublicId : STRING;
+ NotationName : STRING;
+ END;
+
+ TNotationDef = CLASS (TNvpNode) // Represents a <!NOTATION Definition. Value is the System ID
+ PublicId : STRING;
+ END;
+
+ TCharset = SET OF CHAR;
+
+
+CONST
+ CWhitespace = [#32, #9, #13, #10]; // Whitespace characters (XmlSpec 2.3)
+ CLetter = [#$41..#$5A, #$61..#$7A, #$C0..#$D6, #$D8..#$F6, #$F8..#$FF];
+ CDigit = [#$30..#$39];
+ CNameChar = CLetter + CDigit + ['.', '-', '_', ':', #$B7];
+ CNameStart = CLetter + ['_', ':'];
+ CQuoteChar = ['"', ''''];
+ CPubidChar = [#32, ^M, ^J, #9, 'a'..'z', 'A'..'Z', '0'..'9',
+ '-', '''', '(', ')', '+', ',', '.', '/', ':',
+ '=', '?', ';', '!', '*', '#', '@', '$', '_', '%'];
+
+ CDStart = '<![CDATA[';
+ CDEnd = ']]>';
+
+ // --- 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 "<?xml" PI
+found in the stream (= Text Declaration at the beginning of external parsed entities), the
+Encoding found there is used for the External Entity (is assigned to TXmlParser.CurEncoding)
+Default Encoding is for the Document Entity is UTF-8. It is assumed that External Entities
+have the same Encoding as the Document Entity, unless they carry a Text Declaration.
+===============================================================================================
+*)
+
+TYPE
+ TEntityStackNode = CLASS
+ Instance : TObject;
+ Encoding : STRING;
+ LastPos : PChar;
+ END;
+
+(*
+===============================================================================================
+TEntityStack
+For nesting of Entities.
+When there is an entity reference found in the data stream, the corresponding entity
+definition is searched and the current position is pushed to this stack.
+From then on, the program scans the entitiy replacement text as if it were normal content.
+When the parser reaches the end of an entity, the current position is popped off the
+stack again.
+===============================================================================================
+*)
+
+CONSTRUCTOR TEntityStack.Create (TheOwner : TXmlParser);
+BEGIN
+ INHERITED Create;
+ Owner := TheOwner;
+END;
+
+
+PROCEDURE TEntityStack.Push (LastPos : PChar);
+BEGIN
+ Push (NIL, LastPos);
+END;
+
+
+PROCEDURE TEntityStack.Push (Instance : TObject; LastPos : PChar);
+VAR
+ ESN : TEntityStackNode;
+BEGIN
+ ESN := TEntityStackNode.Create;
+ ESN.Instance := Instance;
+ ESN.Encoding := Owner.FCurEncoding; // Save current Encoding
+ ESN.LastPos := LastPos;
+ Add (ESN);
+END;
+
+
+FUNCTION TEntityStack.Pop : PChar;
+VAR
+ ESN : TEntityStackNode;
+BEGIN
+ IF Count > 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 '<MEM>' if successful
+BEGIN
+ Result := FALSE;
+ Clear;
+ FBufferSize := StrLen (Buffer) + 1;
+ TRY
+ GetMem (FBuffer, FBufferSize);
+ EXCEPT
+ Clear;
+ EXIT;
+ END;
+ StrCopy (FBuffer, Buffer);
+ FSource := '<MEM>';
+ Result := TRUE;
+END;
+
+
+PROCEDURE TXmlParser.SetBuffer (Buffer : PChar); // References another buffer
+BEGIN
+ Clear;
+ FBuffer := Buffer;
+ FBufferSize := 0;
+ FSource := '<REFERENCE>';
+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, '<?xml', 5) = 0) AND
+ ((CurStart+5)^ IN CWhitespace) THEN AnalyzeProlog // XML Declaration, Text Declaration
+ ELSE IF StrLComp (CurStart, '<?', 2) = 0 THEN AnalyzePI (CurStart, CurFinal) // PI
+ ELSE IF StrLComp (CurStart, '<!--', 4) = 0 THEN AnalyzeComment (CurStart, CurFinal) // Comment
+ ELSE IF StrLComp (CurStart, '<!DOCTYPE', 9) = 0 THEN AnalyzeDtdc // DTDc
+ ELSE IF StrLComp (CurStart, CDStart, Length (CDStart)) = 0 THEN AnalyzeCdata // CDATA Section
+ ELSE IF StrLComp (CurStart, '<', 1) = 0 THEN AnalyzeTag // Start-Tag, End-Tag, Empty-Element-Tag
+ ELSE AnalyzeText (IsDone); // Text Content
+ UNTIL IsDone;
+ Result := TRUE;
+END;
+
+
+PROCEDURE TXmlParser.AnalyzeProlog;
+ // Analyze XML Prolog or Text Declaration
+VAR
+ F : PChar;
+BEGIN
+ CurAttr.Analyze (CurStart+5, F);
+ IF EntityStack.Count = 0 THEN BEGIN
+ FXmlVersion := CurAttr.Value ('version');
+ FEncoding := CurAttr.Value ('encoding');
+ FStandalone := CurAttr.Value ('standalone') = 'yes';
+ END;
+ CurFinal := StrPos (F, '?>');
+ 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 ::= '<!DOCTYPE' S Name (S ExternalID)? S? ('[' (markupdecl | PEReference | S)* ']' S?)? '>'
+ markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment
+ PEReference ::= '%' Name ';'
+
+ elementdecl ::= '<!ELEMENT' S Name S contentspec S? '>'
+ AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>'
+ EntityDecl ::= '<!ENTITY' S Name S EntityDef S? '>' |
+ '<!ENTITY' S '%' S Name S PEDef S? '>'
+ NotationDecl ::= '<!NOTATION' S Name S (ExternalID | PublicID) S? '>'
+ PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char* )))? '?>'
+ Comment ::= '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->' *)
+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 '<!DOCTYPE'
+ Phase := phName;
+ REPEAT
+ CASE CurFinal^ OF
+ '%' : BEGIN
+ PushPE (CurFinal);
+ CONTINUE;
+ END;
+ #0 : IF EntityStack.Count = 0 THEN
+ BREAK
+ ELSE BEGIN
+ CurFinal := EntityStack.Pop;
+ CONTINUE;
+ END;
+ '[' : BEGIN
+ Phase := phInternal;
+ AnalyzeDtdElements (CurFinal+1, CurFinal);
+ CONTINUE;
+ END;
+ ']' : Phase := phFinishing;
+ '>' : 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, '<!');
+ IF F <> 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, '<!ELEMENT', 9) = 0 THEN AnalyzeElementDecl (Final, Final)
+ ELSE IF StrLComp (Final, '<!ATTLIST', 9) = 0 THEN AnalyzeAttListDecl (Final, Final)
+ ELSE IF StrLComp (Final, '<!ENTITY', 8) = 0 THEN AnalyzeEntityDecl (Final, Final)
+ ELSE IF StrLComp (Final, '<!NOTATION', 10) = 0 THEN AnalyzeNotationDecl (Final, Final)
+ ELSE IF StrLComp (Final, '<?', 2) = 0 THEN BEGIN // PI in DTD
+ DER.ElementType := dePI;
+ DER.Start := Final;
+ AnalyzePI (Final, Final);
+ DER.Target := PChar (CurName);
+ DER.Content := PChar (CurContent);
+ DER.AttrList := CurAttr;
+ DER.Final := Final;
+ DtdElementFound (DER);
+ END
+ ELSE IF StrLComp (Final, '<!--', 4) = 0 THEN BEGIN // Comment in DTD
+ DER.ElementType := deComment;
+ DER.Start := Final;
+ AnalyzeComment (Final, Final);
+ DER.Final := Final;
+ DtdElementFound (DER);
+ END
+ ELSE BEGIN
+ DER.ElementType := deError;
+ DER.Start := Final;
+ DER.Pos := Final;
+ DER.Final := Final;
+ DtdElementFound (DER);
+ END;
+
+ END;
+ INC (Final);
+ UNTIL FALSE;
+END;
+
+
+PROCEDURE TXmlParser.AnalyzeTag;
+ // Analyze Tags
+VAR
+ S, F : PChar;
+ Attr : TAttr;
+ ElemDef : TElemDef;
+ AttrDef : TAttrDef;
+ I : INTEGER;
+BEGIN
+ CurPartType := ptStartTag;
+ S := CurStart+1;
+ IF S^ = '/' THEN BEGIN
+ CurPartType := ptEndTag;
+ INC (S);
+ END;
+ ExtractName (S, CWhitespace + ['/'], F);
+ SetStringSF (CurName, S, F);
+ CurAttr.Analyze (F+1, CurFinal);
+ IF CurFinal^ = '/' THEN BEGIN
+ CurPartType := ptEmptyTag;
+ END;
+ CurFinal := StrScanE (CurFinal, '>');
+
+ // --- 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 <!ELEMENT declaration starting at "Start"
+ Final must point to the terminating '>' character
+ XmlSpec 3.2:
+ elementdecl ::= '<!ELEMENT' S Name S contentspec S? '>'
+ 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 <!ATTLIST declaration starting at "Start"
+ Final must point to the terminating '>' character
+ XmlSpec 3.3:
+ AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>'
+ 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:
+ <!ATTLIST address
+ A1 CDATA "Default"
+ A2 ID #REQUIRED
+ A3 IDREF #IMPLIED
+ A4 IDREFS #IMPLIED
+ A5 ENTITY #FIXED "&at;ü"
+ A6 ENTITIES #REQUIRED
+ A7 NOTATION (WMF | DXF) "WMF"
+ A8 (A | B | C) #REQUIRED> *)
+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 <!ATTLIST
+ Phase := phElementName;
+ DER.Start := Start;
+ AttrDef := NIL;
+ ElemDef := NIL;
+ REPEAT
+ IF NOT (Final^ IN CWhitespace) THEN
+ CASE Final^ OF
+ '%' : BEGIN
+ PushPE (Final);
+ CONTINUE;
+ END;
+ #0 : IF EntityStack.Count = 0 THEN
+ BREAK
+ ELSE BEGIN
+ Final := EntityStack.Pop;
+ CONTINUE;
+ END;
+ '>' : 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 <!ENTITY declaration starting at "Start"
+ Final must point to the terminating '>' character
+ XmlSpec 4.2:
+ EntityDecl ::= '<!ENTITY' S Name S EntityDef S? '>' |
+ '<!ENTITY' S '%' S Name S PEDef S? '>'
+ EntityDef ::= EntityValue | (ExternalID NDataDecl?)
+ PEDef ::= EntityValue | ExternalID
+ NDataDecl ::= S 'NDATA' S Name
+ EntityValue ::= '"' ([^%&"] | PEReference | EntityRef | CharRef)* '"' |
+ "'" ([^%&'] | PEReference | EntityRef | CharRef)* "'"
+ PEReference ::= '%' Name ';'
+
+ Examples
+ <!ENTITY test1 "Stefan Heymann"> <!-- Internal, general, parsed -->
+ <!ENTITY test2 SYSTEM "ent2.xml"> <!-- External, general, parsed -->
+ <!ENTITY test2 SYSTEM "ent3.gif" NDATA gif> <!-- External, general, unparsed -->
+ <!ENTITY % test3 "<!ELEMENT q ANY>"> <!-- Internal, parameter -->
+ <!ENTITY % test6 SYSTEM "ent6.xml"> <!-- External, parameter -->
+ <!ENTITY test4 "&test1; ist lieb"> <!-- IGP, Replacement text <> literal value -->
+ <!ENTITY test5 "<p>Dies ist ein Test-Absatz</p>"> <!-- IGP, See XmlSpec 2.4 -->
+ *)
+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 <!ENTITY
+ DER.Start := Start;
+ Phase := phName;
+ IsParamEntity := FALSE;
+ EntityDef := TEntityDef.Create;
+ REPEAT
+ IF NOT (Final^ IN CWhitespace) THEN
+ CASE Final^ OF
+ '%' : IsParamEntity := TRUE;
+ '>' : 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 <!NOTATION declaration starting at "Start"
+ // Final must point to the terminating '>' character
+ // XmlSpec 4.7: NotationDecl ::= '<!NOTATION' S Name S (ExternalID | PublicID) S? '>'
+TYPE
+ TPhase = (phName, phExtId, phEnd);
+VAR
+ ExternalID : TExternalID;
+ Phase : TPhase;
+ F : PChar;
+ NotationDef : TNotationDef;
+ DER : TDtdElementRec;
+BEGIN
+ Final := Start + 10; // Character after <!NOTATION
+ DER.Start := Start;
+ Phase := phName;
+ NotationDef := TNotationDef.Create;
+ REPEAT
+ IF NOT (Final^ IN CWhitespace) THEN
+ CASE Final^ OF
+ '>',
+ #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 <? xml ?> 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 <!-- comment -->
+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 <?processing instruction ?>
+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 <p>
+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 <br/>
+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 </p>
+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 <!ELEMENT> 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 <!ATTLIST> 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 <!ENTITY> 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 <!NOTATION> 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 new file mode 100644 index 00000000..88bb1698 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/logger.pas @@ -0,0 +1,176 @@ +unit logger;
+{
+ $Id: logger.pas,v 1.1 2004/02/05 00:08:20 savage Exp $
+
+}
+{******************************************************************************}
+{ }
+{ Error Logging Unit }
+{ }
+{ The initial developer of this Pascal code was : }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.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;
+begin
+ FApplicationName := ExtractFileName( ParamStr(0) );
+ FApplicationPath := ExtractFilePath( ParamStr(0) );
+ AssignFile( FFileHandle, FApplicationPath + ChangeFileExt( FApplicationName, '.log' ) );
+ 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 new file mode 100644 index 00000000..146e4b30 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/moduleloader.pas @@ -0,0 +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 <robert_marquardt@gmx.de) }
+{ }
+{ Copyright (C) 2000, 2001 Robert Marquardt. }
+{ }
+{ 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. }
+{ }
+{******************************************************************}
+{
+ $Log: moduleloader.pas,v $
+ Revision 1.4 2004/02/20 17:19:10 savage
+ Added Calling convention to Win32 functions just in case.
+
+ Revision 1.3 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.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/14 00:04:50 savage
+ dllfuncs conflicts with FreePascal so it has been renamed back to the moduleloader.pas
+
+ Revision 1.1 2004/02/05 00:08:19 savage
+ Module 1.0 release
+
+
+}
+
+interface
+
+{$i jedi-sdl.inc}
+{$WEAKPACKAGEUNIT ON}
+
+// each OS gets its own IFDEFed complete code block to make reading easier
+
+{$IFDEF WIN32}
+uses
+ Windows;
+
+type
+ // Handle to a loaded DLL
+ TModuleHandle = HINST;
+
+const
+ // Value designating an unassigned TModuleHandle od a failed loading
+ INVALID_MODULEHANDLE_VALUE = TModuleHandle(0);
+
+function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; stdcall;
+function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; stdcall;
+procedure UnloadModule(var Module: TModuleHandle); stdcall;
+function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; stdcall;
+function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; stdcall;
+function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; stdcall;
+function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; stdcall;
+
+implementation
+
+// load the DLL file FileName
+// the rules for FileName are those of LoadLibrary
+// Returns: True = success, False = failure to load
+// Assigns: the handle of the loaded DLL 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 := LoadLibrary( FileName );
+ Result := Module <> 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 new file mode 100644 index 00000000..2d28a222 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas @@ -0,0 +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 <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl.pas new file mode 100644 index 00000000..ad5d783a --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl.pas @@ -0,0 +1,4118 @@ +unit sdl;
+{
+ $Id: sdl.pas,v 1.17 2005/01/03 18:40:59 savage Exp $
+
+}
+{******************************************************************************}
+{ }
+{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer }
+{ Conversion of the Simple DirectMedia Layer Headers }
+{ }
+{ Portions created by Sam Lantinga <slouken@devolution.com> are }
+{ Copyright (C) 1997-2004 Sam Lantinga }
+{ 5635-34 Springhouse Dr. }
+{ Pleasanton, CA 94588 (USA) }
+{ }
+{ All Rights Reserved. }
+{ }
+{ The original files are : SDL.h }
+{ SDL_main.h }
+{ SDL_types.h }
+{ SDL_rwops.h }
+{ SDL_timer.h }
+{ SDL_audio.h }
+{ SDL_cdrom.h }
+{ SDL_joystick.h }
+{ SDL_mouse.h }
+{ SDL_keyboard.h }
+{ SDL_events.h }
+{ SDL_video.h }
+{ SDL_byteorder.h }
+{ SDL_version.h }
+{ SDL_active.h }
+{ SDL_thread.h }
+{ SDL_mutex .h }
+{ SDL_getenv.h }
+{ SDL_loadso.h }
+{ }
+{ The initial developer of this Pascal code was : }
+{ Dominqiue Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ Portions created by Dominqiue Louis are }
+{ Copyright (C) 2000 - 2004 Dominqiue Louis. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Tom Jones <tigertomjones@gmx.de> His Project inspired this conversion }
+{ Matthias Thoma <ma.thoma@gmx.de> }
+{ }
+{ 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 }
+{ ---------------- }
+{ May 08 2001 - DL : Added Keyboard State Array ( See demos for how to }
+{ use ) }
+{ PKeyStateArr = ^TKeyStateArr; }
+{ TKeyStateArr = array[0..65000] of UInt8; }
+{ As most games will need it. }
+{ }
+{ April 02 2001 - DL : Added SDL_getenv.h definitions and tested version }
+{ 1.2.0 compatability. }
+{ }
+{ March 13 2001 - MT : Added Linux compatibility. }
+{ }
+{ March 10 2001 - MT : Added externalsyms for DEFINES }
+{ Changed the license header }
+{ }
+{ March 09 2001 - MT : Added Kylix Ifdefs/Deleted the uses mmsystem }
+{ }
+{ March 01 2001 - DL : Update conversion of version 1.1.8 }
+{ }
+{ July 22 2001 - DL : Added TUInt8Array and PUIntArray after suggestions }
+{ from Matthias Thoma and Eric Grange. }
+{ }
+{ October 12 2001 - DL : Various changes as suggested by Matthias Thoma and }
+{ David Acklam }
+{ }
+{ October 24 2001 - DL : Added FreePascal support as per suggestions from }
+{ Dean Ellis. }
+{ }
+{ October 27 2001 - DL : Added SDL_BUTTON macro }
+{ }
+{ November 08 2001 - DL : Bug fix as pointed out by Puthoon. }
+{ }
+{ November 29 2001 - DL : Bug fix of SDL_SetGammaRamp as pointed out by Simon}
+{ Rushton. }
+{ }
+{ November 30 2001 - DL : SDL_NOFRAME added as pointed out by Simon Rushton. }
+{ }
+{ December 11 2001 - DL : Added $WEAKPACKAGEUNIT ON to facilitate useage in }
+{ Components }
+{ }
+{ January 05 2002 - DL : Added SDL_Swap32 function as suggested by Matthias }
+{ Thoma and also made sure the _getenv from }
+{ MSVCRT.DLL uses the right calling convention }
+{ }
+{ January 25 2002 - DL : Updated conversion of SDL_AddTimer & }
+{ SDL_RemoveTimer as per suggestions from Matthias }
+{ Thoma. }
+{ }
+{ January 27 2002 - DL : Commented out exported function putenv and getenv }
+{ So that developers get used to using SDL_putenv }
+{ SDL_getenv, as they are more portable }
+{ }
+{ March 05 2002 - DL : Added FreeAnNil procedure for Delphi 4 users. }
+{ }
+{ October 23 2002 - DL : Added Delphi 3 Define of Win32. }
+{ If you intend to you Delphi 3... }
+{ ( which is officially unsupported ) make sure you }
+{ remove references to $EXTERNALSYM in this and other}
+{ SDL files. }
+{ }
+{ November 29 2002 - DL : Fixed bug in Declaration of SDL_GetRGBA that was }
+{ pointed out by Todd Lang }
+{ }
+{ April 03 2003 - DL : Added jedi-sdl.inc include file to support more }
+{ Pascal compilers. Initial support is now included }
+{ for GnuPascal, VirtualPascal, TMT and obviously }
+{ continue support for Delphi Kylix and FreePascal. }
+{ }
+{ April 08 2003 - MK : Aka Mr Kroket - Added Better FPC support }
+{ }
+{ April 24 2003 - 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 }
+{ }
+{ April 30 2003 - DL : under instruction from David Mears AKA }
+{ Jason Siletto, I have added FPC Linux support. }
+{ This was compiled with fpc 1.1, so remember to set }
+{ include file path. ie. -Fi/usr/share/fpcsrc/rtl/* }
+{ }
+{
+ $Log: sdl.pas,v $
+ Revision 1.17 2005/01/03 18:40:59 savage
+ Updated Version number to reflect latest one
+
+ Revision 1.16 2005/01/01 02:02:06 savage
+ Updated to v1.2.8
+
+ Revision 1.15 2004/12/24 18:57:11 savage
+ forgot to apply Michalis Kamburelis' patch to the implementation section. now fixed
+
+ Revision 1.14 2004/12/23 23:42:18 savage
+ Applied Patches supplied by Michalis Kamburelis ( THANKS! ), for greater FreePascal compatability.
+
+ Revision 1.13 2004/09/30 22:31:59 savage
+ Updated with slightly different header comments
+
+ Revision 1.12 2004/09/12 21:52:58 savage
+ Slight changes to fix some issues with the sdl classes.
+
+ Revision 1.11 2004/08/14 22:54:30 savage
+ Updated so that Library name defines are correctly defined for MacOS X.
+
+ Revision 1.10 2004/07/20 23:57:33 savage
+ Thanks to Paul Toth for spotting an error in the SDL Audio Convertion structures.
+ In TSDL_AudioCVT the filters variable should point to and array of pointers and not what I had there previously.
+
+ Revision 1.9 2004/07/03 22:07:22 savage
+ Added Bitwise Manipulation Functions for TSDL_VideoInfo struct.
+
+ Revision 1.8 2004/05/10 14:10:03 savage
+ Initial MacOS X support. Fixed defines for MACOS ( Classic ) and DARWIN ( MacOS X ).
+
+ Revision 1.7 2004/04/13 09:32:08 savage
+ Changed Shared object names back to just the .so extension to avoid conflicts on various Linux/Unix distros. Therefore developers will need to create Symbolic links to the actual Share Objects if necessary.
+
+ Revision 1.6 2004/04/01 20:53:23 savage
+ Changed Linux Shared Object names so they reflect the Symbolic Links that are created when installing the RPMs from the SDL site.
+
+ Revision 1.5 2004/02/22 15:32:10 savage
+ SDL_GetEnv Fix so it also works on FPC/Linux. Thanks to Rodrigo for pointing this out.
+
+ Revision 1.4 2004/02/21 23:24:29 savage
+ SDL_GetEnv Fix so that it is not define twice for FPC. Thanks to Rene Hugentobler for pointing out this bug,
+
+ Revision 1.3 2004/02/18 22:35:51 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.
+
+ Revision 1.2 2004/02/17 21:37:12 savage
+ Tidying up of units
+
+ Revision 1.1 2004/02/05 00:08:20 savage
+ Module 1.0 release
+
+}
+{******************************************************************************}
+
+{$I jedi-sdl.inc}
+
+{$ALIGN ON}
+
+interface
+
+uses
+{$IFDEF __GPC__}
+ system,
+ gpc;
+{$ENDIF}
+
+{$IFDEF WIN32}
+ {$IFNDEF __GPC__}
+ Windows;
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF UNIX}
+ {$IFDEF FPC}
+ {$IFDEF Ver1_0}
+ linux,
+ {$ELSE}
+ pthreads,
+ baseunix,
+ unix,
+ {$ENDIF}
+ x,
+ xlib;
+ {$ELSE}
+ Types,
+ Libc,
+ Xlib;
+ {$ENDIF}
+{$ENDIF}
+
+{$IFDEF __MACH__}
+ GPCMacOSAll;
+{$ENDIF}
+
+const
+{$IFDEF WIN32}
+ SDLLibName = 'SDL.dll';
+{$ENDIF}
+
+{$IFDEF UNIX}
+{$IFDEF DARWIN}
+ SDLLibName = 'libSDL.dylib';
+{$ELSE}
+ SDLLibName = 'libSDL.so';
+{$ENDIF}
+{$ENDIF}
+
+{$IFDEF MACOS}
+ SDLLibName = 'SDL';
+{$ENDIF}
+
+ // SDL.h constants
+ SDL_INIT_TIMER = $00000001;
+{$EXTERNALSYM SDL_INIT_TIMER}
+ SDL_INIT_AUDIO = $00000010;
+{$EXTERNALSYM SDL_INIT_AUDIO}
+ SDL_INIT_VIDEO = $00000020;
+{$EXTERNALSYM SDL_INIT_VIDEO}
+ SDL_INIT_CDROM = $00000100;
+{$EXTERNALSYM SDL_INIT_CDROM}
+ SDL_INIT_JOYSTICK = $00000200;
+{$EXTERNALSYM SDL_INIT_JOYSTICK}
+ SDL_INIT_NOPARACHUTE = $00100000; // Don't catch fatal signals
+{$EXTERNALSYM SDL_INIT_NOPARACHUTE}
+ SDL_INIT_EVENTTHREAD = $01000000; // Not supported on all OS's
+{$EXTERNALSYM SDL_INIT_EVENTTHREAD}
+ SDL_INIT_EVERYTHING = $0000FFFF;
+{$EXTERNALSYM SDL_INIT_EVERYTHING}
+
+ // SDL_error.h constants
+ ERR_MAX_STRLEN = 128;
+{$EXTERNALSYM ERR_MAX_STRLEN}
+ ERR_MAX_ARGS = 5;
+{$EXTERNALSYM ERR_MAX_ARGS}
+
+ // SDL_types.h constants
+ SDL_PRESSED = $01;
+{$EXTERNALSYM SDL_PRESSED}
+ SDL_RELEASED = $00;
+{$EXTERNALSYM SDL_RELEASED}
+
+ // SDL_timer.h constants
+ // This is the OS scheduler timeslice, in milliseconds
+ SDL_TIMESLICE = 10;
+{$EXTERNALSYM SDL_TIMESLICE}
+ // This is the maximum resolution of the SDL timer on all platforms
+ TIMER_RESOLUTION = 10; // Experimentally determined
+{$EXTERNALSYM TIMER_RESOLUTION}
+
+ // SDL_audio.h constants
+ AUDIO_U8 = $0008; // Unsigned 8-bit samples
+{$EXTERNALSYM AUDIO_U8}
+ AUDIO_S8 = $8008; // Signed 8-bit samples
+{$EXTERNALSYM AUDIO_S8}
+ AUDIO_U16LSB = $0010; // Unsigned 16-bit samples
+{$EXTERNALSYM AUDIO_U16LSB}
+ AUDIO_S16LSB = $8010; // Signed 16-bit samples
+{$EXTERNALSYM AUDIO_S16LSB}
+ AUDIO_U16MSB = $1010; // As above, but big-endian byte order
+{$EXTERNALSYM AUDIO_U16MSB}
+ AUDIO_S16MSB = $9010; // As above, but big-endian byte order
+{$EXTERNALSYM AUDIO_S16MSB}
+ AUDIO_U16 = AUDIO_U16LSB;
+{$EXTERNALSYM AUDIO_U16}
+ AUDIO_S16 = AUDIO_S16LSB;
+{$EXTERNALSYM AUDIO_S16}
+
+
+ // SDL_cdrom.h constants
+ // The maximum number of CD-ROM tracks on a disk
+ SDL_MAX_TRACKS = 99;
+{$EXTERNALSYM SDL_MAX_TRACKS}
+ // The types of CD-ROM track possible
+ SDL_AUDIO_TRACK = $00;
+{$EXTERNALSYM SDL_AUDIO_TRACK}
+ SDL_DATA_TRACK = $04;
+{$EXTERNALSYM SDL_DATA_TRACK}
+
+ // Conversion functions from frames to Minute/Second/Frames and vice versa
+ CD_FPS = 75;
+{$EXTERNALSYM CD_FPS}
+ // SDL_byteorder.h constants
+ // The two types of endianness
+ SDL_LIL_ENDIAN = 1234;
+{$EXTERNALSYM SDL_LIL_ENDIAN}
+ SDL_BIG_ENDIAN = 4321;
+{$EXTERNALSYM SDL_BIG_ENDIAN}
+
+{$IFDEF IA32}
+
+ SDL_BYTEORDER = SDL_LIL_ENDIAN;
+{$EXTERNALSYM SDL_BYTEORDER}
+ // Native audio byte ordering
+ AUDIO_U16SYS = AUDIO_U16LSB;
+{$EXTERNALSYM AUDIO_U16SYS}
+ AUDIO_S16SYS = AUDIO_S16LSB;
+{$EXTERNALSYM AUDIO_S16SYS}
+
+{$ELSE}
+
+ SDL_BYTEORDER = SDL_BIG_ENDIAN;
+{$EXTERNALSYM SDL_BYTEORDER}
+ // Native audio byte ordering
+ AUDIO_U16SYS = AUDIO_U16MSB;
+{$EXTERNALSYM AUDIO_U16SYS}
+ AUDIO_S16SYS = AUDIO_S16MSB;
+{$EXTERNALSYM AUDIO_S16SYS}
+
+{$ENDIF}
+
+
+ SDL_MIX_MAXVOLUME = 128;
+{$EXTERNALSYM SDL_MIX_MAXVOLUME}
+
+ // SDL_joystick.h constants
+ MAX_JOYSTICKS = 2; // only 2 are supported in the multimedia API
+{$EXTERNALSYM MAX_JOYSTICKS}
+ MAX_AXES = 6; // each joystick can have up to 6 axes
+{$EXTERNALSYM MAX_AXES}
+ MAX_BUTTONS = 32; // and 32 buttons
+{$EXTERNALSYM MAX_BUTTONS}
+ AXIS_MIN = -32768; // minimum value for axis coordinate
+{$EXTERNALSYM AXIS_MIN}
+ AXIS_MAX = 32767; // maximum value for axis coordinate
+{$EXTERNALSYM AXIS_MAX}
+ JOY_AXIS_THRESHOLD = (((AXIS_MAX) - (AXIS_MIN)) / 100); // 1% motion
+{$EXTERNALSYM JOY_AXIS_THRESHOLD}
+ //JOY_BUTTON_FLAG(n) (1<<n)
+ // array to hold joystick ID values
+ //static UInt SYS_JoystickID[MAX_JOYSTICKS];
+ //static JOYCAPS SYS_Joystick[MAX_JOYSTICKS];
+
+ { Get the current state of a POV hat on a joystick
+ The return value is one of the following positions: }
+ SDL_HAT_CENTERED = $00;
+{$EXTERNALSYM SDL_HAT_CENTERED}
+ SDL_HAT_UP = $01;
+{$EXTERNALSYM SDL_HAT_UP}
+ SDL_HAT_RIGHT = $02;
+{$EXTERNALSYM SDL_HAT_RIGHT}
+ SDL_HAT_DOWN = $04;
+{$EXTERNALSYM SDL_HAT_DOWN}
+ SDL_HAT_LEFT = $08;
+{$EXTERNALSYM SDL_HAT_LEFT}
+ SDL_HAT_RIGHTUP = SDL_HAT_RIGHT or SDL_HAT_UP;
+{$EXTERNALSYM SDL_HAT_RIGHTUP}
+ SDL_HAT_RIGHTDOWN = SDL_HAT_RIGHT or SDL_HAT_DOWN;
+{$EXTERNALSYM SDL_HAT_RIGHTDOWN}
+ SDL_HAT_LEFTUP = SDL_HAT_LEFT or SDL_HAT_UP;
+{$EXTERNALSYM SDL_HAT_LEFTUP}
+ SDL_HAT_LEFTDOWN = SDL_HAT_LEFT or SDL_HAT_DOWN;
+{$EXTERNALSYM SDL_HAT_LEFTDOWN}
+
+ // SDL_verion.h constants
+ // Printable format: "%d.%d.%d", MAJOR, MINOR, PATCHLEVEL
+ SDL_MAJOR_VERSION = 1;
+{$EXTERNALSYM SDL_MAJOR_VERSION}
+ SDL_MINOR_VERSION = 2;
+{$EXTERNALSYM SDL_MINOR_VERSION}
+ SDL_PATCHLEVEL = 8;
+{$EXTERNALSYM SDL_PATCHLEVEL}
+
+ // SDL_events.h constants
+ SDL_NOEVENT = 0; // Unused (do not remove)
+{$EXTERNALSYM SDL_NOEVENT}
+ SDL_ACTIVEEVENT = 1; // Application loses/gains visibility
+{$EXTERNALSYM SDL_ACTIVEEVENT}
+ SDL_KEYDOWN = 2; // Keys pressed
+{$EXTERNALSYM SDL_KEYDOWN}
+ SDL_KEYUP = 3; // Keys released
+{$EXTERNALSYM SDL_KEYUP}
+ SDL_MOUSEMOTION = 4; // Mouse moved
+{$EXTERNALSYM SDL_MOUSEMOTION}
+ SDL_MOUSEBUTTONDOWN = 5; // Mouse button pressed
+{$EXTERNALSYM SDL_MOUSEBUTTONDOWN}
+ SDL_MOUSEBUTTONUP = 6; // Mouse button released
+{$EXTERNALSYM SDL_MOUSEBUTTONUP}
+ SDL_JOYAXISMOTION = 7; // Joystick axis motion
+{$EXTERNALSYM SDL_JOYAXISMOTION}
+ SDL_JOYBALLMOTION = 8; // Joystick trackball motion
+{$EXTERNALSYM SDL_JOYBALLMOTION}
+ SDL_JOYHATMOTION = 9; // Joystick hat position change
+{$EXTERNALSYM SDL_JOYHATMOTION}
+ SDL_JOYBUTTONDOWN = 10; // Joystick button pressed
+{$EXTERNALSYM SDL_JOYBUTTONDOWN}
+ SDL_JOYBUTTONUP = 11; // Joystick button released
+{$EXTERNALSYM SDL_JOYBUTTONUP}
+ SDL_QUITEV = 12; // User-requested quit ( Changed due to procedure conflict )
+{$EXTERNALSYM SDL_QUIT}
+ SDL_SYSWMEVENT = 13; // System specific event
+{$EXTERNALSYM SDL_SYSWMEVENT}
+ SDL_EVENT_RESERVEDA = 14; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVEDA}
+ SDL_EVENT_RESERVED = 15; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED}
+ SDL_VIDEORESIZE = 16; // User resized video mode
+{$EXTERNALSYM SDL_VIDEORESIZE}
+ SDL_VIDEOEXPOSE = 17; // Screen needs to be redrawn
+{$EXTERNALSYM SDL_VIDEOEXPOSE}
+ SDL_EVENT_RESERVED2 = 18; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED2}
+ SDL_EVENT_RESERVED3 = 19; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED3}
+ SDL_EVENT_RESERVED4 = 20; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED4}
+ SDL_EVENT_RESERVED5 = 21; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED5}
+ SDL_EVENT_RESERVED6 = 22; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED6}
+ SDL_EVENT_RESERVED7 = 23; // Reserved for future use..
+{$EXTERNALSYM SDL_EVENT_RESERVED7}
+ // Events SDL_USEREVENT through SDL_MAXEVENTS-1 are for your use
+ SDL_USEREVENT = 24;
+{$EXTERNALSYM SDL_USEREVENT}
+ // This last event is only for bounding internal arrays
+ // It is the number of bits in the event mask datatype -- UInt32
+ SDL_NUMEVENTS = 32;
+{$EXTERNALSYM SDL_NUMEVENTS}
+
+ SDL_ALLEVENTS = $FFFFFFFF;
+{$EXTERNALSYM SDL_ALLEVENTS}
+
+ SDL_ACTIVEEVENTMASK = 1 shl SDL_ACTIVEEVENT;
+{$EXTERNALSYM SDL_ACTIVEEVENTMASK}
+ SDL_KEYDOWNMASK = 1 shl SDL_KEYDOWN;
+{$EXTERNALSYM SDL_KEYDOWNMASK}
+ SDL_KEYUPMASK = 1 shl SDL_KEYUP;
+{$EXTERNALSYM SDL_KEYUPMASK}
+ SDL_MOUSEMOTIONMASK = 1 shl SDL_MOUSEMOTION;
+{$EXTERNALSYM SDL_MOUSEMOTIONMASK}
+ SDL_MOUSEBUTTONDOWNMASK = 1 shl SDL_MOUSEBUTTONDOWN;
+{$EXTERNALSYM SDL_MOUSEBUTTONDOWNMASK}
+ SDL_MOUSEBUTTONUPMASK = 1 shl SDL_MOUSEBUTTONUP;
+{$EXTERNALSYM SDL_MOUSEBUTTONUPMASK}
+ SDL_MOUSEEVENTMASK = 1 shl SDL_MOUSEMOTION or
+ 1 shl SDL_MOUSEBUTTONDOWN or
+ 1 shl SDL_MOUSEBUTTONUP;
+{$EXTERNALSYM SDL_MOUSEEVENTMASK}
+ SDL_JOYAXISMOTIONMASK = 1 shl SDL_JOYAXISMOTION;
+{$EXTERNALSYM SDL_JOYAXISMOTIONMASK}
+ SDL_JOYBALLMOTIONMASK = 1 shl SDL_JOYBALLMOTION;
+{$EXTERNALSYM SDL_JOYBALLMOTIONMASK}
+ SDL_JOYHATMOTIONMASK = 1 shl SDL_JOYHATMOTION;
+{$EXTERNALSYM SDL_JOYHATMOTIONMASK}
+ SDL_JOYBUTTONDOWNMASK = 1 shl SDL_JOYBUTTONDOWN;
+{$EXTERNALSYM SDL_JOYBUTTONDOWNMASK}
+ SDL_JOYBUTTONUPMASK = 1 shl SDL_JOYBUTTONUP;
+{$EXTERNALSYM SDL_JOYBUTTONUPMASK}
+ SDL_JOYEVENTMASK = 1 shl SDL_JOYAXISMOTION or
+ 1 shl SDL_JOYBALLMOTION or
+ 1 shl SDL_JOYHATMOTION or
+ 1 shl SDL_JOYBUTTONDOWN or
+ 1 shl SDL_JOYBUTTONUP;
+{$EXTERNALSYM SDL_JOYEVENTMASK}
+ SDL_VIDEORESIZEMASK = 1 shl SDL_VIDEORESIZE;
+{$EXTERNALSYM SDL_VIDEORESIZEMASK}
+ SDL_QUITMASK = 1 shl SDL_QUITEV;
+{$EXTERNALSYM SDL_QUITMASK}
+ SDL_SYSWMEVENTMASK = 1 shl SDL_SYSWMEVENT;
+{$EXTERNALSYM SDL_SYSWMEVENTMASK}
+
+ { This function allows you to set the state of processing certain events.
+ If 'state' is set to SDL_IGNORE, that event will be automatically dropped
+ from the event queue and will not event be filtered.
+ If 'state' is set to SDL_ENABLE, that event will be processed normally.
+ If 'state' is set to SDL_QUERY, SDL_EventState() will return the
+ current processing state of the specified event. }
+
+ SDL_QUERY = -1;
+{$EXTERNALSYM SDL_QUERY}
+ SDL_IGNORE = 0;
+{$EXTERNALSYM SDL_IGNORE}
+ SDL_DISABLE = 0;
+{$EXTERNALSYM SDL_DISABLE}
+ SDL_ENABLE = 1;
+{$EXTERNALSYM SDL_ENABLE}
+
+ //SDL_keyboard.h constants
+ // This is the mask which refers to all hotkey bindings
+ SDL_ALL_HOTKEYS = $FFFFFFFF;
+{$EXTERNALSYM SDL_ALL_HOTKEYS}
+
+{ Enable/Disable keyboard repeat. Keyboard repeat defaults to off.
+ 'delay' is the initial delay in ms between the time when a key is
+ pressed, and keyboard repeat begins.
+ 'interval' is the time in ms between keyboard repeat events. }
+
+ SDL_DEFAULT_REPEAT_DELAY = 500;
+{$EXTERNALSYM SDL_DEFAULT_REPEAT_DELAY}
+ SDL_DEFAULT_REPEAT_INTERVAL = 30;
+{$EXTERNALSYM SDL_DEFAULT_REPEAT_INTERVAL}
+
+ // The keyboard syms have been cleverly chosen to map to ASCII
+ SDLK_UNKNOWN = 0;
+{$EXTERNALSYM SDLK_UNKNOWN}
+ SDLK_FIRST = 0;
+{$EXTERNALSYM SDLK_FIRST}
+ SDLK_BACKSPACE = 8;
+{$EXTERNALSYM SDLK_BACKSPACE}
+ SDLK_TAB = 9;
+{$EXTERNALSYM SDLK_TAB}
+ SDLK_CLEAR = 12;
+{$EXTERNALSYM SDLK_CLEAR}
+ SDLK_RETURN = 13;
+{$EXTERNALSYM SDLK_RETURN}
+ SDLK_PAUSE = 19;
+{$EXTERNALSYM SDLK_PAUSE}
+ SDLK_ESCAPE = 27;
+{$EXTERNALSYM SDLK_ESCAPE}
+ SDLK_SPACE = 32;
+{$EXTERNALSYM SDLK_SPACE}
+ SDLK_EXCLAIM = 33;
+{$EXTERNALSYM SDLK_EXCLAIM}
+ SDLK_QUOTEDBL = 34;
+{$EXTERNALSYM SDLK_QUOTEDBL}
+ SDLK_HASH = 35;
+{$EXTERNALSYM SDLK_HASH}
+ SDLK_DOLLAR = 36;
+{$EXTERNALSYM SDLK_DOLLAR}
+ SDLK_AMPERSAND = 38;
+{$EXTERNALSYM SDLK_AMPERSAND}
+ SDLK_QUOTE = 39;
+{$EXTERNALSYM SDLK_QUOTE}
+ SDLK_LEFTPAREN = 40;
+{$EXTERNALSYM SDLK_LEFTPAREN}
+ SDLK_RIGHTPAREN = 41;
+{$EXTERNALSYM SDLK_RIGHTPAREN}
+ SDLK_ASTERISK = 42;
+{$EXTERNALSYM SDLK_ASTERISK}
+ SDLK_PLUS = 43;
+{$EXTERNALSYM SDLK_PLUS}
+ SDLK_COMMA = 44;
+{$EXTERNALSYM SDLK_COMMA}
+ SDLK_MINUS = 45;
+{$EXTERNALSYM SDLK_MINUS}
+ SDLK_PERIOD = 46;
+{$EXTERNALSYM SDLK_PERIOD}
+ SDLK_SLASH = 47;
+{$EXTERNALSYM SDLK_SLASH}
+ SDLK_0 = 48;
+{$EXTERNALSYM SDLK_0}
+ SDLK_1 = 49;
+{$EXTERNALSYM SDLK_1}
+ SDLK_2 = 50;
+{$EXTERNALSYM SDLK_2}
+ SDLK_3 = 51;
+{$EXTERNALSYM SDLK_3}
+ SDLK_4 = 52;
+{$EXTERNALSYM SDLK_4}
+ SDLK_5 = 53;
+{$EXTERNALSYM SDLK_5}
+ SDLK_6 = 54;
+{$EXTERNALSYM SDLK_6}
+ SDLK_7 = 55;
+{$EXTERNALSYM SDLK_7}
+ SDLK_8 = 56;
+{$EXTERNALSYM SDLK_8}
+ SDLK_9 = 57;
+{$EXTERNALSYM SDLK_9}
+ SDLK_COLON = 58;
+{$EXTERNALSYM SDLK_COLON}
+ SDLK_SEMICOLON = 59;
+{$EXTERNALSYM SDLK_SEMICOLON}
+ SDLK_LESS = 60;
+{$EXTERNALSYM SDLK_LESS}
+ SDLK_EQUALS = 61;
+{$EXTERNALSYM SDLK_EQUALS}
+ SDLK_GREATER = 62;
+{$EXTERNALSYM SDLK_GREATER}
+ SDLK_QUESTION = 63;
+{$EXTERNALSYM SDLK_QUESTION}
+ SDLK_AT = 64;
+{$EXTERNALSYM SDLK_AT}
+
+ { Skip uppercase letters }
+
+ SDLK_LEFTBRACKET = 91;
+{$EXTERNALSYM SDLK_LEFTBRACKET}
+ SDLK_BACKSLASH = 92;
+{$EXTERNALSYM SDLK_BACKSLASH}
+ SDLK_RIGHTBRACKET = 93;
+{$EXTERNALSYM SDLK_RIGHTBRACKET}
+ SDLK_CARET = 94;
+{$EXTERNALSYM SDLK_CARET}
+ SDLK_UNDERSCORE = 95;
+{$EXTERNALSYM SDLK_UNDERSCORE}
+ SDLK_BACKQUOTE = 96;
+{$EXTERNALSYM SDLK_BACKQUOTE}
+ SDLK_a = 97;
+{$EXTERNALSYM SDLK_a}
+ SDLK_b = 98;
+{$EXTERNALSYM SDLK_b}
+ SDLK_c = 99;
+{$EXTERNALSYM SDLK_c}
+ SDLK_d = 100;
+{$EXTERNALSYM SDLK_d}
+ SDLK_e = 101;
+{$EXTERNALSYM SDLK_e}
+ SDLK_f = 102;
+{$EXTERNALSYM SDLK_f}
+ SDLK_g = 103;
+{$EXTERNALSYM SDLK_g}
+ SDLK_h = 104;
+{$EXTERNALSYM SDLK_h}
+ SDLK_i = 105;
+{$EXTERNALSYM SDLK_i}
+ SDLK_j = 106;
+{$EXTERNALSYM SDLK_j}
+ SDLK_k = 107;
+{$EXTERNALSYM SDLK_k}
+ SDLK_l = 108;
+{$EXTERNALSYM SDLK_l}
+ SDLK_m = 109;
+{$EXTERNALSYM SDLK_m}
+ SDLK_n = 110;
+{$EXTERNALSYM SDLK_n}
+ SDLK_o = 111;
+{$EXTERNALSYM SDLK_o}
+ SDLK_p = 112;
+{$EXTERNALSYM SDLK_p}
+ SDLK_q = 113;
+{$EXTERNALSYM SDLK_q}
+ SDLK_r = 114;
+{$EXTERNALSYM SDLK_r}
+ SDLK_s = 115;
+{$EXTERNALSYM SDLK_s}
+ SDLK_t = 116;
+{$EXTERNALSYM SDLK_t}
+ SDLK_u = 117;
+{$EXTERNALSYM SDLK_u}
+ SDLK_v = 118;
+{$EXTERNALSYM SDLK_v}
+ SDLK_w = 119;
+{$EXTERNALSYM SDLK_w}
+ SDLK_x = 120;
+{$EXTERNALSYM SDLK_x}
+ SDLK_y = 121;
+{$EXTERNALSYM SDLK_y}
+ SDLK_z = 122;
+{$EXTERNALSYM SDLK_z}
+ SDLK_DELETE = 127;
+{$EXTERNALSYM SDLK_DELETE}
+ // End of ASCII mapped keysyms
+
+ // International keyboard syms
+ SDLK_WORLD_0 = 160; // 0xA0
+{$EXTERNALSYM SDLK_WORLD_0}
+ SDLK_WORLD_1 = 161;
+{$EXTERNALSYM SDLK_WORLD_1}
+ SDLK_WORLD_2 = 162;
+{$EXTERNALSYM SDLK_WORLD_2}
+ SDLK_WORLD_3 = 163;
+{$EXTERNALSYM SDLK_WORLD_3}
+ SDLK_WORLD_4 = 164;
+{$EXTERNALSYM SDLK_WORLD_4}
+ SDLK_WORLD_5 = 165;
+{$EXTERNALSYM SDLK_WORLD_5}
+ SDLK_WORLD_6 = 166;
+{$EXTERNALSYM SDLK_WORLD_6}
+ SDLK_WORLD_7 = 167;
+{$EXTERNALSYM SDLK_WORLD_7}
+ SDLK_WORLD_8 = 168;
+{$EXTERNALSYM SDLK_WORLD_8}
+ SDLK_WORLD_9 = 169;
+{$EXTERNALSYM SDLK_WORLD_9}
+ SDLK_WORLD_10 = 170;
+{$EXTERNALSYM SDLK_WORLD_10}
+ SDLK_WORLD_11 = 171;
+{$EXTERNALSYM SDLK_WORLD_11}
+ SDLK_WORLD_12 = 172;
+{$EXTERNALSYM SDLK_WORLD_12}
+ SDLK_WORLD_13 = 173;
+{$EXTERNALSYM SDLK_WORLD_13}
+ SDLK_WORLD_14 = 174;
+{$EXTERNALSYM SDLK_WORLD_14}
+ SDLK_WORLD_15 = 175;
+{$EXTERNALSYM SDLK_WORLD_15}
+ SDLK_WORLD_16 = 176;
+{$EXTERNALSYM SDLK_WORLD_16}
+ SDLK_WORLD_17 = 177;
+{$EXTERNALSYM SDLK_WORLD_17}
+ SDLK_WORLD_18 = 178;
+{$EXTERNALSYM SDLK_WORLD_18}
+ SDLK_WORLD_19 = 179;
+{$EXTERNALSYM SDLK_WORLD_19}
+ SDLK_WORLD_20 = 180;
+{$EXTERNALSYM SDLK_WORLD_20}
+ SDLK_WORLD_21 = 181;
+{$EXTERNALSYM SDLK_WORLD_21}
+ SDLK_WORLD_22 = 182;
+{$EXTERNALSYM SDLK_WORLD_22}
+ SDLK_WORLD_23 = 183;
+{$EXTERNALSYM SDLK_WORLD_23}
+ SDLK_WORLD_24 = 184;
+{$EXTERNALSYM SDLK_WORLD_24}
+ SDLK_WORLD_25 = 185;
+{$EXTERNALSYM SDLK_WORLD_25}
+ SDLK_WORLD_26 = 186;
+{$EXTERNALSYM SDLK_WORLD_26}
+ SDLK_WORLD_27 = 187;
+{$EXTERNALSYM SDLK_WORLD_27}
+ SDLK_WORLD_28 = 188;
+{$EXTERNALSYM SDLK_WORLD_28}
+ SDLK_WORLD_29 = 189;
+{$EXTERNALSYM SDLK_WORLD_29}
+ SDLK_WORLD_30 = 190;
+{$EXTERNALSYM SDLK_WORLD_30}
+ SDLK_WORLD_31 = 191;
+{$EXTERNALSYM SDLK_WORLD_31}
+ SDLK_WORLD_32 = 192;
+{$EXTERNALSYM SDLK_WORLD_32}
+ SDLK_WORLD_33 = 193;
+{$EXTERNALSYM SDLK_WORLD_33}
+ SDLK_WORLD_34 = 194;
+{$EXTERNALSYM SDLK_WORLD_34}
+ SDLK_WORLD_35 = 195;
+{$EXTERNALSYM SDLK_WORLD_35}
+ SDLK_WORLD_36 = 196;
+{$EXTERNALSYM SDLK_WORLD_36}
+ SDLK_WORLD_37 = 197;
+{$EXTERNALSYM SDLK_WORLD_37}
+ SDLK_WORLD_38 = 198;
+{$EXTERNALSYM SDLK_WORLD_38}
+ SDLK_WORLD_39 = 199;
+{$EXTERNALSYM SDLK_WORLD_39}
+ SDLK_WORLD_40 = 200;
+{$EXTERNALSYM SDLK_WORLD_40}
+ SDLK_WORLD_41 = 201;
+{$EXTERNALSYM SDLK_WORLD_41}
+ SDLK_WORLD_42 = 202;
+{$EXTERNALSYM SDLK_WORLD_42}
+ SDLK_WORLD_43 = 203;
+{$EXTERNALSYM SDLK_WORLD_43}
+ SDLK_WORLD_44 = 204;
+{$EXTERNALSYM SDLK_WORLD_44}
+ SDLK_WORLD_45 = 205;
+{$EXTERNALSYM SDLK_WORLD_45}
+ SDLK_WORLD_46 = 206;
+{$EXTERNALSYM SDLK_WORLD_46}
+ SDLK_WORLD_47 = 207;
+{$EXTERNALSYM SDLK_WORLD_47}
+ SDLK_WORLD_48 = 208;
+{$EXTERNALSYM SDLK_WORLD_48}
+ SDLK_WORLD_49 = 209;
+{$EXTERNALSYM SDLK_WORLD_49}
+ SDLK_WORLD_50 = 210;
+{$EXTERNALSYM SDLK_WORLD_50}
+ SDLK_WORLD_51 = 211;
+{$EXTERNALSYM SDLK_WORLD_51}
+ SDLK_WORLD_52 = 212;
+{$EXTERNALSYM SDLK_WORLD_52}
+ SDLK_WORLD_53 = 213;
+{$EXTERNALSYM SDLK_WORLD_53}
+ SDLK_WORLD_54 = 214;
+{$EXTERNALSYM SDLK_WORLD_54}
+ SDLK_WORLD_55 = 215;
+{$EXTERNALSYM SDLK_WORLD_55}
+ SDLK_WORLD_56 = 216;
+{$EXTERNALSYM SDLK_WORLD_56}
+ SDLK_WORLD_57 = 217;
+{$EXTERNALSYM SDLK_WORLD_57}
+ SDLK_WORLD_58 = 218;
+{$EXTERNALSYM SDLK_WORLD_58}
+ SDLK_WORLD_59 = 219;
+{$EXTERNALSYM SDLK_WORLD_59}
+ SDLK_WORLD_60 = 220;
+{$EXTERNALSYM SDLK_WORLD_60}
+ SDLK_WORLD_61 = 221;
+{$EXTERNALSYM SDLK_WORLD_61}
+ SDLK_WORLD_62 = 222;
+{$EXTERNALSYM SDLK_WORLD_62}
+ SDLK_WORLD_63 = 223;
+{$EXTERNALSYM SDLK_WORLD_63}
+ SDLK_WORLD_64 = 224;
+{$EXTERNALSYM SDLK_WORLD_64}
+ SDLK_WORLD_65 = 225;
+{$EXTERNALSYM SDLK_WORLD_65}
+ SDLK_WORLD_66 = 226;
+{$EXTERNALSYM SDLK_WORLD_66}
+ SDLK_WORLD_67 = 227;
+{$EXTERNALSYM SDLK_WORLD_67}
+ SDLK_WORLD_68 = 228;
+{$EXTERNALSYM SDLK_WORLD_68}
+ SDLK_WORLD_69 = 229;
+{$EXTERNALSYM SDLK_WORLD_69}
+ SDLK_WORLD_70 = 230;
+{$EXTERNALSYM SDLK_WORLD_70}
+ SDLK_WORLD_71 = 231;
+{$EXTERNALSYM SDLK_WORLD_71}
+ SDLK_WORLD_72 = 232;
+{$EXTERNALSYM SDLK_WORLD_72}
+ SDLK_WORLD_73 = 233;
+{$EXTERNALSYM SDLK_WORLD_73}
+ SDLK_WORLD_74 = 234;
+{$EXTERNALSYM SDLK_WORLD_74}
+ SDLK_WORLD_75 = 235;
+{$EXTERNALSYM SDLK_WORLD_75}
+ SDLK_WORLD_76 = 236;
+{$EXTERNALSYM SDLK_WORLD_76}
+ SDLK_WORLD_77 = 237;
+{$EXTERNALSYM SDLK_WORLD_77}
+ SDLK_WORLD_78 = 238;
+{$EXTERNALSYM SDLK_WORLD_78}
+ SDLK_WORLD_79 = 239;
+{$EXTERNALSYM SDLK_WORLD_79}
+ SDLK_WORLD_80 = 240;
+{$EXTERNALSYM SDLK_WORLD_80}
+ SDLK_WORLD_81 = 241;
+{$EXTERNALSYM SDLK_WORLD_81}
+ SDLK_WORLD_82 = 242;
+{$EXTERNALSYM SDLK_WORLD_82}
+ SDLK_WORLD_83 = 243;
+{$EXTERNALSYM SDLK_WORLD_83}
+ SDLK_WORLD_84 = 244;
+{$EXTERNALSYM SDLK_WORLD_84}
+ SDLK_WORLD_85 = 245;
+{$EXTERNALSYM SDLK_WORLD_85}
+ SDLK_WORLD_86 = 246;
+{$EXTERNALSYM SDLK_WORLD_86}
+ SDLK_WORLD_87 = 247;
+{$EXTERNALSYM SDLK_WORLD_87}
+ SDLK_WORLD_88 = 248;
+{$EXTERNALSYM SDLK_WORLD_88}
+ SDLK_WORLD_89 = 249;
+{$EXTERNALSYM SDLK_WORLD_89}
+ SDLK_WORLD_90 = 250;
+{$EXTERNALSYM SDLK_WORLD_90}
+ SDLK_WORLD_91 = 251;
+{$EXTERNALSYM SDLK_WORLD_91}
+ SDLK_WORLD_92 = 252;
+{$EXTERNALSYM SDLK_WORLD_92}
+ SDLK_WORLD_93 = 253;
+{$EXTERNALSYM SDLK_WORLD_93}
+ SDLK_WORLD_94 = 254;
+{$EXTERNALSYM SDLK_WORLD_94}
+ SDLK_WORLD_95 = 255; // 0xFF
+{$EXTERNALSYM SDLK_WORLD_95}
+
+ // Numeric keypad
+ SDLK_KP0 = 256;
+{$EXTERNALSYM SDLK_KP0}
+ SDLK_KP1 = 257;
+{$EXTERNALSYM SDLK_KP1}
+ SDLK_KP2 = 258;
+{$EXTERNALSYM SDLK_KP2}
+ SDLK_KP3 = 259;
+{$EXTERNALSYM SDLK_KP3}
+ SDLK_KP4 = 260;
+{$EXTERNALSYM SDLK_KP4}
+ SDLK_KP5 = 261;
+{$EXTERNALSYM SDLK_KP5}
+ SDLK_KP6 = 262;
+{$EXTERNALSYM SDLK_KP6}
+ SDLK_KP7 = 263;
+{$EXTERNALSYM SDLK_KP7}
+ SDLK_KP8 = 264;
+{$EXTERNALSYM SDLK_KP8}
+ SDLK_KP9 = 265;
+{$EXTERNALSYM SDLK_KP9}
+ SDLK_KP_PERIOD = 266;
+{$EXTERNALSYM SDLK_KP_PERIOD}
+ SDLK_KP_DIVIDE = 267;
+{$EXTERNALSYM SDLK_KP_DIVIDE}
+ SDLK_KP_MULTIPLY = 268;
+{$EXTERNALSYM SDLK_KP_MULTIPLY}
+ SDLK_KP_MINUS = 269;
+{$EXTERNALSYM SDLK_KP_MINUS}
+ SDLK_KP_PLUS = 270;
+{$EXTERNALSYM SDLK_KP_PLUS}
+ SDLK_KP_ENTER = 271;
+{$EXTERNALSYM SDLK_KP_ENTER}
+ SDLK_KP_EQUALS = 272;
+{$EXTERNALSYM SDLK_KP_EQUALS}
+
+ // Arrows + Home/End pad
+ SDLK_UP = 273;
+{$EXTERNALSYM SDLK_UP}
+ SDLK_DOWN = 274;
+{$EXTERNALSYM SDLK_DOWN}
+ SDLK_RIGHT = 275;
+{$EXTERNALSYM SDLK_RIGHT}
+ SDLK_LEFT = 276;
+{$EXTERNALSYM SDLK_LEFT}
+ SDLK_INSERT = 277;
+{$EXTERNALSYM SDLK_INSERT}
+ SDLK_HOME = 278;
+{$EXTERNALSYM SDLK_HOME}
+ SDLK_END = 279;
+{$EXTERNALSYM SDLK_END}
+ SDLK_PAGEUP = 280;
+{$EXTERNALSYM SDLK_PAGEUP}
+ SDLK_PAGEDOWN = 281;
+{$EXTERNALSYM SDLK_PAGEDOWN}
+
+ // Function keys
+ SDLK_F1 = 282;
+{$EXTERNALSYM SDLK_F1}
+ SDLK_F2 = 283;
+{$EXTERNALSYM SDLK_F2}
+ SDLK_F3 = 284;
+{$EXTERNALSYM SDLK_F3}
+ SDLK_F4 = 285;
+{$EXTERNALSYM SDLK_F4}
+ SDLK_F5 = 286;
+{$EXTERNALSYM SDLK_F5}
+ SDLK_F6 = 287;
+{$EXTERNALSYM SDLK_F6}
+ SDLK_F7 = 288;
+{$EXTERNALSYM SDLK_F7}
+ SDLK_F8 = 289;
+{$EXTERNALSYM SDLK_F8}
+ SDLK_F9 = 290;
+{$EXTERNALSYM SDLK_F9}
+ SDLK_F10 = 291;
+{$EXTERNALSYM SDLK_F10}
+ SDLK_F11 = 292;
+{$EXTERNALSYM SDLK_F11}
+ SDLK_F12 = 293;
+{$EXTERNALSYM SDLK_F12}
+ SDLK_F13 = 294;
+{$EXTERNALSYM SDLK_F13}
+ SDLK_F14 = 295;
+{$EXTERNALSYM SDLK_F14}
+ SDLK_F15 = 296;
+{$EXTERNALSYM SDLK_F15}
+
+ // Key state modifier keys
+ SDLK_NUMLOCK = 300;
+{$EXTERNALSYM SDLK_NUMLOCK}
+ SDLK_CAPSLOCK = 301;
+{$EXTERNALSYM SDLK_CAPSLOCK}
+ SDLK_SCROLLOCK = 302;
+{$EXTERNALSYM SDLK_SCROLLOCK}
+ SDLK_RSHIFT = 303;
+{$EXTERNALSYM SDLK_RSHIFT}
+ SDLK_LSHIFT = 304;
+{$EXTERNALSYM SDLK_LSHIFT}
+ SDLK_RCTRL = 305;
+{$EXTERNALSYM SDLK_RCTRL}
+ SDLK_LCTRL = 306;
+{$EXTERNALSYM SDLK_LCTRL}
+ SDLK_RALT = 307;
+{$EXTERNALSYM SDLK_RALT}
+ SDLK_LALT = 308;
+{$EXTERNALSYM SDLK_LALT}
+ SDLK_RMETA = 309;
+{$EXTERNALSYM SDLK_RMETA}
+ SDLK_LMETA = 310;
+{$EXTERNALSYM SDLK_LMETA}
+ SDLK_LSUPER = 311; // Left "Windows" key
+{$EXTERNALSYM SDLK_LSUPER}
+ SDLK_RSUPER = 312; // Right "Windows" key
+{$EXTERNALSYM SDLK_RSUPER}
+ SDLK_MODE = 313; // "Alt Gr" key
+{$EXTERNALSYM SDLK_MODE}
+ SDLK_COMPOSE = 314; // Multi-key compose key
+{$EXTERNALSYM SDLK_COMPOSE}
+
+ // Miscellaneous function keys
+ SDLK_HELP = 315;
+{$EXTERNALSYM SDLK_HELP}
+ SDLK_PRINT = 316;
+{$EXTERNALSYM SDLK_PRINT}
+ SDLK_SYSREQ = 317;
+{$EXTERNALSYM SDLK_SYSREQ}
+ SDLK_BREAK = 318;
+{$EXTERNALSYM SDLK_BREAK}
+ SDLK_MENU = 319;
+{$EXTERNALSYM SDLK_MENU}
+ SDLK_POWER = 320; // Power Macintosh power key
+{$EXTERNALSYM SDLK_POWER}
+ SDLK_EURO = 321; // Some european keyboards
+{$EXTERNALSYM SDLK_EURO}
+
+ // Enumeration of valid key mods (possibly OR'd together)
+ KMOD_NONE = $0000;
+{$EXTERNALSYM KMOD_NONE}
+ KMOD_LSHIFT = $0001;
+{$EXTERNALSYM KMOD_LSHIFT}
+ KMOD_RSHIFT = $0002;
+{$EXTERNALSYM KMOD_RSHIFT}
+ KMOD_LCTRL = $0040;
+{$EXTERNALSYM KMOD_LCTRL}
+ KMOD_RCTRL = $0080;
+{$EXTERNALSYM KMOD_RCTRL}
+ KMOD_LALT = $0100;
+{$EXTERNALSYM KMOD_LALT}
+ KMOD_RALT = $0200;
+{$EXTERNALSYM KMOD_RALT}
+ KMOD_LMETA = $0400;
+{$EXTERNALSYM KMOD_LMETA}
+ KMOD_RMETA = $0800;
+{$EXTERNALSYM KMOD_RMETA}
+ KMOD_NUM = $1000;
+{$EXTERNALSYM KMOD_NUM}
+ KMOD_CAPS = $2000;
+{$EXTERNALSYM KMOD_CAPS}
+ KMOD_MODE = 44000;
+{$EXTERNALSYM KMOD_MODE}
+ KMOD_RESERVED = $8000;
+{$EXTERNALSYM KMOD_RESERVED}
+
+ KMOD_CTRL = (KMOD_LCTRL or KMOD_RCTRL);
+{$EXTERNALSYM KMOD_CTRL}
+ KMOD_SHIFT = (KMOD_LSHIFT or KMOD_RSHIFT);
+{$EXTERNALSYM KMOD_SHIFT}
+ KMOD_ALT = (KMOD_LALT or KMOD_RALT);
+{$EXTERNALSYM KMOD_ALT}
+ KMOD_META = (KMOD_LMETA or KMOD_RMETA);
+{$EXTERNALSYM KMOD_META}
+
+ //SDL_video.h constants
+ // Transparency definitions: These define alpha as the opacity of a surface */
+ SDL_ALPHA_OPAQUE = 255;
+{$EXTERNALSYM SDL_ALPHA_OPAQUE}
+ SDL_ALPHA_TRANSPARENT = 0;
+{$EXTERNALSYM SDL_ALPHA_TRANSPARENT}
+
+ // These are the currently supported flags for the SDL_surface
+ // Available for SDL_CreateRGBSurface() or SDL_SetVideoMode()
+ SDL_SWSURFACE = $00000000; // Surface is in system memory
+{$EXTERNALSYM SDL_SWSURFACE}
+ SDL_HWSURFACE = $00000001; // Surface is in video memory
+{$EXTERNALSYM SDL_HWSURFACE}
+ SDL_ASYNCBLIT = $00000004; // Use asynchronous blits if possible
+{$EXTERNALSYM SDL_ASYNCBLIT}
+ // Available for SDL_SetVideoMode()
+ SDL_ANYFORMAT = $10000000; // Allow any video depth/pixel-format
+{$EXTERNALSYM SDL_ANYFORMAT}
+ SDL_HWPALETTE = $20000000; // Surface has exclusive palette
+{$EXTERNALSYM SDL_HWPALETTE}
+ SDL_DOUBLEBUF = $40000000; // Set up double-buffered video mode
+{$EXTERNALSYM SDL_DOUBLEBUF}
+ SDL_FULLSCREEN = $80000000; // Surface is a full screen display
+{$EXTERNALSYM SDL_FULLSCREEN}
+ SDL_OPENGL = $00000002; // Create an OpenGL rendering context
+{$EXTERNALSYM SDL_OPENGL}
+ SDL_OPENGLBLIT = $00000002; // Create an OpenGL rendering context
+{$EXTERNALSYM SDL_OPENGLBLIT}
+ SDL_RESIZABLE = $00000010; // This video mode may be resized
+{$EXTERNALSYM SDL_RESIZABLE}
+ SDL_NOFRAME = $00000020; // No window caption or edge frame
+{$EXTERNALSYM SDL_NOFRAME}
+ // Used internally (read-only)
+ SDL_HWACCEL = $00000100; // Blit uses hardware acceleration
+{$EXTERNALSYM SDL_HWACCEL}
+ SDL_SRCCOLORKEY = $00001000; // Blit uses a source color key
+{$EXTERNALSYM SDL_SRCCOLORKEY}
+ SDL_RLEACCELOK = $00002000; // Private flag
+{$EXTERNALSYM SDL_RLEACCELOK}
+ SDL_RLEACCEL = $00004000; // Colorkey blit is RLE accelerated
+{$EXTERNALSYM SDL_RLEACCEL}
+ SDL_SRCALPHA = $00010000; // Blit uses source alpha blending
+{$EXTERNALSYM SDL_SRCALPHA}
+ SDL_SRCCLIPPING = $00100000; // Blit uses source clipping
+{$EXTERNALSYM SDL_SRCCLIPPING}
+ SDL_PREALLOC = $01000000; // Surface uses preallocated memory
+{$EXTERNALSYM SDL_PREALLOC}
+
+ { The most common video overlay formats.
+ For an explanation of these pixel formats, see:
+ http://www.webartz.com/fourcc/indexyuv.htm
+
+ For information on the relationship between color spaces, see:
+ http://www.neuro.sfc.keio.ac.jp/~aly/polygon/info/color-space-faq.html }
+
+ SDL_YV12_OVERLAY = $32315659; // Planar mode: Y + V + U (3 planes)
+{$EXTERNALSYM SDL_YV12_OVERLAY}
+ SDL_IYUV_OVERLAY = $56555949; // Planar mode: Y + U + V (3 planes)
+{$EXTERNALSYM SDL_IYUV_OVERLAY}
+ SDL_YUY2_OVERLAY = $32595559; // Packed mode: Y0+U0+Y1+V0 (1 plane)
+{$EXTERNALSYM SDL_YUY2_OVERLAY}
+ SDL_UYVY_OVERLAY = $59565955; // Packed mode: U0+Y0+V0+Y1 (1 plane)
+{$EXTERNALSYM SDL_UYVY_OVERLAY}
+ SDL_YVYU_OVERLAY = $55595659; // Packed mode: Y0+V0+Y1+U0 (1 plane)
+{$EXTERNALSYM SDL_YVYU_OVERLAY}
+
+ // flags for SDL_SetPalette()
+ SDL_LOGPAL = $01;
+{$EXTERNALSYM SDL_LOGPAL}
+ SDL_PHYSPAL = $02;
+{$EXTERNALSYM SDL_PHYSPAL}
+
+ //SDL_mouse.h constants
+ { Used as a mask when testing buttons in buttonstate
+ Button 1: Left mouse button
+ Button 2: Middle mouse button
+ Button 3: Right mouse button
+ Button 4: Mouse Wheel Up
+ Button 5: Mouse Wheel Down
+ }
+ SDL_BUTTON_LEFT = 1;
+{$EXTERNALSYM SDL_BUTTON_LEFT}
+ SDL_BUTTON_MIDDLE = 2;
+{$EXTERNALSYM SDL_BUTTON_MIDDLE}
+ SDL_BUTTON_RIGHT = 3;
+{$EXTERNALSYM SDL_BUTTON_RIGHT}
+ SDL_BUTTON_WHEELUP = 4;
+{$EXTERNALSYM SDL_BUTTON_WHEELUP}
+ SDL_BUTTON_WHEELDOWN = 5;
+{$EXTERNALSYM SDL_BUTTON_WHEELDOWN}
+ SDL_BUTTON_LMASK = SDL_PRESSED shl (SDL_BUTTON_LEFT - 1);
+{$EXTERNALSYM SDL_BUTTON_LMASK}
+ SDL_BUTTON_MMASK = SDL_PRESSED shl (SDL_BUTTON_MIDDLE - 1);
+{$EXTERNALSYM SDL_BUTTON_MMASK}
+ SDL_BUTTON_RMask = SDL_PRESSED shl (SDL_BUTTON_RIGHT - 1);
+{$EXTERNALSYM SDL_BUTTON_RMask}
+
+ // SDL_active.h constants
+ // The available application states
+ SDL_APPMOUSEFOCUS = $01; // The app has mouse coverage
+{$EXTERNALSYM SDL_APPMOUSEFOCUS}
+ SDL_APPINPUTFOCUS = $02; // The app has input focus
+{$EXTERNALSYM SDL_APPINPUTFOCUS}
+ SDL_APPACTIVE = $04; // The application is active
+{$EXTERNALSYM SDL_APPACTIVE}
+
+ // SDL_mutex.h constants
+ // Synchronization functions which can time out return this value
+ // they time out.
+
+ SDL_MUTEX_TIMEDOUT = 1;
+{$EXTERNALSYM SDL_MUTEX_TIMEDOUT}
+
+ // This is the timeout value which corresponds to never time out
+ SDL_MUTEX_MAXWAIT = not Cardinal(0);
+{$EXTERNALSYM SDL_MUTEX_MAXWAIT}
+
+ {TSDL_GrabMode = (
+ SDL_GRAB_QUERY,
+ SDL_GRAB_OFF,
+ SDL_GRAB_ON,
+ SDL_GRAB_FULLSCREEN ); // Used internally}
+ SDL_GRAB_QUERY = -1;
+ SDL_GRAB_OFF = 0;
+ SDL_GRAB_ON = 1;
+ //SDL_GRAB_FULLSCREEN // Used internally
+
+type
+ THandle = Cardinal;
+ //SDL_types.h types
+ // Basic data types
+
+ SDL_Bool = (SDL_FALSE, SDL_TRUE);
+ TSDL_Bool = SDL_Bool;
+
+ PUInt8Array = ^TUInt8Array;
+ PUInt8 = ^UInt8;
+ UInt8 = Byte;
+{$EXTERNALSYM UInt8}
+ TUInt8Array = array [0..MAXINT shr 1] of UInt8;
+
+ PUInt16 = ^UInt16;
+ UInt16 = word;
+{$EXTERNALSYM UInt16}
+
+ PSInt16 = ^SInt16;
+ SInt16 = smallint;
+{$EXTERNALSYM SInt16}
+
+ PUInt32 = ^UInt32;
+ UInt32 = Cardinal;
+{$EXTERNALSYM UInt32}
+
+ SInt32 = Integer;
+{$EXTERNALSYM SInt32}
+
+ PInt = ^Integer;
+
+ PShortInt = ^ShortInt;
+
+ PUInt64 = ^UInt64;
+ UInt64 = record
+ hi: UInt32;
+ lo: UInt32;
+ end;
+{$EXTERNALSYM UInt64}
+
+ PSInt64 = ^SInt64;
+ SInt64 = record
+ hi: UInt32;
+ lo: UInt32;
+ end;
+{$EXTERNALSYM SInt64}
+
+ TSDL_GrabMode = Integer;
+
+ // SDL_error.h types
+ TSDL_errorcode = (
+ SDL_ENOMEM,
+ SDL_EFREAD,
+ SDL_EFWRITE,
+ SDL_EFSEEK,
+ SDL_LASTERROR);
+
+ SDL_errorcode = TSDL_errorcode;
+{$EXTERNALSYM SDL_errorcode}
+
+ TArg = record
+ case Byte of
+ 0: (value_ptr: Pointer);
+ (* #if 0 means: never
+ 1 : ( value_c : Byte );
+ *)
+ 2: (value_i: Integer);
+ 3: (value_f: double);
+ 4: (buf: array[0..ERR_MAX_STRLEN - 1] of Byte);
+ end;
+
+ PSDL_error = ^TSDL_error;
+ TSDL_error = record
+ { This is a numeric value corresponding to the current error }
+ error: Integer;
+
+ { This is a key used to index into a language hashtable containing
+ internationalized versions of the SDL error messages. If the key
+ is not in the hashtable, or no hashtable is available, the key is
+ used directly as an error message format string. }
+ key: array[0..ERR_MAX_STRLEN - 1] of Byte;
+
+ { These are the arguments for the error functions }
+ argc: Integer;
+ args: array[0..ERR_MAX_ARGS - 1] of TArg;
+ end;
+
+ // SDL_rwops.h types
+ // This is the read/write operation structure -- very basic
+ // some helper types to handle the unions
+ // "packed" is only guessed
+
+ TStdio = record
+ autoclose: Integer;
+ // FILE * is only defined in Kylix so we use a simple Pointer
+ fp: Pointer;
+ end;
+
+ TMem = record
+ base: PUInt8;
+ here: PUInt8;
+ stop: PUInt8;
+ end;
+
+ TUnknown = record
+ data1: Pointer;
+ end;
+
+ // first declare the pointer type
+ PSDL_RWops = ^TSDL_RWops;
+ // now the pointer to function types
+ {$IFNDEF __GPC__}
+ TSeek = function( context: PSDL_RWops; offset: Integer; whence: Integer ): Integer; cdecl;
+ TRead = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; maxnum : Integer ): Integer; cdecl;
+ TWrite = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; num: Integer ): Integer; cdecl;
+ TClose = function( context: PSDL_RWops ): Integer; cdecl;
+ {$ELSE}
+ TSeek = function( context: PSDL_RWops; offset: Integer; whence: Integer ): Integer;
+ TRead = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; maxnum : Integer ): Integer;
+ TWrite = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; num: Integer ): Integer;
+ TClose = function( context: PSDL_RWops ): Integer;
+ {$ENDIF}
+ // the variant record itself
+ TSDL_RWops = record
+ seek: TSeek;
+ read: TRead;
+ write: TWrite;
+ close: TClose;
+ // a keyword as name is not allowed
+ type_: UInt32;
+ // be warned! structure alignment may arise at this point
+ case Integer of
+ 0: (stdio: TStdio);
+ 1: (mem: TMem);
+ 2: (unknown: TUnknown);
+ end;
+
+ SDL_RWops = TSDL_RWops;
+{$EXTERNALSYM SDL_RWops}
+
+
+ // SDL_timer.h types
+ // Function prototype for the timer callback function
+ {$IFNDEF __GPC__}
+ TSDL_TimerCallback = function( interval: UInt32 ): UInt32; cdecl;
+ {$ELSE}
+ TSDL_TimerCallback = function( interval: UInt32 ): UInt32;
+ {$ENDIF}
+
+ { New timer API, supports multiple timers
+ Written by Stephane Peter <megastep@lokigames.com> }
+
+ { Function prototype for the new timer callback function.
+ The callback function is passed the current timer interval and returns
+ the next timer interval. If the returned value is the same as the one
+ passed in, the periodic alarm continues, otherwise a new alarm is
+ scheduled. If the callback returns 0, the periodic alarm is cancelled. }
+ {$IFNDEF __GPC__}
+ TSDL_NewTimerCallback = function( interval: UInt32; param: Pointer ): UInt32; cdecl;
+ {$ELSE}
+ TSDL_NewTimerCallback = function( interval: UInt32; param: Pointer ): UInt32;
+ {$ENDIF}
+
+ // Definition of the timer ID type
+ PSDL_TimerID = ^TSDL_TimerID;
+ TSDL_TimerID = record
+ interval: UInt32;
+ callback: TSDL_NewTimerCallback;
+ param: Pointer;
+ last_alarm: UInt32;
+ next: PSDL_TimerID;
+ end;
+
+ {$IFNDEF __GPC__}
+ TSDL_AudioSpecCallback = procedure( userdata: Pointer; stream: PUInt8; len: Integer ); cdecl;
+ {$ELSE}
+ TSDL_AudioSpecCallback = procedure( userdata: Pointer; stream: PUInt8; len: Integer );
+ {$ENDIF}
+
+ // SDL_audio.h types
+ // The calculated values in this structure are calculated by SDL_OpenAudio()
+ PSDL_AudioSpec = ^TSDL_AudioSpec;
+ TSDL_AudioSpec = record
+ freq: Integer; // DSP frequency -- samples per second
+ format: UInt16; // Audio data format
+ channels: UInt8; // Number of channels: 1 mono, 2 stereo
+ silence: UInt8; // Audio buffer silence value (calculated)
+ samples: UInt16; // Audio buffer size in samples
+ padding: UInt16; // Necessary for some compile environments
+ size: UInt32; // Audio buffer size in bytes (calculated)
+ { This function is called when the audio device needs more data.
+ 'stream' is a pointer to the audio data buffer
+ 'len' is the length of that buffer in bytes.
+ Once the callback returns, the buffer will no longer be valid.
+ Stereo samples are stored in a LRLRLR ordering.}
+ callback: TSDL_AudioSpecCallback;
+ userdata: Pointer;
+ end;
+
+ // A structure to hold a set of audio conversion filters and buffers
+ PSDL_AudioCVT = ^TSDL_AudioCVT;
+
+ PSDL_AudioCVTFilter = ^TSDL_AudioCVTFilter;
+ TSDL_AudioCVTFilter = record
+ cvt: PSDL_AudioCVT;
+ format: UInt16;
+ end;
+
+ PSDL_AudioCVTFilterArray = ^TSDL_AudioCVTFilterArray;
+ TSDL_AudioCVTFilterArray = array[0..9] of PSDL_AudioCVTFilter;
+
+ TSDL_AudioCVT = record
+ needed: Integer; // Set to 1 if conversion possible
+ src_format: UInt16; // Source audio format
+ dst_format: UInt16; // Target audio format
+ rate_incr: double; // Rate conversion increment
+ buf: PUInt8; // Buffer to hold entire audio data
+ len: Integer; // Length of original audio buffer
+ len_cvt: Integer; // Length of converted audio buffer
+ len_mult: Integer; // buffer must be len*len_mult big
+ len_ratio: double; // Given len, final size is len*len_ratio
+ filters: TSDL_AudioCVTFilterArray;
+ filter_index: Integer; // Current audio conversion function
+ end;
+
+ TSDL_Audiostatus = (
+ SDL_AUDIO_STOPPED,
+ SDL_AUDIO_PLAYING,
+ SDL_AUDIO_PAUSED
+ );
+
+ // SDL_cdrom.h types
+ TSDL_CDStatus = (
+ CD_ERROR,
+ CD_TRAYEMPTY,
+ CD_STOPPED,
+ CD_PLAYING,
+ CD_PAUSED );
+
+ PSDL_CDTrack = ^TSDL_CDTrack;
+ TSDL_CDTrack = record
+ id: UInt8; // Track number
+ type_: UInt8; // Data or audio track
+ unused: UInt16;
+ length: UInt32; // Length, in frames, of this track
+ offset: UInt32; // Offset, in frames, from start of disk
+ end;
+
+ // This structure is only current as of the last call to SDL_CDStatus()
+ PSDL_CD = ^TSDL_CD;
+ TSDL_CD = record
+ id: Integer; // Private drive identifier
+ status: TSDL_CDStatus; // Current drive status
+
+ // The rest of this structure is only valid if there's a CD in drive
+ numtracks: Integer; // Number of tracks on disk
+ cur_track: Integer; // Current track position
+ cur_frame: Integer; // Current frame offset within current track
+ track: array[0..SDL_MAX_TRACKS] of TSDL_CDTrack;
+ end;
+
+ //SDL_joystick.h types
+ PTransAxis = ^TTransAxis;
+ TTransAxis = record
+ offset: Integer;
+ scale: single;
+ end;
+
+ // The private structure used to keep track of a joystick
+ PJoystick_hwdata = ^TJoystick_hwdata;
+ TJoystick_hwdata = record
+ // joystick ID
+ id: Integer;
+ // values used to translate device-specific coordinates into SDL-standard ranges
+ transaxis: array[0..5] of TTransAxis;
+ end;
+
+ PBallDelta = ^TBallDelta;
+ TBallDelta = record
+ dx: Integer;
+ dy: Integer;
+ end; // Current ball motion deltas
+
+ // The SDL joystick structure
+ PSDL_Joystick = ^TSDL_Joystick;
+ TSDL_Joystick = record
+ index: UInt8; // Device index
+ name: PChar; // Joystick name - system dependent
+
+ naxes: Integer; // Number of axis controls on the joystick
+ axes: PUInt16; // Current axis states
+
+ nhats: Integer; // Number of hats on the joystick
+ hats: PUInt8; // Current hat states
+
+ nballs: Integer; // Number of trackballs on the joystick
+ balls: PBallDelta; // Current ball motion deltas
+
+ nbuttons: Integer; // Number of buttons on the joystick
+ buttons: PUInt8; // Current button states
+
+ hwdata: PJoystick_hwdata; // Driver dependent information
+
+ ref_count: Integer; // Reference count for multiple opens
+ end;
+
+ // SDL_verion.h types
+ PSDL_version = ^TSDL_version;
+ TSDL_version = record
+ major: UInt8;
+ minor: UInt8;
+ patch: UInt8;
+ end;
+
+ // SDL_keyboard.h types
+ TSDLKey = LongWord;
+
+ TSDLMod = LongWord;
+
+ PSDL_KeySym = ^TSDL_KeySym;
+ TSDL_KeySym = record
+ scancode: UInt8; // hardware specific scancode
+ sym: TSDLKey; // SDL virtual keysym
+ modifier: TSDLMod; // current key modifiers
+ unicode: UInt16; // translated character
+ end;
+
+ // SDL_events.h types
+ {Checks the event queue for messages and optionally returns them.
+ If 'action' is SDL_ADDEVENT, up to 'numevents' events will be added to
+ the back of the event queue.
+ If 'action' is SDL_PEEKEVENT, up to 'numevents' events at the front
+ of the event queue, matching 'mask', will be returned and will not
+ be removed from the queue.
+ If 'action' is SDL_GETEVENT, up to 'numevents' events at the front
+ of the event queue, matching 'mask', will be returned and will be
+ removed from the queue.
+ This function returns the number of events actually stored, or -1
+ if there was an error. This function is thread-safe. }
+
+ TSDL_EventAction = (SDL_ADDEVENT, SDL_PEEKEVENT, SDL_GETEVENT);
+
+ // Application visibility event structure
+ TSDL_ActiveEvent = record
+ type_: UInt8; // SDL_ACTIVEEVENT
+ gain: UInt8; // Whether given states were gained or lost (1/0)
+ state: UInt8; // A mask of the focus states
+ end;
+
+ // Keyboard event structure
+ TSDL_KeyboardEvent = record
+ type_: UInt8; // SDL_KEYDOWN or SDL_KEYUP
+ which: UInt8; // The keyboard device index
+ state: UInt8; // SDL_PRESSED or SDL_RELEASED
+ keysym: TSDL_KeySym;
+ end;
+
+ // Mouse motion event structure
+ TSDL_MouseMotionEvent = record
+ type_: UInt8; // SDL_MOUSEMOTION
+ which: UInt8; // The mouse device index
+ state: UInt8; // The current button state
+ x, y: UInt16; // The X/Y coordinates of the mouse
+ xrel: SInt16; // The relative motion in the X direction
+ yrel: SInt16; // The relative motion in the Y direction
+ end;
+
+ // Mouse button event structure
+ TSDL_MouseButtonEvent = record
+ type_: UInt8; // SDL_MOUSEBUTTONDOWN or SDL_MOUSEBUTTONUP
+ which: UInt8; // The mouse device index
+ button: UInt8; // The mouse button index
+ state: UInt8; // SDL_PRESSED or SDL_RELEASED
+ x: UInt16; // The X coordinates of the mouse at press time
+ y: UInt16; // The Y coordinates of the mouse at press time
+ end;
+
+ // Joystick axis motion event structure
+ TSDL_JoyAxisEvent = record
+ type_: UInt8; // SDL_JOYAXISMOTION
+ which: UInt8; // The joystick device index
+ axis: UInt8; // The joystick axis index
+ value: SInt16; // The axis value (range: -32768 to 32767)
+ end;
+
+ // Joystick trackball motion event structure
+ TSDL_JoyBallEvent = record
+ type_: UInt8; // SDL_JOYAVBALLMOTION
+ which: UInt8; // The joystick device index
+ ball: UInt8; // The joystick trackball index
+ xrel: SInt16; // The relative motion in the X direction
+ yrel: SInt16; // The relative motion in the Y direction
+ end;
+
+ // Joystick hat position change event structure
+ TSDL_JoyHatEvent = record
+ type_: UInt8; // SDL_JOYHATMOTION */
+ which: UInt8; // The joystick device index */
+ hat: UInt8; // The joystick hat index */
+ value: UInt8; { The hat position value:
+ 8 1 2
+ 7 0 3
+ 6 5 4
+
+ Note that zero means the POV is centered. }
+
+ end;
+
+ // Joystick button event structure
+ TSDL_JoyButtonEvent = record
+ type_: UInt8; // SDL_JOYBUTTONDOWN or SDL_JOYBUTTONUP
+ which: UInt8; // The joystick device index
+ button: UInt8; // The joystick button index
+ state: UInt8; // SDL_PRESSED or SDL_RELEASED
+ end;
+
+ { The "window resized" event
+ When you get this event, you are responsible for setting a new video
+ mode with the new width and height. }
+ TSDL_ResizeEvent = record
+ type_: UInt8; // SDL_VIDEORESIZE
+ w: Integer; // New width
+ h: Integer; // New height
+ end;
+
+ // The "quit requested" event
+ PSDL_QuitEvent = ^TSDL_QuitEvent;
+ TSDL_QuitEvent = record
+ type_: UInt8;
+ end;
+
+ // A user-defined event type
+ PSDL_UserEvent = ^TSDL_UserEvent;
+ TSDL_UserEvent = record
+ type_: UInt8; // SDL_USEREVENT through SDL_NUMEVENTS-1
+ code: Integer; // User defined event code */
+ data1: Pointer; // User defined data pointer */
+ data2: Pointer; // User defined data pointer */
+ end;
+
+ // The "screen redraw" event
+ PSDL_ExposeEvent = ^TSDL_ExposeEvent;
+ TSDL_ExposeEvent = record
+ type_ : Uint8; // SDL_VIDEOEXPOSE
+ end;
+
+ {$IFDEF Unix}
+ //These are the various supported subsystems under UNIX
+ TSDL_SysWm = ( SDL_SYSWM_X11 ) ;
+ {$ENDIF}
+
+// The windows custom event structure
+{$IFDEF Win32}
+ PSDL_SysWMmsg = ^TSDL_SysWMmsg;
+ TSDL_SysWMmsg = record
+ version: TSDL_version;
+ h_wnd: HWND; // The window for the message
+ msg: UInt; // The type of message
+ w_Param: WPARAM; // WORD message parameter
+ lParam: LPARAM; // LONG message parameter
+ end;
+{$ELSE}
+
+{$IFDEF Unix}
+{ The Linux custom event structure }
+ PSDL_SysWMmsg = ^TSDL_SysWMmsg;
+ TSDL_SysWMmsg = record
+ version : TSDL_version;
+ subsystem : TSDL_SysWm;
+ {$IFDEF FPC}
+ event : TXEvent;
+ {$ELSE}
+ event : XEvent;
+ {$ENDIF}
+ end;
+{$ELSE}
+{ The generic custom event structure }
+ PSDL_SysWMmsg = ^TSDL_SysWMmsg;
+ TSDL_SysWMmsg = record
+ version: TSDL_version;
+ data: Integer;
+ end;
+{$ENDIF}
+
+{$ENDIF}
+
+// The Windows custom window manager information structure
+{$IFDEF Win32}
+ PSDL_SysWMinfo = ^TSDL_SysWMinfo;
+ TSDL_SysWMinfo = record
+ version : TSDL_version;
+ window : HWnd; // The display window
+ end;
+{$ELSE}
+
+// The Linux custom window manager information structure
+{$IFDEF Unix}
+ TX11 = record
+ display : PDisplay; // The X11 display
+ window : TWindow ; // The X11 display window */
+ {* These locking functions should be called around
+ any X11 functions using the display variable.
+ They lock the event thread, so should not be
+ called around event functions or from event filters.
+ *}
+ lock_func : Pointer;
+ unlock_func : Pointer;
+
+ // Introduced in SDL 1.0.2
+ fswindow : TWindow ; // The X11 fullscreen window */
+ wmwindow : TWindow ; // The X11 managed input window */
+ end;
+
+ PSDL_SysWMinfo = ^TSDL_SysWMinfo;
+ TSDL_SysWMinfo = record
+ version : TSDL_version ;
+ subsystem : TSDL_SysWm;
+ X11 : TX11;
+ end;
+{$ELSE}
+ // The generic custom window manager information structure
+ PSDL_SysWMinfo = ^TSDL_SysWMinfo;
+ TSDL_SysWMinfo = record
+ version : TSDL_version ;
+ data : integer;
+ end;
+{$ENDIF}
+
+{$ENDIF}
+
+ PSDL_SysWMEvent = ^TSDL_SysWMEvent;
+ TSDL_SysWMEvent = record
+ type_: UInt8;
+ msg: PSDL_SysWMmsg;
+ end;
+
+ PSDL_Event = ^TSDL_Event;
+ TSDL_Event = record
+ case UInt8 of
+ SDL_NOEVENT: (type_: byte);
+ SDL_ACTIVEEVENT: (active: TSDL_ActiveEvent);
+ SDL_KEYDOWN, SDL_KEYUP: (key: TSDL_KeyboardEvent);
+ SDL_MOUSEMOTION: (motion: TSDL_MouseMotionEvent);
+ SDL_MOUSEBUTTONDOWN, SDL_MOUSEBUTTONUP: (button: TSDL_MouseButtonEvent );
+ SDL_JOYAXISMOTION: (jaxis: TSDL_JoyAxisEvent );
+ SDL_JOYBALLMOTION: (jball: TSDL_JoyBallEvent );
+ SDL_JOYHATMOTION: (jhat: TSDL_JoyHatEvent );
+ SDL_JOYBUTTONDOWN, SDL_JOYBUTTONUP: (jbutton: TSDL_JoyButtonEvent );
+ SDL_VIDEORESIZE: (resize: TSDL_ResizeEvent );
+ SDL_QUITEV: (quit: TSDL_QuitEvent );
+ SDL_USEREVENT : ( user : TSDL_UserEvent );
+ SDL_SYSWMEVENT: (syswm: TSDL_SysWMEvent );
+ end;
+
+
+{ This function sets up a filter to process all events before they
+ change internal state and are posted to the internal event queue.
+
+ The filter is protypted as: }
+ {$IFNDEF __GPC__}
+ TSDL_EventFilter = function( event : PSDL_Event ): Integer; cdecl;
+ {$ELSE}
+ TSDL_EventFilter = function( event : PSDL_Event ): Integer;
+ {$ENDIF}
+
+ // SDL_video.h types
+ // Useful data types
+ PPSDL_Rect = ^PSDL_Rect;
+ PSDL_Rect = ^TSDL_Rect;
+ TSDL_Rect = record
+ x, y: SInt16;
+ w, h: UInt16;
+ end;
+
+ SDL_Rect = TSDL_Rect;
+{$EXTERNALSYM SDL_Rect}
+
+ PSDL_Color = ^TSDL_Color;
+ TSDL_Color = record
+ r: UInt8;
+ g: UInt8;
+ b: UInt8;
+ unused: UInt8;
+ end;
+
+ PSDL_ColorArray = ^TSDL_ColorArray;
+ TSDL_ColorArray = array[0..65000] of TSDL_Color;
+
+ PSDL_Palette = ^TSDL_Palette;
+ TSDL_Palette = record
+ ncolors: Integer;
+ colors: PSDL_ColorArray;
+ end;
+
+ // Everything in the pixel format structure is read-only
+ PSDL_PixelFormat = ^TSDL_PixelFormat;
+ TSDL_PixelFormat = record
+ palette: PSDL_Palette;
+ BitsPerPixel: UInt8;
+ BytesPerPixel: UInt8;
+ Rloss: UInt8;
+ Gloss: UInt8;
+ Bloss: UInt8;
+ Aloss: UInt8;
+ Rshift: UInt8;
+ Gshift: UInt8;
+ Bshift: UInt8;
+ Ashift: UInt8;
+ RMask: UInt32;
+ GMask: UInt32;
+ BMask: UInt32;
+ AMask: UInt32;
+ colorkey: UInt32; // RGB color key information
+ alpha: UInt8; // Alpha value information (per-surface alpha)
+ end;
+
+{$IFDEF WIN32}
+ {PPrivate_hwdata = ^TPrivate_hwdata;
+ TPrivate_hwdata = record
+ dd_surface : IDIRECTDRAWSURFACE3;
+ dd_writebuf : IDIRECTDRAWSURFACE3;
+ end;}
+ {ELSE}
+{$ENDIF}
+
+ // The structure passed to the low level blit functions
+ PSDL_BlitInfo = ^TSDL_BlitInfo;
+ TSDL_BlitInfo = record
+ s_pixels: PUInt8;
+ s_width: Integer;
+ s_height: Integer;
+ s_skip: Integer;
+ d_pixels: PUInt8;
+ d_width: Integer;
+ d_height: Integer;
+ d_skip: Integer;
+ aux_data: Pointer;
+ src: PSDL_PixelFormat;
+ table: PUInt8;
+ dst: PSDL_PixelFormat;
+ end;
+
+ // typedef for private surface blitting functions
+ PSDL_Surface = ^TSDL_Surface;
+
+ {$IFNDEF __GPC__}
+ TSDL_Blit = function( src: PSDL_Surface; srcrect: PSDL_Rect; dst: PSDL_Surface; dstrect: PSDL_Rect ): Integer; cdecl;
+ {$ELSE}
+ TSDL_Blit = function( src: PSDL_Surface; srcrect: PSDL_Rect; dst: PSDL_Surface; dstrect: PSDL_Rect ): Integer;
+ {$ENDIF}
+
+ // The type definition for the low level blit functions
+ //TSDL_LoBlit = procedure( info : PSDL_BlitInfo ); cdecl;
+
+ // This is the private info structure for software accelerated blits
+ {PPrivate_swaccel = ^TPrivate_swaccel;
+ TPrivate_swaccel = record
+ blit : TSDL_LoBlit;
+ aux_data : Pointer;
+ end;}
+
+ // Blit mapping definition
+ {PSDL_BlitMap = ^TSDL_BlitMap;
+ TSDL_BlitMap = record
+ dst : PSDL_Surface;
+ identity : Integer;
+ table : PUInt8;
+ hw_blit : TSDL_Blit;
+ sw_blit : TSDL_Blit;
+ hw_data : PPrivate_hwaccel;
+ sw_data : PPrivate_swaccel;
+
+ // the version count matches the destination; mismatch indicates an invalid mapping
+ format_version : Cardinal;
+ end;}
+
+ TSDL_Surface = record
+ flags: UInt32; // Read-only
+ format: PSDL_PixelFormat; // Read-only
+ w, h: Integer; // Read-only
+ pitch: UInt16; // Read-only
+ pixels: Pointer; // Read-write
+ offset: Integer; // Private
+ hwdata: Pointer; //TPrivate_hwdata; Hardware-specific surface info
+
+ // clipping information:
+ clip_rect: TSDL_Rect; // Read-only
+ unused1: UInt32; // for binary compatibility
+ // Allow recursive locks
+ locked: UInt32; // Private
+ // info for fast blit mapping to other surfaces
+ Blitmap: Pointer; // PSDL_BlitMap; // Private
+ // format version, bumped at every change to invalidate blit maps
+ format_version: Cardinal; // Private
+ refcount: Integer;
+ end;
+
+ // Useful for determining the video hardware capabilities
+ PSDL_VideoInfo = ^TSDL_VideoInfo;
+ TSDL_VideoInfo = record
+ hw_available: UInt8; // Hardware and WindowManager flags in first 2 bits ( see below )
+ {hw_available: 1; // Can you create hardware surfaces
+ wm_available: 1; // Can you talk to a window manager?
+ UnusedBits1: 6;}
+ blit_hw: UInt8; // Blit Hardware flags. See below for which bits do what
+ {UnusedBits2: 1;
+ blit_hw: 1; // Flag:UInt32 Accelerated blits HW --> HW
+ blit_hw_CC: 1; // Flag:UInt32 Accelerated blits with Colorkey
+ blit_hw_A: 1; // Flag:UInt32 Accelerated blits with Alpha
+ blit_sw: 1; // Flag:UInt32 Accelerated blits SW --> HW
+ blit_sw_CC: 1; // Flag:UInt32 Accelerated blits with Colorkey
+ blit_sw_A: 1; // Flag:UInt32 Accelerated blits with Alpha
+ blit_fill: 1; // Flag:UInt32 Accelerated color fill}
+ UnusedBits3: UInt8; // Unused at this point
+ video_mem: UInt32; // The total amount of video memory (in K)
+ vfmt: PSDL_PixelFormat; // Value: The format of the video surface
+ end;
+
+ // The YUV hardware video overlay
+ PSDL_Overlay = ^TSDL_Overlay;
+ TSDL_Overlay = record
+ format: UInt32; // Overlay format
+ w, h: Integer; // Width and height of overlay
+ planes: Integer; // Number of planes in the overlay. Usually either 1 or 3
+ pitches: PUInt16;
+ // An array of pitches, one for each plane. Pitch is the length of a row in bytes.
+ pixels: PUInt8;
+ // An array of pointers to teh data of each plane. The overlay should be locked before these pointers are used.
+ hw_overlay: UInt32;
+ // This will be set to 1 if the overlay is hardware accelerated.
+ end;
+
+ // Public enumeration for setting the OpenGL window attributes.
+ TSDL_GLAttr = (
+ SDL_GL_RED_SIZE,
+ SDL_GL_GREEN_SIZE,
+ SDL_GL_BLUE_SIZE,
+ SDL_GL_ALPHA_SIZE,
+ SDL_GL_BUFFER_SIZE,
+ SDL_GL_DOUBLEBUFFER,
+ SDL_GL_DEPTH_SIZE,
+ SDL_GL_STENCIL_SIZE,
+ SDL_GL_ACCUM_RED_SIZE,
+ SDL_GL_ACCUM_GREEN_SIZE,
+ SDL_GL_ACCUM_BLUE_SIZE,
+ SDL_GL_ACCUM_ALPHA_SIZE,
+ SDL_GL_STEREO,
+ SDL_GL_MULTISAMPLEBUFFERS,
+ SDL_GL_MULTISAMPLESAMPLES);
+
+
+
+ PSDL_Cursor = ^TSDL_Cursor;
+ TSDL_Cursor = record
+ area: TSDL_Rect; // The area of the mouse cursor
+ hot_x, hot_y: SInt16; // The "tip" of the cursor
+ data: PUInt8; // B/W cursor data
+ mask: PUInt8; // B/W cursor mask
+ save: array[1..2] of PUInt8; // Place to save cursor area
+ wm_cursor: Pointer; // Window-manager cursor
+ end;
+
+// SDL_mutex.h types
+
+{$IFDEF WIN32}
+ PSDL_Mutex = ^TSDL_Mutex;
+ TSDL_Mutex = record
+ id: THANDLE;
+ end;
+{$ENDIF}
+
+{$IFDEF Unix}
+ PSDL_Mutex = ^TSDL_Mutex;
+ TSDL_mutex = record
+ id: pthread_mutex_t;
+{$IFDEF PTHREAD_NO_RECURSIVE_MUTEX}
+ recursive: Integer;
+ owner: pthread_t;
+{$ENDIF}
+ end;
+{$ENDIF}
+
+{$IFDEF __MACH__}
+ {$define USE_NAMED_SEMAPHORES}
+ // Broken sem_getvalue() in MacOS X Public Beta */
+ {$define BROKEN_SEMGETVALUE}
+{$ENDIF}
+
+PSDL_semaphore = ^TSDL_semaphore;
+{$IFDEF WIN32}
+ // Win32 or Machintosh
+ TSDL_semaphore = record
+ id: THANDLE;
+ count: UInt32;
+ end;
+{$ELSE}
+ {$IFDEF FPC}
+ // This should be semaphore.h
+ __sem_lock_t = {packed} record { Not in header file - anonymous }
+ status: Longint;
+ spinlock: Integer;
+ end;
+
+ sem_t = {packed} record
+ __sem_lock: __sem_lock_t;
+ __sem_value: Integer;
+ __sem_waiting: longint ; {_pthread_queue;}
+ end;
+ {$ENDIF}
+
+ TSDL_semaphore = record
+ sem: Pointer; //PSem_t;
+ {$IFNDEF USE_NAMED_SEMAPHORES}
+ sem_data: Sem_t;
+ {$ENDIF}
+
+ {$IFDEF BROKEN_SEMGETVALUE}
+ { This is a little hack for MacOS X -
+ It's not thread-safe, but it's better than nothing }
+ sem_value: Integer;
+ {$ENDIF}
+ end;
+{$ENDIF}
+
+ PSDL_Sem = ^TSDL_Sem;
+ TSDL_Sem = TSDL_Semaphore;
+
+ PSDL_Cond = ^TSDL_Cond;
+ TSDL_Cond = record
+{$IFDEF Unix}
+ cond: pthread_cond_t;
+{$ELSE}
+ // Generic Cond structure
+ lock: PSDL_mutex;
+ waiting: Integer;
+ signals: Integer;
+ wait_sem: PSDL_Sem;
+ wait_done: PSDL_Sem;
+{$ENDIF}
+ end;
+
+ // SDL_thread.h types
+{$IFDEF WIN32}
+ TSYS_ThreadHandle = THandle;
+{$ENDIF}
+
+{$IFDEF Unix}
+ TSYS_ThreadHandle = pthread_t;
+{$ENDIF}
+
+ { This is the system-independent thread info structure }
+ PSDL_Thread = ^TSDL_Thread;
+ TSDL_Thread = record
+ threadid: UInt32;
+ handle: TSYS_ThreadHandle;
+ status: Integer;
+ errbuf: TSDL_Error;
+ data: Pointer;
+ end;
+
+ // Helper Types
+
+ // Keyboard State Array ( See demos for how to use )
+ PKeyStateArr = ^TKeyStateArr;
+ TKeyStateArr = array[0..65000] of UInt8;
+
+ // Types required so we don't need to use Windows.pas
+ PInteger = ^Integer;
+ PByte = ^Byte;
+ PWord = ^Word;
+ PLongWord = ^Longword;
+
+ // General arrays
+ PByteArray = ^TByteArray;
+ TByteArray = array[0..32767] of Byte;
+
+ PWordArray = ^TWordArray;
+ TWordArray = array[0..16383] of Word;
+
+ PPoint = ^TPoint;
+ TPoint = record
+ x: Longint;
+ y: Longint;
+ end;
+
+ PRect = ^TRect;
+ TRect = record
+ case Integer of
+ 0: (Left, Top, Right, Bottom: Integer);
+ 1: (TopLeft, BottomRight: TPoint);
+ end;
+
+ { Generic procedure pointer }
+ TProcedure = procedure;
+
+{------------------------------------------------------------------------------}
+{ initialization }
+{------------------------------------------------------------------------------}
+
+{ This function loads the SDL dynamically linked library and initializes
+ the subsystems specified by 'flags' (and those satisfying dependencies)
+ Unless the SDL_INIT_NOPARACHUTE flag is set, it will install cleanup
+ signal handlers for some commonly ignored fatal signals (like SIGSEGV) }
+
+function SDL_Init( flags : UInt32 ) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_Init'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_Init}
+
+// This function initializes specific SDL subsystems
+function SDL_InitSubSystem( flags : UInt32 ) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_InitSubSystem'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_InitSubSystem}
+
+// This function cleans up specific SDL subsystems
+procedure SDL_QuitSubSystem( flags : UInt32 );
+cdecl; external {$IFDEF __GPC__}name 'SDL_QuitSubSystem'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_QuitSubSystem}
+
+{ This function returns mask of the specified subsystems which have
+ been initialized.
+ If 'flags' is 0, it returns a mask of all initialized subsystems. }
+
+function SDL_WasInit( flags : UInt32 ): UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_WasInit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WasInit}
+
+{ This function cleans up all initialized subsystems and unloads the
+ dynamically linked library. You should call it upon all exit conditions. }
+procedure SDL_Quit;
+cdecl; external {$IFDEF __GPC__}name 'SDL_Quit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_Quit}
+
+{$IFDEF WIN32}
+// This should be called from your WinMain() function, if any
+function SDL_RegisterApp(name: PChar; style: UInt32; h_Inst: Pointer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_RegisterApp'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_RegisterApp}
+{$ENDIF}
+
+{$IFDEF __MACH__}
+// This should be called from your main() function, if any
+procedure SDL_InitQuickDraw( the_qd: QDGlobals );
+cdecl; external {$IFDEF __GPC__}name 'SDL_InitQuickDraw'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_InitQuickDraw}
+{$ENDIF}
+
+
+{------------------------------------------------------------------------------}
+{ types }
+{------------------------------------------------------------------------------}
+// The number of elements in a table
+function SDL_TableSize( table: PChar ): Integer;
+{$EXTERNALSYM SDL_TABLESIZE}
+
+
+{------------------------------------------------------------------------------}
+{ error-handling }
+{------------------------------------------------------------------------------}
+// Public functions
+function SDL_GetError: PChar;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetError'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetError}
+procedure SDL_SetError(fmt: PChar);
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetError'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetError}
+procedure SDL_ClearError;
+cdecl; external {$IFDEF __GPC__}name 'SDL_ClearError'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_ClearError}
+
+{$IFNDEF WIN32}
+procedure SDL_Error(Code: TSDL_errorcode);
+cdecl; external {$IFDEF __GPC__}name 'SDL_Error'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_Error}
+{$ENDIF}
+
+// Private error message function - used internally
+procedure SDL_OutOfMemory;
+
+{------------------------------------------------------------------------------}
+{ io handling }
+{------------------------------------------------------------------------------}
+// Functions to create SDL_RWops structures from various data sources
+
+function SDL_RWFromFile(filename, mode: PChar): PSDL_RWops;
+cdecl; external {$IFDEF __GPC__}name 'SDL_RWFromFile'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_RWFromFile}
+procedure SDL_FreeRW(area: PSDL_RWops);
+cdecl; external {$IFDEF __GPC__}name 'SDL_FreeRW'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_FreeRW}
+
+//fp is FILE *fp ???
+function SDL_RWFromFP(fp: Pointer; autoclose: Integer): PSDL_RWops;
+cdecl; external {$IFDEF __GPC__}name 'SDL_RWFromFP'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_RWFromFP}
+function SDL_RWFromMem(mem: Pointer; size: Integer): PSDL_RWops;
+cdecl; external {$IFDEF __GPC__}name 'SDL_RWFromMem'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_RWFromMem}
+function SDL_RWFromConstMem(const mem: Pointer; size: Integer) : PSDL_RWops;
+cdecl; external {$IFDEF __GPC__}name 'SDL_RWFromConstMem'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_RWFromConstMem}
+function SDL_AllocRW: PSDL_RWops;
+cdecl; external {$IFDEF __GPC__}name 'SDL_AllocRW'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_AllocRW}
+
+function SDL_RWSeek(context: PSDL_RWops; offset: Integer; whence: Integer) : Integer;
+{$EXTERNALSYM SDL_RWSeek}
+function SDL_RWTell(context: PSDL_RWops): Integer;
+{$EXTERNALSYM SDL_RWTell}
+function SDL_RWRead(context: PSDL_RWops; ptr: Pointer; size: Integer; n : Integer): Integer;
+{$EXTERNALSYM SDL_RWRead}
+function SDL_RWWrite(context: PSDL_RWops; ptr: Pointer; size: Integer; n : Integer): Integer;
+{$EXTERNALSYM SDL_RWWrite}
+function SDL_RWClose(context: PSDL_RWops): Integer;
+{$EXTERNALSYM SDL_RWClose}
+
+{------------------------------------------------------------------------------}
+{ time-handling }
+{------------------------------------------------------------------------------}
+
+{ Get the number of milliseconds since the SDL library initialization. }
+{ Note that this value wraps if the program runs for more than ~49 days. }
+function SDL_GetTicks: UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetTicks'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetTicks}
+
+// Wait a specified number of milliseconds before returning
+procedure SDL_Delay(msec: UInt32);
+cdecl; external {$IFDEF __GPC__}name 'SDL_Delay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_Delay}
+
+{ Add a new timer to the pool of timers already running. }
+{ Returns a timer ID, or NULL when an error occurs. }
+function SDL_AddTimer(interval: UInt32; callback: TSDL_NewTimerCallback; param : Pointer): PSDL_TimerID;
+cdecl; external {$IFDEF __GPC__}name 'SDL_AddTimer'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_AddTimer}
+
+{ Remove one of the multiple timers knowing its ID. }
+{ Returns a boolean value indicating success. }
+function SDL_RemoveTimer(t: PSDL_TimerID): TSDL_Bool;
+cdecl; external {$IFDEF __GPC__}name 'SDL_RemoveTimer'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_RemoveTimer}
+
+function SDL_SetTimer(interval: UInt32; callback: TSDL_TimerCallback): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetTimer'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetTimer}
+
+{------------------------------------------------------------------------------}
+{ audio-routines }
+{------------------------------------------------------------------------------}
+
+{ These functions are used internally, and should not be used unless you
+ have a specific need to specify the audio driver you want to use.
+ You should normally use SDL_Init() or SDL_InitSubSystem(). }
+
+function SDL_AudioInit(driver_name: PChar): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_AudioInit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_AudioInit}
+procedure SDL_AudioQuit;
+cdecl; external {$IFDEF __GPC__}name 'SDL_AudioQuit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_AudioQuit}
+
+{ This function fills the given character buffer with the name of the
+ current audio driver, and returns a Pointer to it if the audio driver has
+ been initialized. It returns NULL if no driver has been initialized. }
+
+function SDL_AudioDriverName(namebuf: PChar; maxlen: Integer): PChar;
+cdecl; external {$IFDEF __GPC__}name 'SDL_AudioDriverName'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_AudioDriverName}
+
+{ This function opens the audio device with the desired parameters, and
+ returns 0 if successful, placing the actual hardware parameters in the
+ structure pointed to by 'obtained'. If 'obtained' is NULL, the audio
+ data passed to the callback function will be guaranteed to be in the
+ requested format, and will be automatically converted to the hardware
+ audio format if necessary. This function returns -1 if it failed
+ to open the audio device, or couldn't set up the audio thread.
+
+ When filling in the desired audio spec structure,
+ 'desired->freq' should be the desired audio frequency in samples-per-second.
+ 'desired->format' should be the desired audio format.
+ 'desired->samples' is the desired size of the audio buffer, in samples.
+ This number should be a power of two, and may be adjusted by the audio
+ driver to a value more suitable for the hardware. Good values seem to
+ range between 512 and 8096 inclusive, depending on the application and
+ CPU speed. Smaller values yield faster response time, but can lead
+ to underflow if the application is doing heavy processing and cannot
+ fill the audio buffer in time. A stereo sample consists of both right
+ and left channels in LR ordering.
+ Note that the number of samples is directly related to time by the
+ following formula: ms = (samples*1000)/freq
+ 'desired->size' is the size in bytes of the audio buffer, and is
+ calculated by SDL_OpenAudio().
+ 'desired->silence' is the value used to set the buffer to silence,
+ and is calculated by SDL_OpenAudio().
+ 'desired->callback' should be set to a function that will be called
+ when the audio device is ready for more data. It is passed a pointer
+ to the audio buffer, and the length in bytes of the audio buffer.
+ This function usually runs in a separate thread, and so you should
+ protect data structures that it accesses by calling SDL_LockAudio()
+ and SDL_UnlockAudio() in your code.
+ 'desired->userdata' is passed as the first parameter to your callback
+ function.
+
+ The audio device starts out playing silence when it's opened, and should
+ be enabled for playing by calling SDL_PauseAudio(0) when you are ready
+ for your audio callback function to be called. Since the audio driver
+ may modify the requested size of the audio buffer, you should allocate
+ any local mixing buffers after you open the audio device. }
+
+function SDL_OpenAudio(desired, obtained: PSDL_AudioSpec): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_OpenAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_OpenAudio}
+
+{ Get the current audio state: }
+function SDL_GetAudioStatus: TSDL_Audiostatus;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetAudioStatus'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetAudioStatus}
+
+{ This function pauses and unpauses the audio callback processing.
+ It should be called with a parameter of 0 after opening the audio
+ device to start playing sound. This is so you can safely initialize
+ data for your callback function after opening the audio device.
+ Silence will be written to the audio device during the pause. }
+
+procedure SDL_PauseAudio(pause_on: Integer);
+cdecl; external {$IFDEF __GPC__}name 'SDL_PauseAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_PauseAudio}
+
+{ This function loads a WAVE from the data source, automatically freeing
+ that source if 'freesrc' is non-zero. For example, to load a WAVE file,
+ you could do:
+ SDL_LoadWAV_RW(SDL_RWFromFile("sample.wav", "rb"), 1, ...);
+
+ If this function succeeds, it returns the given SDL_AudioSpec,
+ filled with the audio data format of the wave data, and sets
+ 'audio_buf' to a malloc()'d buffer containing the audio data,
+ and sets 'audio_len' to the length of that audio buffer, in bytes.
+ You need to free the audio buffer with SDL_FreeWAV() when you are
+ done with it.
+
+ This function returns NULL and sets the SDL error message if the
+ wave file cannot be opened, uses an unknown data format, or is
+ corrupt. Currently raw and MS-ADPCM WAVE files are supported. }
+
+function SDL_LoadWAV_RW(src: PSDL_RWops; freesrc: Integer; spec:
+ PSDL_AudioSpec; audio_buf: PUInt8; audiolen: PUInt32): PSDL_AudioSpec;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LoadWAV_RW'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LoadWAV_RW}
+
+// Compatibility convenience function -- loads a WAV from a file
+function SDL_LoadWAV(filename: PChar; spec: PSDL_AudioSpec; audio_buf:
+ PUInt8; audiolen: PUInt32): PSDL_AudioSpec;
+{$EXTERNALSYM SDL_LoadWAV}
+
+{ This function frees data previously allocated with SDL_LoadWAV_RW() }
+
+procedure SDL_FreeWAV(audio_buf: PUInt8);
+cdecl; external {$IFDEF __GPC__}name 'SDL_FreeWAV'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_FreeWAV}
+
+{ This function takes a source format and rate and a destination format
+ and rate, and initializes the 'cvt' structure with information needed
+ by SDL_ConvertAudio() to convert a buffer of audio data from one format
+ to the other.
+ This function returns 0, or -1 if there was an error. }
+function SDL_BuildAudioCVT(cvt: PSDL_AudioCVT; src_format: UInt16;
+ src_channels: UInt8; src_rate: Integer; dst_format: UInt16; dst_channels: UInt8;
+ dst_rate: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_BuildAudioCVT'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_BuildAudioCVT}
+
+{ Once you have initialized the 'cvt' structure using SDL_BuildAudioCVT(),
+ created an audio buffer cvt->buf, and filled it with cvt->len bytes of
+ audio data in the source format, this function will convert it in-place
+ to the desired format.
+ The data conversion may expand the size of the audio data, so the buffer
+ cvt->buf should be allocated after the cvt structure is initialized by
+ SDL_BuildAudioCVT(), and should be cvt->len*cvt->len_mult bytes long. }
+function SDL_ConvertAudio(cvt: PSDL_AudioCVT): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_ConvertAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_ConvertAudio}
+
+{ This takes two audio buffers of the playing audio format and mixes
+ them, performing addition, volume adjustment, and overflow clipping.
+ The volume ranges from 0 - 128, and should be set to SDL_MIX_MAXVOLUME
+ for full audio volume. Note this does not change hardware volume.
+ This is provided for convenience -- you can mix your own audio data. }
+
+procedure SDL_MixAudio(dst, src: PUInt8; len: UInt32; volume: Integer);
+cdecl; external {$IFDEF __GPC__}name 'SDL_MixAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_MixAudio}
+
+{ The lock manipulated by these functions protects the callback function.
+ During a LockAudio/UnlockAudio pair, you can be guaranteed that the
+ callback function is not running. Do not call these from the callback
+ function or you will cause deadlock. }
+procedure SDL_LockAudio;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LockAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LockAudio}
+procedure SDL_UnlockAudio;
+cdecl; external {$IFDEF __GPC__}name 'SDL_UnlockAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UnlockAudio}
+
+{ This function shuts down audio processing and closes the audio device. }
+
+procedure SDL_CloseAudio;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CloseAudio'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CloseAudio}
+
+{------------------------------------------------------------------------------}
+{ CD-routines }
+{------------------------------------------------------------------------------}
+
+{ Returns the number of CD-ROM drives on the system, or -1 if
+ SDL_Init() has not been called with the SDL_INIT_CDROM flag. }
+
+function SDL_CDNumDrives: Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDNumDrives'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDNumDrives}
+
+{ Returns a human-readable, system-dependent identifier for the CD-ROM.
+ Example:
+ "/dev/cdrom"
+ "E:"
+ "/dev/disk/ide/1/master" }
+
+function SDL_CDName(drive: Integer): PChar;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDName'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDName}
+
+{ Opens a CD-ROM drive for access. It returns a drive handle on success,
+ or NULL if the drive was invalid or busy. This newly opened CD-ROM
+ becomes the default CD used when other CD functions are passed a NULL
+ CD-ROM handle.
+ Drives are numbered starting with 0. Drive 0 is the system default CD-ROM. }
+
+function SDL_CDOpen(drive: Integer): PSDL_CD;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDOpen'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDOpen}
+
+{ This function returns the current status of the given drive.
+ If the drive has a CD in it, the table of contents of the CD and current
+ play position of the CD will be stored in the SDL_CD structure. }
+
+function SDL_CDStatus(cdrom: PSDL_CD): TSDL_CDStatus;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDStatus'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDStatus}
+
+{ Play the given CD starting at 'start_track' and 'start_frame' for 'ntracks'
+ tracks and 'nframes' frames. If both 'ntrack' and 'nframe' are 0, play
+ until the end of the CD. This function will skip data tracks.
+ This function should only be called after calling SDL_CDStatus() to
+ get track information about the CD.
+
+ For example:
+ // Play entire CD:
+ if ( CD_INDRIVE(SDL_CDStatus(cdrom)) ) then
+ SDL_CDPlayTracks(cdrom, 0, 0, 0, 0);
+ // Play last track:
+ if ( CD_INDRIVE(SDL_CDStatus(cdrom)) ) then
+ begin
+ SDL_CDPlayTracks(cdrom, cdrom->numtracks-1, 0, 0, 0);
+ end;
+
+ // Play first and second track and 10 seconds of third track:
+ if ( CD_INDRIVE(SDL_CDStatus(cdrom)) )
+ SDL_CDPlayTracks(cdrom, 0, 0, 2, 10);
+
+ This function returns 0, or -1 if there was an error. }
+
+function SDL_CDPlayTracks(cdrom: PSDL_CD; start_track: Integer; start_frame:
+ Integer; ntracks: Integer; nframes: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDPlayTracks'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDPlayTracks}
+
+
+{ Play the given CD starting at 'start' frame for 'length' frames.
+ It returns 0, or -1 if there was an error. }
+
+function SDL_CDPlay(cdrom: PSDL_CD; start: Integer; length: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDPlay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDPlay}
+
+// Pause play -- returns 0, or -1 on error
+function SDL_CDPause(cdrom: PSDL_CD): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDPause'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDPause}
+
+// Resume play -- returns 0, or -1 on error
+function SDL_CDResume(cdrom: PSDL_CD): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDResume'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDResume}
+
+// Stop play -- returns 0, or -1 on error
+function SDL_CDStop(cdrom: PSDL_CD): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDStop'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDStop}
+
+// Eject CD-ROM -- returns 0, or -1 on error
+function SDL_CDEject(cdrom: PSDL_CD): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDEject'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDEject}
+
+// Closes the handle for the CD-ROM drive
+procedure SDL_CDClose(cdrom: PSDL_CD);
+cdecl; external {$IFDEF __GPC__}name 'SDL_CDClose'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CDClose}
+
+// Given a status, returns true if there's a disk in the drive
+function SDL_CDInDrive( status : TSDL_CDStatus ) : LongBool;
+{$EXTERNALSYM SDL_CDInDrive}
+
+// Conversion functions from frames to Minute/Second/Frames and vice versa
+procedure FRAMES_TO_MSF(frames: Integer; var M: Integer; var S: Integer; var
+ F: Integer);
+{$EXTERNALSYM FRAMES_TO_MSF}
+function MSF_TO_FRAMES(M: Integer; S: Integer; F: Integer): Integer;
+{$EXTERNALSYM MSF_TO_FRAMES}
+
+{------------------------------------------------------------------------------}
+{ JoyStick-routines }
+{------------------------------------------------------------------------------}
+
+{ Count the number of joysticks attached to the system }
+function SDL_NumJoysticks: Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_NumJoysticks'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_NumJoysticks}
+
+{ Get the implementation dependent name of a joystick.
+ This can be called before any joysticks are opened.
+ If no name can be found, this function returns NULL. }
+function SDL_JoystickName(index: Integer): PChar;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickName'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickName}
+
+{ Open a joystick for use - the index passed as an argument refers to
+ the N'th joystick on the system. This index is the value which will
+ identify this joystick in future joystick events.
+
+ This function returns a joystick identifier, or NULL if an error occurred. }
+function SDL_JoystickOpen(index: Integer): PSDL_Joystick;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickOpen'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickOpen}
+
+{ Returns 1 if the joystick has been opened, or 0 if it has not. }
+function SDL_JoystickOpened(index: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickOpened'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickOpened}
+
+{ Get the device index of an opened joystick. }
+function SDL_JoystickIndex(joystick: PSDL_Joystick): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickIndex'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickIndex}
+
+{ Get the number of general axis controls on a joystick }
+function SDL_JoystickNumAxes(joystick: PSDL_Joystick): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickNumAxes'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickNumAxes}
+
+{ Get the number of trackballs on a joystick
+ Joystick trackballs have only relative motion events associated
+ with them and their state cannot be polled. }
+function SDL_JoystickNumBalls(joystick: PSDL_Joystick): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickNumBalls'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickNumBalls}
+
+
+{ Get the number of POV hats on a joystick }
+function SDL_JoystickNumHats(joystick: PSDL_Joystick): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickNumHats'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickNumHats}
+
+{ Get the number of buttons on a joystick }
+function SDL_JoystickNumButtons(joystick: PSDL_Joystick): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickNumButtons'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickNumButtons}
+
+{ Update the current state of the open joysticks.
+ This is called automatically by the event loop if any joystick
+ events are enabled. }
+
+procedure SDL_JoystickUpdate;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickUpdate'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickUpdate;}
+
+{ Enable/disable joystick event polling.
+ If joystick events are disabled, you must call SDL_JoystickUpdate()
+ yourself and check the state of the joystick when you want joystick
+ information.
+ The state can be one of SDL_QUERY, SDL_ENABLE or SDL_IGNORE. }
+
+function SDL_JoystickEventState(state: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickEventState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickEventState}
+
+{ Get the current state of an axis control on a joystick
+ The state is a value ranging from -32768 to 32767.
+ The axis indices start at index 0. }
+
+function SDL_JoystickGetAxis(joystick: PSDL_Joystick; axis: Integer) : SInt16;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickGetAxis'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickGetAxis}
+
+{ The hat indices start at index 0. }
+
+function SDL_JoystickGetHat(joystick: PSDL_Joystick; hat: Integer): UInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickGetHat'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickGetHat}
+
+{ Get the ball axis change since the last poll
+ This returns 0, or -1 if you passed it invalid parameters.
+ The ball indices start at index 0. }
+
+function SDL_JoystickGetBall(joystick: PSDL_Joystick; ball: Integer; var dx: Integer; var dy: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickGetBall'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickGetBall}
+
+{ Get the current state of a button on a joystick
+ The button indices start at index 0. }
+function SDL_JoystickGetButton( joystick: PSDL_Joystick; Button: Integer): UInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickGetButton'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickGetButton}
+
+{ Close a joystick previously opened with SDL_JoystickOpen() }
+procedure SDL_JoystickClose(joystick: PSDL_Joystick);
+cdecl; external {$IFDEF __GPC__}name 'SDL_JoystickClose'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_JoystickClose}
+
+{------------------------------------------------------------------------------}
+{ event-handling }
+{------------------------------------------------------------------------------}
+
+{ Pumps the event loop, gathering events from the input devices.
+ This function updates the event queue and internal input device state.
+ This should only be run in the thread that sets the video mode. }
+
+procedure SDL_PumpEvents;
+cdecl; external {$IFDEF __GPC__}name 'SDL_PumpEvents'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_PumpEvents;}
+
+{ Checks the event queue for messages and optionally returns them.
+ If 'action' is SDL_ADDEVENT, up to 'numevents' events will be added to
+ the back of the event queue.
+ If 'action' is SDL_PEEKEVENT, up to 'numevents' events at the front
+ of the event queue, matching 'mask', will be returned and will not
+ be removed from the queue.
+ If 'action' is SDL_GETEVENT, up to 'numevents' events at the front
+ of the event queue, matching 'mask', will be returned and will be
+ removed from the queue.
+ This function returns the number of events actually stored, or -1
+ if there was an error. This function is thread-safe. }
+
+function SDL_PeepEvents(events: PSDL_Event; numevents: Integer; action: TSDL_eventaction; mask: UInt32): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_PeepEvents'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_PeepEvents}
+
+{ Polls for currently pending events, and returns 1 if there are any pending
+ events, or 0 if there are none available. If 'event' is not NULL, the next
+ event is removed from the queue and stored in that area. }
+
+function SDL_PollEvent(event: PSDL_Event): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_PollEvent'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_PollEvent}
+
+{ Waits indefinitely for the next available event, returning 1, or 0 if there
+ was an error while waiting for events. If 'event' is not NULL, the next
+ event is removed from the queue and stored in that area. }
+
+function SDL_WaitEvent(event: PSDL_Event): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_WaitEvent'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WaitEvent}
+
+function SDL_PushEvent( event : PSDL_Event ) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_PushEvent'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_PushEvent}
+
+{ If the filter returns 1, then the event will be added to the internal queue.
+ If it returns 0, then the event will be dropped from the queue, but the
+ internal state will still be updated. This allows selective filtering of
+ dynamically arriving events.
+
+ WARNING: Be very careful of what you do in the event filter function, as
+ it may run in a different thread!
+
+ There is one caveat when dealing with the SDL_QUITEVENT event type. The
+ event filter is only called when the window manager desires to close the
+ application window. If the event filter returns 1, then the window will
+ be closed, otherwise the window will remain open if possible.
+ If the quit event is generated by an interrupt signal, it will bypass the
+ internal queue and be delivered to the application at the next event poll. }
+procedure SDL_SetEventFilter( filter : TSDL_EventFilter );
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetEventFilter'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetEventFilter}
+
+{ Return the current event filter - can be used to "chain" filters.
+ If there is no event filter set, this function returns NULL. }
+
+function SDL_GetEventFilter: TSDL_EventFilter;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetEventFilter'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetEventFilter}
+
+{ This function allows you to set the state of processing certain events.
+ If 'state' is set to SDL_IGNORE, that event will be automatically dropped
+ from the event queue and will not event be filtered.
+ If 'state' is set to SDL_ENABLE, that event will be processed normally.
+ If 'state' is set to SDL_QUERY, SDL_EventState() will return the
+ current processing state of the specified event. }
+
+function SDL_EventState(type_: UInt8; state: Integer): UInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_EventState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_EventState}
+
+{------------------------------------------------------------------------------}
+{ Version Routines }
+{------------------------------------------------------------------------------}
+
+{ This macro can be used to fill a version structure with the compile-time
+ version of the SDL library. }
+procedure SDL_VERSION(var X: TSDL_Version);
+{$EXTERNALSYM SDL_VERSION}
+
+{ This macro turns the version numbers into a numeric value:
+ (1,2,3) -> (1203)
+ This assumes that there will never be more than 100 patchlevels }
+
+function SDL_VERSIONNUM(X, Y, Z: Integer): Integer;
+{$EXTERNALSYM SDL_VERSIONNUM}
+
+// This is the version number macro for the current SDL version
+function SDL_COMPILEDVERSION: Integer;
+{$EXTERNALSYM SDL_COMPILEDVERSION}
+
+// This macro will evaluate to true if compiled with SDL at least X.Y.Z
+function SDL_VERSION_ATLEAST(X: Integer; Y: Integer; Z: Integer) : LongBool;
+{$EXTERNALSYM SDL_VERSION_ATLEAST}
+
+{ This function gets the version of the dynamically linked SDL library.
+ it should NOT be used to fill a version structure, instead you should
+ use the SDL_Version() macro. }
+
+function SDL_Linked_Version: PSDL_version;
+cdecl; external {$IFDEF __GPC__}name 'SDL_Linked_Version'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_Linked_Version}
+
+{------------------------------------------------------------------------------}
+{ video }
+{------------------------------------------------------------------------------}
+
+{ These functions are used internally, and should not be used unless you
+ have a specific need to specify the video driver you want to use.
+ You should normally use SDL_Init() or SDL_InitSubSystem().
+
+ SDL_VideoInit() initializes the video subsystem -- sets up a connection
+ to the window manager, etc, and determines the current video mode and
+ pixel format, but does not initialize a window or graphics mode.
+ Note that event handling is activated by this routine.
+
+ If you use both sound and video in your application, you need to call
+ SDL_Init() before opening the sound device, otherwise under Win32 DirectX,
+ you won't be able to set full-screen display modes. }
+
+function SDL_VideoInit(driver_name: PChar; flags: UInt32): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_VideoInit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_VideoInit}
+procedure SDL_VideoQuit;
+cdecl; external {$IFDEF __GPC__}name 'SDL_VideoQuit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_VideoQuit}
+
+{ This function fills the given character buffer with the name of the
+ video driver, and returns a pointer to it if the video driver has
+ been initialized. It returns NULL if no driver has been initialized. }
+
+function SDL_VideoDriverName(namebuf: PChar; maxlen: Integer): PChar;
+cdecl; external {$IFDEF __GPC__}name 'SDL_VideoDriverName'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_VideoDriverName}
+
+{ This function returns a pointer to the current display surface.
+ If SDL is doing format conversion on the display surface, this
+ function returns the publicly visible surface, not the real video
+ surface. }
+
+function SDL_GetVideoSurface: PSDL_Surface;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetVideoSurface'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetVideoSurface}
+
+{ This function returns a read-only pointer to information about the
+ video hardware. If this is called before SDL_SetVideoMode(), the 'vfmt'
+ member of the returned structure will contain the pixel format of the
+ "best" video mode. }
+function SDL_GetVideoInfo: PSDL_VideoInfo;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetVideoInfo'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetVideoInfo}
+
+{ Check to see if a particular video mode is supported.
+ It returns 0 if the requested mode is not supported under any bit depth,
+ or returns the bits-per-pixel of the closest available mode with the
+ given width and height. If this bits-per-pixel is different from the
+ one used when setting the video mode, SDL_SetVideoMode() will succeed,
+ but will emulate the requested bits-per-pixel with a shadow surface.
+
+ The arguments to SDL_VideoModeOK() are the same ones you would pass to
+ SDL_SetVideoMode() }
+
+function SDL_VideoModeOK(width, height, bpp: Integer; flags: UInt32): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_VideoModeOK'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_VideoModeOK}
+
+{ Return a pointer to an array of available screen dimensions for the
+ given format and video flags, sorted largest to smallest. Returns
+ NULL if there are no dimensions available for a particular format,
+ or (SDL_Rect **)-1 if any dimension is okay for the given format.
+
+ if 'format' is NULL, the mode list will be for the format given
+ by SDL_GetVideoInfo( ) - > vfmt }
+
+function SDL_ListModes(format: PSDL_PixelFormat; flags: UInt32): PPSDL_Rect;
+cdecl; external {$IFDEF __GPC__}name 'SDL_ListModes'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_ListModes}
+
+
+{ Set up a video mode with the specified width, height and bits-per-pixel.
+
+ If 'bpp' is 0, it is treated as the current display bits per pixel.
+
+ If SDL_ANYFORMAT is set in 'flags', the SDL library will try to set the
+ requested bits-per-pixel, but will return whatever video pixel format is
+ available. The default is to emulate the requested pixel format if it
+ is not natively available.
+
+ If SDL_HWSURFACE is set in 'flags', the video surface will be placed in
+ video memory, if possible, and you may have to call SDL_LockSurface()
+ in order to access the raw framebuffer. Otherwise, the video surface
+ will be created in system memory.
+
+ If SDL_ASYNCBLIT is set in 'flags', SDL will try to perform rectangle
+ updates asynchronously, but you must always lock before accessing pixels.
+ SDL will wait for updates to complete before returning from the lock.
+
+ If SDL_HWPALETTE is set in 'flags', the SDL library will guarantee
+ that the colors set by SDL_SetColors() will be the colors you get.
+ Otherwise, in 8-bit mode, SDL_SetColors() may not be able to set all
+ of the colors exactly the way they are requested, and you should look
+ at the video surface structure to determine the actual palette.
+ If SDL cannot guarantee that the colors you request can be set,
+ i.e. if the colormap is shared, then the video surface may be created
+ under emulation in system memory, overriding the SDL_HWSURFACE flag.
+
+ If SDL_FULLSCREEN is set in 'flags', the SDL library will try to set
+ a fullscreen video mode. The default is to create a windowed mode
+ if the current graphics system has a window manager.
+ If the SDL library is able to set a fullscreen video mode, this flag
+ will be set in the surface that is returned.
+
+ If SDL_DOUBLEBUF is set in 'flags', the SDL library will try to set up
+ two surfaces in video memory and swap between them when you call
+ SDL_Flip(). This is usually slower than the normal single-buffering
+ scheme, but prevents "tearing" artifacts caused by modifying video
+ memory while the monitor is refreshing. It should only be used by
+ applications that redraw the entire screen on every update.
+
+ This function returns the video framebuffer surface, or NULL if it fails. }
+
+function SDL_SetVideoMode(width, height, bpp: Integer; flags: UInt32): PSDL_Surface;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetVideoMode'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetVideoMode}
+
+
+{ Makes sure the given list of rectangles is updated on the given screen.
+ If 'x', 'y', 'w' and 'h' are all 0, SDL_UpdateRect will update the entire
+ screen.
+ These functions should not be called while 'screen' is locked. }
+
+procedure SDL_UpdateRects(screen: PSDL_Surface; numrects: Integer; rects: PSDL_Rect);
+cdecl; external {$IFDEF __GPC__}name 'SDL_UpdateRects'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UpdateRects}
+procedure SDL_UpdateRect(screen: PSDL_Surface; x, y: SInt32; w, h: UInt32);
+cdecl; external {$IFDEF __GPC__}name 'SDL_UpdateRect'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UpdateRect}
+
+
+{ On hardware that supports double-buffering, this function sets up a flip
+ and returns. The hardware will wait for vertical retrace, and then swap
+ video buffers before the next video surface blit or lock will return.
+ On hardware that doesn not support double-buffering, this is equivalent
+ to calling SDL_UpdateRect(screen, 0, 0, 0, 0);
+ The SDL_DOUBLEBUF flag must have been passed to SDL_SetVideoMode() when
+ setting the video mode for this function to perform hardware flipping.
+ This function returns 0 if successful, or -1 if there was an error.}
+
+function SDL_Flip(screen: PSDL_Surface): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_Flip'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_Flip}
+
+{ Set the gamma correction for each of the color channels.
+ The gamma values range (approximately) between 0.1 and 10.0
+
+ If this function isn't supported directly by the hardware, it will
+ be emulated using gamma ramps, if available. If successful, this
+ function returns 0, otherwise it returns -1. }
+
+function SDL_SetGamma(redgamma: single; greengamma: single; bluegamma: single ): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetGamma'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetGamma}
+
+{ Set the gamma translation table for the red, green, and blue channels
+ of the video hardware. Each table is an array of 256 16-bit quantities,
+ representing a mapping between the input and output for that channel.
+ The input is the index into the array, and the output is the 16-bit
+ gamma value at that index, scaled to the output color precision.
+
+ You may pass NULL for any of the channels to leave it unchanged.
+ If the call succeeds, it will return 0. If the display driver or
+ hardware does not support gamma translation, or otherwise fails,
+ this function will return -1. }
+
+function SDL_SetGammaRamp( redtable: PUInt16; greentable: PUInt16; bluetable: PUInt16): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetGammaRamp'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetGammaRamp}
+
+{ Retrieve the current values of the gamma translation tables.
+
+ You must pass in valid pointers to arrays of 256 16-bit quantities.
+ Any of the pointers may be NULL to ignore that channel.
+ If the call succeeds, it will return 0. If the display driver or
+ hardware does not support gamma translation, or otherwise fails,
+ this function will return -1. }
+
+function SDL_GetGammaRamp( redtable: PUInt16; greentable: PUInt16; bluetable: PUInt16): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetGammaRamp'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetGammaRamp}
+
+{ Sets a portion of the colormap for the given 8-bit surface. If 'surface'
+ is not a palettized surface, this function does nothing, returning 0.
+ If all of the colors were set as passed to SDL_SetColors(), it will
+ return 1. If not all the color entries were set exactly as given,
+ it will return 0, and you should look at the surface palette to
+ determine the actual color palette.
+
+ When 'surface' is the surface associated with the current display, the
+ display colormap will be updated with the requested colors. If
+ SDL_HWPALETTE was set in SDL_SetVideoMode() flags, SDL_SetColors()
+ will always return 1, and the palette is guaranteed to be set the way
+ you desire, even if the window colormap has to be warped or run under
+ emulation. }
+
+
+function SDL_SetColors(surface: PSDL_Surface; colors: PSDL_Color; firstcolor : Integer; ncolors: Integer) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetColors'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetColors}
+
+{ Sets a portion of the colormap for a given 8-bit surface.
+ 'flags' is one or both of:
+ SDL_LOGPAL -- set logical palette, which controls how blits are mapped
+ to/from the surface,
+ SDL_PHYSPAL -- set physical palette, which controls how pixels look on
+ the screen
+ Only screens have physical palettes. Separate change of physical/logical
+ palettes is only possible if the screen has SDL_HWPALETTE set.
+
+ The return value is 1 if all colours could be set as requested, and 0
+ otherwise.
+
+ SDL_SetColors() is equivalent to calling this function with
+ flags = (SDL_LOGPAL or SDL_PHYSPAL). }
+
+function SDL_SetPalette(surface: PSDL_Surface; flags: Integer; colors: PSDL_Color; firstcolor: Integer; ncolors: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetPalette'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetPalette}
+
+{ Maps an RGB triple to an opaque pixel value for a given pixel format }
+function SDL_MapRGB(format: PSDL_PixelFormat; r: UInt8; g: UInt8; b: UInt8) : UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_MapRGB'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_MapRGB}
+
+{ Maps an RGBA quadruple to a pixel value for a given pixel format }
+function SDL_MapRGBA(format: PSDL_PixelFormat; r: UInt8; g: UInt8; b: UInt8; a: UInt8): UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_MapRGBA'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_MapRGBA}
+
+{ Maps a pixel value into the RGB components for a given pixel format }
+procedure SDL_GetRGB(pixel: UInt32; fmt: PSDL_PixelFormat; r: PUInt8; g: PUInt8; b: PUInt8);
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetRGB'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetRGB}
+
+{ Maps a pixel value into the RGBA components for a given pixel format }
+procedure SDL_GetRGBA(pixel: UInt32; fmt: PSDL_PixelFormat; r: PUInt8; g: PUInt8; b: PUInt8; a: PUInt8);
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetRGBA'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetRGBA}
+
+{ Allocate and free an RGB surface (must be called after SDL_SetVideoMode)
+ If the depth is 4 or 8 bits, an empty palette is allocated for the surface.
+ If the depth is greater than 8 bits, the pixel format is set using the
+ flags '[RGB]mask'.
+ If the function runs out of memory, it will return NULL.
+
+ The 'flags' tell what kind of surface to create.
+ SDL_SWSURFACE means that the surface should be created in system memory.
+ SDL_HWSURFACE means that the surface should be created in video memory,
+ with the same format as the display surface. This is useful for surfaces
+ that will not change much, to take advantage of hardware acceleration
+ when being blitted to the display surface.
+ SDL_ASYNCBLIT means that SDL will try to perform asynchronous blits with
+ this surface, but you must always lock it before accessing the pixels.
+ SDL will wait for current blits to finish before returning from the lock.
+ SDL_SRCCOLORKEY indicates that the surface will be used for colorkey blits.
+ If the hardware supports acceleration of colorkey blits between
+ two surfaces in video memory, SDL will try to place the surface in
+ video memory. If this isn't possible or if there is no hardware
+ acceleration available, the surface will be placed in system memory.
+ SDL_SRCALPHA means that the surface will be used for alpha blits and
+ if the hardware supports hardware acceleration of alpha blits between
+ two surfaces in video memory, to place the surface in video memory
+ if possible, otherwise it will be placed in system memory.
+ If the surface is created in video memory, blits will be _much_ faster,
+ but the surface format must be identical to the video surface format,
+ and the only way to access the pixels member of the surface is to use
+ the SDL_LockSurface() and SDL_UnlockSurface() calls.
+ If the requested surface actually resides in video memory, SDL_HWSURFACE
+ will be set in the flags member of the returned surface. If for some
+ reason the surface could not be placed in video memory, it will not have
+ the SDL_HWSURFACE flag set, and will be created in system memory instead. }
+
+function SDL_AllocSurface(flags: UInt32; width, height, depth: Integer;
+ RMask, GMask, BMask, AMask: UInt32): PSDL_Surface;
+{$EXTERNALSYM SDL_AllocSurface}
+
+function SDL_CreateRGBSurface(flags: UInt32; width, height, depth: Integer; RMask, GMask, BMask, AMask: UInt32): PSDL_Surface;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateRGBSurface'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateRGBSurface}
+
+function SDL_CreateRGBSurfaceFrom(pixels: Pointer; width, height, depth, pitch
+ : Integer; RMask, GMask, BMask, AMask: UInt32): PSDL_Surface;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateRGBSurfaceFrom'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateRGBSurfaceFrom}
+
+procedure SDL_FreeSurface(surface: PSDL_Surface);
+cdecl; external {$IFDEF __GPC__}name 'SDL_FreeSurface'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_FreeSurface}
+
+function SDL_MustLock(Surface: PSDL_Surface): Boolean;
+{$EXTERNALSYM SDL_MustLock}
+{ SDL_LockSurface() sets up a surface for directly accessing the pixels.
+ Between calls to SDL_LockSurface()/SDL_UnlockSurface(), you can write
+ to and read from 'surface->pixels', using the pixel format stored in
+ 'surface->format'. Once you are done accessing the surface, you should
+ use SDL_UnlockSurface() to release it.
+
+ Not all surfaces require locking. If SDL_MUSTLOCK(surface) evaluates
+ to 0, then you can read and write to the surface at any time, and the
+ pixel format of the surface will not change. In particular, if the
+ SDL_HWSURFACE flag is not given when calling SDL_SetVideoMode(), you
+ will not need to lock the display surface before accessing it.
+
+ No operating system or library calls should be made between lock/unlock
+ pairs, as critical system locks may be held during this time.
+
+ SDL_LockSurface() returns 0, or -1 if the surface couldn't be locked. }
+function SDL_LockSurface(surface: PSDL_Surface): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LockSurface'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LockSurface}
+
+procedure SDL_UnlockSurface(surface: PSDL_Surface);
+cdecl; external {$IFDEF __GPC__}name 'SDL_UnlockSurface'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UnlockSurface}
+
+{ Load a surface from a seekable SDL data source (memory or file.)
+ If 'freesrc' is non-zero, the source will be closed after being read.
+ Returns the new surface, or NULL if there was an error.
+ The new surface should be freed with SDL_FreeSurface(). }
+function SDL_LoadBMP_RW(src: PSDL_RWops; freesrc: Integer): PSDL_Surface;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LoadBMP_RW'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LoadBMP_RW}
+
+// Convenience macro -- load a surface from a file
+function SDL_LoadBMP(filename: PChar): PSDL_Surface;
+{$EXTERNALSYM SDL_LoadBMP}
+
+{ Save a surface to a seekable SDL data source (memory or file.)
+ If 'freedst' is non-zero, the source will be closed after being written.
+ Returns 0 if successful or -1 if there was an error. }
+
+function SDL_SaveBMP_RW(surface: PSDL_Surface; dst: PSDL_RWops; freedst: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SaveBMP_RW'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SaveBMP_RW}
+
+// Convenience macro -- save a surface to a file
+function SDL_SaveBMP(surface: PSDL_Surface; filename: PChar): Integer;
+{$EXTERNALSYM SDL_SaveBMP}
+
+{ Sets the color key (transparent pixel) in a blittable surface.
+ If 'flag' is SDL_SRCCOLORKEY (optionally OR'd with SDL_RLEACCEL),
+ 'key' will be the transparent pixel in the source image of a blit.
+ SDL_RLEACCEL requests RLE acceleration for the surface if present,
+ and removes RLE acceleration if absent.
+ If 'flag' is 0, this function clears any current color key.
+ This function returns 0, or -1 if there was an error. }
+
+function SDL_SetColorKey(surface: PSDL_Surface; flag, key: UInt32) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetColorKey'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetColorKey}
+
+{ This function sets the alpha value for the entire surface, as opposed to
+ using the alpha component of each pixel. This value measures the range
+ of transparency of the surface, 0 being completely transparent to 255
+ being completely opaque. An 'alpha' value of 255 causes blits to be
+ opaque, the source pixels copied to the destination (the default). Note
+ that per-surface alpha can be combined with colorkey transparency.
+
+ If 'flag' is 0, alpha blending is disabled for the surface.
+ If 'flag' is SDL_SRCALPHA, alpha blending is enabled for the surface.
+ OR:ing the flag with SDL_RLEACCEL requests RLE acceleration for the
+ surface; if SDL_RLEACCEL is not specified, the RLE accel will be removed. }
+
+
+function SDL_SetAlpha(surface: PSDL_Surface; flag: UInt32; alpha: UInt8): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetAlpha'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetAlpha}
+
+{ Sets the clipping rectangle for the destination surface in a blit.
+
+ If the clip rectangle is NULL, clipping will be disabled.
+ If the clip rectangle doesn't intersect the surface, the function will
+ return SDL_FALSE and blits will be completely clipped. Otherwise the
+ function returns SDL_TRUE and blits to the surface will be clipped to
+ the intersection of the surface area and the clipping rectangle.
+
+ Note that blits are automatically clipped to the edges of the source
+ and destination surfaces. }
+procedure SDL_SetClipRect(surface: PSDL_Surface; rect: PSDL_Rect); cdecl;
+external {$IFDEF __GPC__}name 'SDL_SetClipRect'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetClipRect}
+
+{ Gets the clipping rectangle for the destination surface in a blit.
+ 'rect' must be a pointer to a valid rectangle which will be filled
+ with the correct values. }
+procedure SDL_GetClipRect(surface: PSDL_Surface; rect: PSDL_Rect); cdecl;
+external {$IFDEF __GPC__}name 'SDL_GetClipRect'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetClipRect}
+
+{ Creates a new surface of the specified format, and then copies and maps
+ the given surface to it so the blit of the converted surface will be as
+ fast as possible. If this function fails, it returns NULL.
+
+ The 'flags' parameter is passed to SDL_CreateRGBSurface() and has those
+ semantics. You can also pass SDL_RLEACCEL in the flags parameter and
+ SDL will try to RLE accelerate colorkey and alpha blits in the resulting
+ surface.
+
+ This function is used internally by SDL_DisplayFormat(). }
+
+function SDL_ConvertSurface(src: PSDL_Surface; fmt: PSDL_PixelFormat; flags: UInt32): PSDL_Surface;
+cdecl; external {$IFDEF __GPC__}name 'SDL_ConvertSurface'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_ConvertSurface}
+
+{
+ This performs a fast blit from the source surface to the destination
+ surface. It assumes that the source and destination rectangles are
+ the same size. If either 'srcrect' or 'dstrect' are NULL, the entire
+ surface (src or dst) is copied. The final blit rectangles are saved
+ in 'srcrect' and 'dstrect' after all clipping is performed.
+ If the blit is successful, it returns 0, otherwise it returns -1.
+
+ The blit function should not be called on a locked surface.
+
+ The blit semantics for surfaces with and without alpha and colorkey
+ are defined as follows:
+
+ RGBA->RGB:
+ SDL_SRCALPHA set:
+ alpha-blend (using alpha-channel).
+ SDL_SRCCOLORKEY ignored.
+ SDL_SRCALPHA not set:
+ copy RGB.
+ if SDL_SRCCOLORKEY set, only copy the pixels matching the
+ RGB values of the source colour key, ignoring alpha in the
+ comparison.
+
+ RGB->RGBA:
+ SDL_SRCALPHA set:
+ alpha-blend (using the source per-surface alpha value);
+ set destination alpha to opaque.
+ SDL_SRCALPHA not set:
+ copy RGB, set destination alpha to opaque.
+ both:
+ if SDL_SRCCOLORKEY set, only copy the pixels matching the
+ source colour key.
+
+ RGBA->RGBA:
+ SDL_SRCALPHA set:
+ alpha-blend (using the source alpha channel) the RGB values;
+ leave destination alpha untouched. [Note: is this correct?]
+ SDL_SRCCOLORKEY ignored.
+ SDL_SRCALPHA not set:
+ copy all of RGBA to the destination.
+ if SDL_SRCCOLORKEY set, only copy the pixels matching the
+ RGB values of the source colour key, ignoring alpha in the
+ comparison.
+
+ RGB->RGB:
+ SDL_SRCALPHA set:
+ alpha-blend (using the source per-surface alpha value).
+ SDL_SRCALPHA not set:
+ copy RGB.
+ both:
+ if SDL_SRCCOLORKEY set, only copy the pixels matching the
+ source colour key.
+
+ If either of the surfaces were in video memory, and the blit returns -2,
+ the video memory was lost, so it should be reloaded with artwork and
+ re-blitted:
+ while ( SDL_BlitSurface(image, imgrect, screen, dstrect) = -2 ) do
+ begin
+ while ( SDL_LockSurface(image) < 0 ) do
+ Sleep(10);
+ -- Write image pixels to image->pixels --
+ SDL_UnlockSurface(image);
+ end;
+
+ This happens under DirectX 5.0 when the system switches away from your
+ fullscreen application. The lock will also fail until you have access
+ to the video memory again. }
+
+{ You should call SDL_BlitSurface() unless you know exactly how SDL
+ blitting works internally and how to use the other blit functions. }
+
+function SDL_BlitSurface(src: PSDL_Surface; srcrect: PSDL_Rect; dst: PSDL_Surface; dstrect: PSDL_Rect): Integer;
+{$EXTERNALSYM SDL_BlitSurface}
+
+{ This is the public blit function, SDL_BlitSurface(), and it performs
+ rectangle validation and clipping before passing it to SDL_LowerBlit() }
+function SDL_UpperBlit(src: PSDL_Surface; srcrect: PSDL_Rect; dst: PSDL_Surface; dstrect: PSDL_Rect): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_UpperBlit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UpperBlit}
+
+{ This is a semi-private blit function and it performs low-level surface
+ blitting only. }
+function SDL_LowerBlit(src: PSDL_Surface; srcrect: PSDL_Rect; dst: PSDL_Surface; dstrect: PSDL_Rect): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LowerBlit'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LowerBlit}
+
+{ This function performs a fast fill of the given rectangle with 'color'
+ The given rectangle is clipped to the destination surface clip area
+ and the final fill rectangle is saved in the passed in pointer.
+ If 'dstrect' is NULL, the whole surface will be filled with 'color'
+ The color should be a pixel of the format used by the surface, and
+ can be generated by the SDL_MapRGB() function.
+ This function returns 0 on success, or -1 on error. }
+
+function SDL_FillRect(dst: PSDL_Surface; dstrect: PSDL_Rect; color: UInt32) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_FillRect'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_FillRect}
+
+{ This function takes a surface and copies it to a new surface of the
+ pixel format and colors of the video framebuffer, suitable for fast
+ blitting onto the display surface. It calls SDL_ConvertSurface()
+
+ If you want to take advantage of hardware colorkey or alpha blit
+ acceleration, you should set the colorkey and alpha value before
+ calling this function.
+
+ If the conversion fails or runs out of memory, it returns NULL }
+
+function SDL_DisplayFormat(surface: PSDL_Surface): PSDL_Surface; cdecl;
+external {$IFDEF __GPC__}name 'SDL_DisplayFormat'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_DisplayFormat}
+
+{ This function takes a surface and copies it to a new surface of the
+ pixel format and colors of the video framebuffer (if possible),
+ suitable for fast alpha blitting onto the display surface.
+ The new surface will always have an alpha channel.
+
+ If you want to take advantage of hardware colorkey or alpha blit
+ acceleration, you should set the colorkey and alpha value before
+ calling this function.
+
+ If the conversion fails or runs out of memory, it returns NULL }
+
+
+function SDL_DisplayFormatAlpha(surface: PSDL_Surface): PSDL_Surface; cdecl;
+external {$IFDEF __GPC__}name 'SDL_DisplayFormatAlpha'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_DisplayFormatAlpha}
+
+//* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+//* YUV video surface overlay functions */
+//* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * */
+
+{ This function creates a video output overlay
+ Calling the returned surface an overlay is something of a misnomer because
+ the contents of the display surface underneath the area where the overlay
+ is shown is undefined - it may be overwritten with the converted YUV data. }
+
+function SDL_CreateYUVOverlay(width: Integer; height: Integer; format: UInt32; display: PSDL_Surface): PSDL_Overlay;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateYUVOverlay}
+
+// Lock an overlay for direct access, and unlock it when you are done
+function SDL_LockYUVOverlay(Overlay: PSDL_Overlay): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LockYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LockYUVOverlay}
+
+procedure SDL_UnlockYUVOverlay(Overlay: PSDL_Overlay); cdecl;
+external {$IFDEF __GPC__}name 'SDL_UnlockYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UnlockYUVOverlay}
+
+
+{ Blit a video overlay to the display surface.
+ The contents of the video surface underneath the blit destination are
+ not defined.
+ The width and height of the destination rectangle may be different from
+ that of the overlay, but currently only 2x scaling is supported. }
+
+function SDL_DisplayYUVOverlay(Overlay: PSDL_Overlay; dstrect: PSDL_Rect) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_DisplayYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_DisplayYUVOverlay}
+
+// Free a video overlay
+procedure SDL_FreeYUVOverlay(Overlay: PSDL_Overlay);
+cdecl; external {$IFDEF __GPC__}name 'SDL_FreeYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_FreeYUVOverlay}
+
+{------------------------------------------------------------------------------}
+{ OpenGL Routines }
+{------------------------------------------------------------------------------}
+
+{ Dynamically load a GL driver, if SDL is built with dynamic GL.
+
+ SDL links normally with the OpenGL library on your system by default,
+ but you can compile it to dynamically load the GL driver at runtime.
+ If you do this, you need to retrieve all of the GL functions used in
+ your program from the dynamic library using SDL_GL_GetProcAddress().
+
+ This is disabled in default builds of SDL. }
+
+
+function SDL_GL_LoadLibrary(filename: PChar): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_LoadLibrary'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_LoadLibrary}
+
+{ Get the address of a GL function (for extension functions) }
+function SDL_GL_GetProcAddress(procname: PChar) : Pointer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_GetProcAddress'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_GetProcAddress}
+
+{ Set an attribute of the OpenGL subsystem before intialization. }
+function SDL_GL_SetAttribute(attr: TSDL_GLAttr; value: Integer) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_SetAttribute'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_SetAttribute}
+
+{ Get an attribute of the OpenGL subsystem from the windowing
+ interface, such as glX. This is of course different from getting
+ the values from SDL's internal OpenGL subsystem, which only
+ stores the values you request before initialization.
+
+ Developers should track the values they pass into SDL_GL_SetAttribute
+ themselves if they want to retrieve these values. }
+
+function SDL_GL_GetAttribute(attr: TSDL_GLAttr; var value: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_GetAttribute'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_GetAttribute}
+
+{ Swap the OpenGL buffers, if double-buffering is supported. }
+
+procedure SDL_GL_SwapBuffers;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_SwapBuffers'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_SwapBuffers;}
+
+{ Internal functions that should not be called unless you have read
+ and understood the source code for these functions. }
+
+procedure SDL_GL_UpdateRects(numrects: Integer; rects: PSDL_Rect);
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_UpdateRects'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_UpdateRects}
+procedure SDL_GL_Lock;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_Lock'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_Lock;}
+procedure SDL_GL_Unlock;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GL_Unlock'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GL_Unlock;}
+
+{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
+{* These functions allow interaction with the window manager, if any. *}
+{* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *}
+
+{ Sets/Gets the title and icon text of the display window }
+procedure SDL_WM_GetCaption(var title : PChar; var icon : PChar);
+cdecl; external {$IFDEF __GPC__}name 'SDL_WM_GetCaption'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WM_GetCaption}
+procedure SDL_WM_SetCaption( const title : PChar; const icon : PChar);
+cdecl; external {$IFDEF __GPC__}name 'SDL_WM_SetCaption'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WM_SetCaption}
+
+{ Sets the icon for the display window.
+ This function must be called before the first call to SDL_SetVideoMode().
+ It takes an icon surface, and a mask in MSB format.
+ If 'mask' is NULL, the entire icon surface will be used as the icon. }
+procedure SDL_WM_SetIcon(icon: PSDL_Surface; mask: UInt8);
+cdecl; external {$IFDEF __GPC__}name 'SDL_WM_SetIcon'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WM_SetIcon}
+
+{ This function iconifies the window, and returns 1 if it succeeded.
+ If the function succeeds, it generates an SDL_APPACTIVE loss event.
+ This function is a noop and returns 0 in non-windowed environments. }
+
+function SDL_WM_IconifyWindow: Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_WM_IconifyWindow'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WM_IconifyWindow}
+
+{ Toggle fullscreen mode without changing the contents of the screen.
+ If the display surface does not require locking before accessing
+ the pixel information, then the memory pointers will not change.
+
+ If this function was able to toggle fullscreen mode (change from
+ running in a window to fullscreen, or vice-versa), it will return 1.
+ If it is not implemented, or fails, it returns 0.
+
+ The next call to SDL_SetVideoMode() will set the mode fullscreen
+ attribute based on the flags parameter - if SDL_FULLSCREEN is not
+ set, then the display will be windowed by default where supported.
+
+ This is currently only implemented in the X11 video driver. }
+
+function SDL_WM_ToggleFullScreen(surface: PSDL_Surface): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_WM_ToggleFullScreen'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WM_ToggleFullScreen}
+
+{ Grabbing means that the mouse is confined to the application window,
+ and nearly all keyboard input is passed directly to the application,
+ and not interpreted by a window manager, if any. }
+
+function SDL_WM_GrabInput(mode: TSDL_GrabMode): TSDL_GrabMode;
+cdecl; external {$IFDEF __GPC__}name 'SDL_WM_GrabInput'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WM_GrabInput}
+
+{------------------------------------------------------------------------------}
+{ mouse-routines }
+{------------------------------------------------------------------------------}
+
+{ Retrieve the current state of the mouse.
+ The current button state is returned as a button bitmask, which can
+ be tested using the SDL_BUTTON(X) macros, and x and y are set to the
+ current mouse cursor position. You can pass NULL for either x or y. }
+
+function SDL_GetMouseState(var x: Integer; var y: Integer): UInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetMouseState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetMouseState}
+
+{ Retrieve the current state of the mouse.
+ The current button state is returned as a button bitmask, which can
+ be tested using the SDL_BUTTON(X) macros, and x and y are set to the
+ mouse deltas since the last call to SDL_GetRelativeMouseState(). }
+function SDL_GetRelativeMouseState(var x: Integer; var y: Integer): UInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetRelativeMouseState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetRelativeMouseState}
+
+{ Set the position of the mouse cursor (generates a mouse motion event) }
+procedure SDL_WarpMouse(x, y: UInt16);
+cdecl; external {$IFDEF __GPC__}name 'SDL_WarpMouse'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WarpMouse}
+
+{ Create a cursor using the specified data and mask (in MSB format).
+ The cursor width must be a multiple of 8 bits.
+
+ The cursor is created in black and white according to the following:
+ data mask resulting pixel on screen
+ 0 1 White
+ 1 1 Black
+ 0 0 Transparent
+ 1 0 Inverted color if possible, black if not.
+
+ Cursors created with this function must be freed with SDL_FreeCursor(). }
+function SDL_CreateCursor(data, mask: PUInt8; w, h, hot_x, hot_y: Integer): PSDL_Cursor;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateCursor'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateCursor}
+
+{ Set the currently active cursor to the specified one.
+ If the cursor is currently visible, the change will be immediately
+ represented on the display. }
+procedure SDL_SetCursor(cursor: PSDL_Cursor);
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetCursor'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetCursor}
+
+{ Returns the currently active cursor. }
+function SDL_GetCursor: PSDL_Cursor;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetCursor'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetCursor}
+
+{ Deallocates a cursor created with SDL_CreateCursor(). }
+procedure SDL_FreeCursor(cursor: PSDL_Cursor);
+cdecl; external {$IFDEF __GPC__}name 'SDL_FreeCursor'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_FreeCursor}
+
+{ Toggle whether or not the cursor is shown on the screen.
+ The cursor start off displayed, but can be turned off.
+ SDL_ShowCursor() returns 1 if the cursor was being displayed
+ before the call, or 0 if it was not. You can query the current
+ state by passing a 'toggle' value of -1. }
+function SDL_ShowCursor(toggle: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_ShowCursor'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_ShowCursor}
+
+function SDL_BUTTON( Button : Integer ) : Integer;
+
+{------------------------------------------------------------------------------}
+{ Keyboard-routines }
+{------------------------------------------------------------------------------}
+
+{ Enable/Disable UNICODE translation of keyboard input.
+ This translation has some overhead, so translation defaults off.
+ If 'enable' is 1, translation is enabled.
+ If 'enable' is 0, translation is disabled.
+ If 'enable' is -1, the translation state is not changed.
+ It returns the previous state of keyboard translation. }
+function SDL_EnableUNICODE(enable: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_EnableUNICODE'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_EnableUNICODE}
+
+{ If 'delay' is set to 0, keyboard repeat is disabled. }
+function SDL_EnableKeyRepeat(delay: Integer; interval: Integer): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_EnableKeyRepeat'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_EnableKeyRepeat}
+
+{ Get a snapshot of the current state of the keyboard.
+ Returns an array of keystates, indexed by the SDLK_* syms.
+ Used:
+
+ UInt8 *keystate = SDL_GetKeyState(NULL);
+ if ( keystate[SDLK_RETURN] ) ... <RETURN> is pressed }
+
+function SDL_GetKeyState(numkeys: PInt): PUInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetKeyState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetKeyState}
+
+{ Get the current key modifier state }
+function SDL_GetModState: TSDLMod;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetModState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetModState}
+
+{ Set the current key modifier state
+ This does not change the keyboard state, only the key modifier flags. }
+procedure SDL_SetModState(modstate: TSDLMod);
+cdecl; external {$IFDEF __GPC__}name 'SDL_SetModState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SetModState}
+
+{ Get the name of an SDL virtual keysym }
+function SDL_GetKeyName(key: TSDLKey): PChar;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetKeyName'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetKeyName}
+
+{------------------------------------------------------------------------------}
+{ Active Routines }
+{------------------------------------------------------------------------------}
+
+{ This function returns the current state of the application, which is a
+ bitwise combination of SDL_APPMOUSEFOCUS, SDL_APPINPUTFOCUS, and
+ SDL_APPACTIVE. If SDL_APPACTIVE is set, then the user is able to
+ see your application, otherwise it has been iconified or disabled. }
+
+function SDL_GetAppState: UInt8;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetAppState'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetAppState}
+
+
+{ Mutex functions }
+
+{ Create a mutex, initialized unlocked }
+
+function SDL_CreateMutex: PSDL_Mutex;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateMutex'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateMutex}
+
+{ Lock the mutex (Returns 0, or -1 on error) }
+
+ function SDL_mutexP(mutex: PSDL_mutex): Integer;
+ cdecl; external {$IFDEF __GPC__}name 'SDL_mutexP'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{ $ EXTERNALSYM SDL_mutexP}
+
+function SDL_LockMutex(mutex: PSDL_mutex): Integer;
+{$EXTERNALSYM SDL_LockMutex}
+
+{ Unlock the mutex (Returns 0, or -1 on error) }
+function SDL_mutexV(mutex: PSDL_mutex): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_mutexV'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_mutexV}
+
+function SDL_UnlockMutex(mutex: PSDL_mutex): Integer;
+{$EXTERNALSYM SDL_UnlockMutex}
+
+{ Destroy a mutex }
+procedure SDL_DestroyMutex(mutex: PSDL_mutex);
+cdecl; external {$IFDEF __GPC__}name 'SDL_DestroyMutex'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_DestroyMutex}
+
+{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
+{ Semaphore functions }
+{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
+{ Create a semaphore, initialized with value, returns NULL on failure. }
+function SDL_CreateSemaphore(initial_value: UInt32): PSDL_Sem;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateSemaphore'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateSemaphore}
+
+
+{ Destroy a semaphore }
+procedure SDL_DestroySemaphore(sem: PSDL_sem);
+cdecl; external {$IFDEF __GPC__}name 'SDL_DestroySemaphore'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_DestroySemaphore}
+
+{ This function suspends the calling thread until the semaphore pointed
+ to by sem has a positive count. It then atomically decreases the semaphore
+ count. }
+
+function SDL_SemWait(sem: PSDL_sem): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SemWait'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SemWait}
+
+{ Non-blocking variant of SDL_SemWait(), returns 0 if the wait succeeds,
+ SDL_MUTEX_TIMEDOUT if the wait would block, and -1 on error. }
+
+function SDL_SemTryWait(sem: PSDL_sem): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SemTryWait'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SemTryWait}
+
+{ Variant of SDL_SemWait() with a timeout in milliseconds, returns 0 if
+ the wait succeeds, SDL_MUTEX_TIMEDOUT if the wait does not succeed in
+ the allotted time, and -1 on error.
+ On some platforms this function is implemented by looping with a delay
+ of 1 ms, and so should be avoided if possible. }
+
+function SDL_SemWaitTimeout(sem: PSDL_sem; ms: UInt32): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SemWaitTimeout'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SemTryWait}
+
+{ Atomically increases the semaphore's count (not blocking), returns 0,
+ or -1 on error. }
+
+function SDL_SemPost(sem: PSDL_sem): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SemPost'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SemTryWait}
+
+{ Returns the current count of the semaphore }
+
+function SDL_SemValue(sem: PSDL_sem): UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_SemValue'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_SemValue}
+
+{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
+{ Condition variable functions }
+{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
+{ Create a condition variable }
+function SDL_CreateCond: PSDL_Cond;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateCond'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateCond}
+
+{ Destroy a condition variable }
+procedure SDL_DestroyCond(cond: PSDL_Cond);
+cdecl; external {$IFDEF __GPC__}name 'SDL_DestroyCond'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_DestroyCond}
+
+{ Restart one of the threads that are waiting on the condition variable,
+ returns 0 or -1 on error. }
+
+function SDL_CondSignal(cond: PSDL_cond): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CondSignal'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CondSignal}
+
+{ Restart all threads that are waiting on the condition variable,
+ returns 0 or -1 on error. }
+
+function SDL_CondBroadcast(cond: PSDL_cond): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CondBroadcast'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CondBroadcast}
+
+
+{ Wait on the condition variable, unlocking the provided mutex.
+ The mutex must be locked before entering this function!
+ Returns 0 when it is signaled, or -1 on error. }
+
+function SDL_CondWait(cond: PSDL_cond; mut: PSDL_mutex): Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CondWait'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CondWait}
+
+{ Waits for at most 'ms' milliseconds, and returns 0 if the condition
+ variable is signaled, SDL_MUTEX_TIMEDOUT if the condition is not
+ signaled in the allotted time, and -1 on error.
+ On some platforms this function is implemented by looping with a delay
+ of 1 ms, and so should be avoided if possible. }
+
+function SDL_CondWaitTimeout(cond: PSDL_cond; mut: PSDL_mutex; ms: UInt32) : Integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CondWaitTimeout'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CondWaitTimeout}
+
+{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
+{ Condition variable functions }
+{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * }
+
+{ Create a thread }
+function SDL_CreateThread(fn: PInt; data: Pointer): PSDL_Thread;
+cdecl; external {$IFDEF __GPC__}name 'SDL_CreateThread'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_CreateThread}
+
+{ Get the 32-bit thread identifier for the current thread }
+function SDL_ThreadID: UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_ThreadID'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_ThreadID}
+
+{ Get the 32-bit thread identifier for the specified thread,
+ equivalent to SDL_ThreadID() if the specified thread is NULL. }
+function SDL_GetThreadID(thread: PSDL_Thread): UInt32;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetThreadID'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetThreadID}
+
+{ Wait for a thread to finish.
+ The return code for the thread function is placed in the area
+ pointed to by 'status', if 'status' is not NULL. }
+
+procedure SDL_WaitThread(thread: PSDL_Thread; var status: Integer);
+cdecl; external {$IFDEF __GPC__}name 'SDL_WaitThread'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_WaitThread}
+
+{ Forcefully kill a thread without worrying about its state }
+procedure SDL_KillThread(thread: PSDL_Thread);
+cdecl; external {$IFDEF __GPC__}name 'SDL_KillThread'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_KillThread}
+
+{------------------------------------------------------------------------------}
+{ Get Environment Routines }
+{------------------------------------------------------------------------------}
+{$IFDEF WIN32}
+function _putenv( const variable : Pchar ): integer;
+cdecl;
+{$ENDIF}
+
+{$IFDEF Unix}
+{$IFDEF FPC}
+function _putenv( const variable : Pchar ): integer;
+cdecl; external 'libc.so' name 'putenv';
+{$ENDIF}
+{$ENDIF}
+
+{ Put a variable of the form "name=value" into the environment }
+//function SDL_putenv(const variable: PChar): integer; cdecl; external {$IFDEF __GPC__}name 'SDL_Init'{$ELSE} SDLLibName{$ENDIF __GPC__}SDLLibName name '';
+function SDL_putenv(const variable: PChar): integer;
+{$EXTERNALSYM SDL_putenv}
+
+// The following function has been commented out to encourage developers to use
+// SDL_putenv as it it more portable
+//function putenv(const variable: PChar): integer;
+//{$EXTERNALSYM putenv}
+
+{$IFDEF WIN32}
+{$IFNDEF __GPC__}
+function getenv( const name : Pchar ): PChar; cdecl;
+{$ENDIF}
+{$ENDIF}
+
+{* Retrieve a variable named "name" from the environment }
+//function SDL_getenv(const name: PChar): PChar; cdecl; external {$IFDEF __GPC__}name 'SDL_Init'{$ELSE} SDLLibName{$ENDIF __GPC__}SDLLibName name '';
+function SDL_getenv(const name: PChar): PChar;
+{$EXTERNALSYM SDL_getenv}
+
+// The following function has been commented out to encourage developers to use
+// SDL_getenv as it it more portable
+//function getenv(const name: PChar): PChar;
+//{$EXTERNALSYM getenv}
+
+{*
+ * This function gives you custom hooks into the window manager information.
+ * It fills the structure pointed to by 'info' with custom information and
+ * returns 1 if the function is implemented. If it's not implemented, or
+ * the version member of the 'info' structure is invalid, it returns 0.
+ *}
+function SDL_GetWMInfo(info : PSDL_SysWMinfo) : integer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_GetWMInfo'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_GetWMInfo}
+
+{------------------------------------------------------------------------------}
+
+//SDL_loadso.h
+{* This function dynamically loads a shared object and returns a pointer
+ * to the object handle (or NULL if there was an error).
+ * The 'sofile' parameter is a system dependent name of the object file.
+ *}
+function SDL_LoadObject( const sofile : PChar ) : Pointer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LoadObject'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LoadObject}
+
+{* Given an object handle, this function looks up the address of the
+ * named function in the shared object and returns it. This address
+ * is no longer valid after calling SDL_UnloadObject().
+ *}
+function SDL_LoadFunction( handle : Pointer; const name : PChar ) : Pointer;
+cdecl; external {$IFDEF __GPC__}name 'SDL_LoadFunction'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_LoadFunction}
+
+{* Unload a shared object from memory *}
+procedure SDL_UnloadObject( handle : Pointer );
+cdecl; external {$IFDEF __GPC__}name 'SDL_UnloadObject'{$ELSE} SDLLibName{$ENDIF __GPC__};
+{$EXTERNALSYM SDL_UnloadObject}
+
+
+
+{------------------------------------------------------------------------------}
+
+function SDL_Swap32(D: Uint32): Uint32;
+{$EXTERNALSYM SDL_Swap32}
+
+{ FreeAndNil frees the given TObject instance and sets the variable reference
+ to nil. Be careful to only pass TObjects to this routine. }
+procedure FreeAndNil(var Obj);
+
+{ Exit procedure handling }
+
+{ AddExitProc adds the given procedure to the run-time library's exit
+ procedure list. When an application terminates, its exit procedures are
+ executed in reverse order of definition, i.e. the last procedure passed
+ to AddExitProc is the first one to get executed upon termination. }
+procedure AddExitProc(Proc: TProcedure);
+
+// Bitwise Checking functions
+function IsBitOn( value : integer; bit : Byte ) : boolean;
+
+function TurnBitOn( value : integer; bit : Byte ) : integer;
+
+function TurnBitOff( value : integer; bit : Byte ) : integer;
+
+implementation
+
+{$IFDEF __GPC__}
+ {$L 'sdl'} { link sdl.dll.a or libsdl.so or libsdl.a }
+{$ENDIF}
+
+function SDL_TABLESIZE(table: PChar): Integer;
+begin
+ Result := SizeOf(table) div SizeOf(table[0]);
+end;
+
+procedure SDL_OutOfMemory;
+begin
+ {$IFNDEF WIN32}
+ SDL_Error(SDL_ENOMEM);
+ {$ENDIF}
+end;
+
+function SDL_RWSeek(context: PSDL_RWops; offset: Integer; whence: Integer) : Integer;
+begin
+ Result := context^.seek(context, offset, whence);
+end;
+
+function SDL_RWTell(context: PSDL_RWops): Integer;
+begin
+ Result := context^.seek(context, 0, 1);
+end;
+
+function SDL_RWRead(context: PSDL_RWops; ptr: Pointer; size: Integer; n: Integer): Integer;
+begin
+ Result := context^.read(context, ptr, size, n);
+end;
+
+function SDL_RWWrite(context: PSDL_RWops; ptr: Pointer; size: Integer; n: Integer): Integer;
+begin
+ Result := context^.write(context, ptr, size, n);
+end;
+
+function SDL_RWClose(context: PSDL_RWops): Integer;
+begin
+ Result := context^.close(context);
+end;
+
+function SDL_LoadWAV(filename: PChar; spec: PSDL_AudioSpec; audio_buf: PUInt8; audiolen: PUInt32): PSDL_AudioSpec;
+begin
+ Result := SDL_LoadWAV_RW(SDL_RWFromFile(filename, 'rb'), 1, spec, audio_buf, audiolen);
+end;
+
+function SDL_CDInDrive( status : TSDL_CDStatus ): LongBool;
+begin
+ Result := ord( status ) > ord( CD_ERROR );
+end;
+
+procedure FRAMES_TO_MSF(frames: Integer; var M: Integer; var S: Integer; var
+ F: Integer);
+var
+ value: Integer;
+begin
+ value := frames;
+ F := value mod CD_FPS;
+ value := value div CD_FPS;
+ S := value mod 60;
+ value := value div 60;
+ M := value;
+end;
+
+function MSF_TO_FRAMES(M: Integer; S: Integer; F: Integer): Integer;
+begin
+ Result := M * 60 * CD_FPS + S * CD_FPS + F;
+end;
+
+procedure SDL_VERSION(var X: TSDL_Version);
+begin
+ X.major := SDL_MAJOR_VERSION;
+ X.minor := SDL_MINOR_VERSION;
+ X.patch := SDL_PATCHLEVEL;
+end;
+
+function SDL_VERSIONNUM(X, Y, Z: Integer): Integer;
+begin
+ Result := X * 1000 + Y * 100 + Z;
+end;
+
+function SDL_COMPILEDVERSION: Integer;
+begin
+ Result := SDL_VERSIONNUM(SDL_MAJOR_VERSION, SDL_MINOR_VERSION, SDL_PATCHLEVEL
+ );
+end;
+
+function SDL_VERSION_ATLEAST(X, Y, Z: Integer): LongBool;
+begin
+ Result := (SDL_COMPILEDVERSION >= SDL_VERSIONNUM(X, Y, Z));
+end;
+
+function SDL_LoadBMP(filename: PChar): PSDL_Surface;
+begin
+ Result := SDL_LoadBMP_RW(SDL_RWFromFile(filename, 'rb'), 1);
+end;
+
+function SDL_SaveBMP(surface: PSDL_Surface; filename: PChar): Integer;
+begin
+ Result := SDL_SaveBMP_RW(surface, SDL_RWFromFile(filename, 'wb'), 1);
+end;
+
+function SDL_BlitSurface(src: PSDL_Surface; srcrect: PSDL_Rect; dst:
+ PSDL_Surface;
+ dstrect: PSDL_Rect): Integer;
+begin
+ Result := SDL_UpperBlit(src, srcrect, dst, dstrect);
+end;
+
+function SDL_AllocSurface(flags: UInt32; width, height, depth: Integer;
+ RMask, GMask, BMask, AMask: UInt32): PSDL_Surface;
+begin
+ Result := SDL_CreateRGBSurface(flags, width, height, depth, RMask, GMask,
+ BMask, AMask);
+end;
+
+function SDL_MustLock(Surface: PSDL_Surface): Boolean;
+begin
+ Result := ( ( surface^.offset <> 0 ) or
+ ( ( surface^.flags and ( SDL_HWSURFACE or SDL_ASYNCBLIT or SDL_RLEACCEL ) ) <> 0 ) );
+end;
+
+function SDL_LockMutex(mutex: PSDL_mutex): Integer;
+begin
+ Result := SDL_mutexP(mutex);
+end;
+
+function SDL_UnlockMutex(mutex: PSDL_mutex): Integer;
+begin
+ Result := SDL_mutexV(mutex);
+end;
+
+{$IFDEF WIN32}
+function _putenv( const variable : Pchar ): Integer;
+cdecl; external {$IFDEF __GPC__}name '_putenv'{$ELSE} 'MSVCRT.DLL'{$ENDIF __GPC__};
+{$ENDIF}
+
+
+function SDL_putenv(const variable: PChar): Integer;
+begin
+ {$IFDEF WIN32}
+ Result := _putenv(variable);
+ {$ENDIF}
+
+ {$IFDEF UNIX}
+ {$IFDEF FPC}
+ Result := _putenv(variable);
+ {$ELSE}
+ Result := libc.putenv(variable);
+ {$ENDIF}
+ {$ENDIF}
+end;
+
+{$IFDEF WIN32}
+{$IFNDEF __GPC__}
+function getenv( const name : Pchar ): PChar;
+cdecl; external {$IFDEF __GPC__}name 'getenv'{$ELSE} 'MSVCRT.DLL'{$ENDIF};
+{$ENDIF}
+{$ENDIF}
+
+function SDL_getenv(const name: PChar): PChar;
+begin
+ {$IFDEF WIN32}
+
+ {$IFDEF __GPC__}
+ Result := getenv( string( name ) );
+ {$ELSE}
+ Result := getenv( name );
+ {$ENDIF}
+
+ {$ELSE}
+
+ {$IFDEF UNIX}
+
+ {$IFDEF FPC}
+ Result := fpgetenv(name);
+ {$ELSE}
+ Result := libc.getenv(name);
+ {$ENDIF}
+
+ {$ENDIF}
+
+ {$ENDIF}
+end;
+
+function SDL_BUTTON( Button : Integer ) : Integer;
+begin
+ Result := SDL_PRESSED shl ( Button - 1 );
+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;
+
+procedure FreeAndNil(var Obj);
+{$IFNDEF __GPC__}
+{$IFNDEF __TMT__}
+var
+ Temp: TObject;
+{$ENDIF}
+{$ENDIF}
+begin
+{$IFNDEF __GPC__}
+{$IFNDEF __TMT__}
+ Temp := TObject(Obj);
+ Pointer(Obj) := nil;
+ Temp.Free;
+{$ENDIF}
+{$ENDIF}
+end;
+
+{ Exit procedure handling }
+type
+ PExitProcInfo = ^TExitProcInfo;
+ TExitProcInfo = record
+ Next: PExitProcInfo;
+ SaveExit: Pointer;
+ Proc: TProcedure;
+ end;
+
+var
+ ExitProcList: PExitProcInfo = nil;
+
+procedure DoExitProc;
+var
+ P: PExitProcInfo;
+ Proc: TProcedure;
+begin
+ P := ExitProcList;
+ ExitProcList := P^.Next;
+ ExitProc := P^.SaveExit;
+ Proc := P^.Proc;
+ Dispose(P);
+ Proc;
+end;
+
+procedure AddExitProc(Proc: TProcedure);
+var
+ P: PExitProcInfo;
+begin
+ New(P);
+ P^.Next := ExitProcList;
+ P^.SaveExit := ExitProc;
+ P^.Proc := Proc;
+ ExitProcList := P;
+ ExitProc := @DoExitProc;
+end;
+
+function IsBitOn( value : integer; bit : Byte ) : boolean;
+begin
+ result := ( ( value and ( 1 shl bit ) ) <> 0 );
+end;
+
+function TurnBitOn( value : integer; bit : Byte ) : integer;
+begin
+ result := ( value or ( 1 shl bit ) );
+end;
+
+function TurnBitOff( value : integer; bit : Byte ) : integer;
+begin
+ result := ( value and not ( 1 shl bit ) );
+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 new file mode 100644 index 00000000..bd371c55 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas @@ -0,0 +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 <slouken@devolution.com> 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 <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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 new file mode 100644 index 00000000..f8bf902c --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas @@ -0,0 +1,195 @@ +unit sdlgameinterface;
+{
+ $Id: sdlgameinterface.pas,v 1.3 2004/10/17 18:41:49 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 <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.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 : TSDL2DWindow;
+ procedure ResetInputManager;
+ procedure LoadSurfaces; virtual;
+ function PointIsInRect( Point : TPoint; x, y, x1, y1 : integer ) : Boolean;
+ constructor Create( const aMainWindow : TSDL2DWindow );
+ 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 : TSDL2DWindow );
+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;
+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;
+ MainWindow.OnRender := Render;
+ MainWindow.OnClose := Close;
+ 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 new file mode 100644 index 00000000..9151168a --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas @@ -0,0 +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 <tigertomjones@gmx.de> }
+{ }
+{ Portions created by Tom Jones are }
+{ Copyright (C) 2000 - 2001 Tom Jones. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ Róbert Kisnémeth <mikrobi@freemail.hu> }
+{ }
+{ 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 new file mode 100644 index 00000000..2955d17a --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlinput.pas @@ -0,0 +1,692 @@ +unit sdlinput;
+{
+ $Id: sdlinput.pas,v 1.7 2004/09/30 22:32:04 savage Exp $
+
+}
+{******************************************************************************}
+{ }
+{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer }
+{ SDL Input Wrapper }
+{ }
+{ }
+{ The initial developer of this Pascal code was : }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ Portions created by Dominique Louis are }
+{ Copyright (C) 2003 - 2100 Dominique Louis. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.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};
+
+ TSDLMouse = class( TSDLCustomInput )
+ private
+ FDragging : Boolean;
+ FMousePos : TPoint;
+ FOnMouseUp: TSDLMouseButtonEvent;
+ FOnMouseDown: TSDLMouseButtonEvent;
+ FOnMouseMove: TSDLMouseMoveEvent;
+ FOnMouseWheel: TSDLMouseWheelEvent;
+ FCursor : PSDL_Cursor; // 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);
+ public
+ destructor Destroy; override;
+ function UpdateInput( event: TSDL_EVENT ) : Boolean; override;
+ function MouseIsDown( Button : Integer ) : Boolean;
+ function MouseIsUp( Button : Integer ) : Boolean;
+ procedure SetCursor(data, mask: PUInt8; w, h, hot_x, hot_y: Integer);
+ 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;
+ 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
+
+{ 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
+ if FCursor <> nil then
+ SDL_FreeCursor( FCursor );
+ 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.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.SetCursor(data, mask: PUInt8; w, h, hot_x, hot_y: Integer);
+begin
+ if FCursor <> nil then
+ SDL_FreeCursor( FCursor );
+ // create the cursor
+ FCursor := SDL_CreateCursor( data, mask, w, h, hot_x, hot_y );
+
+ // set the cursor
+ SDL_SetCursor( FCursor );
+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;
+
+end.
diff --git a/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas new file mode 100644 index 00000000..64009176 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas @@ -0,0 +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" <mrkroket@hotmail.com> }
+{ }
+{******************************************************************}
+{
+ $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 new file mode 100644 index 00000000..4e91ecb8 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlticks.pas @@ -0,0 +1,196 @@ +unit sdlticks;
+{
+ $Id: sdlticks.pas,v 1.1 2004/09/30 22:35:47 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 <Dominique@SavageSoftware.com.au> }
+{ }
+{ Portions created by Dominique Louis are }
+{ Copyright (C) 2004 - 2100 Dominique Louis. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.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
+ m_startTime : Int64;
+ m_ticksPerSecond : Int64;
+ s_lastTime : Int64;
+
+ 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;
+
+ function GetElapsedSeconds( elapsedFrames : Cardinal = 1 ) : single;
+
+ {***************************************************************************
+ GetFPS
+
+ Returns the average frames per second over elapsedFrames, which defaults to
+ one. 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( elapsedFrames : Cardinal = 1 ) : 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 <= targetFPS.
+ ***************************************************************************}
+ function LockFPS( targetFPS : Byte ) : single;
+ end;
+
+implementation
+
+{ TSDLTicks }
+constructor TSDLTicks.Create;
+begin
+
+end;
+
+destructor TSDLTicks.Destroy;
+begin
+
+ inherited;
+end;
+
+function TSDLTicks.GetElapsedSeconds( elapsedFrames: Cardinal ): single;
+var
+ currentTime : Int64;
+begin
+ // s_lastTime := m_startTime;
+
+ currentTime := SDL_GetTicks;
+ //QueryPerformanceCounter( currentTime );
+
+ result := (currentTime - s_lastTime) / m_ticksPerSecond;
+
+ // reset the timer
+ s_lastTime := currentTime;
+end;
+
+function TSDLTicks.GetFPS( elapsedFrames: Cardinal ): single;
+var
+ currentTime : integer;
+ fps : single;
+begin
+ // s_lastTime := m_startTime;
+
+ currentTime := SDL_GetTicks;
+
+ fps := elapsedFrames * m_ticksPerSecond / ( currentTime - s_lastTime);
+
+ // reset the timer
+ s_lastTime := currentTime;
+
+ result := fps;
+end;
+
+function TSDLTicks.Init: boolean;
+begin
+ m_startTime := SDL_GetTicks;
+ s_lastTime := m_startTime;
+ m_ticksPerSecond := 1000;
+ result := true;
+end;
+
+function TSDLTicks.LockFPS(targetFPS: Byte): single;
+var
+ currentTime : integer;
+ fps : single;
+begin
+ if (targetFPS = 0) then
+ targetFPS := 1;
+
+ s_lastTime := m_startTime;
+
+ // delay to maintain a constant frame rate
+ repeat
+ currentTime := SDL_GetTicks;
+ fps := m_ticksPerSecond / (currentTime - s_lastTime);
+ until (fps > targetFPS);
+
+ // reset the timer
+ s_lastTime := m_startTime;
+
+ result := fps;
+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 new file mode 100644 index 00000000..bef83cbc --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlutils.pas @@ -0,0 +1,4256 @@ +unit sdlutils;
+{
+ $Id: sdlutils.pas,v 1.4 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 <tigertomjones@gmx.de> }
+{ }
+{ Portions created by Tom Jones are }
+{ Copyright (C) 2000 - 2001 Tom Jones. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ Róbert Kisnémeth <mikrobi@freemail.hu> }
+{ }
+{ 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.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,
+ 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 : 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 : 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;
+
+procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color :
+ cardinal );
+var
+ SrcColor : cardinal;
+ Addr : cardinal;
+ R, G, B : cardinal;
+begin
+ if Color = 0 then
+ exit;
+ with DstSurface^ do
+ begin
+ Addr := cardinal( 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 : cardinal;
+ R, G, B : cardinal;
+begin
+ if Color = 0 then
+ exit;
+ with DstSurface^ do
+ begin
+ Addr := cardinal( 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 : 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
+ 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 : 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 := 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 : cardinal;
+ _ebx, _esi, _edi, _esp : cardinal;
+ 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 := 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;
+ 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 : cardinal;
+ _ebx, _esi, _edi, _esp : cardinal;
+ WorkX, WorkY : word;
+ SrcMod, DestMod, TextMod : cardinal;
+ SrcColor, TransparentColor, TextureColor : 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 := 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;
+ BPP := DestSurface.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( 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( 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_MoveLine( Surface : PSDL_Surface; x1, x2, y1, xofs, depth : integer );
+var
+ src_pixels, dst_pixels : PUint8;
+ i : integer;
+begin
+ src_pixels := PUint8( integer( Surface^.pixels ) + Surface^.w * y1 * depth + x2 *
+ depth );
+ dst_pixels := PUint8( integer( 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( 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;
+{ 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( Uint32( 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( 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: 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;
+
+ 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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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: UInt32;
+ 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 := UInt32(Src.Pixels);
+ WriteRow := UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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: UInt32;
+ 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 := UInt32(Src.Pixels);
+ WriteRow := UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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(UInt32(ReadRow), SrcPitch);
+ inc(UInt32(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 : 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
+ 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 )^;
+ 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;
+ 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 )^;
+ 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 : 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;
+
+// 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 new file mode 100644 index 00000000..ef290071 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas @@ -0,0 +1,564 @@ +unit sdlwindow;
+{
+ $Id: sdlwindow.pas,v 1.7 2004/09/30 22:35:47 savage Exp $
+
+}
+{******************************************************************************}
+{ }
+{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer }
+{ SDL Window Wrapper }
+{ }
+{ }
+{ The initial developer of this Pascal code was : }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ Portions created by Dominique Louis are }
+{ Copyright (C) 2004 - 2100 Dominique Louis. }
+{ }
+{ }
+{ Contributor(s) }
+{ -------------- }
+{ Dominique Louis <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.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;
+
+ TSDL2DWindow = class( TSDLBaseWindow )
+ 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;
+ property OnCreate;
+ property OnDestroy;
+ property OnClose;
+ property OnShow;
+ property OnResize;
+ property OnRender;
+ property OnUpdate;
+ property DisplaySurface;
+ end;
+
+ TSDL3DWindow = class( TSDLBaseWindow )
+ 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;
+ property OnCreate;
+ property OnDestroy;
+ property OnClose;
+ property OnShow;
+ property OnResize;
+ property OnRender;
+ property OnUpdate;
+ property DisplaySurface;
+ 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 new file mode 100644 index 00000000..97e26520 --- /dev/null +++ b/Game/Code/lib/JEDI-SDL/SDL/Pas/userpreferences.pas @@ -0,0 +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 <Dominique@SavageSoftware.com.au> }
+{ }
+{ 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.
|