From 3260749d369d3466c345d40a8b2189c32c8c1b60 Mon Sep 17 00:00:00 2001 From: Alexander Sulfrian Date: Mon, 7 Nov 2011 15:26:44 +0100 Subject: removed pascal code --- src/base/TextGL.pas | 211 - src/base/UBeatTimer.pas | 170 - src/base/UCatCovers.pas | 214 - src/base/UCommandLine.pas | 345 - src/base/UCommon.pas | 584 -- src/base/UConfig.pas | 232 - src/base/UCovers.pas | 459 - src/base/UDLLManager.pas | 293 - src/base/UDataBase.pas | 614 -- src/base/UDraw.pas | 1408 --- src/base/UEditorLyrics.pas | 259 - src/base/UFiles.pas | 212 - src/base/UFilesystem.pas | 692 -- src/base/UFont.pas | 2798 ------ src/base/UGraphic.pas | 823 -- src/base/UGraphicClasses.pas | 720 -- src/base/UIni.pas | 1219 --- src/base/UJoystick.pas | 312 - src/base/ULog.pas | 441 - src/base/ULyrics.pas | 726 -- src/base/UMain.pas | 569 -- src/base/UMusic.pas | 1139 --- src/base/UNote.pas | 591 -- src/base/UParty.pas | 388 - src/base/UPathUtils.pas | 196 - src/base/UPlatform.pas | 135 - src/base/UPlatformLinux.pas | 149 - src/base/UPlatformMacOSX.pas | 279 - src/base/UPlatformWindows.pas | 128 - src/base/UPlaylist.pas | 520 -- src/base/URecord.pas | 777 -- src/base/USingScores.pas | 1122 --- src/base/USkins.pas | 220 - src/base/USong.pas | 1348 --- src/base/USongs.pas | 845 -- src/base/UTextEncoding.pas | 247 - src/base/UTexture.pas | 547 -- src/base/UThemes.pas | 2397 ----- src/base/UUnicodeUtils.pas | 670 -- src/base/UXMLSong.pas | 623 -- src/lib/FreeImage/FreeBitmap.pas | 1742 ---- src/lib/FreeImage/FreeImage.pas | 771 -- src/lib/JEDI-SDL/OpenGL/Pas/geometry.pas | 1994 ---- src/lib/JEDI-SDL/OpenGL/Pas/gl.pas | 2301 ----- src/lib/JEDI-SDL/OpenGL/Pas/glext.pas | 9579 -------------------- src/lib/JEDI-SDL/OpenGL/Pas/glu.pas | 582 -- src/lib/JEDI-SDL/OpenGL/Pas/glut.pas | 688 -- src/lib/JEDI-SDL/OpenGL/Pas/glx.pas | 279 - src/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas | 2688 ------ src/lib/JEDI-SDL/SDL/Pas/logger.pas | 189 - src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas | 320 - .../JEDI-SDL/SDL/Pas/registryuserpreferences.pas | 229 - src/lib/JEDI-SDL/SDL/Pas/sdl.pas | 4332 --------- src/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas | 155 - src/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas | 202 - src/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas | 5236 ----------- src/lib/JEDI-SDL/SDL/Pas/sdlinput.pas | 923 -- src/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas | 216 - src/lib/JEDI-SDL/SDL/Pas/sdlticks.pas | 197 - src/lib/JEDI-SDL/SDL/Pas/sdlutils.pas | 4363 --------- src/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas | 566 -- src/lib/JEDI-SDL/SDL/Pas/userpreferences.pas | 159 - src/lib/JEDI-SDL/SDL_Image/Pas/sdl_image.pas | 350 - src/lib/SQLite/SQLite3.pas | 253 - src/lib/SQLite/SQLiteTable3.pas | 1500 --- src/lib/SQLite/example/uTestSqlite.pas | 233 - src/lib/TntUnicodeControls/TntClasses.pas | 1799 ---- src/lib/TntUnicodeControls/TntFormatStrUtils.pas | 521 -- src/lib/TntUnicodeControls/TntSysUtils.pas | 1753 ---- src/lib/TntUnicodeControls/TntSystem.pas | 1427 --- src/lib/TntUnicodeControls/TntWideStrUtils.pas | 455 - src/lib/TntUnicodeControls/TntWideStrings.pas | 846 -- src/lib/TntUnicodeControls/TntWindows.pas | 1501 --- src/lib/bass/delphi/bass.pas | 900 -- src/lib/collections/CollArray.pas | 183 - src/lib/collections/CollHash.pas | 1497 --- src/lib/collections/CollLibrary.pas | 131 - src/lib/collections/CollList.pas | 270 - src/lib/collections/CollPArray.pas | 689 -- src/lib/collections/CollWrappers.pas | 876 -- src/lib/collections/Collections.pas | 5318 ----------- src/lib/ctypes/ctypes.pas | 72 - src/lib/ffmpeg/avcodec.pas | 4533 --------- src/lib/ffmpeg/avformat.pas | 1750 ---- src/lib/ffmpeg/avio.pas | 590 -- src/lib/ffmpeg/avutil.pas | 420 - src/lib/ffmpeg/mathematics.pas | 104 - src/lib/ffmpeg/opt.pas | 272 - src/lib/ffmpeg/rational.pas | 179 - src/lib/ffmpeg/swscale.pas | 355 - src/lib/fft/UFFT.pas | 602 -- src/lib/freetype/demo/nehe/UFreeType.pas | 326 - src/lib/freetype/freetype.pas | 1845 ---- src/lib/libpng/png.pas | 974 -- src/lib/midi/MidiFile.pas | 968 -- src/lib/midi/MidiScope.pas | 198 - src/lib/midi/Midicons.pas | 47 - src/lib/midi/Midiin.pas | 727 -- src/lib/midi/Midiout.pas | 619 -- src/lib/midi/demo/MidiTest.pas | 249 - src/lib/other/DirWatch.pas | 345 - src/lib/other/WinAllocation.pas | 101 - src/lib/pcre/pcre.pas | 852 -- src/lib/portaudio/portaudio.pas | 1160 --- src/lib/portmixer/portmixer.pas | 149 - src/lib/projectM/projectM.pas | 232 - src/lib/samplerate/samplerate.pas | 199 - src/lib/zlib/zlib.pas | 215 - src/macosx/PseudoThread.pas | 75 - src/media/UAudioConverter.pas | 483 - src/media/UAudioCore_Bass.pas | 160 - src/media/UAudioCore_Portaudio.pas | 281 - src/media/UAudioDecoder_Bass.pas | 278 - src/media/UAudioDecoder_FFmpeg.pas | 1141 --- src/media/UAudioInput_Bass.pas | 510 -- src/media/UAudioInput_Portaudio.pas | 495 - src/media/UAudioPlaybackBase.pas | 318 - src/media/UAudioPlayback_Bass.pas | 758 -- src/media/UAudioPlayback_Portaudio.pas | 385 - src/media/UAudioPlayback_SDL.pas | 182 - src/media/UAudioPlayback_SoftMixer.pas | 1154 --- src/media/UMediaCore_FFmpeg.pas | 550 -- src/media/UMediaCore_SDL.pas | 63 - src/media/UMedia_dummy.pas | 269 - src/media/UVideo.pas | 966 -- src/media/UVisualizer.pas | 552 -- src/menu/UDrawTexture.pas | 139 - src/menu/UMenu.pas | 1762 ---- src/menu/UMenuBackgroundFade.pas | 176 - src/menu/UMenuBackgroundTexture.pas | 126 - src/menu/UMenuBackgroundVideo.pas | 203 - src/menu/UMenuButton.pas | 647 -- src/menu/UMenuButtonCollection.pas | 101 - src/menu/UMenuEqualizer.pas | 320 - src/menu/UMenuInteract.pas | 54 - src/menu/UMenuSelectSlide.pas | 439 - src/menu/UMenuStatic.pas | 117 - src/menu/UMenuText.pas | 379 - src/screens/UScreenCredits.pas | 1466 --- src/screens/UScreenEdit.pas | 164 - src/screens/UScreenEditConvert.pas | 827 -- src/screens/UScreenEditHeader.pas | 445 - src/screens/UScreenEditSub.pas | 1520 ---- src/screens/UScreenLevel.pas | 139 - src/screens/UScreenLoading.pas | 78 - src/screens/UScreenMain.pas | 266 - src/screens/UScreenName.pas | 284 - src/screens/UScreenOpen.pas | 231 - src/screens/UScreenOptions.pas | 234 - src/screens/UScreenOptionsAdvanced.pas | 171 - src/screens/UScreenOptionsGame.pas | 175 - src/screens/UScreenOptionsGraphics.pas | 172 - src/screens/UScreenOptionsLyrics.pas | 148 - src/screens/UScreenOptionsRecord.pas | 813 -- src/screens/UScreenOptionsSound.pas | 187 - src/screens/UScreenOptionsThemes.pas | 206 - src/screens/UScreenPartyNewRound.pas | 463 - src/screens/UScreenPartyOptions.pas | 318 - src/screens/UScreenPartyPlayer.pas | 385 - src/screens/UScreenPartyScore.pas | 343 - src/screens/UScreenPartyWin.pas | 302 - src/screens/UScreenPopup.pas | 308 - src/screens/UScreenScore.pas | 924 -- src/screens/UScreenSing.pas | 1001 -- src/screens/UScreenSingModi.pas | 582 -- src/screens/UScreenSong.pas | 2061 ----- src/screens/UScreenSongJumpto.pas | 244 - src/screens/UScreenSongMenu.pas | 661 -- src/screens/UScreenStatDetail.pas | 303 - src/screens/UScreenStatMain.pas | 323 - src/screens/UScreenTop5.pas | 307 - src/screens/UScreenWelcome.pas | 164 - 172 files changed, 131216 deletions(-) delete mode 100644 src/base/TextGL.pas delete mode 100644 src/base/UBeatTimer.pas delete mode 100644 src/base/UCatCovers.pas delete mode 100644 src/base/UCommandLine.pas delete mode 100644 src/base/UCommon.pas delete mode 100644 src/base/UConfig.pas delete mode 100644 src/base/UCovers.pas delete mode 100644 src/base/UDLLManager.pas delete mode 100644 src/base/UDataBase.pas delete mode 100644 src/base/UDraw.pas delete mode 100644 src/base/UEditorLyrics.pas delete mode 100644 src/base/UFiles.pas delete mode 100644 src/base/UFilesystem.pas delete mode 100644 src/base/UFont.pas delete mode 100644 src/base/UGraphic.pas delete mode 100644 src/base/UGraphicClasses.pas delete mode 100644 src/base/UIni.pas delete mode 100644 src/base/UJoystick.pas delete mode 100644 src/base/ULog.pas delete mode 100644 src/base/ULyrics.pas delete mode 100644 src/base/UMain.pas delete mode 100644 src/base/UMusic.pas delete mode 100644 src/base/UNote.pas delete mode 100644 src/base/UParty.pas delete mode 100644 src/base/UPathUtils.pas delete mode 100644 src/base/UPlatform.pas delete mode 100644 src/base/UPlatformLinux.pas delete mode 100644 src/base/UPlatformMacOSX.pas delete mode 100644 src/base/UPlatformWindows.pas delete mode 100644 src/base/UPlaylist.pas delete mode 100644 src/base/URecord.pas delete mode 100644 src/base/USingScores.pas delete mode 100644 src/base/USkins.pas delete mode 100644 src/base/USong.pas delete mode 100644 src/base/USongs.pas delete mode 100644 src/base/UTextEncoding.pas delete mode 100644 src/base/UTexture.pas delete mode 100644 src/base/UThemes.pas delete mode 100644 src/base/UUnicodeUtils.pas delete mode 100644 src/base/UXMLSong.pas delete mode 100644 src/lib/FreeImage/FreeBitmap.pas delete mode 100644 src/lib/FreeImage/FreeImage.pas delete mode 100644 src/lib/JEDI-SDL/OpenGL/Pas/geometry.pas delete mode 100644 src/lib/JEDI-SDL/OpenGL/Pas/gl.pas delete mode 100644 src/lib/JEDI-SDL/OpenGL/Pas/glext.pas delete mode 100644 src/lib/JEDI-SDL/OpenGL/Pas/glu.pas delete mode 100644 src/lib/JEDI-SDL/OpenGL/Pas/glut.pas delete mode 100644 src/lib/JEDI-SDL/OpenGL/Pas/glx.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/logger.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdl.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdlinput.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdlticks.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdlutils.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas delete mode 100644 src/lib/JEDI-SDL/SDL/Pas/userpreferences.pas delete mode 100644 src/lib/JEDI-SDL/SDL_Image/Pas/sdl_image.pas delete mode 100644 src/lib/SQLite/SQLite3.pas delete mode 100644 src/lib/SQLite/SQLiteTable3.pas delete mode 100644 src/lib/SQLite/example/uTestSqlite.pas delete mode 100644 src/lib/TntUnicodeControls/TntClasses.pas delete mode 100644 src/lib/TntUnicodeControls/TntFormatStrUtils.pas delete mode 100644 src/lib/TntUnicodeControls/TntSysUtils.pas delete mode 100644 src/lib/TntUnicodeControls/TntSystem.pas delete mode 100644 src/lib/TntUnicodeControls/TntWideStrUtils.pas delete mode 100644 src/lib/TntUnicodeControls/TntWideStrings.pas delete mode 100644 src/lib/TntUnicodeControls/TntWindows.pas delete mode 100644 src/lib/bass/delphi/bass.pas delete mode 100644 src/lib/collections/CollArray.pas delete mode 100644 src/lib/collections/CollHash.pas delete mode 100644 src/lib/collections/CollLibrary.pas delete mode 100644 src/lib/collections/CollList.pas delete mode 100644 src/lib/collections/CollPArray.pas delete mode 100644 src/lib/collections/CollWrappers.pas delete mode 100644 src/lib/collections/Collections.pas delete mode 100644 src/lib/ctypes/ctypes.pas delete mode 100644 src/lib/ffmpeg/avcodec.pas delete mode 100644 src/lib/ffmpeg/avformat.pas delete mode 100644 src/lib/ffmpeg/avio.pas delete mode 100644 src/lib/ffmpeg/avutil.pas delete mode 100644 src/lib/ffmpeg/mathematics.pas delete mode 100644 src/lib/ffmpeg/opt.pas delete mode 100644 src/lib/ffmpeg/rational.pas delete mode 100644 src/lib/ffmpeg/swscale.pas delete mode 100644 src/lib/fft/UFFT.pas delete mode 100644 src/lib/freetype/demo/nehe/UFreeType.pas delete mode 100644 src/lib/freetype/freetype.pas delete mode 100644 src/lib/libpng/png.pas delete mode 100644 src/lib/midi/MidiFile.pas delete mode 100644 src/lib/midi/MidiScope.pas delete mode 100644 src/lib/midi/Midicons.pas delete mode 100644 src/lib/midi/Midiin.pas delete mode 100644 src/lib/midi/Midiout.pas delete mode 100644 src/lib/midi/demo/MidiTest.pas delete mode 100644 src/lib/other/DirWatch.pas delete mode 100644 src/lib/other/WinAllocation.pas delete mode 100644 src/lib/pcre/pcre.pas delete mode 100644 src/lib/portaudio/portaudio.pas delete mode 100644 src/lib/portmixer/portmixer.pas delete mode 100644 src/lib/projectM/projectM.pas delete mode 100644 src/lib/samplerate/samplerate.pas delete mode 100644 src/lib/zlib/zlib.pas delete mode 100644 src/macosx/PseudoThread.pas delete mode 100644 src/media/UAudioConverter.pas delete mode 100644 src/media/UAudioCore_Bass.pas delete mode 100644 src/media/UAudioCore_Portaudio.pas delete mode 100644 src/media/UAudioDecoder_Bass.pas delete mode 100644 src/media/UAudioDecoder_FFmpeg.pas delete mode 100644 src/media/UAudioInput_Bass.pas delete mode 100644 src/media/UAudioInput_Portaudio.pas delete mode 100644 src/media/UAudioPlaybackBase.pas delete mode 100644 src/media/UAudioPlayback_Bass.pas delete mode 100644 src/media/UAudioPlayback_Portaudio.pas delete mode 100644 src/media/UAudioPlayback_SDL.pas delete mode 100644 src/media/UAudioPlayback_SoftMixer.pas delete mode 100644 src/media/UMediaCore_FFmpeg.pas delete mode 100644 src/media/UMediaCore_SDL.pas delete mode 100644 src/media/UMedia_dummy.pas delete mode 100644 src/media/UVideo.pas delete mode 100644 src/media/UVisualizer.pas delete mode 100644 src/menu/UDrawTexture.pas delete mode 100644 src/menu/UMenu.pas delete mode 100644 src/menu/UMenuBackgroundFade.pas delete mode 100644 src/menu/UMenuBackgroundTexture.pas delete mode 100644 src/menu/UMenuBackgroundVideo.pas delete mode 100644 src/menu/UMenuButton.pas delete mode 100644 src/menu/UMenuButtonCollection.pas delete mode 100644 src/menu/UMenuEqualizer.pas delete mode 100644 src/menu/UMenuInteract.pas delete mode 100644 src/menu/UMenuSelectSlide.pas delete mode 100644 src/menu/UMenuStatic.pas delete mode 100644 src/menu/UMenuText.pas delete mode 100644 src/screens/UScreenCredits.pas delete mode 100644 src/screens/UScreenEdit.pas delete mode 100644 src/screens/UScreenEditConvert.pas delete mode 100644 src/screens/UScreenEditHeader.pas delete mode 100644 src/screens/UScreenEditSub.pas delete mode 100644 src/screens/UScreenLevel.pas delete mode 100644 src/screens/UScreenLoading.pas delete mode 100644 src/screens/UScreenMain.pas delete mode 100644 src/screens/UScreenName.pas delete mode 100644 src/screens/UScreenOpen.pas delete mode 100644 src/screens/UScreenOptions.pas delete mode 100644 src/screens/UScreenOptionsAdvanced.pas delete mode 100644 src/screens/UScreenOptionsGame.pas delete mode 100644 src/screens/UScreenOptionsGraphics.pas delete mode 100644 src/screens/UScreenOptionsLyrics.pas delete mode 100644 src/screens/UScreenOptionsRecord.pas delete mode 100644 src/screens/UScreenOptionsSound.pas delete mode 100644 src/screens/UScreenOptionsThemes.pas delete mode 100644 src/screens/UScreenPartyNewRound.pas delete mode 100644 src/screens/UScreenPartyOptions.pas delete mode 100644 src/screens/UScreenPartyPlayer.pas delete mode 100644 src/screens/UScreenPartyScore.pas delete mode 100644 src/screens/UScreenPartyWin.pas delete mode 100644 src/screens/UScreenPopup.pas delete mode 100644 src/screens/UScreenScore.pas delete mode 100644 src/screens/UScreenSing.pas delete mode 100644 src/screens/UScreenSingModi.pas delete mode 100644 src/screens/UScreenSong.pas delete mode 100644 src/screens/UScreenSongJumpto.pas delete mode 100644 src/screens/UScreenSongMenu.pas delete mode 100644 src/screens/UScreenStatDetail.pas delete mode 100644 src/screens/UScreenStatMain.pas delete mode 100644 src/screens/UScreenTop5.pas delete mode 100644 src/screens/UScreenWelcome.pas (limited to 'src') diff --git a/src/base/TextGL.pas b/src/base/TextGL.pas deleted file mode 100644 index 7fe98d29..00000000 --- a/src/base/TextGL.pas +++ /dev/null @@ -1,211 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit TextGL; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - gl, - glext, - SDL, - Classes, - UTexture, - UFont, - UPath, - ULog; - -type - PGLFont = ^TGLFont; - TGLFont = record - Font: TScalableFont; - X, Y, Z: real; - end; - -var - Fonts: array of TGLFont; - ActFont: integer; - -procedure BuildFont; // build our bitmap font -procedure KillFont; // delete the font -function glTextWidth(const text: UTF8String): real; // returns text width -procedure glPrint(const text: UTF8String); // custom GL "Print" routine -procedure ResetFont(); // reset font settings of active font -procedure SetFontPos(X, Y: real); // sets X and Y -procedure SetFontZ(Z: real); // sets Z -procedure SetFontSize(Size: real); -procedure SetFontStyle(Style: integer); // sets active font style (normal, bold, etc) -procedure SetFontItalic(Enable: boolean); // sets italic type letter (works for all fonts) -procedure SetFontReflection(Enable:boolean;Spacing: real); // enables/disables text reflection - -implementation - -uses - UTextEncoding, - SysUtils, - IniFiles, - UCommon, - UMain, - UPathUtils; - -function FindFontFile(FontIni: TCustomIniFile; Font: string): IPath; -var - Filename: IPath; -begin - Filename := Path(FontIni.ReadString(Font, 'File', '')); - Result := FontPath.Append(Filename); - // if path does not exist, try as an absolute path - if (not Result.IsFile) then - Result := Filename; -end; - -procedure BuildFont; -var - FontIni: TMemIniFile; - FontFile: IPath; -begin - ActFont := 0; - - SetLength(Fonts, 4); - FontIni := TMemIniFile.Create(FontPath.Append('fonts.ini').ToNative); - - try - - // Normal - FontFile := FindFontFile(FontIni, 'Normal'); - Fonts[0].Font := TFTScalableFont.Create(FontFile, 64); - //Fonts[0].Font.GlyphSpacing := 1.4; - //Fonts[0].Font.Aspect := 1.2; - - // Bold - FontFile := FindFontFile(FontIni, 'Bold'); - Fonts[1].Font := TFTScalableFont.Create(FontFile, 64); - - // Outline1 - FontFile := FindFontFile(FontIni, 'Outline1'); - Fonts[2].Font := TFTScalableOutlineFont.Create(FontFile, 64, 0.06); - //TFTScalableOutlineFont(Fonts[2].Font).SetOutlineColor(0.3, 0.3, 0.3); - - // Outline2 - FontFile := FindFontFile(FontIni, 'Outline2'); - Fonts[3].Font := TFTScalableOutlineFont.Create(FontFile, 64, 0.08); - - except - on E: Exception do - Log.LogCritical(E.Message, 'BuildFont'); - end; - - // close ini-file - FontIni.Free; -end; - - -// Deletes the font -procedure KillFont; -begin - // delete all characters - //glDeleteLists(..., 256); -end; - -function glTextWidth(const text: UTF8String): real; -var - Bounds: TBoundsDbl; -begin - Bounds := Fonts[ActFont].Font.BBox(Text, true); - Result := Bounds.Right - Bounds.Left; -end; - -// Custom GL "Print" Routine -procedure glPrint(const Text: UTF8String); -var - GLFont: PGLFont; -begin - // if there is no text do nothing - if (Text = '') then - Exit; - - GLFont := @Fonts[ActFont]; - - glPushMatrix(); - // set font position - glTranslatef(GLFont.X, GLFont.Y + GLFont.Font.Ascender, GLFont.Z); - // draw string - GLFont.Font.Print(Text); - glPopMatrix(); -end; - -procedure ResetFont(); -begin - SetFontPos(0, 0); - SetFontZ(0); - SetFontItalic(False); - SetFontReflection(False, 0); -end; - -procedure SetFontPos(X, Y: real); -begin - Fonts[ActFont].X := X; - Fonts[ActFont].Y := Y; -end; - -procedure SetFontZ(Z: real); -begin - Fonts[ActFont].Z := Z; -end; - -procedure SetFontSize(Size: real); -begin - Fonts[ActFont].Font.Height := Size; -end; - -procedure SetFontStyle(Style: integer); -begin - ActFont := Style; -end; - -procedure SetFontItalic(Enable: boolean); -begin - if (Enable) then - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style + [Italic] - else - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style - [Italic] -end; - -procedure SetFontReflection(Enable: boolean; Spacing: real); -begin - if (Enable) then - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style + [Reflect] - else - Fonts[ActFont].Font.Style := Fonts[ActFont].Font.Style - [Reflect]; - Fonts[ActFont].Font.ReflectionSpacing := Spacing - Fonts[ActFont].Font.Descender; -end; - -end. diff --git a/src/base/UBeatTimer.pas b/src/base/UBeatTimer.pas deleted file mode 100644 index 310a49cd..00000000 --- a/src/base/UBeatTimer.pas +++ /dev/null @@ -1,170 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UBeatTimer; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UTime; - -type - (** - * TLyricsState contains all information concerning the - * state of the lyrics, e.g. the current beat or duration of the lyrics. - *) - TLyricsState = class - private - Timer: TRelativeTimer; // keeps track of the current time - public - OldBeat: integer; // previous discovered beat - CurrentBeat: integer; // current beat (rounded) - MidBeat: real; // current beat (float) - - // now we use this for super synchronization! - // only used when analyzing voice - // TODO: change ...D to ...Detect(ed) - OldBeatD: integer; // previous discovered beat - CurrentBeatD: integer; // current discovered beat (rounded) - MidBeatD: real; // current discovered beat (float) - - // we use this for audible clicks - // TODO: Change ...C to ...Click - OldBeatC: integer; // previous discovered beat - CurrentBeatC: integer; - MidBeatC: real; // like CurrentBeatC - - OldLine: integer; // previous displayed sentence - - StartTime: real; // time till start of lyrics (= Gap) - TotalTime: real; // total song time - - constructor Create(); - procedure Pause(); - procedure Resume(); - - procedure Reset(); - procedure UpdateBeats(); - - (** - * current song time (in seconds) used as base-timer for lyrics etc. - *) - function GetCurrentTime(): real; - procedure SetCurrentTime(Time: real); - end; - -implementation -uses UNote, Math; - - -constructor TLyricsState.Create(); -begin - // create a triggered timer, so we can Pause() it, set the time - // and Resume() it afterwards for better synching. - Timer := TRelativeTimer.Create(true); - - // reset state - Reset(); -end; - -procedure TLyricsState.Pause(); -begin - Timer.Pause(); -end; - -procedure TLyricsState.Resume(); -begin - Timer.Resume(); -end; - -procedure TLyricsState.SetCurrentTime(Time: real); -begin - // do not start the timer (if not started already), - // after setting the current time - Timer.SetTime(Time, false); -end; - -function TLyricsState.GetCurrentTime(): real; -begin - Result := Timer.GetTime(); -end; - -(** - * Resets the timer and state of the lyrics. - * The timer will be stopped afterwards so you have to call Resume() - * to start the lyrics timer. - *) -procedure TLyricsState.Reset(); -begin - Pause(); - SetCurrentTime(0); - - StartTime := 0; - TotalTime := 0; - - OldBeat := -1; - MidBeat := -1; - CurrentBeat := -1; - - OldBeatC := -1; - MidBeatC := -1; - CurrentBeatC := -1; - - OldBeatD := -1; - MidBeatD := -1; - CurrentBeatD := -1; -end; - -(** - * Updates the beat information (CurrentBeat/MidBeat/...) according to the - * current lyric time. - *) -procedure TLyricsState.UpdateBeats(); -var - CurLyricsTime: real; -begin - CurLyricsTime := GetCurrentTime(); - - OldBeat := CurrentBeat; - MidBeat := GetMidBeat(CurLyricsTime - StartTime / 1000); - CurrentBeat := Floor(MidBeat); - - OldBeatC := CurrentBeatC; - MidBeatC := GetMidBeat(CurLyricsTime - StartTime / 1000); - CurrentBeatC := Floor(MidBeatC); - - OldBeatD := CurrentBeatD; - // MidBeatD = MidBeat with additional GAP - MidBeatD := -0.5 + GetMidBeat(CurLyricsTime - (StartTime + 120 + 20) / 1000); - CurrentBeatD := Floor(MidBeatD); -end; - -end. \ No newline at end of file diff --git a/src/base/UCatCovers.pas b/src/base/UCatCovers.pas deleted file mode 100644 index d33bbbe1..00000000 --- a/src/base/UCatCovers.pas +++ /dev/null @@ -1,214 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UCatCovers; -///////////////////////////////////////////////////////////////////////// -// UCatCovers by Whiteshark // -// Class for listing and managing the Category Covers // -///////////////////////////////////////////////////////////////////////// - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UIni, - UPath; - -type - TCatCovers = class - protected - cNames: array [0..high(ISorting)] of array of UTF8String; - cFiles: array [0..high(ISorting)] of array of IPath; - public - constructor Create; - procedure Load; //Load Cover aus Cover.ini and Cover Folder - procedure LoadPath(const CoversPath: IPath); - procedure Add(Sorting: integer; const Name: UTF8String; const Filename: IPath); //Add a Cover - function CoverExists(Sorting: integer; const Name: UTF8String): boolean; //Returns True when a cover with the given Name exists - function GetCover(Sorting: integer; const Name: UTF8String): IPath; //Returns the Filename of a Cover - end; - -var - CatCovers: TCatCovers; - -implementation - -uses - IniFiles, - SysUtils, - Classes, - UFilesystem, - ULog, - UMain, - UUnicodeUtils, - UPathUtils; - -constructor TCatCovers.Create; -begin - inherited; - Load; -end; - -procedure TCatCovers.Load; -var - I: integer; -begin - for I := 0 to CoverPaths.Count-1 do - LoadPath(CoverPaths[I] as IPath); -end; - -(** - * Load Cover from Cover.ini and Cover Folder - *) -procedure TCatCovers.LoadPath(const CoversPath: IPath); -var - Ini: TMemIniFile; - List: TStringlist; - I, J: Integer; - Filename: IPath; - Name, TmpName: UTF8String; - CatCover: IPath; - Iter: IFileIterator; - FileInfo: TFileInfo; -begin - Ini := nil; - List := nil; - - try - Ini := TMemIniFile.Create(CoversPath.Append('covers.ini').ToNative); - List := TStringlist.Create; - - //Add every Cover in Covers Ini for Every Sorting option - for I := 0 to High(ISorting) do - begin - Ini.ReadSection(ISorting[I], List); - - for J := 0 to List.Count - 1 do - begin - CatCover := Path(Ini.ReadString(ISorting[I], List.Strings[J], 'NoCover.jpg')); - Add(I, List.Strings[J], CoversPath.Append(CatCover)); - end; - end; - finally - Ini.Free; - List.Free; - end; - - //Add Covers from Folder - Iter := FileSystem.FileFind(CoversPath.Append('*.jpg'), 0); - while Iter.HasNext do - begin - FileInfo := Iter.Next; - - //Add Cover if it doesn't exist for every Section - Filename := CoversPath.Append(FileInfo.Name); - Name := FileInfo.Name.SetExtension('').ToUTF8; - - for I := 0 to high(ISorting) do - begin - TmpName := Name; - if (I = sTitle) and (UTF8Pos('Title', TmpName) <> 0) then - UTF8Delete(TmpName, UTF8Pos('Title', TmpName), 5) - else if (I = sArtist) and (UTF8Pos('Artist', TmpName) <> 0) then - UTF8Delete(TmpName, UTF8Pos('Artist', TmpName), 6); - - if not CoverExists(I, TmpName) then - Add(I, TmpName, Filename); - end; - end; -end; - - //Add a Cover -procedure TCatCovers.Add(Sorting: integer; const Name: UTF8String; const Filename: IPath); -begin - if Filename.IsFile then //If Exists -> Add - begin - SetLength(CNames[Sorting], Length(CNames[Sorting]) + 1); - SetLength(CFiles[Sorting], Length(CNames[Sorting]) + 1); - - CNames[Sorting][high(cNames[Sorting])] := UTF8Uppercase(Name); - CFiles[Sorting][high(cNames[Sorting])] := FileName; - end; -end; - - //Returns True when a cover with the given Name exists -function TCatCovers.CoverExists(Sorting: integer; const Name: UTF8String): boolean; -var - I: Integer; - UpperName: UTF8String; -begin - Result := False; - UpperName := UTF8Uppercase(Name); //Case Insensitiv - - for I := 0 to high(cNames[Sorting]) do - begin - if (cNames[Sorting][I] = UpperName) then //Found Name - begin - Result := true; - break; //Break For Loop - end; - end; -end; - - //Returns the Filename of a Cover -function TCatCovers.GetCover(Sorting: integer; const Name: UTF8String): IPath; -var - I: Integer; - UpperName: UTF8String; - NoCoverPath: IPath; -begin - Result := PATH_NONE; - UpperName := UTF8Uppercase(Name); - - for I := 0 to high(cNames[Sorting]) do - begin - if cNames[Sorting][I] = UpperName then - begin - Result := cFiles[Sorting][I]; - Break; - end; - end; - - //No Cover - if (Result.IsUnset) then - begin - for I := 0 to CoverPaths.Count-1 do - begin - NoCoverPath := (CoverPaths[I] as IPath).Append('NoCover.jpg'); - if (NoCoverPath.IsFile) then - begin - Result := NoCoverPath; - Break; - end; - end; - end; -end; - -end. diff --git a/src/base/UCommandLine.pas b/src/base/UCommandLine.pas deleted file mode 100644 index ac0db2c2..00000000 --- a/src/base/UCommandLine.pas +++ /dev/null @@ -1,345 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UCommandLine; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UPath; - -type - TScreenMode = (scmDefault, scmFullscreen, scmWindowed); - - {** - * Reads infos from ParamStr and set some easy interface variables - *} - TCMDParams = class - private - fLanguage: string; - fResolution: string; - - procedure ShowHelp(); - - procedure ReadParamInfo; - procedure ResetVariables; - - function GetLanguage: integer; - function GetResolution: integer; - public - // some boolean variables set when reading infos - Debug: boolean; - Benchmark: boolean; - NoLog: boolean; - ScreenMode: TScreenMode; - Joypad: boolean; - - // some value variables set when reading infos {-1: Not Set, others: Value} - Depth: integer; - Screens: integer; - - // some strings set when reading infos {Length=0: Not Set} - SongPath: IPath; - ConfigFile: IPath; - ScoreFile: IPath; - - // pseudo integer values - property Language: integer read GetLanguage; - property Resolution: integer read GetResolution; - - // some procedures for reading infos - constructor Create; - end; - -var - Params: TCMDParams; - -const - cHelp = 'help'; - cDebug = 'debug'; - cMediaInterfaces = 'showinterfaces'; - - -implementation - -uses SysUtils, - UPlatform; - -{** - * Resets variables and reads info - *} -constructor TCMDParams.Create; -begin - inherited; - - if FindCmdLineSwitch( cHelp ) or FindCmdLineSwitch( 'h' ) then - ShowHelp(); - - ResetVariables; - ReadParamInfo; -end; - -procedure TCMDParams.ShowHelp(); - - function Fmt(aString : string) : string; - begin - Result := Format('%-15s', [aString]); - end; - -begin - writeln; - writeln('**************************************************************'); - writeln(' UltraStar Deluxe - Command line switches '); - writeln('**************************************************************'); - writeln; - writeln(' '+ Fmt('Switch') +' : Purpose'); - writeln(' ----------------------------------------------------------'); - writeln(' '+ Fmt(cMediaInterfaces) +' : Show in-use media interfaces'); - writeln(' '+ Fmt(cDebug) +' : Display Debugging info'); - writeln; - - platform.halt; -end; - -{** - * Reset Class Variables - *} -procedure TCMDParams.ResetVariables; -begin - Debug := False; - Benchmark := False; - NoLog := False; - ScreenMode := scmDefault; - Joypad := False; - - // some value variables set when reading infos {-1: Not Set, others: Value} - fResolution := ''; - fLanguage := ''; - Depth := -1; - Screens := -1; - - // some strings set when reading infos {Length=0 Not Set} - SongPath := PATH_NONE; - ConfigFile := PATH_NONE; - ScoreFile := PATH_NONE; -end; - -{** - * Read command-line parameters - *} -procedure TCMDParams.ReadParamInfo; -var - I: integer; - PCount: integer; - Command: string; -begin - PCount := ParamCount; - //Log.LogError('ParamCount: ' + Inttostr(PCount)); - - // check all parameters - for I := 1 to PCount do - begin - Command := ParamStr(I); - // check if the string is a parameter - if (Length(Command) > 1) and (Command[1] = '-') then - begin - // remove '-' from command - Command := LowerCase(Trim(Copy(Command, 2, Length(Command) - 1))); - //Log.LogError('Command prepared: ' + Command); - - // check command - - // boolean triggers - if (Command = 'debug') then - Debug := True - else if (Command = 'benchmark') then - Benchmark := True - else if (Command = 'nolog') then - NoLog := True - else if (Command = 'fullscreen') then - ScreenMode := scmFullscreen - else if (Command = 'window') then - ScreenMode := scmWindowed - else if (Command = 'joypad') then - Joypad := True - - // integer variables - else if (Command = 'depth') then - begin - // check if there is another Parameter to get the Value from - if (PCount > I) then - begin - Command := ParamStr(I + 1); - - // check for valid value - // FIXME: guessing an array-index of depth is very error prone. - If (Command = '16') then - Depth := 0 - Else If (Command = '32') then - Depth := 1; - end; - end - - else if (Command = 'screens') then - begin - // check if there is another parameter to get the value from - if (PCount > I) then - begin - Command := ParamStr(I + 1); - - // check for valid value - If (Command = '1') then - Screens := 0 - Else If (Command = '2') then - Screens := 1; - end; - end - - // pseudo integer values - else if (Command = 'language') then - begin - // check if there is another parameter to get the value from - if (PCount > I) then - begin - // write value to string - fLanguage := Lowercase(ParamStr(I + 1)); - end; - end - - else if (Command = 'resolution') then - begin - // check if there is another parameter to get the value from - if (PCount > I) then - begin - // write value to string - fResolution := Lowercase(ParamStr(I + 1)); - end; - end - - // string values - else if (Command = 'songpath') then - begin - // check if there is another parameter to get the value from - if (PCount > I) then - begin - // write value to string - SongPath := Path(ParamStr(I + 1)); - end; - end - - else if (Command = 'configfile') then - begin - // check if there is another parameter to get the value from - if (PCount > I) then - begin - // write value to string - ConfigFile := Path(ParamStr(I + 1)); - - // is this a relative path -> then add gamepath - if (not ConfigFile.IsAbsolute) then - ConfigFile := Platform.GetExecutionDir().Append(ConfigFile); - end; - end - - else if (Command = 'scorefile') then - begin - // check if there is another parameter to get the value from - if (PCount > I) then - begin - // write value to string - ScoreFile := Path(ParamStr(I + 1)); - end; - end; - - end; - - end; - -{ - Log.LogInfo('Screens: ' + Inttostr(Screens)); - Log.LogInfo('Depth: ' + Inttostr(Depth)); - - Log.LogInfo('Resolution: ' + Inttostr(Resolution)); - Log.LogInfo('Resolution: ' + Inttostr(Language)); - - Log.LogInfo('sResolution: ' + sResolution); - Log.LogInfo('sLanguage: ' + sLanguage); - - Log.LogInfo('ConfigFile: ' + ConfigFile); - Log.LogInfo('SongPath: ' + SongPath); - Log.LogInfo('ScoreFile: ' + ScoreFile); -} - -end; - -//------------- -// GetLanguage - Get Language ID from saved String Information -//------------- -function TCMDParams.GetLanguage: integer; -{var - I: integer; -} -begin - Result := -1; -{* JB - 12sep07 to remove uINI dependency - - //Search for Language - For I := 0 to high(ILanguage) do - if (LowerCase(ILanguage[I]) = sLanguage) then - begin - Result := I; - Break; - end; -*} -end; - -//------------- -// GetResolution - Get Resolution ID from saved String Information -//------------- -function TCMDParams.GetResolution: integer; -{var - I: integer; -} -begin - Result := -1; -{* JB - 12sep07 to remove uINI dependency - - //Search for Resolution - For I := 0 to high(IResolution) do - if (LowerCase(IResolution[I]) = sResolution) then - begin - Result := I; - Break; - end; -*} -end; - -end. diff --git a/src/base/UCommon.pas b/src/base/UCommon.pas deleted file mode 100644 index fa0faf3c..00000000 --- a/src/base/UCommon.pas +++ /dev/null @@ -1,584 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UCommon; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF} - UConfig, - ULog, - UPath; - -type - TStringDynArray = array of string; - -const - SepWhitespace = [#9, #10, #13, ' ']; // tab, lf, cr, space - -{** - * Splits a string into pieces separated by Separators. - * MaxCount specifies the max. number of pieces. If it is <= 0 the number is - * not limited. If > 0 the last array element will hold the rest of the string - * (with leading separators removed). - * - * Examples: - * SplitString(' split me now ', 0) -> ['split', 'me', 'now'] - * SplitString(' split me now ', 1) -> ['split', 'me now'] - *} -function SplitString(const Str: string; MaxCount: integer = 0; Separators: TSysCharSet = SepWhitespace): TStringDynArray; - - -type - TMessageType = (mtInfo, mtError); - -procedure ShowMessage(const msg: string; msgType: TMessageType = mtInfo); - -procedure ConsoleWriteLn(const msg: string); - -{$IFDEF FPC} -function RandomRange(aMin: integer; aMax: integer): integer; -{$ENDIF} - -procedure DisableFloatingPointExceptions(); -procedure SetDefaultNumericLocale(); -procedure RestoreNumericLocale(); - -{$IFNDEF MSWINDOWS} -procedure ZeroMemory(Destination: pointer; Length: dword); -function MakeLong(a, b: word): longint; -{$ENDIF} - -// A stable alternative to TList.Sort() (use TList.Sort() if applicable, see below) -procedure MergeSort(List: TList; CompareFunc: TListSortCompare); - -function GetAlignedMem(Size: cardinal; Alignment: integer): pointer; -procedure FreeAlignedMem(P: pointer); - - -implementation - -uses - Math, - {$IFDEF Delphi} - Dialogs, - {$ENDIF} - sdl, - UFilesystem, - UMain, - UUnicodeUtils; - -function SplitString(const Str: string; MaxCount: integer; Separators: TSysCharSet): TStringDynArray; - - {* - * Adds Str[StartPos..Endpos-1] to the result array. - *} - procedure AddSplit(StartPos, EndPos: integer); - begin - SetLength(Result, Length(Result)+1); - Result[High(Result)] := Copy(Str, StartPos, EndPos-StartPos); - end; - -var - I: integer; - Start: integer; - Last: integer; -begin - Start := 0; - SetLength(Result, 0); - - for I := 1 to Length(Str) do - begin - if (Str[I] in Separators) then - begin - // end of component found - if (Start > 0) then - begin - AddSplit(Start, I); - Start := 0; - end; - end - else if (Start = 0) then - begin - // mark beginning of component - Start := I; - // check if this is the last component - if (Length(Result) = MaxCount-1) then - begin - // find last non-separator char - Last := Length(Str); - while (Str[Last] in Separators) do - Dec(Last); - // add component up to last non-separator - AddSplit(Start, Last); - Exit; - end; - end; - end; - - // last component - if (Start > 0) then - AddSplit(Start, Length(Str)+1); -end; - -// data used by the ...Locale() functions -{$IF Defined(Linux) or Defined(FreeBSD)} - -var - PrevNumLocale: string; - -const - LC_NUMERIC = 1; - -function setlocale(category: integer; locale: pchar): pchar; cdecl; external 'c' name 'setlocale'; - -{$IFEND} - -// In Linux and maybe MacOSX some units (like cwstring) call setlocale(LC_ALL, '') -// to set the language/country specific locale (e.g. charset) for this application. -// Unfortunately, LC_NUMERIC is set by this call too. -// It defines the decimal-separator and other country-specific numeric settings. -// This parameter is used by the C string-to-float parsing functions atof() and strtod(). -// After changing LC_NUMERIC some external C-based libs (like projectM) are not -// able to parse strings correctly -// (e.g. in Germany "0.9" is not recognized as a valid number anymore but "0,9" is). -// So we reset the numeric settings to the default ('C'). -// Note: The behaviour of Pascal parsing functions (e.g. strtofloat()) is not -// changed by this because it doesn't use the locale-settings. -// TODO: -// - Check if this is needed in MacOSX (at least the locale is set in cwstring) -// - Find out which libs are concerned by this problem. -// If only projectM is concerned by this problem set and restore the numeric locale -// for each call to projectM instead of changing it globally. -procedure SetDefaultNumericLocale(); -begin - {$IF Defined(LINUX) or Defined(FreeBSD)} - PrevNumLocale := setlocale(LC_NUMERIC, nil); - setlocale(LC_NUMERIC, 'C'); - {$IFEND} -end; - -procedure RestoreNumericLocale(); -begin - {$IF Defined(LINUX) or Defined(FreeBSD)} - setlocale(LC_NUMERIC, PChar(PrevNumLocale)); - {$IFEND} -end; - -(* - * If an invalid floating point operation was performed the Floating-point unit (FPU) - * generates a Floating-point exception (FPE). Dependending on the settings in - * the FPU's control-register (interrupt mask) the FPE is handled by the FPU itself - * (we will call this as "FPE disabled" later on) or is passed to the application - * (FPE enabled). - * If FPEs are enabled a floating-point division by zero (e.g. 10.0 / 0.0) is - * considered an error and an exception is thrown. Otherwise the FPU will handle - * the error and return the result infinity (INF) (10.0 / 0.0 = INF) without - * throwing an error to the application. - * The same applies to a division by INF that either raises an exception - * (FPE enabled) or returns 0.0 (FPE disabled). - * Normally (as with C-programs), Floating-point exceptions (FPE) are DISABLED - * on program startup (at least with Intel CPUs), but for some strange reasons - * they are ENABLED in pascal (both delphi and FPC) by default. - * Many libs operating with floating-point values rely heavily on the C-specific - * behaviour. So using them in delphi is a ticking time-bomb because sooner or - * later they will crash because of an FPE (this problem occurs massively - * in OpenGL-based libs like projectM). In contrast to this no error will occur - * if the lib is linked to a C-program. - * - * Further info on FPUs: - * For x86 and x86_64 CPUs we have to consider two FPU instruction sets. - * The math co-processor i387 (aka 8087 or x87) set introduced with the i386 - * and SSE (Streaming SIMD Extensions) introduced with the Pentium3. - * Both of them have separate control-registers (x87: FPUControlWord, SSE: MXCSR) - * to control FPEs. Either has (among others) 6bits to enable/disable several - * exception types (Invalid,Denormalized,Zero,Overflow,Underflow,Precision). - * Those exception-types must all be masked (=1) to get the default C behaviour. - * The control-registers can be set with the asm-ops FLDCW (x87) and LDMXCSR (SSE). - * Instead of using assembler code, we can use Set8087CW() provided by delphi and - * FPC to set the x87 control-word. FPC also provides SetSSECSR() for SSE's MXCSR. - * Note that both Delphi and FPC enable FPEs (e.g. for div-by-zero) on program - * startup but only FPC enables FPEs (especially div-by-zero) for SSE too. - * So we have to mask FPEs for x87 in Delphi and FPC and for SSE in FPC only. - * FPC and Delphi both provide a SetExceptionMask() for control of the FPE - * mask. SetExceptionMask() sets the masks for x87 in Delphi and for x87 and SSE - * in FPC (seems as if Delphi [2005] is not SSE aware). So SetExceptionMask() - * is what we need and it even is plattform and CPU independent. - * - * Pascal OpenGL headers (like the Delphi standard ones or JEDI-SDL headers) - * already call Set8087CW() to disable FPEs but due to some bugs in the JEDI-SDL - * headers they do not work properly with FPC. I already patched them, so they - * work at least until they are updated the next time. In addition Set8086CW() - * does not suffice to disable FPEs because the SSE FPEs are not disabled by this. - * FPEs with SSE are a big problem with some libs because many linux distributions - * optimize code for SSE or Pentium3 (for example: int(INF) which convert the - * double value "infinity" to an integer might be automatically optimized by - * using SSE's CVTSD2SI instruction). So SSE FPEs must be turned off in any case - * to make USDX portable. - * - * Summary: - * Call this function on initialization to make sure FPEs are turned off. - * It will solve a lot of errors with FPEs in external libs. - *) -procedure DisableFloatingPointExceptions(); -begin - (* - // We will use SetExceptionMask() instead of Set8087CW()/SetSSECSR(). - // Note: Leave these lines for documentation purposes just in case - // SetExceptionMask() does not work anymore (due to bugs in FPC etc.). - {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)} - Set8087CW($133F); - {$IFEND} - {$IF Defined(FPC)} - if (has_sse_support) then - SetSSECSR($1F80); - {$IFEND} - *) - - // disable all of the six FPEs (x87 and SSE) to be compatible with C/C++ and - // other libs which rely on the standard FPU behaviour (no div-by-zero FPE anymore). - SetExceptionMask([exInvalidOp, exDenormalized, exZeroDivide, - exOverflow, exUnderflow, exPrecision]); -end; - -{$IFNDEF MSWINDOWS} -procedure ZeroMemory(Destination: pointer; Length: dword); -begin - FillChar(Destination^, Length, 0); -end; - -function MakeLong(A, B: word): longint; -begin - Result := (LongInt(B) shl 16) + A; -end; - -{$ENDIF} - -{$IFDEF FPC} -function RandomRange(aMin: integer; aMax: integer): integer; -begin - RandomRange := Random(aMax - aMin) + aMin ; -end; -{$ENDIF} - - -{$IFDEF FPC} -var - MessageList: TStringList; - ConsoleHandler: TThreadID; - // Note: TRTLCriticalSection is defined in the units System and Libc, use System one - ConsoleCriticalSection: System.TRTLCriticalSection; - ConsoleEvent: PRTLEvent; - ConsoleQuit: boolean; -{$ENDIF} - -(* - * Write to console if one is available. - * It checks if a console is available before output so it will not - * crash on windows if none is available. - * Do not use this function directly because it is not thread-safe, - * use ConsoleWriteLn() instead. - *) -procedure _ConsoleWriteLn(const aString: string); {$IFDEF HasInline}inline;{$ENDIF} -begin - {$IFDEF MSWINDOWS} - // sanity check to avoid crashes with writeln() - if (IsConsole) then - begin - {$ENDIF} - Writeln(aString); - {$IFDEF MSWINDOWS} - end; - {$ENDIF} -end; - -{$IFDEF FPC} -{* - * The console-handlers main-function. - * TODO: create a quit-event on closing. - *} -function ConsoleHandlerFunc(param: pointer): PtrInt; -var - i: integer; - quit: boolean; -begin - quit := false; - while (not quit) do - begin - // wait for new output or quit-request - RTLeventWaitFor(ConsoleEvent); - - System.EnterCriticalSection(ConsoleCriticalSection); - // output pending messages - for i := 0 to MessageList.Count - 1 do - begin - _ConsoleWriteLn(MessageList[i]); - end; - MessageList.Clear(); - - // use local quit-variable to avoid accessing - // ConsoleQuit outside of the critical section - if (ConsoleQuit) then - quit := true; - - RTLeventResetEvent(ConsoleEvent); - System.LeaveCriticalSection(ConsoleCriticalSection); - end; - result := 0; -end; -{$ENDIF} - -procedure InitConsoleOutput(); -begin - {$IFDEF FPC} - // init thread-safe output - MessageList := TStringList.Create(); - System.InitCriticalSection(ConsoleCriticalSection); - ConsoleEvent := RTLEventCreate(); - ConsoleQuit := false; - // must be a thread managed by FPC. Otherwise (e.g. SDL-thread) - // it will crash when using Writeln. - ConsoleHandler := BeginThread(@ConsoleHandlerFunc); - {$ENDIF} -end; - -procedure FinalizeConsoleOutput(); -begin - {$IFDEF FPC} - // terminate console-handler - System.EnterCriticalSection(ConsoleCriticalSection); - ConsoleQuit := true; - RTLeventSetEvent(ConsoleEvent); - System.LeaveCriticalSection(ConsoleCriticalSection); - WaitForThreadTerminate(ConsoleHandler, 0); - // free data - System.DoneCriticalsection(ConsoleCriticalSection); - RTLeventDestroy(ConsoleEvent); - MessageList.Free(); - {$ENDIF} -end; - -{* - * FPC uses threadvars (TLS) managed by FPC for console output locking. - * Using WriteLn() from external threads (like in SDL callbacks) - * will crash the program as those threadvars have never been initialized. - * The solution is to create an FPC-managed thread which has the TLS data - * and use it to handle the console-output (hence it is called Console-Handler) - *} -procedure ConsoleWriteLn(const msg: string); -begin -{$IFDEF CONSOLE} - {$IFDEF FPC} - // TODO: check for the main-thread and use a simple _ConsoleWriteLn() then? - //GetCurrentThreadThreadId(); - System.EnterCriticalSection(ConsoleCriticalSection); - MessageList.Add(msg); - RTLeventSetEvent(ConsoleEvent); - System.LeaveCriticalSection(ConsoleCriticalSection); - {$ELSE} - _ConsoleWriteLn(msg); - {$ENDIF} -{$ENDIF} -end; - -procedure ShowMessage(const msg: String; msgType: TMessageType); -{$IFDEF MSWINDOWS} -var Flags: cardinal; -{$ENDIF} -begin -{$IF Defined(MSWINDOWS)} - case msgType of - mtInfo: Flags := MB_ICONINFORMATION or MB_OK; - mtError: Flags := MB_ICONERROR or MB_OK; - else Flags := MB_OK; - end; - MessageBox(0, PChar(msg), PChar(USDXVersionStr()), Flags); -{$ELSE} - ConsoleWriteln(msg); -{$IFEND} -end; - -(* - * Recursive part of the MergeSort algorithm. - * OutList will be either InList or TempList and will be swapped in each - * depth-level of recursion. By doing this it we can directly merge into the - * output-list. If we only had In- and OutList parameters we had to merge into - * InList after the recursive calls and copy the data to the OutList afterwards. - *) -procedure _MergeSort(InList, TempList, OutList: TList; StartPos, BlockSize: integer; - CompareFunc: TListSortCompare); -var - LeftSize, RightSize: integer; // number of elements in left/right block - LeftEnd, RightEnd: integer; // Index after last element in left/right block - MidPos: integer; // index of first element in right block - Pos: integer; // position in output list -begin - LeftSize := BlockSize div 2; - RightSize := BlockSize - LeftSize; - MidPos := StartPos + LeftSize; - - // sort left and right halves of this block by recursive calls of this function - if (LeftSize >= 2) then - _MergeSort(InList, OutList, TempList, StartPos, LeftSize, CompareFunc) - else - TempList[StartPos] := InList[StartPos]; - if (RightSize >= 2) then - _MergeSort(InList, OutList, TempList, MidPos, RightSize, CompareFunc) - else - TempList[MidPos] := InList[MidPos]; - - // merge sorted left and right sub-lists into output-list - LeftEnd := MidPos; - RightEnd := StartPos + BlockSize; - Pos := StartPos; - while ((StartPos < LeftEnd) and (MidPos < RightEnd)) do - begin - if (CompareFunc(TempList[StartPos], TempList[MidPos]) <= 0) then - begin - OutList[Pos] := TempList[StartPos]; - Inc(StartPos); - end - else - begin - OutList[Pos] := TempList[MidPos]; - Inc(MidPos); - end; - Inc(Pos); - end; - - // copy remaining elements to output-list - while (StartPos < LeftEnd) do - begin - OutList[Pos] := TempList[StartPos]; - Inc(StartPos); - Inc(Pos); - end; - while (MidPos < RightEnd) do - begin - OutList[Pos] := TempList[MidPos]; - Inc(MidPos); - Inc(Pos); - end; -end; - -(* - * Stable alternative to the instable TList.Sort() (uses QuickSort) implementation. - * A stable sorting algorithm preserves preordered items. E.g. if sorting by - * songs by title first and artist afterwards, the songs of each artist will - * be ordered by title. In contrast to this an unstable algorithm (like QuickSort) - * may destroy an existing order, so the songs of an artist will not be ordered - * by title anymore after sorting by artist in the previous example. - * If you do not need a stable algorithm, use TList.Sort() instead. - *) -procedure MergeSort(List: TList; CompareFunc: TListSortCompare); -var - TempList: TList; -begin - TempList := TList.Create(); - TempList.Count := List.Count; - if (List.Count >= 2) then - _MergeSort(List, TempList, List, 0, List.Count, CompareFunc); - TempList.Free; -end; - - -type - // stores the unaligned pointer of data allocated by GetAlignedMem() - PMemAlignHeader = ^TMemAlignHeader; - TMemAlignHeader = pointer; - -(** - * Use this function to assure that allocated memory is aligned on a specific - * byte boundary. - * Alignment must be a power of 2. - * - * Important: Memory allocated with GetAlignedMem() MUST be freed with - * FreeAlignedMem(), FreeMem() will cause a segmentation fault. - * - * Hint: If you do not need dynamic memory, consider to allocate memory - * statically and use the {$ALIGN x} compiler directive. Note that delphi - * supports an alignment "x" of up to 8 bytes only whereas FPC supports - * alignments on 16 and 32 byte boundaries too. - *) -{$WARNINGS OFF} -function GetAlignedMem(Size: cardinal; Alignment: integer): pointer; -var - OrigPtr: pointer; -const - MIN_ALIGNMENT = 16; -begin - // Delphi and FPC (tested with 2.2.0) align memory blocks allocated with - // GetMem() at least on 8 byte boundaries. Delphi uses a minimal alignment - // of either 8 or 16 bytes depending on the size of the requested block - // (see System.GetMinimumBlockAlignment). As we do not want to change the - // boundary for the worse, we align at least on MIN_ALIGN. - if (Alignment < MIN_ALIGNMENT) then - Alignment := MIN_ALIGNMENT; - - // allocate unaligned memory - GetMem(OrigPtr, SizeOf(TMemAlignHeader) + Size + Alignment); - if (OrigPtr = nil) then - begin - Result := nil; - Exit; - end; - - // reserve space for the header - Result := pointer(PtrUInt(OrigPtr) + SizeOf(TMemAlignHeader)); - // align memory - Result := pointer(PtrUInt(Result) + Alignment - PtrUInt(Result) mod Alignment); - - // set header with info on old pointer for FreeMem - PMemAlignHeader(PtrUInt(Result) - SizeOf(TMemAlignHeader))^ := OrigPtr; -end; -{$WARNINGS ON} - -{$WARNINGS OFF} -procedure FreeAlignedMem(P: pointer); -begin - if (P <> nil) then - FreeMem(PMemAlignHeader(PtrUInt(P) - SizeOf(TMemAlignHeader))^); -end; -{$WARNINGS ON} - - -initialization - InitConsoleOutput(); - -finalization - FinalizeConsoleOutput(); - -end. diff --git a/src/base/UConfig.pas b/src/base/UConfig.pas deleted file mode 100644 index f6dc69a5..00000000 --- a/src/base/UConfig.pas +++ /dev/null @@ -1,232 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UConfig; - -// ------------------------------------------------------------------- -// Note on version comparison (for developers only): -// ------------------------------------------------------------------- -// Delphi (in contrast to FPC) DOESN'T support MACROS. So we -// can't define a macro like VERSION_MAJOR(version) to extract -// parts of the version-number or to create version numbers for -// comparison purposes as with a MAKE_VERSION(maj, min, rev) macro. -// So we have to define constants for every part of the version here. -// -// In addition FPC (in contrast to delphi) DOES NOT support floating- -// point numbers in $IF compiler-directives (e.g. {$IF VERSION > 1.23}) -// It also DOESN'T support arithmetic operations so we aren't able to -// compare versions this way (brackets aren't supported too): -// {$IF VERSION > ((VER_MAJ*2)+(VER_MIN*23)+(VER_REL*1))} -// -// Hence we have to use fixed numbers in the directives. At least -// Pascal allows leading 0s so 0005 equals 5 (octals are -// preceded by & and not by 0 in FPC). -// We also fix the count of digits for each part of the version number -// to 3 (aaaiiirrr with aaa=major, iii=minor, rrr=release version) -// -// A check for a library with at least a version of 2.5.11 would look -// like this: -// {$IF LIB_VERSION >= 002005011} -// -// If you just need to check the major version do this: -// {$IF LIB_VERSION_MAJOR >= 23} -// -// IMPORTANT: -// Because this unit must be included in a uses-section it is -// not possible to use the version-numbers in this uses-clause. -// Example: -// interface -// uses -// versions, // include this file -// {$IF USE_UNIT_XYZ}xyz;{$IFEND} // Error: USE_UNIT_XYZ not defined -// const -// {$IF USE_UNIT_XYZ}test = 2;{$IFEND} // OK -// uses -// {$IF USE_UNIT_XYZ}xyz;{$IFEND} // OK -// -// Even if this file was an include-file no constants could be declared -// before the interface's uses clause. -// In FPC macros {$DEFINE VER:= 3} could be used to declare the version-numbers -// but this is incompatible to Delphi. In addition macros do not allow expand -// arithmetic expressions. Although you can define -// {$DEFINE FPC_VER:= FPC_VERSION*1000000+FPC_RELEASE*1000+FPC_PATCH} -// the following check would fail: -// {$IF FPC_VERSION_INT >= 002002000} -// would fail because FPC_VERSION_INT is interpreted as a string. -// -// PLEASE consider this if you use version numbers in $IF compiler- -// directives. Otherwise you might break portability. -// ------------------------------------------------------------------- - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$MACRO ON} // for evaluation of FPC_VERSION/RELEASE/PATCH -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils; - -const - // IMPORTANT: - // If IncludeConstants is defined, the const-sections - // of the config-file will be included too. - // This switch is necessary because it is not possible to - // include the const-sections in the switches.inc. - // switches.inc is always included before the first uses- - // section but at that place no const-section is allowed. - // So we have to include the config-file in switches.inc - // with IncludeConstants undefined and in UConfig.pas with - // IncludeConstants defined (see the note above). - {$DEFINE IncludeConstants} - - // include config-file (defines + constants) - {$IF Defined(MSWindows)} - {$I ..\config-win.inc} - {$ELSEIF Defined(Linux)} - {$I ../config-linux.inc} - {$ELSEIF Defined(FreeBSD)} - {$I ../config-freebsd.inc} - {$ELSEIF Defined(Darwin)} - {$I ../config-darwin.inc} - {$ELSE} - {$MESSAGE Fatal 'Unknown OS'} - {$IFEND} - -{* Libraries *} - - VERSION_MAJOR = 1000000; - VERSION_MINOR = 1000; - VERSION_RELEASE = 1; - - (* - * Current version of UltraStar Deluxe - *) - USDX_VERSION_MAJOR = 1; - USDX_VERSION_MINOR = 1; - USDX_VERSION_RELEASE = 0; - USDX_VERSION_STATE = 'Alpha'; - USDX_STRING = 'UltraStar Deluxe'; - - (* - * FPC version numbers are already defined as built-in macros: - * FPC_VERSION (MAJOR) - * FPC_RELEASE (MINOR) - * FPC_PATCH (RELEASE) - * Since FPC_VERSION is already defined, we will use FPC_VERSION_INT as - * composed version number. - *) - {$IFNDEF FPC} - // Delphi 7 evaluates every $IF-directive even if it is disabled by a surrounding - // $IF or $IFDEF so the follwing will give you an error in delphi: - // {$IFDEF FPC}{$IF (FPC_VERSION > 2)}...{$IFEND}{$ENDIF} - // The reason for this error is that FPC_VERSION is not a valid constant. - // To avoid this error, we define dummys here. - FPC_VERSION = 0; - FPC_RELEASE = 0; - FPC_PATCH = 0; - {$ENDIF} - - FPC_VERSION_INT = (FPC_VERSION * VERSION_MAJOR) + - (FPC_RELEASE * VERSION_MINOR) + - (FPC_PATCH * VERSION_RELEASE); - - // FPC 2.2.0 unicode support is very buggy. The cwstring unit for example - // always crashes whenever UTF8ToAnsi() is called on a non UTF8 encoded string - // what is fixed in 2.2.2. - {$IF Defined(FPC) and (FPC_VERSION_INT < 2002002)} // < 2.2.2 - {$MESSAGE FATAL 'FPC >= 2.2.2 required!'} - {$IFEND} - - {$IFDEF HaveFFmpeg} - - LIBAVCODEC_VERSION = (LIBAVCODEC_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVCODEC_VERSION_MINOR * VERSION_MINOR) + - (LIBAVCODEC_VERSION_RELEASE * VERSION_RELEASE); - - LIBAVFORMAT_VERSION = (LIBAVFORMAT_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVFORMAT_VERSION_MINOR * VERSION_MINOR) + - (LIBAVFORMAT_VERSION_RELEASE * VERSION_RELEASE); - - LIBAVUTIL_VERSION = (LIBAVUTIL_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVUTIL_VERSION_MINOR * VERSION_MINOR) + - (LIBAVUTIL_VERSION_RELEASE * VERSION_RELEASE); - - {$IFDEF HaveSWScale} - LIBSWSCALE_VERSION = (LIBSWSCALE_VERSION_MAJOR * VERSION_MAJOR) + - (LIBSWSCALE_VERSION_MINOR * VERSION_MINOR) + - (LIBSWSCALE_VERSION_RELEASE * VERSION_RELEASE); - {$ENDIF} - - {$ENDIF} - - {$IFDEF HaveProjectM} - PROJECTM_VERSION = (PROJECTM_VERSION_MAJOR * VERSION_MAJOR) + - (PROJECTM_VERSION_MINOR * VERSION_MINOR) + - (PROJECTM_VERSION_RELEASE * VERSION_RELEASE); - {$ENDIF} - - {$IFDEF HavePortaudio} - PORTAUDIO_VERSION = (PORTAUDIO_VERSION_MAJOR * VERSION_MAJOR) + - (PORTAUDIO_VERSION_MINOR * VERSION_MINOR) + - (PORTAUDIO_VERSION_RELEASE * VERSION_RELEASE); - {$ENDIF} - - {$IFDEF HaveLibsamplerate} - LIBSAMPLERATE_VERSION = (LIBSAMPLERATE_VERSION_MAJOR * VERSION_MAJOR) + - (LIBSAMPLERATE_VERSION_MINOR * VERSION_MINOR) + - (LIBSAMPLERATE_VERSION_RELEASE * VERSION_RELEASE); - {$ENDIF} - -function USDXVersionStr(): string; -function USDXShortVersionStr(): string; - -implementation - -uses - StrUtils, Math; - -function USDXShortVersionStr(): string; -begin - Result := - USDX_STRING + - IfThen(USDX_VERSION_STATE <> '', ' '+USDX_VERSION_STATE); -end; - -function USDXVersionStr(): string; -begin - Result := - USDX_STRING + ' V ' + - IntToStr(USDX_VERSION_MAJOR) + '.' + - IntToStr(USDX_VERSION_MINOR) + '.' + - IntToStr(USDX_VERSION_RELEASE) + - IfThen(USDX_VERSION_STATE <> '', ' '+USDX_VERSION_STATE) + - ' Build'; -end; - -end. diff --git a/src/base/UCovers.pas b/src/base/UCovers.pas deleted file mode 100644 index 6c7c9e48..00000000 --- a/src/base/UCovers.pas +++ /dev/null @@ -1,459 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UCovers; - -{ - TODO: - - adjust database to new song-loading (e.g. use SongIDs) - - support for deletion of outdated covers - - support for update of changed covers - - use paths relative to the song for removable disks support - (a drive might have a different drive-name the next time it is connected, - so "H:/songs/..." will not match "I:/songs/...") -} - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SQLite3, - SQLiteTable3, - SysUtils, - Classes, - UImage, - UTexture, - UPath; - -type - ECoverDBException = class(Exception) - end; - - TCover = class - private - ID: int64; - Filename: IPath; - public - constructor Create(ID: int64; Filename: IPath); - function GetPreviewTexture(): TTexture; - function GetTexture(): TTexture; - end; - - TThumbnailInfo = record - CoverWidth: integer; // Original width of cover - CoverHeight: integer; // Original height of cover - PixelFormat: TImagePixelFmt; // Pixel-format of thumbnail - end; - - TCoverDatabase = class - private - DB: TSQLiteDatabase; - procedure InitCoverDatabase(); - function CreateThumbnail(const Filename: IPath; var Info: TThumbnailInfo): PSDL_Surface; - function LoadCover(CoverID: int64): TTexture; - procedure DeleteCover(CoverID: int64); - function FindCoverIntern(const Filename: IPath): int64; - procedure Open(); - function GetVersion(): integer; - procedure SetVersion(Version: integer); - public - constructor Create(); - destructor Destroy; override; - function AddCover(const Filename: IPath): TCover; - function FindCover(const Filename: IPath): TCover; - function CoverExists(const Filename: IPath): boolean; - function GetMaxCoverSize(): integer; - procedure SetMaxCoverSize(Size: integer); - end; - - TBlobWrapper = class(TCustomMemoryStream) - function Write(const Buffer; Count: Integer): Integer; override; - end; - -var - Covers: TCoverDatabase; - -implementation - -uses - UMain, - ULog, - UPlatform, - UIni, - Math, - DateUtils; - -const - COVERDB_FILENAME: UTF8String = 'cover.db'; - COVERDB_VERSION = 01; // 0.1 - COVER_TBL = 'Cover'; - COVER_THUMBNAIL_TBL = 'CoverThumbnail'; - COVER_IDX = 'Cover_Filename_IDX'; - -// Note: DateUtils.DateTimeToUnix() will throw an exception in FPC -function DateTimeToUnixTime(time: TDateTime): int64; -begin - Result := Round((time - UnixDateDelta) * SecsPerDay); -end; - -// Note: DateUtils.UnixToDateTime() will throw an exception in FPC -function UnixTimeToDateTime(timestamp: int64): TDateTime; -begin - Result := timestamp / SecsPerDay + UnixDateDelta; -end; - - -{ TBlobWrapper } - -function TBlobWrapper.Write(const Buffer; Count: Integer): Integer; -begin - SetPointer(Pointer(Buffer), Count); - Result := Count; -end; - - -{ TCover } - -constructor TCover.Create(ID: int64; Filename: IPath); -begin - Self.ID := ID; - Self.Filename := Filename; -end; - -function TCover.GetPreviewTexture(): TTexture; -begin - Result := Covers.LoadCover(ID); -end; - -function TCover.GetTexture(): TTexture; -begin - Result := Texture.LoadTexture(Filename); -end; - - -{ TCoverDatabase } - -constructor TCoverDatabase.Create(); -begin - inherited; - - Open(); - InitCoverDatabase(); -end; - -destructor TCoverDatabase.Destroy; -begin - DB.Free; - inherited; -end; - -function TCoverDatabase.GetVersion(): integer; -begin - Result := DB.GetTableValue('PRAGMA user_version'); -end; - -procedure TCoverDatabase.SetVersion(Version: integer); -begin - DB.ExecSQL(Format('PRAGMA user_version = %d', [Version])); -end; - -function TCoverDatabase.GetMaxCoverSize(): integer; -begin - Result := ITextureSizeVals[Ini.TextureSize]; -end; - -procedure TCoverDatabase.SetMaxCoverSize(Size: integer); -var - I: integer; -begin - // search for first valid cover-size > Size - for I := 0 to Length(ITextureSizeVals)-1 do - begin - if (Size <= ITextureSizeVals[I]) then - begin - Ini.TextureSize := I; - Exit; - end; - end; - - // fall-back to highest size - Ini.TextureSize := High(ITextureSizeVals); -end; - -procedure TCoverDatabase.Open(); -var - Version: integer; - Filename: IPath; -begin - Filename := Platform.GetGameUserPath().Append(COVERDB_FILENAME); - - DB := TSQLiteDatabase.Create(Filename.ToUTF8()); - Version := GetVersion(); - - // check version, if version is too old/new, delete database file - if ((Version <> 0) and (Version <> COVERDB_VERSION)) then - begin - Log.LogInfo('Outdated cover-database file found', 'TCoverDatabase.Open'); - // close and delete outdated file - DB.Free; - if (not Filename.DeleteFile()) then - raise ECoverDBException.Create('Could not delete ' + Filename.ToNative); - // reopen - DB := TSQLiteDatabase.Create(Filename.ToUTF8()); - Version := 0; - end; - - // set version number after creation - if (Version = 0) then - SetVersion(COVERDB_VERSION); - - // speed-up disk-writing. The default FULL-synchronous mode is too slow. - // With this option disk-writing is approx. 4 times faster but the database - // might be corrupted if the OS crashes, although this is very unlikely. - DB.ExecSQL('PRAGMA synchronous = OFF;'); - - // the next line rather gives a slow-down instead of a speed-up, so we do not use it - //DB.ExecSQL('PRAGMA temp_store = MEMORY;'); -end; - -procedure TCoverDatabase.InitCoverDatabase(); -begin - DB.ExecSQL('CREATE TABLE IF NOT EXISTS ['+COVER_TBL+'] (' + - '[ID] INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, ' + - '[Filename] TEXT UNIQUE NOT NULL, ' + - '[Date] INTEGER NOT NULL, ' + - '[Width] INTEGER NOT NULL, ' + - '[Height] INTEGER NOT NULL ' + - ')'); - - DB.ExecSQL('CREATE INDEX IF NOT EXISTS ['+COVER_IDX+'] ON ['+COVER_TBL+'](' + - '[Filename] ASC' + - ')'); - - DB.ExecSQL('CREATE TABLE IF NOT EXISTS ['+COVER_THUMBNAIL_TBL+'] (' + - '[ID] INTEGER NOT NULL PRIMARY KEY, ' + - '[Format] INTEGER NOT NULL, ' + - '[Width] INTEGER NOT NULL, ' + - '[Height] INTEGER NOT NULL, ' + - '[Data] BLOB NULL' + - ')'); -end; - -function TCoverDatabase.FindCoverIntern(const Filename: IPath): int64; -begin - Result := DB.GetTableValue('SELECT [ID] FROM ['+COVER_TBL+'] ' + - 'WHERE [Filename] = ?', - [Filename.ToUTF8]); -end; - -function TCoverDatabase.FindCover(const Filename: IPath): TCover; -var - CoverID: int64; -begin - Result := nil; - try - CoverID := FindCoverIntern(Filename); - if (CoverID > 0) then - Result := TCover.Create(CoverID, Filename); - except on E: Exception do - Log.LogError(E.Message, 'TCoverDatabase.FindCover'); - end; -end; - -function TCoverDatabase.CoverExists(const Filename: IPath): boolean; -begin - Result := false; - try - Result := (FindCoverIntern(Filename) > 0); - except on E: Exception do - Log.LogError(E.Message, 'TCoverDatabase.CoverExists'); - end; -end; - -function TCoverDatabase.AddCover(const Filename: IPath): TCover; -var - CoverID: int64; - Thumbnail: PSDL_Surface; - CoverData: TBlobWrapper; - FileDate: TDateTime; - Info: TThumbnailInfo; -begin - Result := nil; - - //if (not FileExists(Filename)) then - // Exit; - - // TODO: replace '\' with '/' in filename - FileDate := Now(); //FileDateToDateTime(FileAge(Filename)); - - Thumbnail := CreateThumbnail(Filename, Info); - if (Thumbnail = nil) then - Exit; - - CoverData := TBlobWrapper.Create; - CoverData.Write(Thumbnail^.pixels, Thumbnail^.h * Thumbnail^.pitch); - - try - // Note: use a transaction to speed-up file-writing. - // Without data written by the first INSERT might be moved at the second INSERT. - DB.BeginTransaction(); - - // add general cover info - DB.ExecSQL('INSERT INTO ['+COVER_TBL+'] ' + - '([Filename], [Date], [Width], [Height]) VALUES' + - '(?, ?, ?, ?)', - [Filename.ToUTF8, DateTimeToUnixTime(FileDate), - Info.CoverWidth, Info.CoverHeight]); - - // get auto-generated cover ID - CoverID := DB.GetLastInsertRowID(); - - // add thumbnail info - DB.ExecSQL('INSERT INTO ['+COVER_THUMBNAIL_TBL+'] ' + - '([ID], [Format], [Width], [Height], [Data]) VALUES' + - '(?, ?, ?, ?, ?)', - [CoverID, Ord(Info.PixelFormat), - Thumbnail^.w, Thumbnail^.h, CoverData]); - - Result := TCover.Create(CoverID, Filename); - except on E: Exception do - Log.LogError(E.Message, 'TCoverDatabase.AddCover'); - end; - - DB.Commit(); - CoverData.Free; - SDL_FreeSurface(Thumbnail); -end; - -function TCoverDatabase.LoadCover(CoverID: int64): TTexture; -var - Width, Height: integer; - PixelFmt: TImagePixelFmt; - Data: PChar; - DataSize: integer; - Filename: IPath; - Table: TSQLiteUniTable; -begin - Table := nil; - - try - Table := DB.GetUniTable(Format( - 'SELECT C.[Filename], T.[Format], T.[Width], T.[Height], T.[Data] ' + - 'FROM ['+COVER_TBL+'] C ' + - 'INNER JOIN ['+COVER_THUMBNAIL_TBL+'] T ' + - 'USING(ID) ' + - 'WHERE [ID] = %d', [CoverID])); - - Filename := Path(Table.FieldAsString(0)); - PixelFmt := TImagePixelFmt(Table.FieldAsInteger(1)); - Width := Table.FieldAsInteger(2); - Height := Table.FieldAsInteger(3); - - Data := Table.FieldAsBlobPtr(4, DataSize); - if (Data <> nil) and - (PixelFmt = ipfRGB) then - begin - Result := Texture.CreateTexture(Data, Filename, Width, Height, 24) - end - else - begin - // FillChar() does not decrement the ref-count of ref-counted fields - // -> reset Name field manually - Result.Name := nil; - FillChar(Result, SizeOf(TTexture), 0); - end; - except on E: Exception do - Log.LogError(E.Message, 'TCoverDatabase.LoadCover'); - end; - - Table.Free; -end; - -procedure TCoverDatabase.DeleteCover(CoverID: int64); -begin - DB.ExecSQL(Format('DELETE FROM ['+COVER_TBL+'] WHERE [ID] = %d', [CoverID])); - DB.ExecSQL(Format('DELETE FROM ['+COVER_THUMBNAIL_TBL+'] WHERE [ID] = %d', [CoverID])); -end; - -(** - * Returns a pointer to an array of bytes containing the texture data in the - * requested size - *) -function TCoverDatabase.CreateThumbnail(const Filename: IPath; var Info: TThumbnailInfo): PSDL_Surface; -var - //TargetAspect, SourceAspect: double; - //TargetWidth, TargetHeight: integer; - Thumbnail: PSDL_Surface; - MaxSize: integer; -begin - Result := nil; - - MaxSize := GetMaxCoverSize(); - - Thumbnail := LoadImage(Filename); - if (not assigned(Thumbnail)) then - begin - Log.LogError('Could not load cover: "'+ Filename.ToNative +'"', 'TCoverDatabase.AddCover'); - Exit; - end; - - // Convert pixel format as needed - AdjustPixelFormat(Thumbnail, TEXTURE_TYPE_PLAIN); - - Info.CoverWidth := Thumbnail^.w; - Info.CoverHeight := Thumbnail^.h; - Info.PixelFormat := ipfRGB; - - (* TODO: keep aspect ratio - TargetAspect := Width / Height; - SourceAspect := TexSurface.w / TexSurface.h; - - // Scale texture to covers dimensions (keep aspect) - if (SourceAspect >= TargetAspect) then - begin - TargetWidth := Width; - TargetHeight := Trunc(Width / SourceAspect); - end - else - begin - TargetHeight := Height; - TargetWidth := Trunc(Height * SourceAspect); - end; - *) - - // TODO: do not scale if image is smaller - ScaleImage(Thumbnail, MaxSize, MaxSize); - - Result := Thumbnail; -end; - -end. - diff --git a/src/base/UDLLManager.pas b/src/base/UDLLManager.pas deleted file mode 100644 index d5bb1480..00000000 --- a/src/base/UDLLManager.pas +++ /dev/null @@ -1,293 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UDLLManager; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - ModiSDK, - UFiles, - UPath, - UFilesystem; - -type - TDLLMan = class - private - hLib: THandle; - P_Init: fModi_Init; - P_Draw: fModi_Draw; - P_Finish: fModi_Finish; - P_RData: pModi_RData; - public - Plugins: array of TPluginInfo; - PluginPaths: array of IPath; - Selected: ^TPluginInfo; - - constructor Create; - - procedure GetPluginList; - procedure ClearPluginInfo(No: cardinal); - function LoadPluginInfo(const Filename: IPath; No: cardinal): boolean; - - function LoadPlugin(No: cardinal): boolean; - procedure UnLoadPlugin; - - function PluginInit (const TeamInfo: TTeamInfo; - var Playerinfo: TPlayerinfo; - const Sentences: TSentences; - const LoadTex: fModi_LoadTex; - const Print: fModi_Print; - LoadSound: fModi_LoadSound; - PlaySound: pModi_PlaySound) - : boolean; - function PluginDraw (var Playerinfo: TPlayerinfo; const CurSentence: cardinal): boolean; - function PluginFinish (var Playerinfo: TPlayerinfo): byte; - procedure PluginRData (handle: HSTREAM; buffer: Pointer; len: dword; user: dword); - end; - -var - DLLMan: TDLLMan; - -const -{$IF Defined(MSWINDOWS)} - DLLExt = '.dll'; -{$ELSEIF Defined(DARWIN)} - DLLExt = '.dylib'; -{$ELSEIF Defined(UNIX)} - DLLExt = '.so'; -{$IFEND} - -implementation - -uses - {$IFDEF MSWINDOWS} - windows, - {$ELSE} - dynlibs, - {$ENDIF} - UPathUtils, - ULog, - SysUtils; - - -constructor TDLLMan.Create; -begin - inherited; - SetLength(Plugins, 0); - SetLength(PluginPaths, Length(Plugins)); - GetPluginList; -end; - -procedure TDLLMan.GetPluginList; -var - Iter: IFileIterator; - FileInfo: TFileInfo; -begin - Iter := FileSystem.FileFind(PluginPath.Append('*' + DLLExt), 0); - while (Iter.HasNext) do - begin - SetLength(Plugins, Length(Plugins)+1); - SetLength(PluginPaths, Length(Plugins)); - - FileInfo := Iter.Next; - - if LoadPluginInfo(FileInfo.Name, High(Plugins)) then // loaded succesful - begin - PluginPaths[High(PluginPaths)] := FileInfo.Name; - end - else // error loading - begin - SetLength(Plugins, Length(Plugins)-1); - SetLength(PluginPaths, Length(Plugins)); - end; - end; -end; - -procedure TDLLMan.ClearPluginInfo(No: cardinal); -begin -// set to party modi plugin - Plugins[No].Typ := 8; - - Plugins[No].Name := 'unknown'; - Plugins[No].NumPlayers := 0; - - Plugins[No].Creator := 'Nobody'; - Plugins[No].PluginDesc := 'NO_PLUGIN_DESC'; - - Plugins[No].LoadSong := true; - Plugins[No].ShowScore := true; - Plugins[No].ShowBars := true; - Plugins[No].ShowNotes := true; - Plugins[No].LoadVideo := true; - Plugins[No].LoadBack := true; - - Plugins[No].TeamModeOnly := true; - Plugins[No].GetSoundData := true; - Plugins[No].Dummy := true; - - - Plugins[No].BGShowFull := true; - Plugins[No].BGShowFull_O := true; - - Plugins[No].ShowRateBar := true; - Plugins[No].ShowRateBar_O := true; - - Plugins[No].EnLineBonus := true; - Plugins[No].EnLineBonus_O := true; -end; - -function TDLLMan.LoadPluginInfo(const Filename: IPath; No: cardinal): boolean; -var - hLibg: THandle; - Info: pModi_PluginInfo; -// I: integer; -begin - Result := true; -// clear plugin info - ClearPluginInfo(No); - -{ -// workaround plugins loaded 2 times - for i := low(pluginpaths) to high(pluginpaths) do - if (pluginpaths[i] = filename) then - exit; -} - -// load libary - hLibg := LoadLibrary(PChar(PluginPath.Append(Filename).ToNative)); -// if loaded - if (hLibg <> 0) then - begin -// load info procedure - @Info := GetProcAddress(hLibg, PChar('PluginInfo')); - -// if loaded - if (@Info <> nil) then - begin -// load plugininfo - Info(Plugins[No]); - Result := true; - end - else - Log.LogError('Could not load plugin "' + Filename.ToNative + '": Info procedure not found'); - - FreeLibrary (hLibg); - end - else - Log.LogError('Could not load plugin "' + Filename.ToNative + '": Libary not loaded'); -end; - -function TDLLMan.LoadPlugin(No: cardinal): boolean; -begin - Result := true; -// load libary - hLib := LoadLibrary(PChar(PluginPath.Append(PluginPaths[No]).ToNative)); -// if loaded - if (hLib <> 0) then - begin -// load info procedure - @P_Init := GetProcAddress (hLib, 'Init'); - @P_Draw := GetProcAddress (hLib, 'Draw'); - @P_Finish := GetProcAddress (hLib, 'Finish'); - -// if loaded - if (@P_Init <> nil) and (@P_Draw <> nil) and (@P_Finish <> nil) then - begin - Selected := @Plugins[No]; - Result := true; - end - else - begin - Log.LogError('Could not load plugin "' + PluginPaths[No].ToNative + '": Procedures not found'); - end; - end - else - Log.LogError('Could not load plugin "' + PluginPaths[No].ToNative + '": Libary not loaded'); -end; - -procedure TDLLMan.UnLoadPlugin; -begin - if (hLib <> 0) then - FreeLibrary (hLib); - -// Selected := nil; - @P_Init := nil; - @P_Draw := nil; - @P_Finish := nil; - @P_RData := nil; -end; - -function TDLLMan.PluginInit (const TeamInfo: TTeamInfo; - var Playerinfo: TPlayerinfo; - const Sentences: TSentences; - const LoadTex: fModi_LoadTex; - const Print: fModi_Print; - LoadSound: fModi_LoadSound; - PlaySound: pModi_PlaySound) - : boolean; -var - Methods: TMethodRec; -begin - Methods.LoadTex := LoadTex; - Methods.Print := Print; - Methods.LoadSound := LoadSound; - Methods.PlaySound := PlaySound; - - if (@P_Init <> nil) then - Result := P_Init (TeamInfo, PlayerInfo, Sentences, Methods) - else - Result := true -end; - -function TDLLMan.PluginDraw (var Playerinfo: TPlayerinfo; const CurSentence: cardinal): boolean; -begin - if (@P_Draw <> nil) then - Result := P_Draw (PlayerInfo, CurSentence) - else - Result := true -end; - -function TDLLMan.PluginFinish (var Playerinfo: TPlayerinfo): byte; -begin - if (@P_Finish <> nil) then - Result := P_Finish (PlayerInfo) - else - Result := 0; -end; - -procedure TDLLMan.PluginRData (handle: HStream; buffer: Pointer; len: dword; user: dword); -begin -if (@P_RData <> nil) then - P_RData (handle, buffer, len, user); -end; - -end. diff --git a/src/base/UDataBase.pas b/src/base/UDataBase.pas deleted file mode 100644 index 85b4b8e8..00000000 --- a/src/base/UDataBase.pas +++ /dev/null @@ -1,614 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UDataBase; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - SQLiteTable3, - UPath, - USong, - USongs; - -//-------------------- -//DataBaseSystem - Class including all DB methods -//-------------------- -type - TStatType = ( - stBestScores, // Best scores - stBestSingers, // Best singers - stMostSungSong, // Most sung songs - stMostPopBand // Most popular band - ); - - // abstract super-class for statistic results - TStatResult = class - public - Typ: TStatType; - end; - - TStatResultBestScores = class(TStatResult) - public - Singer: UTF8String; - Score: word; - Difficulty: byte; - SongArtist: UTF8String; - SongTitle: UTF8String; - Date: UTF8String; - end; - - TStatResultBestSingers = class(TStatResult) - public - Player: UTF8String; - AverageScore: word; - end; - - TStatResultMostSungSong = class(TStatResult) - public - Artist: UTF8String; - Title: UTF8String; - TimesSung: word; - end; - - TStatResultMostPopBand = class(TStatResult) - public - ArtistName: UTF8String; - TimesSungTot: word; - end; - - - TDataBaseSystem = class - private - ScoreDB: TSQLiteDatabase; - fFilename: IPath; - - function GetVersion(): integer; - procedure SetVersion(Version: integer); - public - property Filename: IPath read fFilename; - - destructor Destroy; override; - - procedure Init(const Filename: IPath); - procedure ReadScore(Song: TSong); - procedure AddScore(Song: TSong; Level: integer; const Name: UTF8String; Score: integer); - procedure WriteScore(Song: TSong); - - function GetStats(Typ: TStatType; Count: byte; Page: cardinal; Reversed: boolean): TList; - procedure FreeStats(StatList: TList); - function GetTotalEntrys(Typ: TStatType): cardinal; - function GetStatReset: TDateTime; - function FormatDate(time_stamp: integer): UTF8String; - end; - -var - DataBase: TDataBaseSystem; - -implementation - -uses - DateUtils, - ULanguage, - StrUtils, - SysUtils, - ULog; - -{ - cDBVersion - history - 0 = USDX 1.01 or no Database - 01 = USDX 1.1 -} -const - cDBVersion = 01; // 0.1 - cUS_Scores = 'us_scores'; - cUS_Songs = 'us_songs'; - cUS_Statistics_Info = 'us_statistics_info'; - -(** - * Open database and create tables if they do not exist - *) -procedure TDataBaseSystem.Init(const Filename: IPath); -var - Version: integer; - finalizeConversion: boolean; -begin - if Assigned(ScoreDB) then - Exit; - - Log.LogStatus('Initializing database: "' + Filename.ToNative + '"', 'TDataBaseSystem.Init'); - - try - - // open database - ScoreDB := TSQLiteDatabase.Create(Filename.ToUTF8); - fFilename := Filename; - - Version := GetVersion(); - - // add Table cUS_Statistics_Info - // needed in the conversion from 1.01 to 1.1 - if not ScoreDB.TableExists(cUS_Statistics_Info) then - begin - Log.LogInfo('Outdated song database found - missing table"' + cUS_Statistics_Info + '"', 'TDataBaseSystem.Init'); - ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS [' + cUS_Statistics_Info + '] (' + - '[ResetTime] INTEGER' + - ');'); - // insert creation timestamp - ScoreDB.ExecSQL(Format('INSERT INTO [' + cUS_Statistics_Info + '] ' + - '([ResetTime]) VALUES(%d);', - [DateTimeToUnix(Now())])); - end; - - // convert data from 1.01 to 1.1 - // part #1 - prearrangement - finalizeConversion := false; - if (Version = 0) AND ScoreDB.TableExists('US_Scores') then - begin - // rename old tables - to be able to insert new table structures - ScoreDB.ExecSQL('ALTER TABLE US_Scores RENAME TO us_scores_101;'); - ScoreDB.ExecSQL('ALTER TABLE US_Songs RENAME TO us_songs_101;'); - finalizeConversion := true; // means: conversion has to be done! - end; - - // Set version number after creation - if (Version = 0) then - SetVersion(cDBVersion); - - // SQLite does not handle VARCHAR(n) or INT(n) as expected. - // Texts do not have a restricted length, no matter which type is used, - // so use the native TEXT type. INT(n) is always INTEGER. - // In addition, SQLiteTable3 will fail if other types than the native SQLite - // types are used (especially FieldAsInteger). Also take care to write the - // types in upper-case letters although SQLite does not care about this - - // SQLiteTable3 is very sensitive in this regard. - ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS [' + cUS_Scores + '] (' + - '[SongID] INTEGER NOT NULL, ' + - '[Difficulty] INTEGER NOT NULL, ' + - '[Player] TEXT NOT NULL, ' + - '[Score] INTEGER NOT NULL, ' + - '[Date] INTEGER NULL' + - ');'); - - ScoreDB.ExecSQL('CREATE TABLE IF NOT EXISTS [' + cUS_Songs + '] (' + - '[ID] INTEGER PRIMARY KEY, ' + - '[Artist] TEXT NOT NULL, ' + - '[Title] TEXT NOT NULL, ' + - '[TimesPlayed] INTEGER NOT NULL, ' + - '[Rating] INTEGER NULL' + - ');'); - - // convert data from 1.01 to 1.1 - // part #2 - accomplishment - if finalizeConversion then - begin - Log.LogInfo('Outdated song database found - begin conversion from V1.01 to V1.1', 'TDataBaseSystem.Init'); - // insert old values into new db-schemes (/tables) - ScoreDB.ExecSQL('INSERT INTO ' + cUS_Scores + ' SELECT SongID, Difficulty, Player, Score FROM us_scores_101;'); - ScoreDB.ExecSQL('INSERT INTO ' + cUS_Songs + ' SELECT ID, Artist, Title, TimesPlayed, ''NULL'' FROM us_songs_101;'); - //now drop old tables - ScoreDB.ExecSQL('DROP TABLE us_scores_101;'); - ScoreDB.ExecSQL('DROP TABLE us_songs_101;'); - end; - - // add column rating to cUS_Songs - // just for users of nightly builds and developers! - if not ScoreDB.ContainsColumn(cUS_Songs, 'Rating') then - begin - Log.LogInfo('Outdated song database found - adding column rating to "' + cUS_Songs + '"', 'TDataBaseSystem.Init'); - ScoreDB.ExecSQL('ALTER TABLE ' + cUS_Songs + ' ADD COLUMN [Rating] INTEGER NULL'); - end; - - - //add column date to cUS-Scores - if not ScoreDB.ContainsColumn(cUS_Scores, 'Date') then - begin - Log.LogInfo('adding column date to "' + cUS_Scores + '"', 'TDataBaseSystem.Init'); - ScoreDB.ExecSQL('ALTER TABLE ' + cUS_Scores + ' ADD COLUMN [Date] INTEGER NULL'); - end; - - except - on E: Exception do - begin - Log.LogError(E.Message, 'TDataBaseSystem.Init'); - FreeAndNil(ScoreDB); - end; - end; - -end; - -(** - * Frees Database - *) -destructor TDataBaseSystem.Destroy; -begin - Log.LogInfo('TDataBaseSystem.Free', 'TDataBaseSystem.Destroy'); - ScoreDB.Free; - inherited; -end; - -(** - * Format a UNIX-Timestamp into DATE (If 0 then '') - *) -function TDataBaseSystem.FormatDate(time_stamp: integer): UTF8String; -var - Year, Month, Day: word; -begin - Result:=''; - try - if time_stamp<>0 then - begin - DecodeDate(UnixToDateTime(time_stamp), Year, Month, Day); - Result := Format(Language.Translate('STAT_FORMAT_DATE'), [Day, Month, Year]); - end; - except - on E: EConvertError do - Log.LogError('Error Parsing FormatString "STAT_FORMAT_DATE": ' + E.Message); - end; -end; - - -(** - * Read Scores into SongArray - *) -procedure TDataBaseSystem.ReadScore(Song: TSong); -var - TableData: TSQLiteUniTable; - Difficulty: integer; - I: integer; - PlayerListed: boolean; -begin - if not Assigned(ScoreDB) then - Exit; - - TableData := nil; - try - // Search Song in DB - TableData := ScoreDB.GetUniTable( - 'SELECT [Difficulty], [Player], [Score], [Date] FROM [' + cUS_Scores + '] ' + - 'WHERE [SongID] = (' + - 'SELECT [ID] FROM [' + cUS_Songs + '] ' + - 'WHERE [Artist] = ? AND [Title] = ? ' + - 'LIMIT 1) ' + - 'ORDER BY [Score] DESC;', //no LIMIT! see filter below! - [Song.Artist, Song.Title]); - - // Empty Old Scores - SetLength(Song.Score[0], 0); //easy - SetLength(Song.Score[1], 0); //medium - SetLength(Song.Score[2], 0); //hard - - // Go through all Entrys - while (not TableData.EOF) do - begin - // Add one Entry to Array - Difficulty := TableData.FieldAsInteger(TableData.FieldIndex['Difficulty']); - if ((Difficulty >= 0) and (Difficulty <= 2)) and - (Length(Song.Score[Difficulty]) < 5) then - begin - //filter player - PlayerListed:=false; - if (Length(Song.Score[Difficulty])>0) then - begin - for I := 0 to Length(Song.Score[Difficulty]) - 1 do - begin - if (Song.Score[Difficulty, I].Name = TableData.FieldByName['Player']) then - begin - PlayerListed:=true; - break; - end; - end; - end; - - if not PlayerListed then - begin - SetLength(Song.Score[Difficulty], Length(Song.Score[Difficulty]) + 1); - - Song.Score[Difficulty, High(Song.Score[Difficulty])].Name := - TableData.FieldByName['Player']; - Song.Score[Difficulty, High(Song.Score[Difficulty])].Score := - TableData.FieldAsInteger(TableData.FieldIndex['Score']); - Song.Score[Difficulty, High(Song.Score[Difficulty])].Date := - FormatDate(TableData.FieldAsInteger(TableData.FieldIndex['Date'])); - end; - end; - - TableData.Next; - end; // while - - except - for Difficulty := 0 to 2 do - begin - SetLength(Song.Score[Difficulty], 1); - Song.Score[Difficulty, 1].Name := 'Error Reading ScoreDB'; - end; - end; - - TableData.Free; -end; - -(** - * Adds one new score to DB - *) -procedure TDataBaseSystem.AddScore(Song: TSong; Level: integer; const Name: UTF8String; Score: integer); -var - ID: integer; - TableData: TSQLiteTable; -begin - if not Assigned(ScoreDB) then - Exit; - - // Prevent 0 Scores from being added EDIT: ==> UScreenTop5.pas! - //if (Score <= 0) then - // Exit; - - TableData := nil; - - try - - ID := ScoreDB.GetTableValue( - 'SELECT [ID] FROM [' + cUS_Songs + '] ' + - 'WHERE [Artist] = ? AND [Title] = ?', - [Song.Artist, Song.Title]); - if (ID = 0) then - begin - // Create song if it does not exist - ScoreDB.ExecSQL( - 'INSERT INTO [' + cUS_Songs + '] ' + - '([ID], [Artist], [Title], [TimesPlayed]) VALUES ' + - '(NULL, ?, ?, 0);', - [Song.Artist, Song.Title]); - // Get song-ID - ID := ScoreDB.GetLastInsertRowID(); - end; - // Create new entry - ScoreDB.ExecSQL( - 'INSERT INTO [' + cUS_Scores + '] ' + - '([SongID] ,[Difficulty], [Player], [Score], [Date]) VALUES ' + - '(?, ?, ?, ?, ?);', - [ID, Level, Name, Score, DateTimeToUnix(Now())]); - - except on E: Exception do - Log.LogError(E.Message, 'TDataBaseSystem.AddScore'); - end; - - TableData.Free; -end; - -(** - * Not needed with new system. - * Used to increment played count - *) -procedure TDataBaseSystem.WriteScore(Song: TSong); -begin - if not Assigned(ScoreDB) then - Exit; - - try - // Increase TimesPlayed - ScoreDB.ExecSQL( - 'UPDATE [' + cUS_Songs + '] ' + - 'SET [TimesPlayed] = [TimesPlayed] + 1 ' + - 'WHERE [Title] = ? AND [Artist] = ?;', - [Song.Title, Song.Artist]); - except on E: Exception do - Log.LogError(E.Message, 'TDataBaseSystem.WriteScore'); - end; -end; - -(** - * Writes some stats to array. - * Returns nil if the database is not ready or a list with zero or more statistic - * entries. - * Free the result-list with FreeStats() after usage to avoid memory leaks. - *) -function TDataBaseSystem.GetStats(Typ: TStatType; Count: byte; Page: cardinal; Reversed: boolean): TList; -var - Query: string; - TableData: TSQLiteUniTable; - Stat: TStatResult; -begin - Result := nil; - - if not Assigned(ScoreDB) then - Exit; - - {Todo: Add Prevention that only players with more than 5 scores are selected at type 2} - - // Create query - case Typ of - stBestScores: begin - Query := 'SELECT [Player], [Difficulty], [Score], [Artist], [Title], [Date] FROM [' + cUS_Scores + '] ' + - 'INNER JOIN [' + cUS_Songs + '] ON ([SongID] = [ID]) ORDER BY [Score]'; - end; - stBestSingers: begin - Query := 'SELECT [Player], ROUND(AVG([Score])) FROM [' + cUS_Scores + '] ' + - 'GROUP BY [Player] ORDER BY AVG([Score])'; - end; - stMostSungSong: begin - Query := 'SELECT [Artist], [Title], [TimesPlayed] FROM [' + cUS_Songs + '] ' + - 'ORDER BY [TimesPlayed]'; - end; - stMostPopBand: begin - Query := 'SELECT [Artist], SUM([TimesPlayed]) FROM [' + cUS_Songs + '] ' + - 'GROUP BY [Artist] ORDER BY SUM([TimesPlayed])'; - end; - end; - - // Add order direction - Query := Query + IfThen(Reversed, ' ASC', ' DESC'); - - // Add limit - Query := Query + ' LIMIT ' + InttoStr(Count * Page) + ', ' + InttoStr(Count) + ';'; - - // Execute query - try - TableData := ScoreDB.GetUniTable(Query); - except - on E: Exception do - begin - Log.LogError(E.Message, 'TDataBaseSystem.GetStats'); - Exit; - end; - end; - - Result := TList.Create; - Stat := nil; - - // Copy result to stats array - while not TableData.EOF do - begin - case Typ of - stBestScores: begin - Stat := TStatResultBestScores.Create; - with TStatResultBestScores(Stat) do - begin - Singer := TableData.Fields[0]; - Difficulty := TableData.FieldAsInteger(1); - Score := TableData.FieldAsInteger(2); - SongArtist := TableData.Fields[3]; - SongTitle := TableData.Fields[4]; - Date := FormatDate(TableData.FieldAsInteger(5)); - end; - end; - stBestSingers: begin - Stat := TStatResultBestSingers.Create; - with TStatResultBestSingers(Stat) do - begin - Player := TableData.Fields[0]; - AverageScore := TableData.FieldAsInteger(1); - end; - end; - stMostSungSong: begin - Stat := TStatResultMostSungSong.Create; - with TStatResultMostSungSong(Stat) do - begin - Artist := TableData.Fields[0]; - Title := TableData.Fields[1]; - TimesSung := TableData.FieldAsInteger(2); - end; - end; - stMostPopBand: begin - Stat := TStatResultMostPopBand.Create; - with TStatResultMostPopBand(Stat) do - begin - ArtistName := TableData.Fields[0]; - TimesSungTot := TableData.FieldAsInteger(1); - end; - end - else - Log.LogCritical('Unknown stat-type', 'TDataBaseSystem.GetStats'); - end; - - Stat.Typ := Typ; - Result.Add(Stat); - - TableData.Next; - end; - - TableData.Free; -end; - -procedure TDataBaseSystem.FreeStats(StatList: TList); -var - Index: integer; -begin - if (StatList = nil) then - Exit; - for Index := 0 to StatList.Count-1 do - TStatResult(StatList[Index]).Free; - StatList.Free; -end; - -(** - * Gets total number of entrys for a stats query - *) -function TDataBaseSystem.GetTotalEntrys(Typ: TStatType): cardinal; -var - Query: string; -begin - Result := 0; - - if not Assigned(ScoreDB) then - Exit; - - try - // Create query - case Typ of - stBestScores: - Query := 'SELECT COUNT([SongID]) FROM [' + cUS_Scores + '];'; - stBestSingers: - Query := 'SELECT COUNT(DISTINCT [Player]) FROM [' + cUS_Scores + '];'; - stMostSungSong: - Query := 'SELECT COUNT([ID]) FROM [' + cUS_Songs + '];'; - stMostPopBand: - Query := 'SELECT COUNT(DISTINCT [Artist]) FROM [' + cUS_Songs + '];'; - end; - - Result := ScoreDB.GetTableValue(Query); - except on E: Exception do - Log.LogError(E.Message, 'TDataBaseSystem.GetTotalEntrys'); - end; - -end; - -(** - * Gets reset date of statistic data - *) -function TDataBaseSystem.GetStatReset: TDateTime; -var - Query: string; -begin - Result := 0; - - if not Assigned(ScoreDB) then - Exit; - - try - Query := 'SELECT [ResetTime] FROM [' + cUS_Statistics_Info + '];'; - Result := UnixToDateTime(ScoreDB.GetTableValue(Query)); - except on E: Exception do - Log.LogError(E.Message, 'TDataBaseSystem.GetStatReset'); - end; -end; - -function TDataBaseSystem.GetVersion(): integer; -begin - Result := ScoreDB.GetTableValue('PRAGMA user_version'); -end; - -procedure TDataBaseSystem.SetVersion(Version: integer); -begin - ScoreDB.ExecSQL(Format('PRAGMA user_version = %d', [Version])); -end; - -end. diff --git a/src/base/UDraw.pas b/src/base/UDraw.pas deleted file mode 100644 index 1783986f..00000000 --- a/src/base/UDraw.pas +++ /dev/null @@ -1,1408 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UDraw; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UThemes, - ModiSDK, - UGraphicClasses; - -procedure SingDraw; -procedure SingModiDraw (PlayerInfo: TPlayerInfo); -procedure SingDrawBackground; -procedure SingDrawOscilloscope(X, Y, W, H: real; NrSound: integer); -procedure SingDrawNoteLines(Left, Top, Right: real; Space: integer); -procedure SingDrawLyricHelper(Left, LyricsMid: real); -procedure SingDrawBeatDelimeters(Left, Top, Right: real; NrLines: integer); -procedure SingDrawLine(Left, Top, Right: real; NrLines: integer; Space: integer); -procedure SingDrawPlayerLine(X, Y, W: real; PlayerIndex: integer; Space: integer); -procedure SingDrawPlayerBGLine(Left, Top, Right: real; NrLines, PlayerIndex: integer; Space: integer); - -// TimeBar -procedure SingDrawTimeBar(); - -//Draw Editor NoteLines -procedure EditDrawLine(Left, Top, Right: real; NrLines: integer; Space: integer); - -type - TRecR = record - Top: real; - Left: real; - Right: real; - Bottom: real; - - Width: real; - WMid: real; - Height: real; - HMid: real; - Mid: real; - end; - -var - NotesW: real; - NotesH: real; - Starfr: integer; - StarfrG: integer; - - //SingBar - TickOld: cardinal; - TickOld2: cardinal; - -implementation - -uses - SysUtils, - Math, - gl, - TextGL, - UDLLManager, - UDrawTexture, - UGraphic, - UIni, - ULog, - ULyrics, - UNote, - UMusic, - URecord, - UScreenSing, - UScreenSingModi, - UTexture; - -procedure SingDrawBackground; -var - Rec: TRecR; - TexRec: TRecR; -begin - if (ScreenSing.Tex_Background.TexNum > 0) then - begin - if (Ini.MovieSize <= 1) then //HalfSize BG - begin - (* half screen + gradient *) - Rec.Top := 110; // 80 - Rec.Bottom := Rec.Top + 20; - Rec.Left := 0; - Rec.Right := 800; - - TexRec.Top := (Rec.Top / 600) * ScreenSing.Tex_Background.TexH; - TexRec.Bottom := (Rec.Bottom / 600) * ScreenSing.Tex_Background.TexH; - TexRec.Left := 0; - TexRec.Right := ScreenSing.Tex_Background.TexW; - - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, ScreenSing.Tex_Background.TexNum); - glEnable(GL_BLEND); - glBegin(GL_QUADS); - (* gradient draw *) - (* top *) - glColor4f(1, 1, 1, 0); - glTexCoord2f(TexRec.Right, TexRec.Top); glVertex2f(Rec.Right, Rec.Top); - glTexCoord2f(TexRec.Left, TexRec.Top); glVertex2f(Rec.Left, Rec.Top); - glColor4f(1, 1, 1, 1); - glTexCoord2f(TexRec.Left, TexRec.Bottom); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(TexRec.Right, TexRec.Bottom); glVertex2f(Rec.Right, Rec.Bottom); - (* mid *) - Rec.Top := Rec.Bottom; - Rec.Bottom := 490 - 20; // 490 - 20 - TexRec.Top := TexRec.Bottom; - TexRec.Bottom := (Rec.Bottom / 600) * ScreenSing.Tex_Background.TexH; - glTexCoord2f(TexRec.Left, TexRec.Top); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(TexRec.Left, TexRec.Bottom); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(TexRec.Right, TexRec.Bottom); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(TexRec.Right, TexRec.Top); glVertex2f(Rec.Right, Rec.Top); - (* bottom *) - Rec.Top := Rec.Bottom; - Rec.Bottom := 490; // 490 - TexRec.Top := TexRec.Bottom; - TexRec.Bottom := (Rec.Bottom / 600) * ScreenSing.Tex_Background.TexH; - glTexCoord2f(TexRec.Right, TexRec.Top); glVertex2f(Rec.Right, Rec.Top); - glTexCoord2f(TexRec.Left, TexRec.Top); glVertex2f(Rec.Left, Rec.Top); - glColor4f(1, 1, 1, 0); - glTexCoord2f(TexRec.Left, TexRec.Bottom); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(TexRec.Right, TexRec.Bottom); glVertex2f(Rec.Right, Rec.Bottom); - - glEnd; - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - end - else //Full Size BG - begin - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, ScreenSing.Tex_Background.TexNum); - //glEnable(GL_BLEND); - glBegin(GL_QUADS); - - glTexCoord2f(0, 0); glVertex2f(0, 0); - glTexCoord2f(0, ScreenSing.Tex_Background.TexH); glVertex2f(0, 600); - glTexCoord2f( ScreenSing.Tex_Background.TexW, ScreenSing.Tex_Background.TexH); glVertex2f(800, 600); - glTexCoord2f( ScreenSing.Tex_Background.TexW, 0); glVertex2f(800, 0); - - glEnd; - glDisable(GL_TEXTURE_2D); - //glDisable(GL_BLEND); - end; - end; -end; - -procedure SingDrawOscilloscope(X, Y, W, H: real; NrSound: integer); -var - SampleIndex: integer; - Sound: TCaptureBuffer; - MaxX, MaxY: real; -begin; - Sound := AudioInputProcessor.Sound[NrSound]; - - // Log.LogStatus('Oscilloscope', 'SingDraw'); - glColor3f(Skin_OscR, Skin_OscG, Skin_OscB); -{ - if (ParamStr(1) = '-black') or (ParamStr(1) = '-fsblack') then - glColor3f(1, 1, 1); -} - MaxX := W-1; - MaxY := (H-1) / 2; - - Sound.LockAnalysisBuffer(); - - glBegin(GL_LINE_STRIP); - for SampleIndex := 0 to High(Sound.AnalysisBuffer) do - begin - glVertex2f(X + MaxX * SampleIndex/High(Sound.AnalysisBuffer), - Y + MaxY * (1 - Sound.AnalysisBuffer[SampleIndex]/-Low(Smallint))); - end; - glEnd; - - Sound.UnlockAnalysisBuffer(); -end; - -procedure SingDrawNoteLines(Left, Top, Right: real; Space: integer); -var - Count: integer; -begin - glEnable(GL_BLEND); - glColor4f(Skin_P1_LinesR, Skin_P1_LinesG, Skin_P1_LinesB, 0.4); - glBegin(GL_LINES); - for Count := 0 to 9 do - begin - glVertex2f(Left, Top + Count * Space); - glVertex2f(Right, Top + Count * Space); - end; - glEnd; - glDisable(GL_BLEND); -end; - -procedure SingDrawBeatDelimeters(Left, Top, Right: real; NrLines: integer); -var - Count: integer; - TempR: real; -begin - TempR := (Right-Left) / (Lines[NrLines].Line[Lines[NrLines].Current].End_ - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start); - glEnable(GL_BLEND); - glBegin(GL_LINES); - for Count := Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start to Lines[NrLines].Line[Lines[NrLines].Current].End_ do - begin - if (Count mod Lines[NrLines].Resolution) = Lines[NrLines].NotesGAP then - glColor4f(0, 0, 0, 1) - else - glColor4f(0, 0, 0, 0.3); - glVertex2f(Left + TempR * (Count - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start), Top); - glVertex2f(Left + TempR * (Count - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start), Top + 135); - end; - glEnd; - glDisable(GL_BLEND); -end; - -// draw blank Notebars -procedure SingDrawLine(Left, Top, Right: real; NrLines: integer; Space: integer); -var - Rec: TRecR; - Count: integer; - TempR: real; - - PlayerNumber: integer; - - GoldenStarPos: real; - - lTmpA, lTmpB : real; -begin -// We actually don't have a playernumber in this procedure, it should reside in NrLines - but it is always set to zero -// So we exploit this behavior a bit - we give NrLines the playernumber, keep it in playernumber - and then we set NrLines to zero -// This could also come quite in handy when we do the duet mode, cause just the notes for the player that has to sing should be drawn then -// BUT this is not implemented yet, all notes are drawn! :D - - PlayerNumber := NrLines + 1; // Player 1 is 0 - NrLines := 0; - -// exploit done - - glColor3f(1, 1, 1); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - lTmpA := (Right-Left); - lTmpB := (Lines[NrLines].Line[Lines[NrLines].Current].End_ - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start); - - if ( lTmpA > 0 ) and ( lTmpB > 0 ) then - TempR := lTmpA / lTmpB - else - TempR := 0; - - with Lines[NrLines].Line[Lines[NrLines].Current] do - begin - for Count := 0 to HighNote do - begin - with Note[Count] do - begin - if NoteType <> ntFreestyle then - begin - if Ini.EffectSing = 0 then - // If Golden note Effect of then Change not Color - begin - case NoteType of - ntNormal: glColor4f(1, 1, 1, 1); // We set alpha to 1, cause we can control the transparency through the png itself - ntGolden: glColor4f(1, 1, 0.3, 1); // no stars, paint yellow -> glColor4f(1, 1, 0.3, 0.85); - we could - end; // case - end //Else all Notes same Color - else - glColor4f(1, 1, 1, 1); // We set alpha to 1, cause we can control the transparency through the png itself - - // left part - Rec.Left := (Start-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left + 0.5 + 10*ScreenX; - Rec.Right := Rec.Left + NotesW; - Rec.Top := Top - (Tone-BaseNote)*Space/2 - NotesH; - Rec.Bottom := Rec.Top + 2 * NotesH; - glBindTexture(GL_TEXTURE_2D, Tex_plain_Left[PlayerNumber].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - //We keep the postion of the top left corner b4 it's overwritten - GoldenStarPos := Rec.Left; - //done - - // middle part - Rec.Left := Rec.Right; - Rec.Right := (Start+Length-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left - NotesW - 0.5 + 10*ScreenX; - - glBindTexture(GL_TEXTURE_2D, Tex_plain_Mid[PlayerNumber].TexNum); - glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT ); - glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT ); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(round((Rec.Right-Rec.Left)/32), 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(round((Rec.Right-Rec.Left)/32), 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // right part - Rec.Left := Rec.Right; - Rec.Right := Rec.Right + NotesW; - - glBindTexture(GL_TEXTURE_2D, Tex_plain_Right[PlayerNumber].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // Golden Star Patch - if (NoteType = ntGolden) and (Ini.EffectSing=1) then - begin - GoldenRec.SaveGoldenStarsRec(GoldenStarPos, Rec.Top, Rec.Right, Rec.Bottom); - end; - - end; // if not FreeStyle - end; // with - end; // for - end; // with - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -// draw sung notes -procedure SingDrawPlayerLine(X, Y, W: real; PlayerIndex: integer; Space: integer); -var - TempR: real; - Rec: TRecR; - N: integer; -// R, G, B, A: real; - NotesH2: real; -begin - //Log.LogStatus('Player notes', 'SingDraw'); -{ - if NrGracza = 0 then - LoadColor(R, G, B, 'P1Light') - else - LoadColor(R, G, B, 'P2Light'); -} - //R := 71/255; - //G := 175/255; - //B := 247/255; - - glColor3f(1, 1, 1); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - //if Player[NrGracza].LengthNote > 0 then - begin - TempR := W / (Lines[0].Line[Lines[0].Current].End_ - Lines[0].Line[Lines[0].Current].Note[0].Start); - for N := 0 to Player[PlayerIndex].HighNote do - begin - with Player[PlayerIndex].Note[N] do - begin - // Left part of note - Rec.Left := X + (Start-Lines[0].Line[Lines[0].Current].Note[0].Start) * TempR + 0.5 + 10*ScreenX; - Rec.Right := Rec.Left + NotesW; - - // Draw it in half size, if not hit - if Hit then - begin - NotesH2 := NotesH - end - else - begin - NotesH2 := int(NotesH * 0.65); - end; - - Rec.Top := Y - (Tone-Lines[0].Line[Lines[0].Current].BaseNote)*Space/2 - NotesH2; - Rec.Bottom := Rec.Top + 2 * NotesH2; - - // draw the left part - glColor3f(1, 1, 1); - glBindTexture(GL_TEXTURE_2D, Tex_Left[PlayerIndex+1].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // Middle part of the note - Rec.Left := Rec.Right; - Rec.Right := X + (Start+Length-Lines[0].Line[Lines[0].Current].Note[0].Start) * TempR - NotesW - 0.5 + 10*ScreenX; - - // new - if (Start+Length-1 = LyricsState.CurrentBeatD) then - Rec.Right := Rec.Right - (1-Frac(LyricsState.MidBeatD)) * TempR; - // the left note is more right than the right note itself, sounds weird - so we fix that xD - if Rec.Right <= Rec.Left then - Rec.Right := Rec.Left; - - // draw the middle part - glBindTexture(GL_TEXTURE_2D, Tex_Mid[PlayerIndex+1].TexNum); - glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_REPEAT ); - glTexParameterf( GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_REPEAT ); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(round((Rec.Right-Rec.Left)/32), 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(round((Rec.Right-Rec.Left)/32), 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - glColor3f(1, 1, 1); - - // the right part of the note - Rec.Left := Rec.Right; - Rec.Right := Rec.Right + NotesW; - - glBindTexture(GL_TEXTURE_2D, Tex_Right[PlayerIndex+1].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // Perfect note is stored - if Perfect and (Ini.EffectSing=1) then - begin - //A := 1 - 2*(LyricsState.GetCurrentTime() - GetTimeFromBeat(Start+Length)); - if not (Start+Length-1 = LyricsState.CurrentBeatD) then - begin - //Star animation counter - //inc(Starfr); - //Starfr := Starfr mod 128; - GoldenRec.SavePerfectNotePos(Rec.Left, Rec.Top); - end; - end; - end; // with - end; // for - - // actually we need a comparison here, to determine if the singing process - // is ahead Rec.Right even if there is no singing - - if (Ini.EffectSing = 1) then - GoldenRec.GoldenNoteTwinkle(Rec.Top,Rec.Bottom,Rec.Right, PlayerIndex); - end; // if -end; - -//draw Note glow -procedure SingDrawPlayerBGLine(Left, Top, Right: real; NrLines, PlayerIndex: integer; Space: integer); -var - Rec: TRecR; - Count: integer; - TempR: real; - X1, X2, X3, X4: real; - W, H: real; - lTmpA, lTmpB: real; -begin - if (Player[PlayerIndex].ScoreTotalInt >= 0) then - begin - glColor4f(1, 1, 1, sqrt((1+sin( AudioPlayback.Position * 3))/4)/ 2 + 0.5 ); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - lTmpA := (Right-Left); - lTmpB := (Lines[NrLines].Line[Lines[NrLines].Current].End_ - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start); - - if ( lTmpA > 0 ) and ( lTmpB > 0 ) then - TempR := lTmpA / lTmpB - else - TempR := 0; - - with Lines[NrLines].Line[Lines[NrLines].Current] do - begin - for Count := 0 to HighNote do - begin - with Note[Count] do - begin - if NoteType <> ntFreestyle then - begin - // begin: 14, 20 - // easy: 6, 11 - W := NotesW * 2 + 2; - H := NotesH * 1.5 + 3.5; - - X2 := (Start-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left + 0.5 + 10*ScreenX + 4; - X1 := X2-W; - - X3 := (Start+Length-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left - 0.5 + 10*ScreenX - 4; - X4 := X3+W; - - // left - Rec.Left := X1; - Rec.Right := X2; - Rec.Top := Top - (Tone-BaseNote)*Space/2 - H; - Rec.Bottom := Rec.Top + 2 * H; - - glBindTexture(GL_TEXTURE_2D, Tex_BG_Left[PlayerIndex+1].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // middle part - Rec.Left := X2; - Rec.Right := X3; - - glBindTexture(GL_TEXTURE_2D, Tex_BG_Mid[PlayerIndex+1].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // right part - Rec.Left := X3; - Rec.Right := X4; - - glBindTexture(GL_TEXTURE_2D, Tex_BG_Right[PlayerIndex+1].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - end; // if not FreeStyle - end; // with - end; // for - end; // with - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - end; -end; - -(** - * Draws the lyrics helper bar. - * Left: position the bar starts at - * LyricsMid: the middle of the lyrics relative to the position Left - *) -procedure SingDrawLyricHelper(Left, LyricsMid: real); -var - Bounds: TRecR; // bounds of the lyric help bar - BarProgress: real; // progress of the lyrics helper - BarMoveDelta: real; // current beat relative to the beat the bar starts to move at - BarAlpha: real; // transparency - CurLine: PLine; // current lyric line (beat specific) - LineWidth: real; // lyric line width - FirstNoteBeat: integer; // beat of the first note in the current line - FirstNoteDelta: integer; // time in beats between the start of the current line and its first note - MoveStartX: real; // x-pos. the bar starts to move from - MoveDist: real; // number of pixels the bar will move - LyricEngine: TLyricEngine; -const - BarWidth = 50; // width of the lyric helper bar - BarHeight = 30; // height of the lyric helper bar - BarMoveLimit = 40; // max. number of beats remaining before the bar starts to move -begin - // get current lyrics line and the time in beats of its first note - CurLine := @Lines[0].Line[Lines[0].Current]; - - // FIXME: accessing ScreenSing is not that generic - LyricEngine := ScreenSing.Lyrics; - - // do not draw the lyrics helper if the current line does not contain any note - if (Length(CurLine.Note) > 0) then - begin - // start beat of the first note of this line - FirstNoteBeat := CurLine.Note[0].Start; - // time in beats between the start of the current line and its first note - FirstNoteDelta := FirstNoteBeat - CurLine.Start; - - // beats from current beat to the first note of the line - BarMoveDelta := FirstNoteBeat - LyricsState.MidBeat; - - if (FirstNoteDelta > 8) and // if the wait-time is large enough - (BarMoveDelta > 0) then // and the first note of the line is not reached - begin - // let the bar blink to the beat - BarAlpha := 0.75 + cos(BarMoveDelta/2) * 0.25; - - // if the number of beats to the first note is too big, - // the bar stays on the left side. - if (BarMoveDelta > BarMoveLimit) then - BarMoveDelta := BarMoveLimit; - - // limit number of beats the bar moves - if (FirstNoteDelta > BarMoveLimit) then - FirstNoteDelta := BarMoveLimit; - - // calc bar progress - BarProgress := 1 - BarMoveDelta / FirstNoteDelta; - - // retrieve the width of the upper lyrics line on the display - if (LyricEngine.GetUpperLine() <> nil) then - LineWidth := LyricEngine.GetUpperLine().Width - else - LineWidth := 0; - - // distance the bar will move (LyricRec.Left to beginning of text) - MoveDist := LyricsMid - LineWidth / 2 - BarWidth; - // if the line is too long the helper might move from right to left - // so we have to assure the start position is left of the text. - if (MoveDist >= 0) then - MoveStartX := Left - else - MoveStartX := Left + MoveDist; - - // determine lyric help bar position and size - Bounds.Left := MoveStartX + BarProgress * MoveDist; - Bounds.Right := Bounds.Left + BarWidth; - Bounds.Top := Theme.LyricBar.IndicatorYOffset + Theme.LyricBar.UpperY ; - Bounds.Bottom := Bounds.Top + BarHeight + 3; - - // draw lyric help bar - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glColor4f(1, 1, 1, BarAlpha); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, Tex_Lyric_Help_Bar.TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Bounds.Left, Bounds.Top); - glTexCoord2f(0, 1); glVertex2f(Bounds.Left, Bounds.Bottom); - glTexCoord2f(1, 1); glVertex2f(Bounds.Right, Bounds.Bottom); - glTexCoord2f(1, 0); glVertex2f(Bounds.Right, Bounds.Top); - glEnd; - glDisable(GL_BLEND); - end; - end; -end; - -procedure SingDraw; -var - NR: TRecR; // lyrics area bounds (NR = NoteRec?) - LyricEngine: TLyricEngine; -begin - // positions - if Ini.SingWindow = 0 then - NR.Left := 120 - else - NR.Left := 20; - - NR.Right := 780; - - NR.Width := NR.Right - NR.Left; - NR.WMid := NR.Width / 2; - NR.Mid := NR.Left + NR.WMid; - - // FIXME: accessing ScreenSing is not that generic - LyricEngine := ScreenSing.Lyrics; - - // draw time-bar - SingDrawTimeBar(); - - // draw note-lines - - if (PlayersPlay = 1) and (Ini.NoteLines = 1) then - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); - - if ((PlayersPlay = 2) or (PlayersPlay = 4)) and (Ini.NoteLines = 1) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P1_NotesB - 105, NR.Right + 10*ScreenX, 15); - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); - end; - - if ((PlayersPlay = 3) or (PlayersPlay = 6)) and (Ini.NoteLines = 1) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, 120, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 245, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 370, NR.Right + 10*ScreenX, 12); - end; - - // draw Lyrics - LyricEngine.Draw(LyricsState.MidBeat); - SingDrawLyricHelper(NR.Left, NR.WMid); - - // oscilloscope - if Ini.Oscilloscope = 1 then - begin - if PlayersPlay = 1 then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - - if PlayersPlay = 2 then - begin - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 1); - end; - - if PlayersPlay = 4 then - begin - if ScreenAct = 1 then - begin - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 1); - end; - if ScreenAct = 2 then - begin - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 2); - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 3); - end; - end; - - if PlayersPlay = 3 then - begin - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 0); - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 1); - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 2); - end; - - if PlayersPlay = 6 then - begin - if ScreenAct = 1 then - begin - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 0); - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 1); - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 2); - end; - if ScreenAct = 2 then - begin - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 3); - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 4); - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 5); - end; - end; - - end; - - // Set the note heights according to the difficulty level - case Ini.Difficulty of - 0: - begin - NotesH := 11; // 9 - NotesW := 6; // 5 - end; - 1: - begin - NotesH := 8; // 7 - NotesW := 4; // 4 - end; - 2: - begin - NotesH := 5; - NotesW := 3; - end; - end; - - // Draw the Notes - if PlayersPlay = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 0, 15); // Background glow - colorized in playercolor - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); // Plain unsung notes - colorized in playercolor - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 0, 15); // imho the sung notes - end; - - if PlayersPlay = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 1, 15); - - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 1, 15); - - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 1, 15); - end; - - if PlayersPlay = 3 then - begin - NotesW := NotesW * 0.8; - NotesH := NotesH * 0.8; - - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 0, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 1, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 2, 12); - - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 1, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 2, 12); - - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 1, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 2, 12); - end; - - if PlayersPlay = 4 then - begin - if ScreenAct = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 2, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 3, 15); - end; - - if ScreenAct = 1 then - begin - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 2, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 3, 15); - end; - - if ScreenAct = 1 then - begin - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 2, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 3, 15); - end; - end; - - if PlayersPlay = 6 then - begin - NotesW := NotesW * 0.8; - NotesH := NotesH * 0.8; - - if ScreenAct = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 0, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 1, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 3, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 4, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 5, 12); - end; - - if ScreenAct = 1 then - begin - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 1, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 3, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 4, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 5, 12); - end; - - if ScreenAct = 1 then - begin - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 1, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 3, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 4, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 5, 12); - end; - end; - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -// q'n'd for using the game mode dll's -procedure SingModiDraw (PlayerInfo: TPlayerInfo); -var - NR: TRecR; -begin - // positions - if Ini.SingWindow = 0 then - begin - NR.Left := 120; - end - else - begin - NR.Left := 20; - end; - - NR.Right := 780; - NR.Width := NR.Right - NR.Left; - NR.WMid := NR.Width / 2; - NR.Mid := NR.Left + NR.WMid; - - // time bar - SingDrawTimeBar(); - - if DLLMan.Selected.ShowNotes then - begin - if PlayersPlay = 1 then - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); - if (PlayersPlay = 2) or (PlayersPlay = 4) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P1_NotesB - 105, NR.Right + 10*ScreenX, 15); - SingDrawNoteLines(NR.Left + 10*ScreenX, Skin_P2_NotesB - 105, NR.Right + 10*ScreenX, 15); - end; - - if (PlayersPlay = 3) or (PlayersPlay = 6) then - begin - SingDrawNoteLines(NR.Left + 10*ScreenX, 120, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 245, NR.Right + 10*ScreenX, 12); - SingDrawNoteLines(NR.Left + 10*ScreenX, 370, NR.Right + 10*ScreenX, 12); - end; - end; - - // Draw Lyrics - ScreenSingModi.Lyrics.Draw(LyricsState.MidBeat); - // TODO: Lyrics helper - - // oscilloscope | the thing that moves when you yell into your mic (imho) - if (((Ini.Oscilloscope = 1) and (DLLMan.Selected.ShowRateBar_O)) and (not DLLMan.Selected.ShowRateBar)) then - begin - if PlayersPlay = 1 then - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - - if PlayersPlay = 2 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 1); - end; - - if PlayersPlay = 4 then - begin - if ScreenAct = 1 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 1); - end; - if ScreenAct = 2 then - begin - if PlayerInfo.Playerinfo[2].Enabled then - SingDrawOscilloscope(190 + 10*ScreenX, 55, 180, 40, 2); - if PlayerInfo.Playerinfo[3].Enabled then - SingDrawOscilloscope(425 + 10*ScreenX, 55, 180, 40, 3); - end; - end; - - if PlayersPlay = 3 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 1); - if PlayerInfo.Playerinfo[2].Enabled then - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 2); - end; - - if PlayersPlay = 6 then - begin - if ScreenAct = 1 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 0); - if PlayerInfo.Playerinfo[1].Enabled then - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 1); - if PlayerInfo.Playerinfo[2].Enabled then - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 2); - end; - if ScreenAct = 2 then - begin - if PlayerInfo.Playerinfo[3].Enabled then - SingDrawOscilloscope( 75 + 10*ScreenX, 95, 100, 20, 3); - if PlayerInfo.Playerinfo[4].Enabled then - SingDrawOscilloscope(370 + 10*ScreenX, 95, 100, 20, 4); - if PlayerInfo.Playerinfo[5].Enabled then - SingDrawOscilloscope(670 + 10*ScreenX, 95, 100, 20, 5); - end; - end; - - end; - -// resize the notes according to the difficulty level - case Ini.Difficulty of - 0: - begin - NotesH := 11; // 9 - NotesW := 6; // 5 - end; - 1: - begin - NotesH := 8; // 7 - NotesW := 4; // 4 - end; - 2: - begin - NotesH := 5; - NotesW := 3; - end; - end; - - if (DLLMAn.Selected.ShowNotes and DLLMan.Selected.LoadSong) then - begin - if (PlayersPlay = 1) and PlayerInfo.Playerinfo[0].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 0, 15); - end; - - if PlayersPlay = 2 then - begin - if PlayerInfo.Playerinfo[0].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 0, 15); - end; - if PlayerInfo.Playerinfo[1].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 1, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 1, 15); - end; - - end; - - if PlayersPlay = 3 then - begin - NotesW := NotesW * 0.8; - NotesH := NotesH * 0.8; - - if PlayerInfo.Playerinfo[0].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 0, 12); - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 0, 12); - end; - - if PlayerInfo.Playerinfo[1].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 1, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 1, 12); - end; - - if PlayerInfo.Playerinfo[2].Enabled then - begin - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 2, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 2, 12); - end; - end; - - if PlayersPlay = 4 then - begin - if ScreenAct = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 0, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 2, 15); - SingDrawPlayerBGLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 3, 15); - end; - - SingDrawLine(NR.Left + 20, Skin_P1_NotesB, NR.Right - 20, 0, 15); - SingDrawLine(NR.Left + 20, Skin_P2_NotesB, NR.Right - 20, 0, 15); - - if ScreenAct = 1 then - begin - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 0, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 1, 15); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerLine(NR.Left + 20, Skin_P1_NotesB, NR.Width - 40, 2, 15); - SingDrawPlayerLine(NR.Left + 20, Skin_P2_NotesB, NR.Width - 40, 3, 15); - end; - end; - - if PlayersPlay = 6 then - begin - NotesW := NotesW * 0.8; - NotesH := NotesH * 0.8; - - if ScreenAct = 1 then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 0, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 1, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerBGLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 3, 12); - SingDrawPlayerBGLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 4, 12); - SingDrawPlayerBGLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 5, 12); - end; - - SingDrawLine(NR.Left + 20, 120+95, NR.Right - 20, 0, 12); - SingDrawLine(NR.Left + 20, 245+95, NR.Right - 20, 0, 12); - SingDrawLine(NR.Left + 20, 370+95, NR.Right - 20, 0, 12); - - if ScreenAct = 1 then - begin - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 0, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 1, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 2, 12); - end; - if ScreenAct = 2 then - begin - SingDrawPlayerLine(NR.Left + 20, 120+95, NR.Width - 40, 3, 12); - SingDrawPlayerLine(NR.Left + 20, 245+95, NR.Width - 40, 4, 12); - SingDrawPlayerLine(NR.Left + 20, 370+95, NR.Width - 40, 5, 12); - end; - end; - end; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -{//SingBar Mod -procedure SingDrawSingbar(X, Y, W, H: real; Percent: integer); -var - R: real; - G: real; - B: real; - A: cardinal; - I: integer; - -begin; - - //SingBar Background - glColor4f(1, 1, 1, 0.8); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, Tex_SingBar_Back.TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(X, Y); - glTexCoord2f(0, 1); glVertex2f(X, Y+H); - glTexCoord2f(1, 1); glVertex2f(X+W, Y+H); - glTexCoord2f(1, 0); glVertex2f(X+W, Y); - glEnd; - - //SingBar coloured Bar - case Percent of - 0..22: begin - R := 1; - G := 0; - B := 0; - end; - 23..42: begin - R := 1; - G := ((Percent-23)/100)*5; - B := 0; - end; - 43..57: begin - R := 1; - G := 1; - B := 0; - end; - 58..77: begin - R := 1-(Percent - 58)/100*5; - G := 1; - B := 0; - end; - 78..99: begin - R := 0; - G := 1; - B := 0; - end; - end; //case - - glColor4f(R, G, B, 1); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, Tex_SingBar_Bar.TexNum); - //Size= Player[PlayerNum].ScorePercent of W - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(X, Y); - glTexCoord2f(0, 1); glVertex2f(X, Y+H); - glTexCoord2f(1, 1); glVertex2f(X+(W/100 * (Percent +1)), Y+H); - glTexCoord2f(1, 0); glVertex2f(X+(W/100 * (Percent +1)), Y); - glEnd; - - //SingBar Front - glColor4f(1, 1, 1, 0.6); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, Tex_SingBar_Front.TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(X, Y); - glTexCoord2f(0, 1); glVertex2f(X, Y+H); - glTexCoord2f(1, 1); glVertex2f(X+W, Y+H); - glTexCoord2f(1, 0); glVertex2f(X+W, Y); - glEnd; -end; -//end Singbar Mod - -//PhrasenBonus - Line Bonus Pop Up -procedure SingDrawLineBonus(const X, Y: Single; Color: TRGB; Alpha: Single; Text: string; Age: integer); -var - Length, X2: real; //Length of Text - Size: integer; //Size of Popup -begin - if Alpha <> 0 then - begin - -//Set Font Propertys - SetFontStyle(2); //Font: Outlined1 - if Age < 5 then - SetFontSize((Age + 1) * 3) - else - SetFontSize(18); - SetFontItalic(False); - -//Check Font Size - Length := glTextWidth (Text) + 3; //Little Space for a Better Look ^^ - -//Text - SetFontPos (X + 50 - (Length / 2), Y + 12); //Position - - if Age < 5 then - Size := Age * 10 - else - Size := 50; - -//Draw Background -// glColor4f(Color.R, Color.G, Color.B, Alpha); //Set Color - glColor4f(1, 1, 1, Alpha); - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); -// glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - -//New Method, Not Variable - glBindTexture(GL_TEXTURE_2D, Tex_SingLineBonusBack[2].TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(X + 50 - Size, Y + 25 - (Size/2)); - glTexCoord2f(0, 1); glVertex2f(X + 50 - Size, Y + 25 + (Size/2)); - glTexCoord2f(1, 1); glVertex2f(X + 50 + Size, Y + 25 + (Size/2)); - glTexCoord2f(1, 0); glVertex2f(X + 50 + Size, Y + 25 - (Size/2)); - glEnd; - - glColor4f(1, 1, 1, Alpha); //Set Color -//Draw Text - glPrint (Text); - end; -end; -//PhrasenBonus - Line Bonus Mod} - -// Draw Note Bars for Editor -// There are 11 reasons for a new procedure: (nice binary :D ) -// 1. It does not look good when you draw the golden note star effect in the editor -// 2. You can see the freestyle notes in the editor semitransparent -// 3. It is easier and faster then changing the old procedure -procedure EditDrawLine(Left, Top, Right: real; NrLines: integer; Space: integer); -var - Rec: TRecR; - Count: integer; - TempR: real; -begin - glColor3f(1, 1, 1); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - TempR := (Right-Left) / (Lines[NrLines].Line[Lines[NrLines].Current].End_ - Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start); - with Lines[NrLines].Line[Lines[NrLines].Current] do - begin - for Count := 0 to HighNote do - begin - with Note[Count] do - begin - - // Golden Note Patch - case NoteType of - ntFreestyle: glColor4f(1, 1, 1, 0.35); - ntNormal: glColor4f(1, 1, 1, 0.85); - ntGolden: Glcolor4f(1, 1, 0.3, 0.85); - end; // case - - // left part - Rec.Left := (Start-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left + 0.5 + 10*ScreenX; - Rec.Right := Rec.Left + NotesW; - Rec.Top := Top - (Tone-BaseNote)*Space/2 - NotesH; - Rec.Bottom := Rec.Top + 2 * NotesH; - glBindTexture(GL_TEXTURE_2D, Tex_Left[Color].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // middle part - Rec.Left := Rec.Right; - Rec.Right := (Start+Length-Lines[NrLines].Line[Lines[NrLines].Current].Note[0].Start) * TempR + Left - NotesW - 0.5 + 10*ScreenX; - - glBindTexture(GL_TEXTURE_2D, Tex_Mid[Color].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - // right part - Rec.Left := Rec.Right; - Rec.Right := Rec.Right + NotesW; - - glBindTexture(GL_TEXTURE_2D, Tex_Right[Color].TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Rec.Left, Rec.Top); - glTexCoord2f(0, 1); glVertex2f(Rec.Left, Rec.Bottom); - glTexCoord2f(1, 1); glVertex2f(Rec.Right, Rec.Bottom); - glTexCoord2f(1, 0); glVertex2f(Rec.Right, Rec.Top); - glEnd; - - end; // with - end; // for - end; // with - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -procedure SingDrawTimeBar(); -var - x, y: real; - width, height: real; - LyricsProgress: real; - CurLyricsTime: real; -begin - x := Theme.Sing.StaticTimeProgress.x; - y := Theme.Sing.StaticTimeProgress.y; - - width := Theme.Sing.StaticTimeProgress.w; - height := Theme.Sing.StaticTimeProgress.h; - - glColor4f(Theme.Sing.StaticTimeProgress.ColR, - Theme.Sing.StaticTimeProgress.ColG, - Theme.Sing.StaticTimeProgress.ColB, 1); //Set Color - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - - glBindTexture(GL_TEXTURE_2D, Tex_TimeProgress.TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); - glVertex2f(x, y); - - CurLyricsTime := LyricsState.GetCurrentTime(); - if (CurLyricsTime > 0) and - (LyricsState.TotalTime > 0) then - begin - LyricsProgress := CurLyricsTime / LyricsState.TotalTime; - glTexCoord2f((width * LyricsProgress) / 8, 0); - glVertex2f(x + width * LyricsProgress, y); - - glTexCoord2f((width * LyricsProgress) / 8, 1); - glVertex2f(x + width * LyricsProgress, y + height); - end; - - glTexCoord2f(0, 1); - glVertex2f(x, y + height); - glEnd; - - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - glcolor4f(1, 1, 1, 1); -end; - -end. - diff --git a/src/base/UEditorLyrics.pas b/src/base/UEditorLyrics.pas deleted file mode 100644 index 0eacd1f9..00000000 --- a/src/base/UEditorLyrics.pas +++ /dev/null @@ -1,259 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UEditorLyrics; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - gl, - UMusic, - UTexture; - -type - TAlignmentType = (atLeft, atCenter, atRight); - - TWord = record - X: real; - Y: real; - Size: real; - Width: real; - Text: string; - ColR: real; - ColG: real; - ColB: real; - FontStyle: integer; - Italic: boolean; - Selected: boolean; - end; - - TEditorLyrics = class - private - AlignI: TAlignmentType; - XR: real; - YR: real; - SizeR: real; - SelectedI: integer; - FontStyleI: integer; // font number - Word: array of TWord; - - procedure SetX(Value: real); - procedure SetY(Value: real); - function GetClientX: real; - procedure SetAlign(Value: TAlignmentType); - function GetSize: real; - procedure SetSize(Value: real); - procedure SetSelected(Value: integer); - procedure SetFontStyle(Value: integer); - procedure AddWord(Text: UTF8String); - procedure Refresh; - public - ColR: real; - ColG: real; - ColB: real; - ColSR: real; - ColSG: real; - ColSB: real; - Italic: boolean; - - constructor Create; - destructor Destroy; override; - - procedure AddLine(NrLine: integer); - - procedure Clear; - procedure Draw; - published - property X: real write SetX; - property Y: real write SetY; - property ClientX: real read GetClientX; - property Align: TAlignmentType write SetAlign; - property Size: real read GetSize write SetSize; - property Selected: integer read SelectedI write SetSelected; - property FontStyle: integer write SetFontStyle; - end; - -implementation - -uses - TextGL, - UGraphic, - UDrawTexture, - Math, - USkins; - -constructor TEditorLyrics.Create; -begin - inherited; -end; - -destructor TEditorLyrics.Destroy; -begin - SetLength(Word, 0); - inherited; -end; - -procedure TEditorLyrics.SetX(Value: real); -begin - XR := Value; -end; - -procedure TEditorLyrics.SetY(Value: real); -begin - YR := Value; -end; - -function TEditorLyrics.GetClientX: real; -begin - Result := Word[0].X; -end; - -procedure TEditorLyrics.SetAlign(Value: TAlignmentType); -begin - AlignI := Value; -end; - -function TEditorLyrics.GetSize: real; -begin - Result := SizeR; -end; - -procedure TEditorLyrics.SetSize(Value: real); -begin - SizeR := Value; -end; - -procedure TEditorLyrics.SetSelected(Value: integer); -begin - if (-1 < SelectedI) and (SelectedI <= High(Word)) then - begin - Word[SelectedI].Selected := false; - Word[SelectedI].ColR := ColR; - Word[SelectedI].ColG := ColG; - Word[SelectedI].ColB := ColB; - end; - - SelectedI := Value; - if (-1 < Value) and (Value <= High(Word)) then - begin - Word[Value].Selected := true; - Word[Value].ColR := ColSR; - Word[Value].ColG := ColSG; - Word[Value].ColB := ColSB; - end; - - Refresh; -end; - -procedure TEditorLyrics.SetFontStyle(Value: integer); -begin - FontStyleI := Value; -end; - -procedure TEditorLyrics.AddWord(Text: UTF8String); -var - WordNum: integer; -begin - WordNum := Length(Word); - SetLength(Word, WordNum + 1); - if WordNum = 0 then - Word[WordNum].X := XR - else - Word[WordNum].X := Word[WordNum - 1].X + Word[WordNum - 1].Width; - - Word[WordNum].Y := YR; - Word[WordNum].Size := SizeR; - Word[WordNum].FontStyle := FontStyleI; - SetFontStyle(FontStyleI); - SetFontSize(SizeR); - Word[WordNum].Width := glTextWidth(Text); - Word[WordNum].Text := Text; - Word[WordNum].ColR := ColR; - Word[WordNum].ColG := ColG; - Word[WordNum].ColB := ColB; - Word[WordNum].Italic := Italic; - - Refresh; -end; - -procedure TEditorLyrics.AddLine(NrLine: integer); -var - NoteIndex: integer; -begin - Clear; - for NoteIndex := 0 to Lines[0].Line[NrLine].HighNote do - begin - Italic := Lines[0].Line[NrLine].Note[NoteIndex].NoteType = ntFreestyle; - AddWord(Lines[0].Line[NrLine].Note[NoteIndex].Text); - end; - Selected := -1; -end; - -procedure TEditorLyrics.Clear; -begin - SetLength(Word, 0); - SelectedI := -1; -end; - -procedure TEditorLyrics.Refresh; -var - WordIndex: integer; - TotalWidth: real; -begin - if AlignI = atCenter then - begin - TotalWidth := 0; - for WordIndex := 0 to High(Word) do - TotalWidth := TotalWidth + Word[WordIndex].Width; - - Word[0].X := XR - TotalWidth / 2; - for WordIndex := 1 to High(Word) do - Word[WordIndex].X := Word[WordIndex - 1].X + Word[WordIndex - 1].Width; - end; -end; - -procedure TEditorLyrics.Draw; -var - WordIndex: integer; -begin - for WordIndex := 0 to High(Word) do - begin - SetFontStyle(Word[WordIndex].FontStyle); - SetFontPos(Word[WordIndex].X + 10*ScreenX, Word[WordIndex].Y); - SetFontSize(Word[WordIndex].Size); - SetFontItalic(Word[WordIndex].Italic); - glColor3f(Word[WordIndex].ColR, Word[WordIndex].ColG, Word[WordIndex].ColB); - glPrint(Word[WordIndex].Text); - end; -end; - -end. diff --git a/src/base/UFiles.pas b/src/base/UFiles.pas deleted file mode 100644 index 5a258e3e..00000000 --- a/src/base/UFiles.pas +++ /dev/null @@ -1,212 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UFiles; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} -{$I switches.inc} - -uses - SysUtils, - Classes, - ULog, - UMusic, - USongs, - USong, - UPath; - -procedure ResetSingTemp; - -type - TSaveSongResult = (ssrOK, ssrFileError, ssrEncodingError); - -{** - * Throws a TEncodingException if the song's fields cannot be encoded in the - * requested encoding. - *} -function SaveSong(const Song: TSong; const Lines: TLines; const Name: IPath; Relative: boolean): TSaveSongResult; - -implementation - -uses - TextGL, - UIni, - UNote, - UPlatform, - UUnicodeUtils, - UTextEncoding; - -//-------------------- -// Resets the temporary Sentence Arrays for each Player and some other Variables -//-------------------- -procedure ResetSingTemp; -var - Count: integer; -begin - SetLength(Lines, Length(Player)); - for Count := 0 to High(Player) do begin - SetLength(Lines[Count].Line, 1); - SetLength(Lines[Count].Line[0].Note, 0); - Lines[Count].Line[0].Lyric := ''; - Player[Count].Score := 0; - Player[Count].LengthNote := 0; - Player[Count].HighNote := -1; - end; -end; - -//-------------------- -// Saves a Song -//-------------------- -function SaveSong(const Song: TSong; const Lines: TLines; const Name: IPath; Relative: boolean): TSaveSongResult; -var - C: integer; - N: integer; - S: AnsiString; - B: integer; - RelativeSubTime: integer; - NoteState: AnsiString; - SongFile: TTextFileStream; - - function EncodeToken(const Str: UTF8String): RawByteString; - var - Success: boolean; - begin - Success := EncodeStringUTF8(Str, Result, Song.Encoding); - if (not Success) then - SaveSong := ssrEncodingError; - end; - - procedure WriteCustomTags; - var - I: integer; - Line: RawByteString; - begin - for I := 0 to High(Song.CustomTags) do - begin - Line := EncodeToken(Song.CustomTags[I].Content); - if (Length(Song.CustomTags[I].Tag) > 0) then - Line := EncodeToken(Song.CustomTags[I].Tag) + ':' + Line; - - SongFile.WriteLine('#' + Line); - end; - - end; - -begin - // Relative := true; // override (idea - use shift+S to save with relative) - Result := ssrOK; - - try - SongFile := TMemTextFileStream.Create(Name, fmCreate); - try - // to-do: should we really write the BOM? - // it causes problems w/ older versions - // e.g. usdx 1.0.1a or ultrastar < 0.7.0 - if (Song.Encoding = encUTF8) then - SongFile.WriteString(UTF8_BOM); - - SongFile.WriteLine('#ENCODING:' + EncodingName(Song.Encoding)); - SongFile.WriteLine('#TITLE:' + EncodeToken(Song.Title)); - SongFile.WriteLine('#ARTIST:' + EncodeToken(Song.Artist)); - - if Song.Creator <> '' then SongFile.WriteLine('#CREATOR:' + EncodeToken(Song.Creator)); - if Song.Edition <> 'Unknown' then SongFile.WriteLine('#EDITION:' + EncodeToken(Song.Edition)); - if Song.Genre <> 'Unknown' then SongFile.WriteLine('#GENRE:' + EncodeToken(Song.Genre)); - if Song.Language <> 'Unknown' then SongFile.WriteLine('#LANGUAGE:' + EncodeToken(Song.Language)); - if Song.Year <> 0 then SongFile.WriteLine('#YEAR:' + IntToStr(Song.Year)); - - SongFile.WriteLine('#MP3:' + EncodeToken(Song.Mp3.ToUTF8)); - if Song.Cover.IsSet then SongFile.WriteLine('#COVER:' + EncodeToken(Song.Cover.ToUTF8)); - if Song.Background.IsSet then SongFile.WriteLine('#BACKGROUND:' + EncodeToken(Song.Background.ToUTF8)); - if Song.Video.IsSet then SongFile.WriteLine('#VIDEO:' + EncodeToken(Song.Video.ToUTF8)); - - if Song.VideoGAP <> 0 then SongFile.WriteLine('#VIDEOGAP:' + FloatToStr(Song.VideoGAP)); - if Song.Resolution <> 4 then SongFile.WriteLine('#RESOLUTION:' + IntToStr(Song.Resolution)); - if Song.NotesGAP <> 0 then SongFile.WriteLine('#NOTESGAP:' + IntToStr(Song.NotesGAP)); - if Song.Start <> 0 then SongFile.WriteLine('#START:' + FloatToStr(Song.Start)); - if Song.Finish <> 0 then SongFile.WriteLine('#END:' + IntToStr(Song.Finish)); - if Relative then SongFile.WriteLine('#RELATIVE:yes'); - - SongFile.WriteLine('#BPM:' + FloatToStr(Song.BPM[0].BPM / 4)); - SongFile.WriteLine('#GAP:' + FloatToStr(Song.GAP)); - - // write custom header tags - WriteCustomTags; - - RelativeSubTime := 0; - for B := 1 to High(Song.BPM) do - SongFile.WriteLine('B ' + FloatToStr(Song.BPM[B].StartBeat) + ' ' - + FloatToStr(Song.BPM[B].BPM/4)); - - for C := 0 to Lines.High do - begin - for N := 0 to Lines.Line[C].HighNote do - begin - with Lines.Line[C].Note[N] do - begin - //Golden + Freestyle Note Patch - case Lines.Line[C].Note[N].NoteType of - ntFreestyle: NoteState := 'F '; - ntNormal: NoteState := ': '; - ntGolden: NoteState := '* '; - end; // case - S := NoteState + IntToStr(Start-RelativeSubTime) + ' ' - + IntToStr(Length) + ' ' - + IntToStr(Tone) + ' ' - + EncodeToken(Text); - - SongFile.WriteLine(S); - end; // with - end; // N - - if C < Lines.High then // don't write end of last sentence - begin - if not Relative then - S := '- ' + IntToStr(Lines.Line[C+1].Start) - else - begin - S := '- ' + IntToStr(Lines.Line[C+1].Start - RelativeSubTime) + - ' ' + IntToStr(Lines.Line[C+1].Start - RelativeSubTime); - RelativeSubTime := Lines.Line[C+1].Start; - end; - SongFile.WriteLine(S); - end; - end; // C - - SongFile.WriteLine('E'); - finally - SongFile.Free; - end; - except - Result := ssrFileError; - end; -end; - -end. - diff --git a/src/base/UFilesystem.pas b/src/base/UFilesystem.pas deleted file mode 100644 index d4972df5..00000000 --- a/src/base/UFilesystem.pas +++ /dev/null @@ -1,692 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UFilesystem; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - {$IFDEF MSWINDOWS} - Windows, - TntSysUtils, - {$ENDIF} - UPath; - -type - {$IFDEF MSWINDOWS} - TSytemSearchRec = TSearchRecW; - {$ELSE} - TSytemSearchRec = TSearchRec; - {$ENDIF} - - TFileInfo = record - Time: integer; // timestamp - Size: int64; // file size (byte) - Attr: integer; // file attributes - Name: IPath; // basename with extension - end; - - {** - * Iterates through the search results retrieved by FileFind(). - * Example usage: - * while(Iter.HasNext()) do - * SearchRec := Iter.Next(); - *} - IFileIterator = interface - function HasNext(): boolean; - function Next(): TFileInfo; - end; - - {** - * Wrapper for SysUtils file functions. - * For documentation and examples, check the SysUtils equivalent. - *} - IFileSystem = interface - function ExpandFileName(const FileName: IPath): IPath; - function FileCreate(const FileName: IPath): THandle; - function DirectoryCreate(const Dir: IPath): boolean; - function FileOpen(const FileName: IPath; Mode: longword): THandle; - function FileAge(const FileName: IPath): integer; overload; - function FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; overload; - - function DirectoryExists(const Name: IPath): boolean; - - {** - * On Windows: returns true only for files (not directories) - * On Apple/Unix: returns true for all kind of files (even directories) - * @seealso SysUtils.FileExists() - *} - function FileExists(const Name: IPath): boolean; - - function FileGetAttr(const FileName: IPath): Cardinal; - function FileSetAttr(const FileName: IPath; Attr: integer): boolean; - function FileIsReadOnly(const FileName: IPath): boolean; - function FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; - function FileIsAbsolute(const FileName: IPath): boolean; - function ForceDirectories(const Dir: IPath): boolean; - function RenameFile(const OldName, NewName: IPath): boolean; - function DeleteFile(const FileName: IPath): boolean; - function RemoveDir(const Dir: IPath): boolean; - - {** - * Copies file Source to Target. If FailIfExists is true, the file is not - * copied if it already exists. - * Returns true if the file was successfully copied. - *} - function CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; - - function ExtractFileDrive(const FileName: IPath): IPath; - function ExtractFilePath(const FileName: IPath): IPath; - function ExtractFileDir(const FileName: IPath): IPath; - function ExtractFileName(const FileName: IPath): IPath; - function ExtractFileExt(const FileName: IPath): IPath; - function ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; - - function ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; - - function IncludeTrailingPathDelimiter(const FileName: IPath): IPath; - function ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; - - {** - * Searches for a file with filename Name in the directories given in DirList. - *} - function FileSearch(const Name: IPath; DirList: array of IPath): IPath; - - {** - * More convenient version of FindFirst/Next/Close with iterator support. - *} - function FileFind(const FilePattern: IPath; Attr: integer): IFileIterator; - - {** - * Old style search functions. Use FileFind() instead. - *} - function FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; - function FindNext(var F: TSytemSearchRec): integer; - procedure FindClose(var F: TSytemSearchRec); - - function GetCurrentDir: IPath; - function SetCurrentDir(const Dir: IPath): boolean; - - {** - * Returns true if the filesystem is case-sensitive. - *} - function IsCaseSensitive(): boolean; - end; - - function FileSystem(): IFileSystem; - -implementation - -type - TFileSystemImpl = class(TInterfacedObject, IFileSystem) - public - function ExpandFileName(const FileName: IPath): IPath; - function FileCreate(const FileName: IPath): THandle; - function DirectoryCreate(const Dir: IPath): boolean; - function FileOpen(const FileName: IPath; Mode: longword): THandle; - function FileAge(const FileName: IPath): integer; overload; - function FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; overload; - function DirectoryExists(const Name: IPath): boolean; - function FileExists(const Name: IPath): boolean; - function FileGetAttr(const FileName: IPath): Cardinal; - function FileSetAttr(const FileName: IPath; Attr: integer): boolean; - function FileIsReadOnly(const FileName: IPath): boolean; - function FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; - function FileIsAbsolute(const FileName: IPath): boolean; - function ForceDirectories(const Dir: IPath): boolean; - function RenameFile(const OldName, NewName: IPath): boolean; - function DeleteFile(const FileName: IPath): boolean; - function RemoveDir(const Dir: IPath): boolean; - function CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; - - function ExtractFileDrive(const FileName: IPath): IPath; - function ExtractFilePath(const FileName: IPath): IPath; - function ExtractFileDir(const FileName: IPath): IPath; - function ExtractFileName(const FileName: IPath): IPath; - function ExtractFileExt(const FileName: IPath): IPath; - function ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; - function ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; - function IncludeTrailingPathDelimiter(const FileName: IPath): IPath; - function ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; - - function FileSearch(const Name: IPath; DirList: array of IPath): IPath; - function FileFind(const FilePattern: IPath; Attr: integer): IFileIterator; - - function FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; - function FindNext(var F: TSytemSearchRec): integer; - procedure FindClose(var F: TSytemSearchRec); - - function GetCurrentDir: IPath; - function SetCurrentDir(const Dir: IPath): boolean; - - function IsCaseSensitive(): boolean; - end; - - TFileIterator = class(TInterfacedObject, IFileIterator) - private - fHasNext: boolean; - fSearchRec: TSytemSearchRec; - public - constructor Create(const FilePattern: IPath; Attr: integer); - destructor Destroy(); override; - - function HasNext(): boolean; - function Next(): TFileInfo; - end; - - -var - FileSystem_Singleton: IFileSystem; - -function FileSystem(): IFileSystem; -begin - Result := FileSystem_Singleton; -end; - -function TFileSystemImpl.FileFind(const FilePattern: IPath; Attr: integer): IFileIterator; -begin - Result := TFileIterator.Create(FilePattern, Attr); -end; - -function TFileSystemImpl.IsCaseSensitive(): boolean; -begin - // Windows and Mac OS X do not have case sensitive file systems - {$IF Defined(MSWINDOWS) or Defined(DARWIN)} - Result := false; - {$ELSE} - Result := true; - {$IFEND} -end; - -function TFileSystemImpl.FileIsAbsolute(const FileName: IPath): boolean; -var - NameStr: UTF8String; -begin - Result := true; - NameStr := FileName.ToUTF8(); - - {$IFDEF MSWINDOWS} - // check if drive is given 'C:...' - if (FileName.GetDrive().ToUTF8 <> '') then - Exit; - // check if path starts with '\\' - if (Length(NameStr) >= 2) and - (NameStr[1] = PathDelim) and (NameStr[2] = PathDelim) then - Exit; - {$ELSE} // Unix based systems - // check if root dir given '/...' - if (Length(NameStr) >= 1) and (NameStr[1] = PathDelim) then - Exit; - {$ENDIF} - - Result := false; -end; - -{$IFDEF MSWINDOWS} - -function TFileSystemImpl.ExpandFileName(const FileName: IPath): IPath; -begin - Result := Path(WideExpandFileName(FileName.ToWide())); -end; - -function TFileSystemImpl.FileCreate(const FileName: IPath): THandle; -begin - Result := WideFileCreate(FileName.ToWide()); -end; - -function TFileSystemImpl.DirectoryCreate(const Dir: IPath): boolean; -begin - Result := WideCreateDir(Dir.ToWide()); -end; - -function TFileSystemImpl.FileOpen(const FileName: IPath; Mode: longword): THandle; -begin - Result := WideFileOpen(FileName.ToWide(), Mode); -end; - -function TFileSystemImpl.FileAge(const FileName: IPath): integer; -begin - Result := WideFileAge(FileName.ToWide()); -end; - -function TFileSystemImpl.FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; -begin - Result := WideFileAge(FileName.ToWide(), FileDateTime); -end; - -function TFileSystemImpl.DirectoryExists(const Name: IPath): boolean; -begin - Result := WideDirectoryExists(Name.ToWide()); -end; - -function TFileSystemImpl.FileExists(const Name: IPath): boolean; -begin - Result := WideFileExists(Name.ToWide()); -end; - -function TFileSystemImpl.FileGetAttr(const FileName: IPath): Cardinal; -begin - Result := WideFileGetAttr(FileName.ToWide()); -end; - -function TFileSystemImpl.FileSetAttr(const FileName: IPath; Attr: integer): boolean; -begin - Result := WideFileSetAttr(FileName.ToWide(), Attr); -end; - -function TFileSystemImpl.FileIsReadOnly(const FileName: IPath): boolean; -begin - Result := WideFileIsReadOnly(FileName.ToWide()); -end; - -function TFileSystemImpl.FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; -begin - Result := WideFileSetReadOnly(FileName.ToWide(), ReadOnly); -end; - -function TFileSystemImpl.ForceDirectories(const Dir: IPath): boolean; -begin - Result := WideForceDirectories(Dir.ToWide()); -end; - -function TFileSystemImpl.FileSearch(const Name: IPath; DirList: array of IPath): IPath; -var - I: integer; - DirListStr: WideString; -begin - DirListStr := ''; - for I := 0 to High(DirList) do - begin - if (I > 0) then - DirListStr := DirListStr + PathSep; - DirListStr := DirListStr + DirList[I].ToWide(); - end; - Result := Path(WideFileSearch(Name.ToWide(), DirListStr)); -end; - -function TFileSystemImpl.RenameFile(const OldName, NewName: IPath): boolean; -begin - Result := WideRenameFile(OldName.ToWide(), NewName.ToWide()); -end; - -function TFileSystemImpl.DeleteFile(const FileName: IPath): boolean; -begin - Result := WideDeleteFile(FileName.ToWide()); -end; - -function TFileSystemImpl.RemoveDir(const Dir: IPath): boolean; -begin - Result := WideRemoveDir(Dir.ToWide()); -end; - -function TFileSystemImpl.CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; -begin - Result := WideCopyFile(Source.ToWide(), Target.ToWide(), FailIfExists); -end; - -function TFileSystemImpl.ExtractFileDrive(const FileName: IPath): IPath; -begin - Result := Path(WideExtractFileDrive(FileName.ToWide())); -end; - -function TFileSystemImpl.ExtractFilePath(const FileName: IPath): IPath; -begin - Result := Path(WideExtractFilePath(FileName.ToWide())); -end; - -function TFileSystemImpl.ExtractFileDir(const FileName: IPath): IPath; -begin - Result := Path(WideExtractFileDir(FileName.ToWide())); -end; - -function TFileSystemImpl.ExtractFileName(const FileName: IPath): IPath; -begin - Result := Path(WideExtractFileName(FileName.ToWide())); -end; - -function TFileSystemImpl.ExtractFileExt(const FileName: IPath): IPath; -begin - Result := Path(WideExtractFileExt(FileName.ToWide())); -end; - -function TFileSystemImpl.ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; -begin - Result := Path(WideExtractRelativePath(BaseName.ToWide(), FileName.ToWide())); -end; - -function TFileSystemImpl.ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; -begin - Result := Path(WideChangeFileExt(FileName.ToWide(), Extension.ToWide())); -end; - -function TFileSystemImpl.IncludeTrailingPathDelimiter(const FileName: IPath): IPath; -begin - Result := Path(WideIncludeTrailingPathDelimiter(FileName.ToWide())); -end; - -function TFileSystemImpl.ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; -begin - Result := Path(WideExcludeTrailingPathDelimiter(FileName.ToWide())); -end; - -function TFileSystemImpl.FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; -begin - Result := WideFindFirst(FilePattern.ToWide(), Attr, F); -end; - -function TFileSystemImpl.FindNext(var F: TSytemSearchRec): integer; -begin - Result := WideFindNext(F); -end; - -procedure TFileSystemImpl.FindClose(var F: TSytemSearchRec); -begin - WideFindClose(F); -end; - -function TFileSystemImpl.GetCurrentDir: IPath; -begin - Result := Path(WideGetCurrentDir()); -end; - -function TFileSystemImpl.SetCurrentDir(const Dir: IPath): boolean; -begin - Result := WideSetCurrentDir(Dir.ToWide()); -end; - -{$ELSE} // UNIX - -function TFileSystemImpl.ExpandFileName(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExpandFileName(FileName.ToNative())); -end; - -function TFileSystemImpl.FileCreate(const FileName: IPath): THandle; -begin - Result := SysUtils.FileCreate(FileName.ToNative()); -end; - -function TFileSystemImpl.DirectoryCreate(const Dir: IPath): boolean; -begin - Result := SysUtils.CreateDir(Dir.ToNative()); -end; - -function TFileSystemImpl.FileOpen(const FileName: IPath; Mode: longword): THandle; -begin - Result := SysUtils.FileOpen(FileName.ToNative(), Mode); -end; - -function TFileSystemImpl.FileAge(const FileName: IPath): integer; -begin - Result := SysUtils.FileAge(FileName.ToNative()); -end; - -function TFileSystemImpl.FileAge(const FileName: IPath; out FileDateTime: TDateTime): boolean; -var - FileDate: integer; -begin - FileDate := SysUtils.FileAge(FileName.ToNative()); - Result := (FileDate <> -1); - if (Result) then - FileDateTime := FileDateToDateTime(FileDate); -end; - -function TFileSystemImpl.DirectoryExists(const Name: IPath): boolean; -begin - Result := SysUtils.DirectoryExists(Name.ToNative()); -end; - -function TFileSystemImpl.FileExists(const Name: IPath): boolean; -begin - Result := SysUtils.FileExists(Name.ToNative()); -end; - -function TFileSystemImpl.FileGetAttr(const FileName: IPath): Cardinal; -begin - Result := SysUtils.FileGetAttr(FileName.ToNative()); -end; - -function TFileSystemImpl.FileSetAttr(const FileName: IPath; Attr: integer): boolean; -begin - Result := (SysUtils.FileSetAttr(FileName.ToNative(), Attr) = 0); -end; - -function TFileSystemImpl.FileIsReadOnly(const FileName: IPath): boolean; -begin - Result := SysUtils.FileIsReadOnly(FileName.ToNative()); -end; - -function TFileSystemImpl.FileSetReadOnly(const FileName: IPath; ReadOnly: boolean): boolean; -begin - Result := (SysUtils.FileSetAttr(FileName.ToNative(), faReadOnly) = 0); -end; - -function TFileSystemImpl.ForceDirectories(const Dir: IPath): boolean; -begin - Result := SysUtils.ForceDirectories(Dir.ToNative()); -end; - -function TFileSystemImpl.FileSearch(const Name: IPath; DirList: array of IPath): IPath; -var - I: integer; - DirListStr: AnsiString; -begin - DirListStr := ''; - for I := 0 to High(DirList) do - begin - if (I > 0) then - DirListStr := DirListStr + PathSep; - DirListStr := DirListStr + DirList[I].ToNative(); - end; - Result := Path(SysUtils.FileSearch(Name.ToNative(), DirListStr)); -end; - -function TFileSystemImpl.RenameFile(const OldName, NewName: IPath): boolean; -begin - Result := SysUtils.RenameFile(OldName.ToNative(), NewName.ToNative()); -end; - -function TFileSystemImpl.DeleteFile(const FileName: IPath): boolean; -begin - Result := SysUtils.DeleteFile(FileName.ToNative()); -end; - -function TFileSystemImpl.RemoveDir(const Dir: IPath): boolean; -begin - Result := SysUtils.RemoveDir(Dir.ToNative()); -end; - -function TFileSystemImpl.CopyFile(const Source, Target: IPath; FailIfExists: boolean): boolean; -const - COPY_BUFFER_SIZE = 4096; // a good tradeoff between speed and memory consumption -var - SourceFile, TargetFile: TFileStream; - FileCopyBuffer: array [0..COPY_BUFFER_SIZE-1] of byte; // temporary copy-buffer. - NumberOfBytes: integer; // number of bytes read from SourceFile -begin - Result := false; - SourceFile := nil; - TargetFile := nil; - - // if overwrite is disabled return if the target file already exists - if (FailIfExists and FileExists(Target)) then - Exit; - - try - try - // open source and target file (might throw an exception on error) - SourceFile := TFileStream.Create(Source.ToNative(), fmOpenRead); - TargetFile := TFileStream.Create(Target.ToNative(), fmCreate or fmOpenWrite); - - while true do - begin - // read a block from the source file and check for errors or EOF - NumberOfBytes := SourceFile.Read(FileCopyBuffer, SizeOf(FileCopyBuffer)); - if (NumberOfBytes <= 0) then - Break; - // write block to target file and check if everything was written - if (TargetFile.Write(FileCopyBuffer, NumberOfBytes) <> NumberOfBytes) then - Exit; - end; - except - Exit; - end; - finally - SourceFile.Free; - TargetFile.Free; - end; - - Result := true; -end; - -function TFileSystemImpl.ExtractFileDrive(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExtractFileDrive(FileName.ToNative())); -end; - -function TFileSystemImpl.ExtractFilePath(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExtractFilePath(FileName.ToNative())); -end; - -function TFileSystemImpl.ExtractFileDir(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExtractFileDir(FileName.ToNative())); -end; - -function TFileSystemImpl.ExtractFileName(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExtractFileName(FileName.ToNative())); -end; - -function TFileSystemImpl.ExtractFileExt(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExtractFileExt(FileName.ToNative())); -end; - -function TFileSystemImpl.ExtractRelativePath(const BaseName: IPath; const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExtractRelativePath(BaseName.ToNative(), FileName.ToNative())); -end; - -function TFileSystemImpl.ChangeFileExt(const FileName: IPath; const Extension: IPath): IPath; -begin - Result := Path(SysUtils.ChangeFileExt(FileName.ToNative(), Extension.ToNative())); -end; - -function TFileSystemImpl.IncludeTrailingPathDelimiter(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.IncludeTrailingPathDelimiter(FileName.ToNative())); -end; - -function TFileSystemImpl.ExcludeTrailingPathDelimiter(const FileName: IPath): IPath; -begin - Result := Path(SysUtils.ExcludeTrailingPathDelimiter(FileName.ToNative())); -end; - -function TFileSystemImpl.FindFirst(const FilePattern: IPath; Attr: integer; var F: TSytemSearchRec): integer; -begin - Result := SysUtils.FindFirst(FilePattern.ToNative(), Attr, F); -end; - -function TFileSystemImpl.FindNext(var F: TSytemSearchRec): integer; -begin - Result := SysUtils.FindNext(F); -end; - -procedure TFileSystemImpl.FindClose(var F: TSytemSearchRec); -begin - SysUtils.FindClose(F); -end; - -function TFileSystemImpl.GetCurrentDir: IPath; -begin - Result := Path(SysUtils.GetCurrentDir()); -end; - -function TFileSystemImpl.SetCurrentDir(const Dir: IPath): boolean; -begin - Result := SysUtils.SetCurrentDir(Dir.ToNative()); -end; - -{$ENDIF} - - -{ TFileIterator } - -constructor TFileIterator.Create(const FilePattern: IPath; Attr: integer); -begin - inherited Create(); - fHasNext := (FileSystem.FindFirst(FilePattern, Attr, fSearchRec) = 0); -end; - -destructor TFileIterator.Destroy(); -begin - FileSystem.FindClose(fSearchRec); - inherited; -end; - -function TFileIterator.HasNext(): boolean; -begin - Result := fHasNext; -end; - -function TFileIterator.Next(): TFileInfo; -begin - if (not fHasNext) then - begin - // Note: do not use FillChar() on records with ref-counted fields - Result.Time := 0; - Result.Size := 0; - Result.Attr := 0; - Result.Name := nil; - Exit; - end; - - Result.Time := fSearchRec.Time; - Result.Size := fSearchRec.Size; - Result.Attr := fSearchRec.Attr; - Result.Name := Path(fSearchRec.Name); - - // fetch next entry - fHasNext := (FileSystem.FindNext(fSearchRec) = 0); -end; - - -initialization - FileSystem_Singleton := TFileSystemImpl.Create; - -finalization - FileSystem_Singleton := nil; - -end. diff --git a/src/base/UFont.pas b/src/base/UFont.pas deleted file mode 100644 index 191e74d2..00000000 --- a/src/base/UFont.pas +++ /dev/null @@ -1,2798 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UFont; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -interface - -{$IFNDEF FREETYPE_DEMO} - // Flip direction of y-axis. - // Default is a cartesian coordinate system with y-axis in upper direction - // but with USDX the y-axis is in lower direction. - {$DEFINE FLIP_YAXIS} - {$DEFINE BITMAP_FONT} -{$ENDIF} - -uses - FreeType, - gl, - glext, - glu, - sdl, - Math, - Classes, - SysUtils, - UUnicodeUtils, - {$IFDEF BITMAP_FONT} - UTexture, - {$ENDIF} - UPath; - -type - - PGLubyteArray = ^TGLubyteArray; - TGLubyteArray = array[0 .. (MaxInt div SizeOf(GLubyte))-1] of GLubyte; - TGLubyteDynArray = array of GLubyte; - - TUCS4StringArray = array of UCS4String; - - TGLColor = packed record - case byte of - 0: ( vals: array[0..3] of GLfloat; ); - 1: ( r, g, b, a: GLfloat; ); - end; - - TBoundsDbl = record - Left, Right: double; - Bottom, Top: double; - end; - - TPositionDbl = record - X, Y: double; - end; - - TTextureSize = record - Width, Height: integer; - end; - - TBitmapCoords = record - Left, Top: double; - Width, Height: integer; - end; - - {** - * Abstract base class representing a glyph. - *} - TGlyph = class - protected - function GetAdvance(): TPositionDbl; virtual; abstract; - function GetBounds(): TBoundsDbl; virtual; abstract; - public - procedure Render(UseDisplayLists: boolean); virtual; abstract; - procedure RenderReflection(); virtual; abstract; - - {** Distance to next glyph (in pixels) *} - property Advance: TPositionDbl read GetAdvance; - {** Glyph bounding box (in pixels) *} - property Bounds: TBoundsDbl read GetBounds; - end; - - {** - * Font styles used by TFont.Style - *} - TFontStyle = set of (Italic, Underline, Reflect); - - {** - * Base font class. - *} - TFont = class - private - {** Non-virtual reset-method used in Create() and Reset() } - procedure ResetIntern(); - - protected - fStyle: TFontStyle; - fUseKerning: boolean; - fLineSpacing: single; // must be inited by subclass - fReflectionSpacing: single; // must be inited by subclass to -2*Descender - fGlyphSpacing: single; - fReflectionPass: boolean; - - {** - * Splits lines in Text seperated by newline (char-code #13). - * @param Text UCS-4 encoded string - * @param Lines splitted UCS4String lines - *} - procedure SplitLines(const Text: UCS4String; var Lines: TUCS4StringArray); - - {** - * Print an array of UCS4Strings. Each array-item is a line of text. - * Lines of text are seperated by the line-spacing. - * This is the base function for all text drawing. - *} - procedure Print(const Text: TUCS4StringArray); overload; virtual; - - {** - * Draws an underline. - *} - procedure DrawUnderline(const Text: UCS4String); virtual; - - {** - * Renders (one) line of text. - *} - procedure Render(const Text: UCS4String); virtual; abstract; - - {** - * Returns the bounds of text-lines contained in Text. - * @param(Advance if true the right bound is set to the advance instead - * of the minimal right bound.) - *} - function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; overload; virtual; abstract; - - {** - * Resets all user settings to default values. - * Override methods should always call the inherited version. - *} - procedure Reset(); virtual; - - function GetHeight(): single; virtual; abstract; - function GetAscender(): single; virtual; abstract; - function GetDescender(): single; virtual; abstract; - procedure SetLineSpacing(Spacing: single); virtual; - function GetLineSpacing(): single; virtual; - procedure SetGlyphSpacing(Spacing: single); virtual; - function GetGlyphSpacing(): single; virtual; - procedure SetReflectionSpacing(Spacing: single); virtual; - function GetReflectionSpacing(): single; virtual; - procedure SetStyle(Style: TFontStyle); virtual; - function GetStyle(): TFontStyle; virtual; - function GetUnderlinePosition(): single; virtual; abstract; - function GetUnderlineThickness(): single; virtual; abstract; - procedure SetUseKerning(Enable: boolean); virtual; - function GetUseKerning(): boolean; virtual; - procedure SetReflectionPass(Enable: boolean); virtual; - - {** Returns true if the current render-pass is used to draw the reflection } - property ReflectionPass: boolean read fReflectionPass write SetReflectionPass; - - public - constructor Create(); - destructor Destroy(); override; - - {** - * Prints a text. - *} - procedure Print(const Text: UCS4String); overload; - {** UTF-16 version of @link(Print) } - procedure Print(const Text: WideString); overload; - {** UTF-8 version of @link(Print) } - procedure Print(const Text: UTF8String); overload; - - {** - * Calculates the bounding box (width and height) around Text. - * Works with Italic and Underline styles but reflections created - * with the Reflect style are not considered. - * Note that the width might differ due to kerning with appended text, - * e.g. Width('VA') <= Width('V') + Width('A'). - * @param Advance if set to true, Result.Right is set to the advance of - * the given text rather than the min. right border. The advance width is - * bigger than the text's width as it additionally contains the advance - * and glyph-spacing of the last character. - *} - function BBox(const Text: UCS4String; Advance: boolean = true): TBoundsDbl; overload; - {** UTF-16 version of @link(BBox) } - function BBox(const Text: WideString; Advance: boolean = true): TBoundsDbl; overload; - {** UTF-8 version of @link(BBox) } - function BBox(const Text: UTF8String; Advance: boolean = true): TBoundsDbl; overload; - - {** Font height } - property Height: single read GetHeight; - {** Vertical distance from baseline to top of glyph } - property Ascender: single read GetAscender; - {** Vertical distance from baseline to bottom of glyph } - property Descender: single read GetDescender; - {** Vertical distance between two baselines } - property LineSpacing: single read GetLineSpacing write SetLineSpacing; - {** Space between end and start of next glyph added to the advance width } - property GlyphSpacing: single read GetGlyphSpacing write SetGlyphSpacing; - {** Distance between normal baseline and baseline of the reflection } - property ReflectionSpacing: single read GetReflectionSpacing write SetReflectionSpacing; - {** Font style (italic/underline/...) } - property Style: TFontStyle read GetStyle write SetStyle; - {** If set to true (default) kerning will be used if available } - property UseKerning: boolean read GetUseKerning write SetUseKerning; - end; - -const - //** Max. number of mipmap levels that a TScalableFont can contain - cMaxMipmapLevel = 5; - -type - {** - * Wrapper around TFont to allow font size changes. - * The font is scaled to the requested size by a modelview matrix - * transformation (glScale) and not by rescaling the internal bitmap - * representation. This way changing the size is really fast but the result - * may lack quality on large or small scale factors. - *} - TScalableFont = class(TFont) - private - procedure ResetIntern(); - - protected - fScale: single; //**< current height to base-font height ratio - fAspect: single; //**< width to height aspect - fBaseFont: TFont; //**< shortcut for fMipmapFonts[0] - fUseMipmaps: boolean; //**< true if mipmap fonts are generated - /// Mipmap fonts (size[level+1] = size[level]/2) - fMipmapFonts: array[0..cMaxMipmapLevel] of TFont; - - procedure Render(const Text: UCS4String); override; - procedure Print(const Text: TUCS4StringArray); override; - function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; - - {** - * Callback called for creation of each mipmap font. - * Must be defined by the subclass. - * Mipmaps created by this method are managed and freed by TScalableFont. - *} - function CreateMipmap(Level: integer; Scale: single): TFont; virtual; abstract; - - {** - * Returns the mipmap level considering the current scale and projection - * matrix. - *} - function GetMipmapLevel(): integer; - - {** - * Returns the scale applied to the given mipmap font. - * fScale * fBaseFont.Height / fMipmapFont[Level].Height - *} - function GetMipmapScale(Level: integer): single; - - {** - * Chooses the mipmap that looks nicest with current scale and projection - * matrix. - *} - function ChooseMipmapFont(): TFont; - - procedure SetHeight(Height: single); virtual; - function GetHeight(): single; override; - procedure SetAspect(Aspect: single); virtual; - function GetAspect(): single; virtual; - function GetAscender(): single; override; - function GetDescender(): single; override; - procedure SetLineSpacing(Spacing: single); override; - function GetLineSpacing(): single; override; - procedure SetGlyphSpacing(Spacing: single); override; - function GetGlyphSpacing(): single; override; - procedure SetReflectionSpacing(Spacing: single); override; - function GetReflectionSpacing(): single; override; - procedure SetStyle(Style: TFontStyle); override; - function GetStyle(): TFontStyle; override; - function GetUnderlinePosition(): single; override; - function GetUnderlineThickness(): single; override; - procedure SetUseKerning(Enable: boolean); override; - - public - {** - * Creates a wrapper to make the base-font Font scalable. - * If UseMipmaps is set to true smaller fonts are created so that a - * resized (Height property changed) font looks nicer. - * The font passed is managed and freed by TScalableFont. - *} - constructor Create(Font: TFont; UseMipmaps: boolean); overload; - - {** - * Frees memory. The fonts passed on Create() and mipmap creation - * are freed too. - *} - destructor Destroy(); override; - - {** @seealso TFont.Reset } - procedure Reset(); override; - - {** Font height } - property Height: single read GetHeight write SetHeight; - {** Factor for font stretching (NewWidth = Width*Aspect), 1.0 by default } - property Aspect: single read GetAspect write SetAspect; - end; - - {** - * Table for storage of max. 256 glyphs. - * Used for the second cache level. Indexed by the LSB of the UCS4Char - * char-code. - *} - PGlyphTable = ^TGlyphTable; - TGlyphTable = array[0..255] of TGlyph; - - {** - * Cache for glyphs of a single font. - * The cached glyphs are stored inside a hash-list. - * Hashing is performed in two steps: - * 1. the least significant byte (LSB) of the UCS4Char character code - * is removed (shr 8) and the result (we call it BaseCode here) looked up in - * the hash-list. - * 2. Each entry of the hash-list contains a table with max. 256 entries. - * The LSB of the char-code of a glyph is the table-offset of that glyph. - *} - TGlyphCache = class - private - fHash: TList; - - {** - * Finds a glyph-table storing cached glyphs with base-code BaseCode - * (= upper char-code bytes) in the hash-list and returns the table and - * its index. - * @param(InsertPos the position of the tyble in the list if it was found, - * otherwise the position the table should be inserted) - *} - function FindGlyphTable(BaseCode: cardinal; out InsertPos: integer): PGlyphTable; - - public - constructor Create(); - destructor Destroy(); override; - - {** - * Add glyph Glyph with char-code ch to the cache. - * @returns @true on success, @false otherwise - *} - function AddGlyph(ch: UCS4Char; const Glyph: TGlyph): boolean; - - {** - * Removes the glyph with char-code ch from the cache. - *} - procedure DeleteGlyph(ch: UCS4Char); - - {** - * Removes the glyph with char-code ch from the cache. - *} - function GetGlyph(ch: UCS4Char): TGlyph; - - {** - * Checks if a glyph with char-code ch is cached. - *} - function HasGlyph(ch: UCS4Char): boolean; - - {** - * Remove and free all cached glyphs. If KeepBaseSet is set to - * true, cached characters in the range 0..255 will not be flushed. - *} - procedure FlushCache(KeepBaseSet: boolean); - end; - - {** - * Entry of a glyph-cache's (TGlyphCache) hash. - * Stores a BaseCode (upper-bytes of a glyph's char-code) and a table - * with all glyphs cached at the moment with that BaseCode. - *} - TGlyphCacheHashEntry = class - private - fBaseCode: cardinal; - public - GlyphTable: TGlyphTable; - - constructor Create(BaseCode: cardinal); - - {** Base-code (upper-bytes) of the glyphs stored in this entry's table } - property BaseCode: cardinal read fBaseCode; - end; - - TCachedFont = class(TFont) - protected - fCache: TGlyphCache; - - {** - * Retrieves a cached glyph with char-code ch from cache. - * If the glyph is not already cached, it is loaded with LoadGlyph(). - *} - function GetGlyph(ch: UCS4Char): TGlyph; - - {** - * Callback to create (load) a glyph with char-code ch. - * Implemented by subclasses. - *} - function LoadGlyph(ch: UCS4Char): TGlyph; virtual; abstract; - - public - constructor Create(); - destructor Destroy(); override; - - {** - * Remove and free all cached glyphs. If KeepBaseSet is set to - * true, the base glyphs are not be flushed. - * @seealso TGlyphCache.FlushCache - *} - procedure FlushCache(KeepBaseSet: boolean); - end; - - TFTFont = class; - - {** - * Freetype glyph. - * Each glyph stores a texture with the glyph's image. - *} - TFTGlyph = class(TGlyph) - private - fCharCode: UCS4Char; //**< Char code - fCharIndex: FT_UInt; //**< Freetype specific char-index (<> char-code) - fDisplayList: GLuint; //**< Display-list ID - fTexture: GLuint; //**< Texture ID - fBitmapCoords: TBitmapCoords; //**< Left/Top offset and Width/Height of the bitmap (in pixels) - fTexOffset: TPositionDbl; //**< Right and bottom texture offset for removal of power-of-2 padding - fTexSize: TTextureSize; //**< Texture size in pixels - - fFont: TFTFont; //**< Font associated with this glyph - fAdvance: TPositionDbl; //**< Advance width of this glyph - fBounds: TBoundsDbl; //**< Glyph bounds - fOutset: single; //**< Extrusion outset - - {** - * Extrudes the outline of a glyph's bitmap stored in TexBuffer with size - * fTexSize by Outset pixels. - * This is useful to create bold or outlined fonts. - * TexBuffer must be 2*Ceil(Outset) pixels higher and wider than the - * original glyph bitmap, otherwise the glyph borders cannot be extruded - * correctly. - * The bitmap must be 2* pixels wider and higher than the - * original glyph's bitmap with the latter centered in it. - *} - procedure StrokeBorder(var Glyph: FT_Glyph); - - {** - * Creates an OpenGL texture (and display list) for the glyph. - * The glyph's and bitmap's metrics are set correspondingly. - * @param LoadFlags flags passed to FT_Load_Glyph() - * @raises Exception if the glyph could not be initialized - *} - procedure CreateTexture(LoadFlags: FT_Int32); - - protected - function GetAdvance(): TPositionDbl; override; - function GetBounds(): TBoundsDbl; override; - - public - {** - * Creates a glyph with char-code ch from font Font. - * @param LoadFlags flags passed to FT_Load_Glyph() - *} - constructor Create(Font: TFTFont; ch: UCS4Char; Outset: single; - LoadFlags: FT_Int32); - destructor Destroy(); override; - - {** Renders the glyph (normal render pass) } - procedure Render(UseDisplayLists: boolean); override; - {** Renders the glyph's reflection } - procedure RenderReflection(); override; - - {** Freetype specific char-index (<> char-code) } - property CharIndex: FT_UInt read fCharIndex; - end; - - TFontPart = ( fpNone, fpInner, fpOutline ); - - {** - * Freetype font class. - *} - TFTFont = class(TCachedFont) - private - procedure ResetIntern(); - - protected - fFilename: IPath; //**< filename of the font-file - fSize: integer; //**< Font base size (in pixels) - fOutset: single; //**< size of outset extrusion (in pixels) - fFace: FT_Face; //**< Holds the height of the font - fLoadFlags: FT_Int32; //**< FT glpyh load-flags - fFontUnitScale: TPositionDbl; //**< FT font-units to pixel ratio - fUseDisplayLists: boolean; //**< true: use display-lists, false: direct drawing - fPart: TFontPart; //**< indicates the part of an outline font - - {** @seealso TCachedFont.LoadGlyph } - function LoadGlyph(ch: UCS4Char): TGlyph; override; - - procedure Render(const Text: UCS4String); override; - function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; - - function GetHeight(): single; override; - function GetAscender(): single; override; - function GetDescender(): single; override; - function GetUnderlinePosition(): single; override; - function GetUnderlineThickness(): single; override; - - property Face: FT_Face read fFace; - - public - {** - * Creates a font of size Size (in pixels) from the file Filename. - * If Outset (in pixels) is set to a value > 0 the glyphs will be extruded - * at their borders. Use it for e.g. a bold effect. - * @param LoadFlags flags passed to FT_Load_Glyph() - * @raises Exception if the font-file could not be loaded - *} - constructor Create(const Filename: IPath; - Size: integer; Outset: single = 0.0; - LoadFlags: FT_Int32 = FT_LOAD_DEFAULT); - - {** - * Frees all resources associated with the font. - *} - destructor Destroy(); override; - - {** @seealso TFont.Reset } - procedure Reset(); override; - - {** Size of the base font } - property Size: integer read fSize; - {** Outset size } - property Outset: single read fOutset; - end; - - TFTScalableFont = class(TScalableFont) - protected - function GetOutset(): single; virtual; - function CreateMipmap(Level: integer; Scale: single): TFont; override; - - public - {** - * Creates a scalable font of size Size (in pixels) from the file Filename. - * OutsetAmount is the ratio of the glyph extrusion. - * The extrusion in pixels is Size*OutsetAmount - * (0.0 -> no extrusion, 0.1 -> 10%). - *} - constructor Create(const Filename: IPath; - Size: integer; OutsetAmount: single = 0.0; - UseMipmaps: boolean = true); - - {** @seealso TGlyphCache.FlushCache } - procedure FlushCache(KeepBaseSet: boolean); - - {** Outset size (in pixels) of the scaled font } - property Outset: single read GetOutset; - end; - - - {** - * Represents a freetype font with an additional outline around its glyphs. - * The outline size is passed on creation and cannot be changed later. - *} - TFTOutlineFont = class(TFont) - private - fFilename: IPath; - fSize: integer; - fOutset: single; - fInnerFont, fOutlineFont: TFTFont; - fOutlineColor: TGLColor; - - procedure ResetIntern(); - - protected - procedure DrawUnderline(const Text: UCS4String); override; - procedure Render(const Text: UCS4String); override; - function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; - - function GetHeight(): single; override; - function GetAscender(): single; override; - function GetDescender(): single; override; - procedure SetLineSpacing(Spacing: single); override; - procedure SetGlyphSpacing(Spacing: single); override; - procedure SetReflectionSpacing(Spacing: single); override; - procedure SetStyle(Style: TFontStyle); override; - function GetStyle(): TFontStyle; override; - function GetUnderlinePosition(): single; override; - function GetUnderlineThickness(): single; override; - procedure SetUseKerning(Enable: boolean); override; - procedure SetReflectionPass(Enable: boolean); override; - - public - constructor Create(const Filename: IPath; - Size: integer; Outset: single; - LoadFlags: FT_Int32 = FT_LOAD_DEFAULT); - destructor Destroy; override; - - {** - * Sets the color of the outline. - * If the alpha component is < 0, OpenGL's current alpha value will be - * used. - *} - procedure SetOutlineColor(r, g, b: GLfloat; a: GLfloat = -1.0); - - {** @seealso TGlyphCache.FlushCache } - procedure FlushCache(KeepBaseSet: boolean); - - {** @seealso TFont.Reset } - procedure Reset(); override; - - {** Size of the base font } - property Size: integer read fSize; - {** Outset size } - property Outset: single read fOutset; - end; - - {** - * Wrapper around TOutlineFont to allow font resizing. - * @seealso TScalableFont - *} - TFTScalableOutlineFont = class(TScalableFont) - protected - function GetOutset(): single; virtual; - function CreateMipmap(Level: integer; Scale: single): TFont; override; - - public - constructor Create(const Filename: IPath; - Size: integer; OutsetAmount: single; - UseMipmaps: boolean = true); - - {** @seealso TFTOutlineFont.SetOutlineColor } - procedure SetOutlineColor(r, g, b: GLfloat; a: GLfloat = -1.0); - - {** @seealso TGlyphCache.FlushCache } - procedure FlushCache(KeepBaseSet: boolean); - - {** Outset size } - property Outset: single read GetOutset; - end; - -{$IFDEF BITMAP_FONT} - - {** - * A bitmapped font loads it's glyphs from a bitmap and stores them in a - * texture. Unicode characters are not supported (but could be by supporting - * multiple textures each storing a subset of unicode glyphs). - * For backward compatibility only. - *} - TBitmapFont = class(TFont) - private - fTex: TTexture; - fTexSize: integer; - fBaseline: integer; - fAscender: integer; - fDescender: integer; - fWidths: array[0..255] of byte; //**< half widths - fOutline: integer; - fTempColor: TGLColor; //**< colours for the reflection - - procedure ResetIntern(); - - procedure RenderChar(ch: UCS4Char; var AdvanceX: real); - - {** - * Load font widths from an info file. - * @param InfoFile the name of the info (.dat) file - * @raises Exception if the file is corrupted - *} - procedure LoadFontInfo(const InfoFile: IPath); - - protected - procedure Render(const Text: UCS4String); override; - function BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; override; - - function GetHeight(): single; override; - function GetAscender(): single; override; - function GetDescender(): single; override; - function GetUnderlinePosition(): single; override; - function GetUnderlineThickness(): single; override; - - public - {** - * Creates a bitmapped font from image Filename and font width info - * loaded from the corresponding file with ending .dat. - * @param(Baseline y-coord of the baseline given in cartesian coords - * (y-axis up) and from the lower edge of the glyphs bounding box) - * @param(Ascender pixels from baseline to top of highest glyph) - *} - constructor Create(const Filename: IPath; Outline: integer; - Baseline, Ascender, Descender: integer); - destructor Destroy(); override; - - {** - * Corrects font widths provided by the info file. - * NewWidth := Width * WidthMult + WidthAdd - *} - procedure CorrectWidths(WidthMult: real; WidthAdd: integer); - - {** @seealso TFont.Reset } - procedure Reset(); override; - end; - -{$ENDIF BITMAP_FONT} - - TFreeType = class - public - {** - * Returns a pointer to the freetype library singleton. - * If non exists, freetype will be initialized. - * @raises Exception if initialization failed - *} - class function GetLibrary(): FT_Library; - class procedure FreeLibrary(); - end; - - -implementation - -uses Types; - -const - //** shear factor used for the italic effect (bigger value -> more bending) - cShearFactor = 0.25; - cShearMatrix: array[0..15] of GLfloat = ( - 1, 0, 0, 0, - cShearFactor, 1, 0, 0, - 0, 0, 1, 0, - 0, 0, 0, 1 - ); - cShearMatrixInv: array[0..15] of GLfloat = ( - 1, 0, 0, 0, - -cShearFactor, 1, 0, 0, - 0, 0, 1, 0, - 0, 0, 0, 1 - ); - -var - LibraryInst: FT_Library; - -function NewGLColor(r, g, b, a: GLfloat): TGLColor; -begin - Result.r := r; - Result.g := g; - Result.b := b; - Result.a := a; -end; - -{** - * Returns the first power of 2 >= Value. - *} -function NextPowerOf2(Value: integer): integer; {$IFDEF HasInline}inline;{$ENDIF} -begin - Result := 1; - while (Result < Value) do - Result := Result shl 1; -end; - - -{* - * TFont - *} - -constructor TFont.Create(); -begin - inherited; - ResetIntern(); -end; - -destructor TFont.Destroy(); -begin - inherited; -end; - -procedure TFont.ResetIntern(); -begin - fStyle := []; - fUseKerning := true; - fGlyphSpacing := 0.0; - fReflectionPass := false; - - // must be set by subclasses - fLineSpacing := 0.0; - fReflectionSpacing := 0.0; -end; - -procedure TFont.Reset(); -begin - ResetIntern(); -end; - -procedure TFont.SplitLines(const Text: UCS4String; var Lines: TUCS4StringArray); -var - CharIndex: integer; - LineStart: integer; - LineLength: integer; - EOT: boolean; // End-Of-Text -begin - // split lines on newline - SetLength(Lines, 0); - EOT := false; - LineStart := 0; - - for CharIndex := 0 to High(Text) do - begin - // check for end of text (UCS4Strings are zero-terminated) - if (CharIndex = High(Text)) then - EOT := true; - - // check for newline (carriage return (#13)) or end of text - if (Text[CharIndex] = 13) or EOT then - begin - LineLength := CharIndex - LineStart; - // check if last character was a newline - if (EOT and (LineLength = 0)) then - Break; - - // copy line (even if LineLength is 0) - SetLength(Lines, Length(Lines)+1); - Lines[High(Lines)] := UCS4Copy(Text, LineStart, LineLength); - - LineStart := CharIndex+1; - end; - end; -end; - -function TFont.BBox(const Text: UCS4String; Advance: boolean): TBoundsDbl; -var - LineArray: TUCS4StringArray; -begin - SplitLines(Text, LineArray); - Result := BBox(LineArray, Advance); - SetLength(LineArray, 0); -end; - -function TFont.BBox(const Text: UTF8String; Advance: boolean): TBoundsDbl; -begin - Result := BBox(UTF8Decode(Text), Advance); -end; - -function TFont.BBox(const Text: WideString; Advance: boolean): TBoundsDbl; -begin - Result := BBox(WideStringToUCS4String(Text), Advance); -end; - -procedure TFont.Print(const Text: TUCS4StringArray); -var - LineIndex: integer; -begin - // recursively call this function to draw reflected text - if ((Reflect in Style) and not ReflectionPass) then - begin - ReflectionPass := true; - Print(Text); - ReflectionPass := false; - end; - - // store current color, enable-flags, matrix-mode - glPushAttrib(GL_CURRENT_BIT or GL_ENABLE_BIT or GL_TRANSFORM_BIT); - - // set OpenGL state - glMatrixMode(GL_MODELVIEW); - glDisable(GL_DEPTH_TEST); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - { - // TODO: just draw texels with alpha > 0 to avoid setting z-buffer for them? - glAlphaFunc(GL_GREATER, 0); - glEnable(GL_ALPHA_TEST); - - //TODO: Do we need depth-testing? - if (ReflectionPass) then - begin - glDepthMask(0); - glEnable(GL_DEPTH_TEST); - end; - } - - {$IFDEF FLIP_YAXIS} - glPushMatrix(); - glScalef(1, -1, 1); - {$ENDIF} - - // display text - for LineIndex := 0 to High(Text) do - begin - glPushMatrix(); - - // move to baseline - glTranslatef(0, -LineSpacing*LineIndex, 0); - - if ((Underline in Style) and not ReflectionPass) then - begin - glDisable(GL_TEXTURE_2D); - DrawUnderline(Text[LineIndex]); - glEnable(GL_TEXTURE_2D); - end; - - // draw reflection - if (ReflectionPass) then - begin - // set reflection spacing - glTranslatef(0, -ReflectionSpacing, 0); - // flip y-axis - glScalef(1, -1, 1); - end; - - // shear for italic effect - if (Italic in Style) then - glMultMatrixf(@cShearMatrix); - - // render text line - Render(Text[LineIndex]); - - glPopMatrix(); - end; - - // restore settings - {$IFDEF FLIP_YAXIS} - glPopMatrix(); - {$ENDIF} - glPopAttrib(); -end; - -procedure TFont.Print(const Text: UCS4String); -var - LineArray: TUCS4StringArray; -begin - SplitLines(Text, LineArray); - Print(LineArray); - SetLength(LineArray, 0); -end; - -procedure TFont.Print(const Text: UTF8String); -begin - Print(UTF8Decode(Text)); -end; - -procedure TFont.Print(const Text: WideString); -begin - Print(WideStringToUCS4String(Text)); -end; - -procedure TFont.DrawUnderline(const Text: UCS4String); -var - UnderlineY1, UnderlineY2: single; - Bounds: TBoundsDbl; -begin - UnderlineY1 := GetUnderlinePosition(); - UnderlineY2 := UnderlineY1 + GetUnderlineThickness(); - Bounds := BBox(Text, false); - glRectf(Bounds.Left, UnderlineY1, Bounds.Right, UnderlineY2); -end; - -procedure TFont.SetStyle(Style: TFontStyle); -begin - fStyle := Style; -end; - -function TFont.GetStyle(): TFontStyle; -begin - Result := fStyle; -end; - -procedure TFont.SetLineSpacing(Spacing: single); -begin - fLineSpacing := Spacing; -end; - -function TFont.GetLineSpacing(): single; -begin - Result := fLineSpacing; -end; - -procedure TFont.SetGlyphSpacing(Spacing: single); -begin - fGlyphSpacing := Spacing; -end; - -function TFont.GetGlyphSpacing(): single; -begin - Result := fGlyphSpacing; -end; - -procedure TFont.SetReflectionSpacing(Spacing: single); -begin - fReflectionSpacing := Spacing; -end; - -function TFont.GetReflectionSpacing(): single; -begin - Result := fReflectionSpacing; -end; - -procedure TFont.SetUseKerning(Enable: boolean); -begin - fUseKerning := Enable; -end; - -function TFont.GetUseKerning(): boolean; -begin - Result := fUseKerning; -end; - -procedure TFont.SetReflectionPass(Enable: boolean); -begin - fReflectionPass := Enable; -end; - - -{* - * TScalableFont - *} - -constructor TScalableFont.Create(Font: TFont; UseMipmaps: boolean); -var - MipmapLevel: integer; -begin - inherited Create(); - - fBaseFont := Font; - fMipmapFonts[0] := Font; - fUseMipmaps := UseMipmaps; - ResetIntern(); - - // create mipmap fonts if requested - if (UseMipmaps) then - begin - for MipmapLevel := 1 to cMaxMipmapLevel do - begin - fMipmapFonts[MipmapLevel] := CreateMipmap(MipmapLevel, 1/(1 shl MipmapLevel)); - // stop if no smaller mipmap font is returned - if (fMipmapFonts[MipmapLevel] = nil) then - Break; - end; - end; -end; - -destructor TScalableFont.Destroy(); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - fMipmapFonts[Level].Free; - inherited; -end; - -procedure TScalableFont.ResetIntern(); -begin - fScale := 1.0; - fAspect := 1.0; -end; - -procedure TScalableFont.Reset(); -var - Level: integer; -begin - inherited; - ResetIntern(); - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - fMipmapFonts[Level].Reset(); -end; - -{** - * Returns the mipmap level to use with regard to the current projection - * and modelview matrix, font scale and aspect. - * - * Note: - * - for Freetype fonts, hinting and grid-fitting must be disabled, otherwise - * the glyph widths/heights ratios and advance widths of the mipmap fonts - * do not match as they are adjusted sligthly (e.g. an 'a' at size 12px has - * width 12px, but at size 6px width 8px). - * - returned mipmap-level is used for all glyphs of the current text to print. - * This is faster, much easier to handle, since we just need to create - * multiple sized fonts and select the one we need for the mipmap-level and - * it avoids that neighbored glyphs use different mipmap-level which might - * look odd because one glyph might look blurry and the other sharp. - * - * Motivation: - * We do not use OpenGL for mipmapping as the results are very bad. At least - * with automatic mipmap generation (gluBuildMipmaps) the fonts look rather - * blurry. - * Defining our own mipmaps by creating multiple textures with - * for different mimap levels is a pain, as the font size passed to freetype - * is not the size of the bitmaps created and it does not guarantee that a - * glyph bitmap of a font with font-size s/2 is half the size of the font with - * font-size s. If the bitmap size is just a single pixel bigger than the half - * we might need a texture of the next power-of-2 and the texture would not be - * half of the size of the next bigger mipmap. In addition we use a fixed one - * pixel sized border to smooth the texture (see cTexSmoothBorder) and maybe - * an outset that is added to the font, so creating a glyph mipmap that is - * exactly half the size of the next bigger one is a very difficult task. - * - * Solution: - * Use mipmap textures that are not exactly half the size of the next mipmap - * level. OpenGL does not support this (at least not without extensions). - * The trickiest task is to determine the mipmap to use by calculating the - * amount of minification that is performed in this function. - *} -function TScalableFont.GetMipmapLevel(): integer; -var - ModelMatrix, ProjMatrix: T16dArray; - WinCoords: array[0..2, 0..2] of GLdouble; - ViewPortArray: TViewPortArray; - Dist, Dist2: double; - WidthScale, HeightScale: double; -const - // width/height of square used for determining the scale - cTestSize = 10.0; - // an offset to the mipmap-level to adjust the change-over of two consecutive - // mipmap levels. If for example the bias is 0.1 and unbiased level is 1.9 - // the result level will be 2. A bias of 0.5 is equal to rounding. - // With bias=0.1 we prefer larger mipmaps over smaller ones. - cBias = 0.2; -begin - // 1. retrieve current transformation matrices for gluProject - glGetDoublev(GL_MODELVIEW_MATRIX, @ModelMatrix); - glGetDoublev(GL_PROJECTION_MATRIX, @ProjMatrix); - glGetIntegerv(GL_VIEWPORT, @ViewPortArray); - - // 2. project three of the corner points of a square with size cTestSize - // to window coordinates (the square is just a dummy for a glyph) - - // project point (x1, y1) to window corrdinates - gluProject(0, 0, 0, - ModelMatrix, ProjMatrix, ViewPortArray, - @WinCoords[0][0], @WinCoords[0][1], @WinCoords[0][2]); - // project point (x2, y1) to window corrdinates - gluProject(cTestSize, 0, 0, - ModelMatrix, ProjMatrix, ViewPortArray, - @WinCoords[1][0], @WinCoords[1][1], @WinCoords[1][2]); - // project point (x1, y2) to window corrdinates - gluProject(0, cTestSize, 0, - ModelMatrix, ProjMatrix, ViewPortArray, - @WinCoords[2][0], @WinCoords[2][1], @WinCoords[2][2]); - - // 3. Lets see how much the width and height of the square changed. - // Calculate the width and height as displayed on the screen in window - // coordinates and calculate the ratio to the original coordinates in - // modelview space so the ratio gives us the scale (minification here). - - // projected width ||(x1, y1) - (x2, y1)|| - Dist := (WinCoords[0][0] - WinCoords[1][0]); - Dist2 := (WinCoords[0][1] - WinCoords[1][1]); - - WidthScale := 1; - if (Sqrt(Dist*Dist + Dist2*Dist2) <> 0) then - begin - WidthScale := cTestSize / Sqrt(Dist*Dist + Dist2*Dist2); - end; - - // projected height ||(x1, y1) - (x1, y2)|| - Dist := (WinCoords[0][0] - WinCoords[2][0]); - Dist2 := (WinCoords[0][1] - WinCoords[2][1]); - - HeightScale := 1; - if (Sqrt(Dist*Dist + Dist2*Dist2) <> 0) then - begin - HeightScale := cTestSize / Sqrt(Dist*Dist + Dist2*Dist2); - end; - - //writeln(Format('Scale %f, %f', [WidthScale, HeightScale])); - - // 4. Now that we have got the scale, take the bigger minification scale - // and get it to a logarithmic scale as each mipmap is 1/2 the size of its - // predecessor (Mipmap_size[i] = Mipmap_size[i-1]/2). - // The result is our mipmap-level = the index of the mipmap to use. - - // Level > 0: Minification; < 0: Magnification - Result := Trunc(Log2(Max(WidthScale, HeightScale)) + cBias); - - // clamp to valid range - if (Result < 0) then - Result := 0; - if (Result > High(fMipmapFonts)) then - Result := High(fMipmapFonts); -end; - -function TScalableFont.GetMipmapScale(Level: integer): single; -begin - if (fMipmapFonts[Level] = nil) then - begin - Result := -1; - Exit; - end; - - Result := fScale * fMipmapFonts[0].Height / fMipmapFonts[Level].Height; -end; - -{** - * Returns the correct mipmap font for the current scale and projection - * matrix. The modelview scale is adjusted to the mipmap level, so - * Result.Print() will display the font in the correct size. - *} -function TScalableFont.ChooseMipmapFont(): TFont; -var - DesiredLevel: integer; - Level: integer; - MipmapScale: single; -begin - Result := nil; - DesiredLevel := GetMipmapLevel(); - - // get the smallest mipmap available for the desired level - // as not all levels must be assigned to a font. - for Level := DesiredLevel downto 0 do - begin - if (fMipmapFonts[Level] <> nil) then - begin - Result := fMipmapFonts[Level]; - Break; - end; - end; - - // since the mipmap font (if level > 0) is smaller than the base-font - // we have to scale to get its size right. - MipmapScale := fMipmapFonts[0].Height/Result.Height; - glScalef(MipmapScale, MipmapScale, 0); -end; - -procedure TScalableFont.Print(const Text: TUCS4StringArray); -begin - glPushMatrix(); - - // set scale and stretching - glScalef(fScale * fAspect, fScale, 0); - - // print text - if (fUseMipmaps) then - ChooseMipmapFont().Print(Text) - else - fBaseFont.Print(Text); - - glPopMatrix(); -end; - -procedure TScalableFont.Render(const Text: UCS4String); -begin - Assert(false, 'Unused TScalableFont.Render() was called'); -end; - -function TScalableFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; -begin - Result := fBaseFont.BBox(Text, Advance); - Result.Left := Result.Left * fScale * fAspect; - Result.Right := Result.Right * fScale * fAspect; - Result.Top := Result.Top * fScale; - Result.Bottom := Result.Bottom * fScale; -end; - -procedure TScalableFont.SetHeight(Height: single); -begin - fScale := Height / fBaseFont.GetHeight(); -end; - -function TScalableFont.GetHeight(): single; -begin - Result := fBaseFont.GetHeight() * fScale; -end; - -procedure TScalableFont.SetAspect(Aspect: single); -begin - fAspect := Aspect; -end; - -function TScalableFont.GetAspect(): single; -begin - Result := fAspect; -end; - -function TScalableFont.GetAscender(): single; -begin - Result := fBaseFont.GetAscender() * fScale; -end; - -function TScalableFont.GetDescender(): single; -begin - Result := fBaseFont.GetDescender() * fScale; -end; - -procedure TScalableFont.SetLineSpacing(Spacing: single); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - fMipmapFonts[Level].SetLineSpacing(Spacing / GetMipmapScale(Level)); -end; - -function TScalableFont.GetLineSpacing(): single; -begin - Result := fBaseFont.GetLineSpacing() * fScale; -end; - -procedure TScalableFont.SetGlyphSpacing(Spacing: single); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - fMipmapFonts[Level].SetGlyphSpacing(Spacing / GetMipmapScale(Level)); -end; - -function TScalableFont.GetGlyphSpacing(): single; -begin - Result := fBaseFont.GetGlyphSpacing() * fScale; -end; - -procedure TScalableFont.SetReflectionSpacing(Spacing: single); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if ((fMipmapFonts[Level] <> nil) AND (GetMipmapScale(Level) > 0)) then - fMipmapFonts[Level].SetReflectionSpacing(Spacing / GetMipmapScale(Level)); -end; - -function TScalableFont.GetReflectionSpacing(): single; -begin - Result := fBaseFont.GetLineSpacing() * fScale; -end; - -procedure TScalableFont.SetStyle(Style: TFontStyle); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - fMipmapFonts[Level].SetStyle(Style); -end; - -function TScalableFont.GetStyle(): TFontStyle; -begin - Result := fBaseFont.GetStyle(); -end; - -function TScalableFont.GetUnderlinePosition(): single; -begin - Result := fBaseFont.GetUnderlinePosition(); -end; - -function TScalableFont.GetUnderlineThickness(): single; -begin - Result := fBaseFont.GetUnderlinePosition(); -end; - -procedure TScalableFont.SetUseKerning(Enable: boolean); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - fMipmapFonts[Level].SetUseKerning(Enable); -end; - - -{* - * TCachedFont - *} - -constructor TCachedFont.Create(); -begin - inherited; - fCache := TGlyphCache.Create(); -end; - -destructor TCachedFont.Destroy(); -begin - fCache.Free; - inherited; -end; - -function TCachedFont.GetGlyph(ch: UCS4Char): TGlyph; -begin - Result := fCache.GetGlyph(ch); - if (Result = nil) then - begin - Result := LoadGlyph(ch); - if (not fCache.AddGlyph(ch, Result)) then - Result.Free; - end; -end; - -procedure TCachedFont.FlushCache(KeepBaseSet: boolean); -begin - fCache.FlushCache(KeepBaseSet); -end; - - -{* - * TFTFont - *} - -constructor TFTFont.Create( - const Filename: IPath; - Size: integer; Outset: single; - LoadFlags: FT_Int32); -var - ch: UCS4Char; -begin - inherited Create(); - - fFilename := Filename; - fSize := Size; - fOutset := Outset; - fLoadFlags := LoadFlags; - fUseDisplayLists := true; - fPart := fpNone; - - // load font information - if (FT_New_Face(TFreeType.GetLibrary(), PChar(Filename.ToNative), 0, fFace) <> 0) then - raise Exception.Create('FT_New_Face: Could not load font ''' + Filename.ToNative + ''''); - - // support scalable fonts only - if (not FT_IS_SCALABLE(fFace)) then - raise Exception.Create('Font is not scalable'); - - if (FT_Set_Pixel_Sizes(fFace, 0, Size) <> 0) then - raise Exception.Create('FT_Set_Pixel_Sizes failes'); - - // get scale factor for font-unit to pixel-size transformation - fFontUnitScale.X := fFace.size.metrics.x_ppem / fFace.units_per_EM; - fFontUnitScale.Y := fFace.size.metrics.y_ppem / fFace.units_per_EM; - - ResetIntern(); - - // pre-cache some commonly used glyphs (' ' - '~') - for ch := 32 to 126 do - fCache.AddGlyph(ch, TFTGlyph.Create(Self, ch, Outset, LoadFlags)); -end; - -destructor TFTFont.Destroy(); -begin - // free face - FT_Done_Face(fFace); - inherited; -end; - -procedure TFTFont.ResetIntern(); -begin - // Note: outset and non outset fonts use same spacing - fLineSpacing := fFace.height * fFontUnitScale.Y; - fReflectionSpacing := -2*fFace.descender * fFontUnitScale.Y; -end; - -procedure TFTFont.Reset(); -begin - inherited; - ResetIntern(); -end; - -function TFTFont.LoadGlyph(ch: UCS4Char): TGlyph; -begin - Result := TFTGlyph.Create(Self, ch, Outset, fLoadFlags); -end; - -function TFTFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; -var - Glyph, PrevGlyph: TFTGlyph; - TextLine: UCS4String; - LineYOffset: single; - LineIndex, CharIndex: integer; - LineBounds: TBoundsDbl; - KernDelta: FT_Vector; - UnderlinePos: double; -begin - // Reset global bounds - Result.Left := Infinity; - Result.Right := 0; - Result.Bottom := Infinity; - Result.Top := 0; - - // reset last glyph - PrevGlyph := nil; - - // display text - for LineIndex := 0 to High(Text) do - begin - // get next text line - TextLine := Text[LineIndex]; - LineYOffset := -LineSpacing * LineIndex; - - // reset line bounds - LineBounds.Left := Infinity; - LineBounds.Right := 0; - LineBounds.Bottom := Infinity; - LineBounds.Top := 0; - - // for each glyph image, compute its bounding box - for CharIndex := 0 to LengthUCS4(TextLine)-1 do - begin - Glyph := TFTGlyph(GetGlyph(TextLine[CharIndex])); - if (Glyph <> nil) then - begin - // get kerning - if (fUseKerning and FT_HAS_KERNING(fFace) and (PrevGlyph <> nil)) then - begin - FT_Get_Kerning(fFace, PrevGlyph.CharIndex, Glyph.CharIndex, - FT_KERNING_UNSCALED, KernDelta); - LineBounds.Right := LineBounds.Right + KernDelta.x * fFontUnitScale.X; - end; - - // update left bound (must be done before right bound is updated) - if (LineBounds.Right + Glyph.Bounds.Left < LineBounds.Left) then - LineBounds.Left := LineBounds.Right + Glyph.Bounds.Left; - - // update right bound - if (CharIndex < LengthUCS4(TextLine)-1) or // not the last character - (TextLine[CharIndex] = Ord(' ')) or // on space char (Bounds.Right = 0) - Advance then // or in advance mode - begin - // add advance and glyph spacing - LineBounds.Right := LineBounds.Right + Glyph.Advance.x + GlyphSpacing - end - else - begin - // add glyph's right bound - LineBounds.Right := LineBounds.Right + Glyph.Bounds.Right; - end; - - // update bottom and top bounds - if (Glyph.Bounds.Bottom < LineBounds.Bottom) then - LineBounds.Bottom := Glyph.Bounds.Bottom; - if (Glyph.Bounds.Top > LineBounds.Top) then - LineBounds.Top := Glyph.Bounds.Top; - end; - - PrevGlyph := Glyph; - end; - - // handle italic font style - if (Italic in Style) then - begin - LineBounds.Left := LineBounds.Left + LineBounds.Bottom * cShearFactor; - LineBounds.Right := LineBounds.Right + LineBounds.Top * cShearFactor; - end; - - // handle underlined font style - if (Underline in Style) then - begin - UnderlinePos := GetUnderlinePosition(); - if (UnderlinePos < LineBounds.Bottom) then - LineBounds.Bottom := UnderlinePos; - end; - - // add line offset - LineBounds.Bottom := LineBounds.Bottom + LineYOffset; - LineBounds.Top := LineBounds.Top + LineYOffset; - - // adjust global bounds - if (Result.Left > LineBounds.Left) then - Result.Left := LineBounds.Left; - if (Result.Right < LineBounds.Right) then - Result.Right := LineBounds.Right; - if (Result.Bottom > LineBounds.Bottom) then - Result.Bottom := LineBounds.Bottom; - if (Result.Top < LineBounds.Top) then - Result.Top := LineBounds.Top; - end; - - // if left or bottom bound was not set, set them to 0 - if (IsInfinite(Result.Left)) then - Result.Left := 0.0; - if (IsInfinite(Result.Bottom)) then - Result.Bottom := 0.0; -end; - -procedure TFTFont.Render(const Text: UCS4String); -var - CharIndex: integer; - Glyph, PrevGlyph: TFTGlyph; - KernDelta: FT_Vector; -begin - // reset last glyph - PrevGlyph := nil; - - // draw current line - for CharIndex := 0 to LengthUCS4(Text)-1 do - begin - Glyph := TFTGlyph(GetGlyph(Text[CharIndex])); - if (Assigned(Glyph)) then - begin - // get kerning - if (fUseKerning and FT_HAS_KERNING(fFace) and (PrevGlyph <> nil)) then - begin - FT_Get_Kerning(fFace, PrevGlyph.CharIndex, Glyph.CharIndex, - FT_KERNING_UNSCALED, KernDelta); - glTranslatef(KernDelta.x * fFontUnitScale.X, 0, 0); - end; - - if (ReflectionPass) then - Glyph.RenderReflection() - else - Glyph.Render(fUseDisplayLists); - - glTranslatef(Glyph.Advance.x + fGlyphSpacing, 0, 0); - end; - - PrevGlyph := Glyph; - end; -end; - -function TFTFont.GetHeight(): single; -begin - Result := Ascender - Descender; -end; - -function TFTFont.GetAscender(): single; -begin - Result := fFace.ascender * fFontUnitScale.Y + Outset*2; -end; - -function TFTFont.GetDescender(): single; -begin - // Note: outset is not part of the descender as the baseline is lifted - Result := fFace.descender * fFontUnitScale.Y; -end; - -function TFTFont.GetUnderlinePosition(): single; -begin - Result := fFace.underline_position * fFontUnitScale.Y - Outset; -end; - -function TFTFont.GetUnderlineThickness(): single; -begin - Result := fFace.underline_thickness * fFontUnitScale.Y + Outset*2; -end; - - -{* - * TFTScalableFont - *} - -constructor TFTScalableFont.Create(const Filename: IPath; - Size: integer; OutsetAmount: single; - UseMipmaps: boolean); -var - LoadFlags: FT_Int32; -begin - LoadFlags := FT_LOAD_DEFAULT; - // Disable hinting and grid-fitting to preserve font outlines at each font - // size, otherwise the font widths/heights do not match resulting in ugly - // text size changes during zooming. - // A drawback is a reduced quality with smaller font sizes but it is not that - // bad with gray-scaled rendering (at least it looks better than OpenGL's - // linear downscaling on minification). - if (UseMipmaps) then - LoadFlags := LoadFlags or FT_LOAD_NO_HINTING; - inherited Create( - TFTFont.Create(Filename, Size, Size * OutsetAmount, LoadFlags), - UseMipmaps); -end; - -function TFTScalableFont.CreateMipmap(Level: integer; Scale: single): TFont; -var - ScaledSize: integer; - BaseFont: TFTFont; -begin - Result := nil; - BaseFont := TFTFont(fBaseFont); - ScaledSize := Round(BaseFont.Size * Scale); - // do not create mipmap fonts < 8 pixels - if (ScaledSize < 8) then - Exit; - Result := TFTFont.Create(BaseFont.fFilename, - ScaledSize, BaseFont.fOutset * Scale, - FT_LOAD_DEFAULT or FT_LOAD_NO_HINTING); -end; - -function TFTScalableFont.GetOutset(): single; -begin - Result := TFTFont(fBaseFont).Outset * fScale; -end; - -procedure TFTScalableFont.FlushCache(KeepBaseSet: boolean); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - TFTFont(fMipmapFonts[Level]).FlushCache(KeepBaseSet); -end; - - -{* - * TOutlineFont - *} - -constructor TFTOutlineFont.Create( - const Filename: IPath; - Size: integer; Outset: single; - LoadFlags: FT_Int32); -begin - inherited Create(); - - fFilename := Filename; - fSize := Size; - fOutset := Outset; - - fInnerFont := TFTFont.Create(Filename, Size, 0.0, LoadFlags); - fInnerFont.fPart := fpInner; - fOutlineFont := TFTFont.Create(Filename, Size, Outset, LoadFlags); - fOutlineFont.fPart := fpOutline; - - ResetIntern(); -end; - -destructor TFTOutlineFont.Destroy; -begin - fOutlineFont.Free; - fInnerFont.Free; - inherited; -end; - -procedure TFTOutlineFont.ResetIntern(); -begin - // TODO: maybe swap fInnerFont/fOutlineFont.GlyphSpacing to use the spacing - // of the outline font? - //fInnerFont.GlyphSpacing := fOutset*2; - fOutlineFont.GlyphSpacing := -fOutset*2; - - fLineSpacing := fOutlineFont.LineSpacing; - fReflectionSpacing := fOutlineFont.ReflectionSpacing; - fOutlineColor := NewGLColor(0, 0, 0, -1); -end; - -procedure TFTOutlineFont.Reset(); -begin - inherited; - fInnerFont.Reset(); - fOutlineFont.Reset(); - ResetIntern(); -end; - -procedure TFTOutlineFont.DrawUnderline(const Text: UCS4String); -var - CurrentColor: TGLColor; - OutlineColor: TGLColor; -begin - // save current color - glGetFloatv(GL_CURRENT_COLOR, @CurrentColor.vals); - - // if the outline's alpha component is < 0 use the current alpha - OutlineColor := fOutlineColor; - if (OutlineColor.a < 0) then - OutlineColor.a := CurrentColor.a; - - // draw underline outline (in outline color) - glColor4fv(@OutlineColor.vals); - fOutlineFont.DrawUnderline(Text); - glColor4fv(@CurrentColor.vals); - - // draw underline inner part (in current color) - glPushMatrix(); - glTranslatef(fOutset, 0, 0); - fInnerFont.DrawUnderline(Text); - glPopMatrix(); -end; - -procedure TFTOutlineFont.Render(const Text: UCS4String); -var - CurrentColor: TGLColor; - OutlineColor: TGLColor; -begin - // save current color - glGetFloatv(GL_CURRENT_COLOR, @CurrentColor.vals); - - // if the outline's alpha component is < 0 use the current alpha - OutlineColor := fOutlineColor; - if (OutlineColor.a < 0) then - OutlineColor.a := CurrentColor.a; - - { setup and render outline font } - - glColor4fv(@OutlineColor.vals); - glPushMatrix(); - fOutlineFont.Render(Text); - glPopMatrix(); - glColor4fv(@CurrentColor.vals); - - { setup and render inner font } - - glPushMatrix(); - glTranslatef(fOutset, fOutset, 0); - fInnerFont.Render(Text); - glPopMatrix(); -end; - -procedure TFTOutlineFont.SetOutlineColor(r, g, b: GLfloat; a: GLfloat); -begin - fOutlineColor := NewGLColor(r, g, b, a); -end; - -procedure TFTOutlineFont.FlushCache(KeepBaseSet: boolean); -begin - fOutlineFont.FlushCache(KeepBaseSet); - fInnerFont.FlushCache(KeepBaseSet); -end; - -function TFTOutlineFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; -begin - Result := fOutlineFont.BBox(Text, Advance); -end; - -function TFTOutlineFont.GetHeight(): single; -begin - Result := fOutlineFont.Height; -end; - -function TFTOutlineFont.GetAscender(): single; -begin - Result := fOutlineFont.Ascender; -end; - -function TFTOutlineFont.GetDescender(): single; -begin - Result := fOutlineFont.Descender; -end; - -procedure TFTOutlineFont.SetLineSpacing(Spacing: single); -begin - inherited SetLineSpacing(Spacing); - fInnerFont.LineSpacing := Spacing; - fOutlineFont.LineSpacing := Spacing; -end; - -procedure TFTOutlineFont.SetGlyphSpacing(Spacing: single); -begin - inherited SetGlyphSpacing(Spacing); - fInnerFont.GlyphSpacing := Spacing; - fOutlineFont.GlyphSpacing := Spacing - Outset*2; -end; - -procedure TFTOutlineFont.SetReflectionSpacing(Spacing: single); -begin - inherited SetReflectionSpacing(Spacing); - fInnerFont.ReflectionSpacing := Spacing; - fOutlineFont.ReflectionSpacing := Spacing; -end; - -procedure TFTOutlineFont.SetStyle(Style: TFontStyle); -begin - inherited SetStyle(Style); - fInnerFont.Style := Style; - fOutlineFont.Style := Style; -end; - -function TFTOutlineFont.GetStyle(): TFontStyle; -begin - Result := inherited GetStyle(); -end; - -function TFTOutlineFont.GetUnderlinePosition(): single; -begin - Result := fOutlineFont.GetUnderlinePosition(); -end; - -function TFTOutlineFont.GetUnderlineThickness(): single; -begin - Result := fOutlineFont.GetUnderlinePosition(); -end; - -procedure TFTOutlineFont.SetUseKerning(Enable: boolean); -begin - inherited SetUseKerning(Enable); - fInnerFont.fUseKerning := Enable; - fOutlineFont.fUseKerning := Enable; -end; - -procedure TFTOutlineFont.SetReflectionPass(Enable: boolean); -begin - inherited SetReflectionPass(Enable); - fInnerFont.fReflectionPass := Enable; - fOutlineFont.fReflectionPass := Enable; -end; - -{** - * TScalableOutlineFont - *} - -constructor TFTScalableOutlineFont.Create( - const Filename: IPath; - Size: integer; OutsetAmount: single; - UseMipmaps: boolean); -var - LoadFlags: FT_Int32; -begin - LoadFlags := FT_LOAD_DEFAULT; - // Disable hinting and grid-fitting (see TFTScalableFont.Create) - if (UseMipmaps) then - LoadFlags := LoadFlags or FT_LOAD_NO_HINTING; - inherited Create( - TFTOutlineFont.Create(Filename, Size, Size*OutsetAmount, LoadFlags), - UseMipmaps); -end; - -function TFTScalableOutlineFont.CreateMipmap(Level: integer; Scale: single): TFont; -var - ScaledSize: integer; - BaseFont: TFTOutlineFont; -begin - Result := nil; - BaseFont := TFTOutlineFont(fBaseFont); - ScaledSize := Round(BaseFont.Size*Scale); - // do not create mipmap fonts < 8 pixels - if (ScaledSize < 8) then - Exit; - Result := TFTOutlineFont.Create(BaseFont.fFilename, - ScaledSize, BaseFont.fOutset*Scale, - FT_LOAD_DEFAULT or FT_LOAD_NO_HINTING); -end; - -function TFTScalableOutlineFont.GetOutset(): single; -begin - Result := TFTOutlineFont(fBaseFont).Outset * fScale; -end; - -procedure TFTScalableOutlineFont.SetOutlineColor(r, g, b: GLfloat; a: GLfloat); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - TFTOutlineFont(fMipmapFonts[Level]).SetOutlineColor(r, g, b, a); -end; - -procedure TFTScalableOutlineFont.FlushCache(KeepBaseSet: boolean); -var - Level: integer; -begin - for Level := 0 to High(fMipmapFonts) do - if (fMipmapFonts[Level] <> nil) then - TFTOutlineFont(fMipmapFonts[Level]).FlushCache(KeepBaseSet); -end; - - -{* - * TFTGlyph - *} - -const - {** - * Size of the transparent border surrounding the glyph image in the texture. - * The border is necessary because OpenGL does not smooth texels at the - * border of a texture with the GL_CLAMP or GL_CLAMP_TO_EDGE styles. - * Without the border, magnified glyph textures look very ugly at their edges. - * It looks edgy, as if some pixels are missing especially on the left edge - * (just set cTexSmoothBorder to 0 to see what is meant by this). - * With the border even the glyphs edges are blended to the border (transparent) - * color and everything looks nice. - * - * Note: - * OpenGL already supports texture border by setting the border parameter - * of glTexImage*D() to 1 and using a texture size of 2^m+2b and setting the - * border pixels to the border color. In some forums it is discouraged to use - * the border parameter as only a few of the more modern graphics cards support - * this feature. On an ATI Radeon 9700 card, the slowed down to 0.5 fps and - * the glyph's background got black. So instead of using this feature we - * handle it on our own. The only drawback is that textures might get bigger - * because the border might require a higher power of 2 size instead of just - * two additional pixels. - *} - cTexSmoothBorder = 1; - -procedure TFTGlyph.StrokeBorder(var Glyph: FT_Glyph); -var - Outline: PFT_Outline; - OuterStroker, InnerStroker: FT_Stroker; - OuterNumPoints, InnerNumPoints, GlyphNumPoints: FT_UInt; - OuterNumContours, InnerNumContours, GlyphNumContours: FT_UInt; - OuterBorder, InnerBorder: FT_StrokerBorder; - OutlineFlags: FT_Int; - UseStencil: boolean; -begin - // It is possible to extrude the borders of a glyph with FT_Glyph_Stroke - // but it will extrude the border to the outside and the inside of a glyph - // although we just want to extrude to the outside. - // FT_Glyph_StrokeBorder extrudes to the outside but also fills the interior - // (this is what we need for bold fonts). - // In both cases the inner font and outline font (border) will overlap. - // Normally this does not matter but it does if alpha blending is active. - // In this case if e.g. the inner color is set to white, the outline to red - // and alpha to 0.5 the inner part will not be white it will be pink. - - InnerStroker := nil; - OuterStroker := nil; - - // If we are to create the interior of an outlined font (fInner = true) - // we have to create two borders: - // - one extruded to the outside by fOutset pixels and - // - one extruded to the inside by almost 0 zero pixels. - // The second one is used as a stencil for the first one, clearing the - // interiour of the glyph. - // The stencil is not needed to create bold fonts. - UseStencil := (fFont.fPart = fpInner); - - Outline := @FT_OutlineGlyph(Glyph).outline; - - OuterBorder := FT_Outline_GetOutsideBorder(Outline); - if (OuterBorder = FT_STROKER_BORDER_LEFT) then - InnerBorder := FT_STROKER_BORDER_RIGHT - else - InnerBorder := FT_STROKER_BORDER_LEFT; - - { extrude outer border } - - if (FT_Stroker_New(Glyph.library_, OuterStroker) <> 0) then - raise Exception.Create('FT_Stroker_New failed!'); - FT_Stroker_Set( - OuterStroker, - Round(fOutset * 64), - FT_STROKER_LINECAP_ROUND, - FT_STROKER_LINEJOIN_BEVEL, - 0); - - // similar to FT_Glyph_StrokeBorder(inner = FT_FALSE) but it is possible to - // use FT_Stroker_ExportBorder() afterwards to combine inner and outer borders - if (FT_Stroker_ParseOutline(OuterStroker, Outline, FT_FALSE) <> 0) then - raise Exception.Create('FT_Stroker_ParseOutline failed!'); - - FT_Stroker_GetBorderCounts(OuterStroker, OuterBorder, OuterNumPoints, OuterNumContours); - - { extrude inner border (= stencil) } - - if (UseStencil) then - begin - if (FT_Stroker_New(Glyph.library_, InnerStroker) <> 0) then - raise Exception.Create('FT_Stroker_New failed!'); - FT_Stroker_Set( - InnerStroker, - 63, // extrude at most one pixel to avoid a black border - FT_STROKER_LINECAP_ROUND, - FT_STROKER_LINEJOIN_BEVEL, - 0); - - if (FT_Stroker_ParseOutline(InnerStroker, Outline, FT_FALSE) <> 0) then - raise Exception.Create('FT_Stroker_ParseOutline failed!'); - - FT_Stroker_GetBorderCounts(InnerStroker, InnerBorder, InnerNumPoints, InnerNumContours); - end else begin - InnerNumPoints := 0; - InnerNumContours := 0; - end; - - { combine borders (subtract: OuterBorder - InnerBorder) } - - GlyphNumPoints := InnerNumPoints + OuterNumPoints; - GlyphNumContours := InnerNumContours + OuterNumContours; - - // save flags before deletion (TODO: set them on the resulting outline) - OutlineFlags := Outline.flags; - - // resize glyph outline to hold inner and outer border - FT_Outline_Done(Glyph.Library_, Outline); - if (FT_Outline_New(Glyph.Library_, GlyphNumPoints, GlyphNumContours, Outline) <> 0) then - raise Exception.Create('FT_Outline_New failed!'); - - Outline.n_points := 0; - Outline.n_contours := 0; - - // add points to outline. The inner-border is used as a stencil. - FT_Stroker_ExportBorder(OuterStroker, OuterBorder, Outline); - if (UseStencil) then - FT_Stroker_ExportBorder(InnerStroker, InnerBorder, Outline); - if (FT_Outline_Check(outline) <> 0) then - raise Exception.Create('FT_Stroker_ExportBorder failed!'); - - if (InnerStroker <> nil) then - FT_Stroker_Done(InnerStroker); - if (OuterStroker <> nil) then - FT_Stroker_Done(OuterStroker); -end; - -procedure TFTGlyph.CreateTexture(LoadFlags: FT_Int32); -var - X, Y: integer; - Glyph: FT_Glyph; - BitmapGlyph: FT_BitmapGlyph; - Bitmap: PFT_Bitmap; - BitmapLine: PByteArray; - BitmapBuffer: PByteArray; - TexBuffer: TGLubyteDynArray; - TexLine: PGLubyteArray; - CBox: FT_BBox; -begin - // load the Glyph for our character - if (FT_Load_Glyph(fFont.Face, fCharIndex, LoadFlags) <> 0) then - raise Exception.Create('FT_Load_Glyph failed'); - - // move the face's glyph into a Glyph object - if (FT_Get_Glyph(fFont.Face^.glyph, Glyph) <> 0) then - raise Exception.Create('FT_Get_Glyph failed'); - - if (fOutset > 0) then - StrokeBorder(Glyph); - - // store scaled advance width/height in glyph-object - fAdvance.X := fFont.Face^.glyph^.advance.x / 64 + fOutset*2; - fAdvance.Y := fFont.Face^.glyph^.advance.y / 64 + fOutset*2; - - // get the contour's bounding box (in 1/64th pixels, not font-units) - FT_Glyph_Get_CBox(Glyph, FT_GLYPH_BBOX_UNSCALED, CBox); - // convert 1/64th values to double values - fBounds.Left := CBox.xMin / 64; - fBounds.Right := CBox.xMax / 64 + fOutset*2; - fBounds.Bottom := CBox.yMin / 64; - fBounds.Top := CBox.yMax / 64 + fOutset*2; - - // convert the glyph to a bitmap (and destroy original glyph image). - // Request 8 bit gray level pixel mode. - FT_Glyph_To_Bitmap(Glyph, FT_RENDER_MODE_NORMAL, nil, 1); - BitmapGlyph := FT_BitmapGlyph(Glyph); - - // get bitmap offsets - fBitmapCoords.Left := BitmapGlyph^.left - cTexSmoothBorder; - // Note: add 1*fOutset for lifting the baseline so outset fonts to not intersect - // with the baseline; Ceil(fOutset) for the outset pixels added to the bitmap. - fBitmapCoords.Top := BitmapGlyph^.top + fOutset+Ceil(fOutset) + cTexSmoothBorder; - - // make accessing the bitmap easier - Bitmap := @BitmapGlyph^.bitmap; - // get bitmap dimensions - fBitmapCoords.Width := Bitmap.width + (Ceil(fOutset) + cTexSmoothBorder)*2; - fBitmapCoords.Height := Bitmap.rows + (Ceil(fOutset) + cTexSmoothBorder)*2; - - // get power-of-2 bitmap widths - fTexSize.Width := - NextPowerOf2(Bitmap.width + (Ceil(fOutset) + cTexSmoothBorder)*2); - fTexSize.Height := - NextPowerOf2(Bitmap.rows + (Ceil(fOutset) + cTexSmoothBorder)*2); - - // texture-widths ignoring empty (power-of-2) padding space - fTexOffset.X := fBitmapCoords.Width / fTexSize.Width; - fTexOffset.Y := fBitmapCoords.Height / fTexSize.Height; - - // allocate memory for texture data - SetLength(TexBuffer, fTexSize.Width * fTexSize.Height); - FillChar(TexBuffer[0], Length(TexBuffer), 0); - - // Freetype stores the bitmap with either upper (pitch is > 0) or lower - // (pitch < 0) glyphs line first. Set the buffer to the upper line. - // See http://freetype.sourceforge.net/freetype2/docs/glyphs/glyphs-7.html - if (Bitmap.pitch > 0) then - BitmapBuffer := @Bitmap.buffer[0] - else - BitmapBuffer := @Bitmap.buffer[(Bitmap.rows-1) * Abs(Bitmap.pitch)]; - - // copy data to texture bitmap (upper line first). - for Y := 0 to Bitmap.rows-1 do - begin - // set pointer to first pixel in line that holds bitmap data. - // Each line starts with a cTexSmoothBorder pixel and multiple outset pixels - // that are added by Extrude() later. - TexLine := @TexBuffer[(Y + cTexSmoothBorder + Ceil(fOutset)) * fTexSize.Width + - cTexSmoothBorder + Ceil(fOutset)]; - // get next lower line offset, use pitch instead of width as it tells - // us the storage direction of the lines. In addition a line might be padded. - BitmapLine := @BitmapBuffer[Y * Bitmap.pitch]; - - // check for pixel mode and copy pixels - // Should be 8 bit gray, but even with FT_RENDER_MODE_NORMAL, freetype - // sometimes (e.g. 16px sized japanese fonts) fallbacks to 1 bit pixels. - case (Bitmap.pixel_mode) of - FT_PIXEL_MODE_GRAY: begin // 8 bit gray - for X := 0 to Bitmap.width-1 do - TexLine[X] := BitmapLine[X]; - end; - FT_PIXEL_MODE_MONO: begin // 1 bit mono - for X := 0 to Bitmap.width-1 do - TexLine[X] := High(GLubyte) * ((BitmapLine[X div 8] shr (7-(X mod 8))) and $1); - end; - else begin - // unhandled pixel format - end; - end; - end; - - // allocate resources for textures and display lists - glGenTextures(1, @fTexture); - - // setup texture parameters - glBindTexture(GL_TEXTURE_2D, fTexture); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - - glPixelStorei(GL_UNPACK_ALIGNMENT, 1); - // create alpha-map (GL_ALPHA component only). - // TexCoord (0,0) corresponds to the top left pixel of the glyph, - // (1,1) to the bottom right pixel. So the glyph is flipped as OpenGL uses - // a cartesian (y-axis up) coordinate system for textures. - // See the cTexSmoothBorder comment for info on texture borders. - glTexImage2D(GL_TEXTURE_2D, 0, GL_ALPHA, fTexSize.Width, fTexSize.Height, - 0, GL_ALPHA, GL_UNSIGNED_BYTE, @TexBuffer[0]); - - // free expanded data - SetLength(TexBuffer, 0); - - // create the display list - fDisplayList := glGenLists(1); - - // render to display-list - glNewList(fDisplayList, GL_COMPILE); - Render(false); - glEndList(); - - // free glyph data (bitmap, etc.) - FT_Done_Glyph(Glyph); -end; - -constructor TFTGlyph.Create(Font: TFTFont; ch: UCS4Char; Outset: single; - LoadFlags: FT_Int32); -begin - inherited Create(); - - fFont := Font; - fOutset := Outset; - fCharCode := ch; - - // get the Freetype char-index (use default UNICODE charmap) - fCharIndex := FT_Get_Char_Index(Font.fFace, FT_ULONG(ch)); - - CreateTexture(LoadFlags); -end; - -destructor TFTGlyph.Destroy; -begin - if (fDisplayList <> 0) then - glDeleteLists(fDisplayList, 1); - if (fTexture <> 0) then - glDeleteTextures(1, @fTexture); - inherited; -end; - -procedure TFTGlyph.Render(UseDisplayLists: boolean); -begin - // use display-lists if enabled and exit - if (UseDisplayLists) then - begin - glCallList(fDisplayList); - Exit; - end; - - glBindTexture(GL_TEXTURE_2D, fTexture); - glPushMatrix(); - - // move to top left glyph position - glTranslatef(fBitmapCoords.Left, fBitmapCoords.Top, 0); - - // draw glyph texture - glBegin(GL_QUADS); - // top right - glTexCoord2f(fTexOffset.X, 0); - glVertex2f(fBitmapCoords.Width, 0); - - // top left - glTexCoord2f(0, 0); - glVertex2f(0, 0); - - // bottom left - glTexCoord2f(0, fTexOffset.Y); - glVertex2f(0, -fBitmapCoords.Height); - - // bottom right - glTexCoord2f(fTexOffset.X, fTexOffset.Y); - glVertex2f(fBitmapCoords.Width, -fBitmapCoords.Height); - glEnd(); - - glPopMatrix(); -end; - -procedure TFTGlyph.RenderReflection(); -var - Color: TGLColor; - TexUpperPos: single; - TexLowerPos: single; - UpperPos: single; -const - CutOff = 0.6; -begin - glPushMatrix(); - glBindTexture(GL_TEXTURE_2D, fTexture); - glGetFloatv(GL_CURRENT_COLOR, @Color.vals); - - // add extra space to the left of the glyph - glTranslatef(fBitmapCoords.Left, 0, 0); - - // The upper position of the glyph, if CutOff is 1.0, it is fFont.Ascender. - // If CutOff is set to 0.5 only half of the glyph height is displayed. - UpperPos := fFont.Descender + fFont.Height * CutOff; - - // the glyph texture's height is just the height of the glyph but not the font - // height. Setting a color for the upper and lower bounds of the glyph results - // in different color gradients. So we have to set the color values for the - // descender and ascender (as we have a cutoff, for the upper-pos here) as - // these positions are font but not glyph specific. - - // To get the texture positions we have to enhance the texture at the top and - // bottom by the amount from the top to ascender (rather upper-pos here) and - // from the bottom (Height-Top) to descender. Then we have to convert those - // heights to texture coordinates by dividing by the bitmap Height and - // removing the power-of-2 padding space by multiplying with fTexOffset.Y - // (as fBitmapCoords.Height corresponds to fTexOffset.Y and not 1.0). - TexUpperPos := -(UpperPos - fBitmapCoords.Top) / fBitmapCoords.Height * fTexOffset.Y; - TexLowerPos := (-(fFont.Descender + fBitmapCoords.Height - fBitmapCoords.Top) / - fBitmapCoords.Height + 1) * fTexOffset.Y; - - // draw glyph texture - glBegin(GL_QUADS); - // top right - glColor4f(Color.r, Color.g, Color.b, 0); - glTexCoord2f(fTexOffset.X, TexUpperPos); - glVertex2f(fBitmapCoords.Width, UpperPos); - - // top left - glTexCoord2f(0, TexUpperPos); - glVertex2f(0, UpperPos); - - // bottom left - glColor4f(Color.r, Color.g, Color.b, Color.a-0.3); - glTexCoord2f(0, TexLowerPos); - glVertex2f(0, fFont.Descender); - - // bottom right - glTexCoord2f(fTexOffset.X, TexLowerPos); - glVertex2f(fBitmapCoords.Width, fFont.Descender); - glEnd(); - - glPopMatrix(); - - // restore old color - // Note: glPopAttrib(GL_CURRENT_BIT)/glPopAttrib() is much slower then - // glGetFloatv(GL_CURRENT_COLOR, ...)/glColor4fv(...) - glColor4fv(@Color.vals); -end; - -function TFTGlyph.GetAdvance(): TPositionDbl; -begin - Result := fAdvance; -end; - -function TFTGlyph.GetBounds(): TBoundsDbl; -begin - Result := fBounds; -end; - - -{* - * TGlyphCache - *} - -constructor TGlyphCache.Create(); -begin - inherited; - fHash := TList.Create(); -end; - -destructor TGlyphCache.Destroy(); -begin - // free cached glyphs - FlushCache(false); - - // destroy TList - fHash.Free; - - inherited; -end; - -function TGlyphCache.FindGlyphTable(BaseCode: cardinal; out InsertPos: integer): PGlyphTable; -var - I: integer; - Entry: TGlyphCacheHashEntry; -begin - Result := nil; - - for I := 0 to fHash.Count-1 do - begin - Entry := TGlyphCacheHashEntry(fHash[I]); - - if (Entry.BaseCode > BaseCode) then - begin - InsertPos := I; - Exit; - end; - - if (Entry.BaseCode = BaseCode) then - begin - InsertPos := I; - Result := @Entry.GlyphTable; - Exit; - end; - end; - - InsertPos := fHash.Count; -end; - -function TGlyphCache.AddGlyph(ch: UCS4Char; const Glyph: TGlyph): boolean; -var - BaseCode: cardinal; - GlyphCode: integer; - InsertPos: integer; - GlyphTable: PGlyphTable; - Entry: TGlyphCacheHashEntry; -begin - Result := false; - - BaseCode := Ord(ch) shr 8; - GlyphTable := FindGlyphTable(BaseCode, InsertPos); - if (GlyphTable = nil) then - begin - Entry := TGlyphCacheHashEntry.Create(BaseCode); - GlyphTable := @Entry.GlyphTable; - fHash.Insert(InsertPos, Entry); - end; - - // get glyph table offset - GlyphCode := Ord(ch) and $FF; - // insert glyph into table if not present - if (GlyphTable[GlyphCode] = nil) then - begin - GlyphTable[GlyphCode] := Glyph; - Result := true; - end; -end; - -procedure TGlyphCache.DeleteGlyph(ch: UCS4Char); -var - Table: PGlyphTable; - TableIndex, GlyphIndex: integer; - TableEmpty: boolean; -begin - // find table - Table := FindGlyphTable(Ord(ch) shr 8, TableIndex); - if (Table = nil) then - Exit; - - // find glyph - GlyphIndex := Ord(ch) and $FF; - if (Table[GlyphIndex] <> nil) then - begin - // destroy glyph - FreeAndNil(Table[GlyphIndex]); - - // check if table is empty - TableEmpty := true; - for GlyphIndex := 0 to High(Table^) do - begin - if (Table[GlyphIndex] <> nil) then - begin - TableEmpty := false; - Break; - end; - end; - - // free empty table - if (TableEmpty) then - begin - fHash.Delete(TableIndex); - end; - end; -end; - -function TGlyphCache.GetGlyph(ch: UCS4Char): TGlyph; -var - InsertPos: integer; - Table: PGlyphTable; -begin - Table := FindGlyphTable(Ord(ch) shr 8, InsertPos); - if (Table = nil) then - Result := nil - else - Result := Table[Ord(ch) and $FF]; -end; - -function TGlyphCache.HasGlyph(ch: UCS4Char): boolean; -begin - Result := (GetGlyph(ch) <> nil); -end; - -procedure TGlyphCache.FlushCache(KeepBaseSet: boolean); -var - EntryIndex, TableIndex: integer; - Entry: TGlyphCacheHashEntry; -begin - // destroy cached glyphs - for EntryIndex := 0 to fHash.Count-1 do - begin - Entry := TGlyphCacheHashEntry(fHash[EntryIndex]); - - // the base set (0-255) has BaseCode 0 as the upper bytes are 0. - if KeepBaseSet and (Entry.fBaseCode = 0) then - Continue; - - for TableIndex := 0 to High(Entry.GlyphTable) do - begin - if (Entry.GlyphTable[TableIndex] <> nil) then - FreeAndNil(Entry.GlyphTable[TableIndex]); - end; - FreeAndNil(Entry); - end; -end; - - -{* - * TGlyphCacheEntry - *} - -constructor TGlyphCacheHashEntry.Create(BaseCode: cardinal); -begin - inherited Create(); - fBaseCode := BaseCode; -end; - - -{* - * TFreeType - *} - -class function TFreeType.GetLibrary(): FT_Library; -begin - if (LibraryInst = nil) then - begin - // initialize freetype - if (FT_Init_FreeType(LibraryInst) <> 0) then - raise Exception.Create('FT_Init_FreeType failed'); - end; - Result := LibraryInst; -end; - -class procedure TFreeType.FreeLibrary(); -begin - if (LibraryInst <> nil) then - FT_Done_FreeType(LibraryInst); - LibraryInst := nil; -end; - - -{$IFDEF BITMAP_FONT} -{* - * TBitmapFont - *} - -constructor TBitmapFont.Create(const Filename: IPath; Outline: integer; - Baseline, Ascender, Descender: integer); -begin - inherited Create(); - - fTex := Texture.LoadTexture(true, Filename, TEXTURE_TYPE_TRANSPARENT, 0); - fTexSize := 1024; - fOutline := Outline; - fBaseline := Baseline; - fAscender := Ascender; - fDescender := Descender; - - LoadFontInfo(Filename.SetExtension('.dat')); - - ResetIntern(); -end; - -destructor TBitmapFont.Destroy(); -begin - glDeleteTextures(1, @fTex.TexNum); - inherited; -end; - -procedure TBitmapFont.ResetIntern(); -begin - fLineSpacing := Height; -end; - -procedure TBitmapFont.Reset(); -begin - inherited; - ResetIntern(); -end; - -procedure TBitmapFont.CorrectWidths(WidthMult: real; WidthAdd: integer); -var - Count: integer; -begin - for Count := 0 to 255 do - fWidths[Count] := Round(fWidths[Count] * WidthMult) + WidthAdd; -end; - -procedure TBitmapFont.LoadFontInfo(const InfoFile: IPath); -var - Stream: TStream; -begin - FillChar(fWidths[0], Length(fWidths), 0); - - Stream := nil; - try - Stream := TBinaryFileStream.Create(InfoFile, fmOpenRead); - Stream.Read(fWidths, 256); - except - raise Exception.Create('Could not read font info file ''' + InfoFile.ToNative + ''''); - end; - Stream.Free; -end; - -function TBitmapFont.BBox(const Text: TUCS4StringArray; Advance: boolean): TBoundsDbl; -var - LineIndex, CharIndex: integer; - CharCode: cardinal; - Line: UCS4String; - LineWidth: double; -begin - Result.Left := 0; - Result.Right := 0; - Result.Top := Height; - Result.Bottom := 0; - - for LineIndex := 0 to High(Text) do - begin - Line := Text[LineIndex]; - LineWidth := 0; - for CharIndex := 0 to LengthUCS4(Line)-1 do - begin - CharCode := Ord(Line[CharIndex]); - if (CharCode < Length(fWidths)) then - LineWidth := LineWidth + fWidths[CharCode]; - end; - if (LineWidth > Result.Right) then - Result.Right := LineWidth; - end; -end; - -procedure TBitmapFont.RenderChar(ch: UCS4Char; var AdvanceX: real); -var - TexX, TexY: real; - TexR, TexB: real; - GlyphWidth: real; - PL, PT: real; - PR, PB: real; - CharCode: cardinal; -begin - CharCode := Ord(ch); - if (CharCode > High(fWidths)) then - CharCode := 0; - - GlyphWidth := fWidths[CharCode]; - - // set texture positions - TexX := (CharCode mod 16) * 1/16 + 1/32 - (GlyphWidth/2 - fOutline)/fTexSize; - TexY := (CharCode div 16) * 1/16 + {2 texels} 2/fTexSize; - TexR := (CharCode mod 16) * 1/16 + 1/32 + (GlyphWidth/2 + fOutline)/fTexSize; - TexB := (1 + CharCode div 16) * 1/16 - {2 texels} 2/fTexSize; - - // set vector positions - PL := AdvanceX - fOutline; - PR := PL + GlyphWidth + fOutline*2; - PB := -fBaseline; - PT := PB + fTexSize div 16; - - (* - if (Font.Blend) then - begin - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - end; - *) - - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, fTex.TexNum); - - if (not ReflectionPass) then - begin - glBegin(GL_QUADS); - glTexCoord2f(TexX, TexY); glVertex2f(PL, PT); - glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); - glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); - glTexCoord2f(TexR, TexY); glVertex2f(PR, PT); - glEnd; - end - else - begin - glDepthRange(0, 10); - glDepthFunc(GL_LEQUAL); - glEnable(GL_DEPTH_TEST); - - glBegin(GL_QUADS); - glTexCoord2f(TexX, TexY); glVertex2f(PL, PT); - glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); - glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); - glTexCoord2f(TexR, TexY); glVertex2f(PR, PT); - glEnd; - - glBegin(GL_QUADS); - glTexCoord2f(TexX, TexY); glVertex2f(PL, PT); - glTexCoord2f(TexX, TexB); glVertex2f(PL, PB); - glTexCoord2f(TexR, TexB); glVertex2f(PR, PB); - glTexCoord2f(TexR, TexY); glVertex2f(PR, PT); - -(* - glColor4f(fTempColor.r, fTempColor.g, fTempColor.b, 0.7); - glTexCoord2f(TexX, TexB); glVertex3f(PL, PB, 0); - glTexCoord2f(TexR, TexB); glVertex3f(PR, PB, 0); - - glColor4f(fTempColor.r, fTempColor.g, fTempColor.b, 0); - glTexCoord2f(TexR, (TexY + TexB)/2); glVertex3f(PR, (PT + PB)/2, 0); - glTexCoord2f(TexX, (TexY + TexB)/2); glVertex3f(PL, (PT + PB)/2, 0); -*) - glEnd; - - //write the colour back - glColor4fv(@fTempColor); - - glDisable(GL_DEPTH_TEST); - end; // reflection - - glDisable(GL_TEXTURE_2D); - (* - if (Font.Blend) then - glDisable(GL_BLEND); - *) - - AdvanceX := AdvanceX + GlyphWidth; -end; - -procedure TBitmapFont.Render(const Text: UCS4String); -var - CharIndex: integer; - AdvanceX: real; -begin - // if there is no text do nothing - if (Text = nil) or (Text[0] = 0) then - Exit; - - //Save the current color and alpha (for reflection) - glGetFloatv(GL_CURRENT_COLOR, @fTempColor); - - AdvanceX := 0; - for CharIndex := 0 to LengthUCS4(Text)-1 do - begin - RenderChar(Text[CharIndex], AdvanceX); - end; -end; - -function TBitmapFont.GetHeight(): single; -begin - Result := fAscender - fDescender; -end; - -function TBitmapFont.GetAscender(): single; -begin - Result := fAscender; -end; - -function TBitmapFont.GetDescender(): single; -begin - Result := fDescender; -end; - -function TBitmapFont.GetUnderlinePosition(): single; -begin - Result := -2.0; -end; - -function TBitmapFont.GetUnderlineThickness(): single; -begin - Result := 1.0; -end; - -{$ENDIF BITMAP_FONT} - - -initialization - -finalization - TFreeType.FreeLibrary(); - -end. diff --git a/src/base/UGraphic.pas b/src/base/UGraphic.pas deleted file mode 100644 index b0e5a7d8..00000000 --- a/src/base/UGraphic.pas +++ /dev/null @@ -1,823 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UGraphic; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - gl, - glext, - UTexture, - TextGL, - ULog, - SysUtils, - ULyrics, - UImage, - UMusic, - UScreenLoading, - UScreenWelcome, - UScreenMain, - UScreenName, - UScreenLevel, - UScreenOptions, - UScreenOptionsGame, - UScreenOptionsGraphics, - UScreenOptionsSound, - UScreenOptionsLyrics, - UScreenOptionsThemes, - UScreenOptionsRecord, - UScreenOptionsAdvanced, - UScreenSong, - UScreenSing, - UScreenScore, - UScreenTop5, - UScreenEditSub, - UScreenEdit, - UScreenEditConvert, - UScreenEditHeader, - UScreenOpen, - UThemes, - USkins, - UScreenSongMenu, - UScreenSongJumpto, - {Party Screens} - UScreenSingModi, - UScreenPartyNewRound, - UScreenPartyScore, - UScreenPartyOptions, - UScreenPartyWin, - UScreenPartyPlayer, - {Stats Screens} - UScreenStatMain, - UScreenStatDetail, - {CreditsScreen} - UScreenCredits, - {Popup for errors, etc.} - UScreenPopup; - -type - TRecR = record - Top: real; - Left: real; - Right: real; - Bottom: real; - end; - -var - Screen: PSDL_Surface; - LoadingThread: PSDL_Thread; - Mutex: PSDL_Mutex; - - RenderW: integer; - RenderH: integer; - ScreenW: integer; - ScreenH: integer; - Screens: integer; - ScreenAct: integer; - ScreenX: integer; - - ScreenLoading: TScreenLoading; - ScreenWelcome: TScreenWelcome; - ScreenMain: TScreenMain; - ScreenName: TScreenName; - ScreenLevel: TScreenLevel; - ScreenSong: TScreenSong; - ScreenSing: TScreenSing; - ScreenScore: TScreenScore; - ScreenTop5: TScreenTop5; - ScreenOptions: TScreenOptions; - ScreenOptionsGame: TScreenOptionsGame; - ScreenOptionsGraphics: TScreenOptionsGraphics; - ScreenOptionsSound: TScreenOptionsSound; - ScreenOptionsLyrics: TScreenOptionsLyrics; - ScreenOptionsThemes: TScreenOptionsThemes; - ScreenOptionsRecord: TScreenOptionsRecord; - ScreenOptionsAdvanced: TScreenOptionsAdvanced; - ScreenEditSub: TScreenEditSub; - ScreenEdit: TScreenEdit; - ScreenEditConvert: TScreenEditConvert; - ScreenEditHeader: TScreenEditHeader; - ScreenOpen: TScreenOpen; - - ScreenSongMenu: TScreenSongMenu; - ScreenSongJumpto: TScreenSongJumpto; - - //Party Screens - ScreenSingModi: TScreenSingModi; - ScreenPartyNewRound: TScreenPartyNewRound; - ScreenPartyScore: TScreenPartyScore; - ScreenPartyWin: TScreenPartyWin; - ScreenPartyOptions: TScreenPartyOptions; - ScreenPartyPlayer: TScreenPartyPlayer; - - //StatsScreens - ScreenStatMain: TScreenStatMain; - ScreenStatDetail: TScreenStatDetail; - - //CreditsScreen - ScreenCredits: TScreenCredits; - - //popup mod - ScreenPopupCheck: TScreenPopupCheck; - ScreenPopupError: TScreenPopupError; - ScreenPopupInfo: TScreenPopupInfo; - - //Notes - Tex_Left: array[1..6] of TTexture; //rename to tex_note_left - Tex_Mid: array[1..6] of TTexture; //rename to tex_note_mid - Tex_Right: array[1..6] of TTexture; //rename to tex_note_right - - Tex_plain_Left: array[1..6] of TTexture; //rename to tex_notebg_left - Tex_plain_Mid: array[1..6] of TTexture; //rename to tex_notebg_mid - Tex_plain_Right: array[1..6] of TTexture; //rename to tex_notebg_right - - Tex_BG_Left: array[1..6] of TTexture; //rename to tex_noteglow_left - Tex_BG_Mid: array[1..6] of TTexture; //rename to tex_noteglow_mid - Tex_BG_Right: array[1..6] of TTexture; //rename to tex_noteglow_right - - Tex_Note_Star: TTexture; - Tex_Note_Perfect_Star: TTexture; - - - Tex_Ball: TTexture; - Tex_Lyric_Help_Bar: TTexture; - FullScreen: boolean; - - Tex_TimeProgress: TTexture; - - //Sing Bar Mod - Tex_SingBar_Back: TTexture; - Tex_SingBar_Bar: TTexture; - Tex_SingBar_Front: TTexture; - //end Singbar Mod - - //PhrasenBonus - Line Bonus Mod - Tex_SingLineBonusBack: array[0..8] of TTexture; - //End PhrasenBonus - Line Bonus Mod - - //ScoreBG Texs - Tex_ScoreBG: array [0..5] of TTexture; - - //Score Screen Textures - Tex_Score_NoteBarLevel_Dark : array [1..6] of TTexture; - Tex_Score_NoteBarRound_Dark : array [1..6] of TTexture; - - Tex_Score_NoteBarLevel_Light : array [1..6] of TTexture; - Tex_Score_NoteBarRound_Light : array [1..6] of TTexture; - - Tex_Score_NoteBarLevel_Lightest : array [1..6] of TTexture; - Tex_Score_NoteBarRound_Lightest : array [1..6] of TTexture; - - Tex_Score_Ratings : array [0..7] of TTexture; - - // arrows for SelectSlide - Tex_SelectS_ArrowL: TTexture; - Tex_SelectS_ArrowR: TTexture; - - // textures for software mouse cursor - Tex_Cursor_Unpressed: TTexture; - Tex_Cursor_Pressed: TTexture; -const - Skin_BGColorR = 1; - Skin_BGColorG = 1; - Skin_BGColorB = 1; - - Skin_SpectrumR = 0; - Skin_SpectrumG = 0; - Skin_SpectrumB = 0; - - Skin_Spectograph1R = 0.6; - Skin_Spectograph1G = 0.8; - Skin_Spectograph1B = 1; - - Skin_Spectograph2R = 0; - Skin_Spectograph2G = 0; - Skin_Spectograph2B = 0.2; - - Skin_FontR = 0; - Skin_FontG = 0; - Skin_FontB = 0; - - Skin_FontHighlightR = 0.3; // 0.3 - Skin_FontHighlightG = 0.3; // 0.3 - Skin_FontHighlightB = 1; // 1 - - Skin_TimeR = 0.25; //0,0,0 - Skin_TimeG = 0.25; - Skin_TimeB = 0.25; - - Skin_OscR = 0; - Skin_OscG = 0; - Skin_OscB = 0; - - Skin_SpectrumT = 470; - Skin_SpectrumBot = 570; - Skin_SpectrumH = 100; - - Skin_P1_LinesR = 0.5; // 0.6 0.6 1 - Skin_P1_LinesG = 0.5; - Skin_P1_LinesB = 0.5; - - Skin_P2_LinesR = 0.5; // 1 0.6 0.6 - Skin_P2_LinesG = 0.5; - Skin_P2_LinesB = 0.5; - - Skin_P1_NotesB = 250; - Skin_P2_NotesB = 430; // 430 / 300 - - Skin_P1_ScoreT = 50; - Skin_P1_ScoreL = 20; - - Skin_P2_ScoreT = 50; - Skin_P2_ScoreL = 640; - -procedure Initialize3D (Title: string); -procedure Reinitialize3D; -procedure SwapBuffers; - -procedure LoadTextures; -procedure InitializeScreen; -procedure LoadLoadingScreen; -procedure LoadScreens; -procedure UnLoadScreens; - -function LoadingThreadFunction: integer; - - -implementation - -uses - Classes, - UMain, - UIni, - UDisplay, - UCommandLine, - UPathUtils; - -procedure LoadFontTextures; -begin - Log.LogStatus('Building Fonts', 'LoadTextures'); - BuildFont; -end; - -procedure LoadTextures; - -var - P: integer; - R, G, B: real; - Col: integer; -begin - Log.LogStatus('Loading Textures', 'LoadTextures'); - - // P1-6 - // TODO... do it once for each player... this is a bit crappy !! - // can we make it any better !? - for P := 1 to 6 do - begin - LoadColor(R, G, B, 'P' + IntToStr(P) + 'Light'); - Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - - { some colors for tests - Col := $10000 * Round(0.02*255) + $100 * Round(0.6 *255) + Round(0.8 *255); //blue - Col := $10000 * Round(0.8 *255) ; //red - Col := $100 * Round(0.85*255) ; //green - Col := $10000 * 255 + $100 * Round(0.52*255) ; //orange - Col := $10000 * 255 + $100 * 255 ; //yellow - Col := $10000 * Round(0.82*255) + 255 ; //purple - Col := $10000 * Round(0.22*255) + $100 * Round(0.39*255) + Round(0.64*255); //dark blue - Col := $10000 * Round(0 *255) + $100 * Round(0 *255) + Round(0 *255); //black - Col := $10000 * Round(1.0 *255) + $100 * Round(0.43*255) + Round(0.70*255); //pink - Col := 0; //black - Col := $FFFFFF; //white - Col := $FF0000; //red - Col := $00FF00; //green - Col := $002200; //light green - Col := $002222; //light greenblue - Col := $222200; //light yellow - Col := $340000; //red - Col := $FF6EB4; //pink - Col := $333333; //grey - } - - Tex_Left[P] := Texture.LoadTexture(Skin.GetTextureFileName('GrayLeft'), TEXTURE_TYPE_COLORIZED, Col); - Tex_Mid[P] := Texture.LoadTexture(Skin.GetTextureFileName('GrayMid'), TEXTURE_TYPE_COLORIZED, Col); - Tex_Right[P] := Texture.LoadTexture(Skin.GetTextureFileName('GrayRight'), TEXTURE_TYPE_COLORIZED, Col); - - Tex_plain_Left[P] := Texture.LoadTexture(Skin.GetTextureFileName('NotePlainLeft'), TEXTURE_TYPE_COLORIZED, Col); - Tex_plain_Mid[P] := Texture.LoadTexture(Skin.GetTextureFileName('NotePlainMid'), TEXTURE_TYPE_COLORIZED, Col); - Tex_plain_Right[P] := Texture.LoadTexture(Skin.GetTextureFileName('NotePlainRight'), TEXTURE_TYPE_COLORIZED, Col); - - Tex_BG_Left[P] := Texture.LoadTexture(Skin.GetTextureFileName('NoteBGLeft'), TEXTURE_TYPE_COLORIZED, Col); - Tex_BG_Mid[P] := Texture.LoadTexture(Skin.GetTextureFileName('NoteBGMid'), TEXTURE_TYPE_COLORIZED, Col); - Tex_BG_Right[P] := Texture.LoadTexture(Skin.GetTextureFileName('NoteBGRight'), TEXTURE_TYPE_COLORIZED, Col); - end; - - Log.LogStatus('Loading Textures - B', 'LoadTextures'); - - Tex_Note_Perfect_Star := Texture.LoadTexture(Skin.GetTextureFileName('NotePerfectStar'), TEXTURE_TYPE_TRANSPARENT, 0); - Tex_Note_Star := Texture.LoadTexture(Skin.GetTextureFileName('NoteStar') , TEXTURE_TYPE_TRANSPARENT, $FFFFFF); - Tex_Ball := Texture.LoadTexture(Skin.GetTextureFileName('Ball'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - Tex_Lyric_Help_Bar := Texture.LoadTexture(Skin.GetTextureFileName('LyricHelpBar'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - - Tex_SelectS_ArrowL := Texture.LoadTexture(Skin.GetTextureFileName('Select_ArrowLeft'), TEXTURE_TYPE_TRANSPARENT, 0); - Tex_SelectS_ArrowR := Texture.LoadTexture(Skin.GetTextureFileName('Select_ArrowRight'), TEXTURE_TYPE_TRANSPARENT, 0); - - Tex_Cursor_Unpressed := Texture.LoadTexture(Skin.GetTextureFileName('Cursor'), TEXTURE_TYPE_TRANSPARENT, 0); - - if (Skin.GetTextureFileName('Cursor_Pressed').IsSet) then - Tex_Cursor_Pressed := Texture.LoadTexture(Skin.GetTextureFileName('Cursor_Pressed'), TEXTURE_TYPE_TRANSPARENT, 0) - else - Tex_Cursor_Pressed.TexNum := 0; - - //TimeBar mod - Tex_TimeProgress := Texture.LoadTexture(Skin.GetTextureFileName('TimeBar')); - //eoa TimeBar mod - - //SingBar Mod - Tex_SingBar_Back := Texture.LoadTexture(Skin.GetTextureFileName('SingBarBack'), TEXTURE_TYPE_PLAIN, 0); - Tex_SingBar_Bar := Texture.LoadTexture(Skin.GetTextureFileName('SingBarBar'), TEXTURE_TYPE_PLAIN, 0); - Tex_SingBar_Front := Texture.LoadTexture(Skin.GetTextureFileName('SingBarFront'), TEXTURE_TYPE_PLAIN, 0); - //end Singbar Mod - - Log.LogStatus('Loading Textures - C', 'LoadTextures'); - - //Line Bonus PopUp - for P := 0 to 8 do - begin - Case P of - 0: begin - R := 1; - G := 0; - B := 0; - end; - 1..3: begin - R := 1; - G := (P * 0.25); - B := 0; - end; - 4: begin - R := 1; - G := 1; - B := 0; - end; - 5..7: begin - R := 1-((P-4)*0.25); - G := 1; - B := 0; - end; - 8: begin - R := 0; - G := 1; - B := 0; - end; - End; - - Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_SingLineBonusBack[P] := Texture.LoadTexture(Skin.GetTextureFileName('LineBonusBack'), TEXTURE_TYPE_COLORIZED, Col); - end; - -//## backgrounds for the scores ## - for P := 0 to 5 do begin - LoadColor(R, G, B, 'P' + IntToStr(P+1) + 'Light'); - Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_ScoreBG[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreBG'), TEXTURE_TYPE_COLORIZED, Col); - end; - - - Log.LogStatus('Loading Textures - D', 'LoadTextures'); - -// ###################### -// Score screen textures -// ###################### - -//## the bars that visualize the score ## - for P := 1 to 6 do begin -//NoteBar ScoreBar - LoadColor(R, G, B, 'P' + IntToStr(P) + 'Dark'); - Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_Score_NoteBarLevel_Dark[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Dark'), TEXTURE_TYPE_COLORIZED, Col); - Tex_Score_NoteBarRound_Dark[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Dark_Round'), TEXTURE_TYPE_COLORIZED, Col); -//LineBonus ScoreBar - LoadColor(R, G, B, 'P' + IntToStr(P) + 'Light'); - Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_Score_NoteBarLevel_Light[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Light'), TEXTURE_TYPE_COLORIZED, Col); - Tex_Score_NoteBarRound_Light[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Light_Round'), TEXTURE_TYPE_COLORIZED, Col); -//GoldenNotes ScoreBar - LoadColor(R, G, B, 'P' + IntToStr(P) + 'Lightest'); - Col := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - Tex_Score_NoteBarLevel_Lightest[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Lightest'), TEXTURE_TYPE_COLORIZED, Col); - Tex_Score_NoteBarRound_Lightest[P] := Texture.LoadTexture(Skin.GetTextureFileName('ScoreLevel_Lightest_Round'), TEXTURE_TYPE_COLORIZED, Col); - end; - -//## rating pictures that show a picture according to your rate ## - for P := 0 to 7 do begin - Tex_Score_Ratings[P] := Texture.LoadTexture(Skin.GetTextureFileName('Rating_'+IntToStr(P)), TEXTURE_TYPE_TRANSPARENT, 0); - end; - - Log.LogStatus('Loading Textures - Done', 'LoadTextures'); -end; - -(* - * Load OpenGL extensions. Must be called after SDL_SetVideoMode() and each - * time the pixel-format or render-context (RC) changes. - *) -procedure LoadOpenGLExtensions; -begin - // Load OpenGL 1.2 extensions for OpenGL 1.2 compatibility - if (not Load_GL_version_1_2()) then - begin - Log.LogCritical('Failed loading OpenGL 1.2', 'UGraphic.Initialize3D'); - end; - - // Other extensions e.g. OpenGL 1.3-2.0 or Framebuffer-Object might be loaded here - // ... - //Load_GL_EXT_framebuffer_object(); -end; - -const - WINDOW_ICON = 'icons/ultrastardx-icon.png'; - -procedure Initialize3D (Title: string); -var - Icon: PSDL_Surface; -begin - Log.LogStatus('SDL_Init', 'UGraphic.Initialize3D'); - if ( SDL_InitSubSystem(SDL_INIT_VIDEO) = -1 ) then - begin - Log.LogCritical('SDL_Init Failed', 'UGraphic.Initialize3D'); - end; - - // load icon image (must be 32x32 for win32) - Icon := LoadImage(ResourcesPath.Append(WINDOW_ICON)); - if (Icon <> nil) then - SDL_WM_SetIcon(Icon, nil); - - SDL_WM_SetCaption(PChar(Title), nil); - - //Log.BenchmarkStart(2); - - InitializeScreen; - - //Log.BenchmarkEnd(2); - //Log.LogBenchmark('--> Setting Screen', 2); - - //Log.BenchmarkStart(2); - Texture := TTextureUnit.Create; - // FIXME: this does not seem to be correct as Limit. - // Is the max. of either width or height. - Texture.Limit := 1024*1024; - - //LoadTextures; - //Log.BenchmarkEnd(2); - //Log.LogBenchmark('--> Loading Textures', 2); - - { - Log.BenchmarkStart(2); - Lyric:= TLyric.Create; - Log.BenchmarkEnd(2); - Log.LogBenchmark('--> Loading Fonts', 2); - } - - // Note: do not initialize video modules earlier. They might depend on some - // SDL video functions or OpenGL extensions initialized in InitializeScreen() - InitializeVideo(); - - //Log.BenchmarkStart(2); - - Log.LogStatus('TDisplay.Create', 'UGraphic.Initialize3D'); - Display := TDisplay.Create; - //Display.SetCursor; - - //Log.BenchmarkEnd(2); Log.LogBenchmark('====> Creating Display', 2); - - //Log.LogStatus('Loading Screens', 'Initialize3D'); - //Log.BenchmarkStart(3); - - Log.LogStatus('Loading Font Textures', 'UGraphic.Initialize3D'); - LoadFontTextures(); - - // Show the Loading Screen ------------- - Log.LogStatus('Loading Loading Screen', 'UGraphic.Initialize3D'); - LoadLoadingScreen; - - - Log.LogStatus(' Loading Textures', 'UGraphic.Initialize3D'); - LoadTextures; // jb - - - - // now that we have something to display while loading, - // start thread that loads the rest of ultrastar - //Mutex := SDL_CreateMutex; - //SDL_UnLockMutex(Mutex); - - // does not work this way because the loading thread tries to access opengl. - // See comment below - //LoadingThread := SDL_CreateThread(@LoadingThread, nil); - - // this would be run in the loadingthread - Log.LogStatus(' Loading Screens', 'UGraphic.Initialize3D'); - LoadScreens; - - - // TODO: - // here should be a loop which - // * draws the loading screen (form time to time) - // * controlls the "process of the loading screen" - // * checks if the loadingthread has loaded textures (check mutex) and - // * load the textures into opengl - // * tells the loadingthread, that the memory for the texture can be reused - // to load the netx texture (over another mutex) - // * runs as long as the loadingthread tells, that everything is loaded and ready (using a third mutex) - // - // therefor loadtexture have to be changed, that it, instat of caling some opengl functions - // for itself, it should change mutex - // the mainthread have to know somehow what opengl function have to be called with which parameters like - // texturetype, textureobjekt, textur-buffer-adress, ... - - // wait for loading thread to finish - // currently does not work this way - // SDL_WaitThread(LoadingThread, I); - // SDL_DestroyMutex(Mutex); - - Display.CurrentScreen^.FadeTo( @ScreenMain ); - - Log.BenchmarkEnd(2); - Log.LogBenchmark('--> Loading Screens', 2); - - Log.LogStatus('Finish', 'Initialize3D'); -end; - -procedure SwapBuffers; -begin - SDL_GL_SwapBuffers; - glMatrixMode(GL_PROJECTION); - glLoadIdentity; - glOrtho(0, RenderW, RenderH, 0, -1, 100); - glMatrixMode(GL_MODELVIEW); -end; - -procedure Reinitialize3D; -begin - InitializeScreen; -end; - -procedure InitializeScreen; -var - S: string; - I: integer; - W, H: integer; - Depth: Integer; - Fullscreen: boolean; -begin - if (Params.Screens <> -1) then - Screens := Params.Screens + 1 - else - Screens := Ini.Screens + 1; - - // Set minimum color component sizes - // Note: do not request an alpha plane with SDL_GL_ALPHA_SIZE here as - // some cards/implementations do not support them (SDL_SetVideoMode fails). - // We do not the alpha plane anymore since offscreen rendering in back-buffer - // was removed. - SDL_GL_SetAttribute(SDL_GL_RED_SIZE, 5); - SDL_GL_SetAttribute(SDL_GL_GREEN_SIZE, 5); - SDL_GL_SetAttribute(SDL_GL_BLUE_SIZE, 5); - - SDL_GL_SetAttribute(SDL_GL_DEPTH_SIZE, 16); // Z-Buffer depth - SDL_GL_SetAttribute(SDL_GL_DOUBLEBUFFER, 1); - - // VSYNC works for windows only at the moment. SDL_GL_SWAP_CONTROL under - // linux uses GLX_MESA_swap_control which is not supported by nvidea cards. - // Maybe use glXSwapIntervalSGI(1) from the GLX_SGI_swap_control extension instead. - //SDL_GL_SetAttribute(SDL_GL_SWAP_CONTROL, 1); // VSYNC (currently Windows only) - - // If there is a resolution in Parameters, use it, else use the Ini value - I := Params.Resolution; - if (I <> -1) then - S := IResolution[I] - else - S := IResolution[Ini.Resolution]; - - I := Pos('x', S); - W := StrToInt(Copy(S, 1, I-1)) * Screens; - H := StrToInt(Copy(S, I+1, 1000)); - - if (Params.Depth <> -1) then - Depth := Params.Depth - else - Depth := Ini.Depth; - - Log.LogStatus('SDL_SetVideoMode', 'Initialize3D'); - - // check whether to start in fullscreen or windowed mode. - // The command-line parameters take precedence over the ini settings. - Fullscreen := ((Ini.FullScreen = 1) or (Params.ScreenMode = scmFullscreen)) and - not (Params.ScreenMode = scmWindowed); - - if Fullscreen then - begin - Log.LogStatus('SDL_SetVideoMode', 'Set Video Mode... Full Screen'); - screen := SDL_SetVideoMode(W, H, (Depth+1) * 16, SDL_OPENGL or SDL_FULLSCREEN ); - end - else - begin - Log.LogStatus('SDL_SetVideoMode', 'Set Video Mode... Windowed'); - screen := SDL_SetVideoMode(W, H, 0, SDL_OPENGL or SDL_RESIZABLE); - end; - - SDL_ShowCursor(0); - - if (screen = nil) then - begin - Log.LogCritical('SDL_SetVideoMode Failed', 'Initialize3D'); - end; - - LoadOpenGLExtensions(); - - // define virtual (Render) and real (Screen) screen size - RenderW := 800; - RenderH := 600; - ScreenW := W; - ScreenH := H; - - // clear screen once window is being shown - // Note: SwapBuffers uses RenderW/H, so they must be defined before - glClearColor(1, 1, 1, 1); - glClear(GL_COLOR_BUFFER_BIT); - SwapBuffers; -end; - -procedure LoadLoadingScreen; -begin - ScreenLoading := TScreenLoading.Create; - ScreenLoading.OnShow; - - Display.CurrentScreen := @ScreenLoading; - - SwapBuffers; - - ScreenLoading.Draw; - Display.Draw; - - SwapBuffers; -end; - -procedure LoadScreens; -begin -{ ScreenLoading := TScreenLoading.Create; - ScreenLoading.OnShow; - Display.CurrentScreen := @ScreenLoading; - ScreenLoading.Draw; - Display.Draw; - SwapBuffers; -} - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Loading', 3); Log.BenchmarkStart(3); -{ ScreenWelcome := TScreenWelcome.Create; //'BG', 4, 3); - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Welcome', 3); Log.BenchmarkStart(3);} - ScreenMain := TScreenMain.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Main', 3); Log.BenchmarkStart(3); - ScreenName := TScreenName.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Name', 3); Log.BenchmarkStart(3); - ScreenLevel := TScreenLevel.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Level', 3); Log.BenchmarkStart(3); - ScreenSong := TScreenSong.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Song', 3); Log.BenchmarkStart(3); - ScreenSongMenu := TScreenSongMenu.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Song Menu', 3); Log.BenchmarkStart(3); - ScreenSing := TScreenSing.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Sing', 3); Log.BenchmarkStart(3); - ScreenScore := TScreenScore.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Score', 3); Log.BenchmarkStart(3); - ScreenTop5 := TScreenTop5.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Top5', 3); Log.BenchmarkStart(3); - ScreenOptions := TScreenOptions.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options', 3); Log.BenchmarkStart(3); - ScreenOptionsGame := TScreenOptionsGame.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Game', 3); Log.BenchmarkStart(3); - ScreenOptionsGraphics := TScreenOptionsGraphics.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Graphics', 3); Log.BenchmarkStart(3); - ScreenOptionsSound := TScreenOptionsSound.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Sound', 3); Log.BenchmarkStart(3); - ScreenOptionsLyrics := TScreenOptionsLyrics.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Lyrics', 3); Log.BenchmarkStart(3); - ScreenOptionsThemes := TScreenOptionsThemes.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Themes', 3); Log.BenchmarkStart(3); - ScreenOptionsRecord := TScreenOptionsRecord.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Record', 3); Log.BenchmarkStart(3); - ScreenOptionsAdvanced := TScreenOptionsAdvanced.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Options Advanced', 3); Log.BenchmarkStart(3); - ScreenEditSub := TScreenEditSub.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Edit Sub', 3); Log.BenchmarkStart(3); - ScreenEdit := TScreenEdit.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Edit', 3); Log.BenchmarkStart(3); - ScreenEditConvert := TScreenEditConvert.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen EditConvert', 3); Log.BenchmarkStart(3); -// ScreenEditHeader := TScreenEditHeader.Create(Skin.ScoreBG); -// Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Edit Header', 3); Log.BenchmarkStart(3); - ScreenOpen := TScreenOpen.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Open', 3); Log.BenchmarkStart(3); - ScreenSingModi := TScreenSingModi.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Sing with Modi support', 3); Log.BenchmarkStart(3); - ScreenSongMenu := TScreenSongMenu.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen SongMenu', 3); Log.BenchmarkStart(3); - ScreenSongJumpto := TScreenSongJumpto.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen SongJumpto', 3); Log.BenchmarkStart(3); - ScreenPopupCheck := TScreenPopupCheck.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Popup (Check)', 3); Log.BenchmarkStart(3); - ScreenPopupError := TScreenPopupError.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Popup (Error)', 3); Log.BenchmarkStart(3); - ScreenPopupInfo := TScreenPopupInfo.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Popup (Info)', 3); Log.BenchmarkStart(3); - ScreenPartyNewRound := TScreenPartyNewRound.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyNewRound', 3); Log.BenchmarkStart(3); - ScreenPartyScore := TScreenPartyScore.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyScore', 3); Log.BenchmarkStart(3); - ScreenPartyWin := TScreenPartyWin.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyWin', 3); Log.BenchmarkStart(3); - ScreenPartyOptions := TScreenPartyOptions.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyOptions', 3); Log.BenchmarkStart(3); - ScreenPartyPlayer := TScreenPartyPlayer.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen PartyPlayer', 3); Log.BenchmarkStart(3); - ScreenStatMain := TScreenStatMain.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Stat Main', 3); Log.BenchmarkStart(3); - ScreenStatDetail := TScreenStatDetail.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Stat Detail', 3); Log.BenchmarkStart(3); - ScreenCredits := TScreenCredits.Create; - Log.BenchmarkEnd(3); Log.LogBenchmark('====> Screen Credits', 3); Log.BenchmarkStart(3); - -end; - -function LoadingThreadFunction: integer; -begin - LoadScreens; - Result:= 1; -end; - -procedure UnLoadScreens; -begin - ScreenMain.Destroy; - ScreenName.Destroy; - ScreenLevel.Destroy; - ScreenSong.Destroy; - ScreenSing.Destroy; - ScreenScore.Destroy; - ScreenTop5.Destroy; - ScreenOptions.Destroy; - ScreenOptionsGame.Destroy; - ScreenOptionsGraphics.Destroy; - ScreenOptionsSound.Destroy; - ScreenOptionsLyrics.Destroy; -// ScreenOptionsThemes.Destroy; - ScreenOptionsRecord.Destroy; - ScreenOptionsAdvanced.Destroy; - ScreenEditSub.Destroy; - ScreenEdit.Destroy; - ScreenEditConvert.Destroy; - ScreenOpen.Destroy; - ScreenSingModi.Destroy; - ScreenSongMenu.Destroy; - ScreenSongJumpto.Destroy; - ScreenPopupCheck.Destroy; - ScreenPopupError.Destroy; - ScreenPopupInfo.Destroy; - ScreenPartyNewRound.Destroy; - ScreenPartyScore.Destroy; - ScreenPartyWin.Destroy; - ScreenPartyOptions.Destroy; - ScreenPartyPlayer.Destroy; - ScreenStatMain.Destroy; - ScreenStatDetail.Destroy; -end; - -end. diff --git a/src/base/UGraphicClasses.pas b/src/base/UGraphicClasses.pas deleted file mode 100644 index cdaa238e..00000000 --- a/src/base/UGraphicClasses.pas +++ /dev/null @@ -1,720 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UGraphicClasses; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UTexture, - SDL; - -const - DelayBetweenFrames : cardinal = 60; - -type - - TParticleType = (GoldenNote, PerfectNote, NoteHitTwinkle, PerfectLineTwinkle, ColoredStar, Flare); - - TColour3f = record - r, g, b: real; - end; - - TParticle = class - X, Y : real; //Position - Screen : integer; - W, H : cardinal; //dimensions of particle - Col : array of TColour3f; // Colour(s) of particle - Scale : array of real; // Scaling factors of particle layers - Frame : byte; //act. Frame - Tex : cardinal; //Tex num from Textur Manager - Live : byte; //How many Cycles before Kill - RecIndex : integer; //To which rectangle this particle belongs (only GoldenNote) - StarType : TParticleType; // GoldenNote | PerfectNote | NoteHitTwinkle | PerfectLineTwinkle - Alpha : real; // used for fading... - mX, mY : real; // movement-vector for PerfectLineTwinkle - SizeMod : real; // experimental size modifier - SurviveSentenceChange : Boolean; - - constructor Create(cX, cY : real; - cScreen : integer; - cLive : byte; - cFrame : integer; - cRecArrayIndex : integer; - cStarType : TParticleType; - Player : cardinal); - destructor Destroy(); override; - procedure Draw; - procedure LiveOn; - end; - - RectanglePositions = record - xTop, yTop, xBottom, yBottom : real; - TotalStarCount : integer; - CurrentStarCount : integer; - Screen : integer; - end; - - PerfectNotePositions = record - xPos, yPos : real; - Screen : integer; - end; - - TEffectManager = class - Particle : array of TParticle; - LastTime : cardinal; - RecArray : array of RectanglePositions; - TwinkleArray : array[0..5] of real; // store x-position of last twinkle for every player - PerfNoteArray : array of PerfectNotePositions; - - FlareTex: TTexture; - - constructor Create; - destructor Destroy; override; - procedure Draw; - function Spawn(X, Y: real; - Screen: integer; - Live: byte; - StartFrame: integer; - RecArrayIndex: integer; // this is only used with GoldenNotes - StarType: TParticleType; - Player: cardinal // for PerfectLineTwinkle - ): cardinal; - procedure SpawnRec(); - procedure Kill(index: cardinal); - procedure KillAll(); - procedure SentenceChange(); - procedure SaveGoldenStarsRec(Xtop, Ytop, Xbottom, Ybottom: real); - procedure SavePerfectNotePos(Xtop, Ytop: real); - procedure GoldenNoteTwinkle(Top, Bottom, Right: real; Player: integer); - procedure SpawnPerfectLineTwinkle(); - end; - -var - GoldenRec : TEffectManager; - -implementation - -uses - SysUtils, - Math, - gl, - UCommon, - UDrawTexture, - UGraphic, - UIni, - UNote, - USkins, - UThemes; - -//TParticle -constructor TParticle.Create(cX, cY : real; - cScreen : integer; - cLive : byte; - cFrame : integer; - cRecArrayIndex : integer; - cStarType : TParticleType; - Player : cardinal); -begin - inherited Create; - // in this constructor we set all initial values for our particle - X := cX; - Y := cY; - Screen := cScreen; - Live := cLive; - Frame := cFrame; - RecIndex := cRecArrayIndex; - StarType := cStarType; - Alpha := (-cos((Frame+1)*2*pi/16)+1); // neat fade-in-and-out - SetLength(Scale,1); - Scale[0] := 1; - SurviveSentenceChange := False; - SizeMod := 1; - case cStarType of - GoldenNote: - begin - Tex := Tex_Note_Star.TexNum; - W := 20; - H := 20; - SetLength(Scale,4); - Scale[1] := 0.8; - Scale[2] := 0.4; - Scale[3] := 0.3; - SetLength(Col,4); - Col[0].r := 1; - Col[0].g := 0.7; - Col[0].b := 0.1; - - Col[1].r := 1; - Col[1].g := 1; - Col[1].b := 0.4; - - Col[2].r := 1; - Col[2].g := 1; - Col[2].b := 1; - - Col[3].r := 1; - Col[3].g := 1; - Col[3].b := 1; - end; - PerfectNote: - begin - Tex := Tex_Note_Perfect_Star.TexNum; - W := 30; - H := 30; - SetLength(Col,1); - Col[0].r := 1; - Col[0].g := 1; - Col[0].b := 0.95; - end; - NoteHitTwinkle: - begin - Tex := Tex_Note_Star.TexNum; - Alpha := (Live/16); // linear fade-out - W := 15; - H := 15; - Setlength(Col,1); - Col[0].r := 1; - Col[0].g := 1; - Col[0].b := RandomRange(10*Live,100)/90; //0.9; - end; - PerfectLineTwinkle: - begin - Tex := Tex_Note_Star.TexNum; - W := RandomRange(10,20); - H := W; - SizeMod := (-cos((Frame+1)*5*2*pi/16)*0.5+1.1); - SurviveSentenceChange := True; - // assign colours according to player given - SetLength(Scale,3); - Scale[1] := 0.3; - Scale[2] := 0.2; - SetLength(Col,3); - case Player of - 0: LoadColor(Col[0].r,Col[0].g,Col[0].b,'P1Light'); - 1: LoadColor(Col[0].r,Col[0].g,Col[0].b,'P2Light'); - 2: LoadColor(Col[0].r,Col[0].g,Col[0].b,'P3Light'); - 3: LoadColor(Col[0].r,Col[0].g,Col[0].b,'P4Light'); - 4: LoadColor(Col[0].r,Col[0].g,Col[0].b,'P5Light'); - 5: LoadColor(Col[0].r,Col[0].g,Col[0].b,'P6Light'); - else LoadColor(Col[0].r,Col[0].g,Col[0].b,'P1Light'); - end; - Col[1].r := 1; - Col[1].g := 1; - Col[1].b := 0.4; - Col[2].r := Col[0].r+0.5; - Col[2].g := Col[0].g+0.5; - Col[2].b := Col[0].b+0.5; - mX := RandomRange(-5,5); - mY := RandomRange(-5,5); - end; - ColoredStar: - begin - Tex := Tex_Note_Star.TexNum; - W := RandomRange(10,20); - H := W; - SizeMod := (-cos((Frame+1)*5*2*pi/16)*0.5+1.1); - SurviveSentenceChange := True; - // assign colours according to player given - SetLength(Scale,1); - SetLength(Col,1); - Col[0].b := (Player and $ff)/255; - Col[0].g := ((Player shr 8) and $ff)/255; - Col[0].r := ((Player shr 16) and $ff)/255; - mX := 0; - mY := 0; - end; - Flare: - begin - Tex := Tex_Note_Star.TexNum; - W := 7; - H := 7; - SizeMod := (-cos((Frame+1)*5*2*pi/16)*0.5+1.1); - mX := RandomRange(-5,5); - mY := RandomRange(-5,5); - SetLength(Scale,4); - Scale[1] := 0.8; - Scale[2] := 0.4; - Scale[3] := 0.3; - SetLength(Col,4); - Col[0].r := 1; - Col[0].g := 0.7; - Col[0].b := 0.1; - - Col[1].r := 1; - Col[1].g := 1; - Col[1].b := 0.4; - - Col[2].r := 1; - Col[2].g := 1; - Col[2].b := 1; - - Col[3].r := 1; - Col[3].g := 1; - Col[3].b := 1; - - end; - else // just some random default values - begin - Tex := Tex_Note_Star.TexNum; - Alpha := 1; - W := 20; - H := 20; - SetLength(Col,1); - Col[0].r := 1; - Col[0].g := 1; - Col[0].b := 1; - end; - end; -end; - -destructor TParticle.Destroy(); -begin - SetLength(Scale,0); - SetLength(Col,0); - inherited; -end; - -procedure TParticle.LiveOn; -begin - //Live = 0 => Live forever ?? but if this is 0 they would be killed in the Manager at Draw - if (Live > 0) then - Dec(Live); - - // animate frames - Frame := ( Frame + 1 ) mod 16; - - // make our particles do funny stuff (besides being animated) - // changes of any particle-values throughout its life are done here - case StarType of - GoldenNote: - begin - Alpha := (-cos((Frame+1)*2*pi/16)+1); // neat fade-in-and-out - end; - PerfectNote: - begin - Alpha := (-cos((Frame+1)*2*pi/16)+1); // neat fade-in-and-out - end; - NoteHitTwinkle: - begin - Alpha := (Live/10); // linear fade-out - end; - PerfectLineTwinkle: - begin - Alpha := (-cos((Frame+1)*2*pi/16)+1); // neat fade-in-and-out - SizeMod := (-cos((Frame+1)*5*2*pi/16)*0.5+1.1); - // move around - X := X + mX; - Y := Y + mY; - end; - ColoredStar: - begin - Alpha := (-cos((Frame+1)*2*pi/16)+1); // neat fade-in-and-out - end; - Flare: - begin - Alpha := (-cos((Frame+1)/16*1.7*pi+0.3*pi)+1); // neat fade-in-and-out - SizeMod := (-cos((Frame+1)*5*2*pi/16)*0.5+1.1); - // move around - X := X + mX; - Y := Y + mY; - mY := mY+1.8; -// mX := mX/2; - end; - end; -end; - -procedure TParticle.Draw; -var - L: cardinal; -begin - if ScreenAct = Screen then - // this draws (multiple) texture(s) of our particle - for L := 0 to High(Col) do - begin - glColor4f(Col[L].r, Col[L].g, Col[L].b, Alpha); - - glBindTexture(GL_TEXTURE_2D, Tex); - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - glBegin(GL_QUADS); - glTexCoord2f((1/16) * Frame, 0); glVertex2f(X-W*Scale[L]*SizeMod, Y-H*Scale[L]*SizeMod); - glTexCoord2f((1/16) * Frame + (1/16), 0); glVertex2f(X-W*Scale[L]*SizeMod, Y+H*Scale[L]*SizeMod); - glTexCoord2f((1/16) * Frame + (1/16), 1); glVertex2f(X+W*Scale[L]*SizeMod, Y+H*Scale[L]*SizeMod); - glTexCoord2f((1/16) * Frame, 1); glVertex2f(X+W*Scale[L]*SizeMod, Y-H*Scale[L]*SizeMod); - glEnd; - end; - glcolor4f(1,1,1,1); -end; -// end of TParticle - -// TEffectManager - -constructor TEffectManager.Create; -var - c: cardinal; -begin - inherited; - LastTime := SDL_GetTicks(); - for c := 0 to 5 do - begin - TwinkleArray[c] := 0; - end; -end; - -destructor TEffectManager.Destroy; -begin - Killall; - inherited; -end; - - -procedure TEffectManager.Draw; -var - I: integer; - CurrentTime: cardinal; -//const -// DelayBetweenFrames : cardinal = 100; -begin - - CurrentTime := SDL_GetTicks(); - //Manage particle life - if (CurrentTime - LastTime) > DelayBetweenFrames then - begin - LastTime := CurrentTime; - for I := 0 to high(Particle) do - Particle[I].LiveOn; - end; - - I := 0; - //Kill dead particles - while (I <= High(Particle)) do - begin - if (Particle[I].Live <= 0) then - begin - kill(I); - end - else - begin - inc(I); - end; - end; - - //Draw - for I := 0 to high(Particle) do - begin - Particle[I].Draw; - end; -end; - -// this method creates just one particle -function TEffectManager.Spawn(X, Y: real; Screen: integer; Live: byte; StartFrame : integer; RecArrayIndex : integer; StarType : TParticleType; Player: cardinal): cardinal; -begin - Result := Length(Particle); - SetLength(Particle, (Result + 1)); - Particle[Result] := TParticle.Create(X, Y, Screen, Live, StartFrame, RecArrayIndex, StarType, Player); -end; - -// manage Sparkling of GoldenNote Bars -procedure TEffectManager.SpawnRec(); -var - Xkatze, Ykatze : real; - RandomFrame : integer; - P : integer; // P as seen on TV as Positionman -begin -//Spawn a random amount of stars within the given coordinates -//RandomRange(0,14) <- this one starts at a random frame, 16 is our last frame - would be senseless to start a particle with 16, cause it would be dead at the next frame - for P := 0 to high(RecArray) do - begin - while (RecArray[P].TotalStarCount > RecArray[P].CurrentStarCount) do - begin - Xkatze := RandomRange(Ceil(RecArray[P].xTop), Ceil(RecArray[P].xBottom)); - Ykatze := RandomRange(Ceil(RecArray[P].yTop), Ceil(RecArray[P].yBottom)); - RandomFrame := RandomRange(0,14); - // Spawn a GoldenNote Particle - Spawn(Xkatze, Ykatze, RecArray[P].Screen, 16 - RandomFrame, RandomFrame, P, GoldenNote, 0); - inc(RecArray[P].CurrentStarCount); - end; - end; - draw; -end; - -// kill one particle (with given index in our particle array) -procedure TEffectManager.Kill(Index: cardinal); -var - LastParticleIndex : integer; -begin -// delete particle indexed by Index, -// overwrite it's place in our particle-array with the particle stored at the last array index, -// shorten array - LastParticleIndex := high(Particle); - if not(LastParticleIndex = -1) then // is there still a particle to delete? - begin - if not(Particle[Index].RecIndex = -1) then // if it is a GoldenNote particle... - dec(RecArray[Particle[Index].RecIndex].CurrentStarCount); // take care of its associated GoldenRec - // now get rid of that particle - Particle[Index].Destroy; - Particle[Index] := Particle[LastParticleIndex]; - SetLength(Particle, LastParticleIndex); - end; -end; - -// clean up all particles and management structures -procedure TEffectManager.KillAll(); -var - c: cardinal; -begin -//It's the kill all kennies rotuine - while Length(Particle) > 0 do // kill all existing particles - Kill(0); - SetLength(RecArray,0); // remove GoldenRec positions - SetLength(PerfNoteArray,0); // remove PerfectNote positions - for c := 0 to 5 do - begin - TwinkleArray[c] := 0; // reset GoldenNoteHit memory - end; -end; - -procedure TEffectManager.SentenceChange(); -var - c: cardinal; -begin - c := 0; - while c <= High(Particle) do - begin - if Particle[c].SurviveSentenceChange then - inc(c) - else - Kill(c); - end; - SetLength(RecArray,0); // remove GoldenRec positions - SetLength(PerfNoteArray,0); // remove PerfectNote positions - for c := 0 to 5 do - begin - TwinkleArray[c] := 0; // reset GoldenNoteHit memory - end; -end; - -procedure TeffectManager.GoldenNoteTwinkle(Top, Bottom, Right: real; Player: integer); -//Twinkle stars while golden note hit -// this is called from UDraw.pas, SingDrawPlayerCzesc -var - C, P, XKatze, YKatze, LKatze: integer; - H: real; -begin - // make sure we spawn only one time at one position - if (TwinkleArray[Player] < Right) then - for P := 0 to high(RecArray) do // Are we inside a GoldenNoteRectangle? - begin - H := (Top+Bottom)/2; // helper... - with RecArray[P] do - if ((xBottom >= Right) and (xTop <= Right) and - (yTop <= H) and (yBottom >= H)) - and (Screen = ScreenAct) then - begin - TwinkleArray[Player] := Right; // remember twinkle position for this player - for C := 1 to 10 do - begin - Ykatze := RandomRange(ceil(Top) , ceil(Bottom)); - XKatze := RandomRange(-7,3); - LKatze := RandomRange(7,13); - Spawn(Ceil(Right)+XKatze, YKatze, ScreenAct, LKatze, 0, -1, NoteHitTwinkle, 0); - end; - for C := 1 to 3 do - begin - Ykatze := RandomRange(ceil(Top)-6 , ceil(Top)); - XKatze := RandomRange(-5,1); - LKatze := RandomRange(4,7); - Spawn(Ceil(Right)+XKatze, YKatze, ScreenAct, LKatze, 0, -1, NoteHitTwinkle, 0); - end; - for C := 1 to 3 do - begin - Ykatze := RandomRange(ceil(Bottom), ceil(Bottom)+6); - XKatze := RandomRange(-5,1); - LKatze := RandomRange(4,7); - Spawn(Ceil(Right)+XKatze, YKatze, ScreenAct, LKatze, 0, -1, NoteHitTwinkle, 0); - end; - for C := 1 to 3 do - begin - Ykatze := RandomRange(ceil(Top)-10 , ceil(Top)-6); - XKatze := RandomRange(-5,1); - LKatze := RandomRange(1,4); - Spawn(Ceil(Right)+XKatze, YKatze, ScreenAct, LKatze, 0, -1, NoteHitTwinkle, 0); - end; - for C := 1 to 3 do - begin - Ykatze := RandomRange(ceil(Bottom)+6 , ceil(Bottom)+10); - XKatze := RandomRange(-5,1); - LKatze := RandomRange(1,4); - Spawn(Ceil(Right)+XKatze, YKatze, ScreenAct, LKatze, 0, -1, NoteHitTwinkle, 0); - end; - - exit; // found a matching GoldenRec, did spawning stuff... done - end; - end; -end; - -procedure TEffectManager.SaveGoldenStarsRec(Xtop, Ytop, Xbottom, Ybottom: real); -var - P : integer; // P like used in Positions - NewIndex : integer; -begin - for P := 0 to high(RecArray) do // Do we already have that "new" position? - begin - if (ceil(RecArray[P].xTop) = ceil(Xtop)) and - (ceil(RecArray[P].yTop) = ceil(Ytop)) and - (ScreenAct = RecArray[p].Screen) then - exit; // it's already in the array, so we don't have to create a new one - end; - - // we got a new position, add the new positions to our array - NewIndex := Length(RecArray); - SetLength(RecArray, NewIndex + 1); - RecArray[NewIndex].xTop := Xtop; - RecArray[NewIndex].yTop := Ytop; - RecArray[NewIndex].xBottom := Xbottom; - RecArray[NewIndex].yBottom := Ybottom; - RecArray[NewIndex].TotalStarCount := ceil(Xbottom - Xtop) div 12 + 3; - RecArray[NewIndex].CurrentStarCount := 0; - RecArray[NewIndex].Screen := ScreenAct; -end; - -procedure TEffectManager.SavePerfectNotePos(Xtop, Ytop: real); -var - P : integer; // P like used in Positions - NewIndex : integer; - RandomFrame : integer; - Xkatze, Ykatze : integer; -begin - for P := 0 to high(PerfNoteArray) do // Do we already have that "new" position? - begin - with PerfNoteArray[P] do - if (ceil(xPos) = ceil(Xtop)) and (ceil(yPos) = ceil(Ytop)) and - (Screen = ScreenAct) then - exit; // it's already in the array, so we don't have to create a new one - end; //for - - // we got a new position, add the new positions to our array - NewIndex := Length(PerfNoteArray); - SetLength(PerfNoteArray, NewIndex + 1); - PerfNoteArray[NewIndex].xPos := Xtop; - PerfNoteArray[NewIndex].yPos := Ytop; - PerfNoteArray[NewIndex].Screen := ScreenAct; - - for P := 0 to 2 do - begin - Xkatze := RandomRange(ceil(Xtop) - 5 , ceil(Xtop) + 10); - Ykatze := RandomRange(ceil(Ytop) - 5 , ceil(Ytop) + 10); - RandomFrame := RandomRange(0,14); - Spawn(Xkatze, Ykatze, ScreenAct, 16 - RandomFrame, RandomFrame, -1, PerfectNote, 0); - end; //for - -end; - -procedure TEffectManager.SpawnPerfectLineTwinkle(); -var - P, I, Life: cardinal; - Left, Right, Top, Bottom: cardinal; - cScreen: integer; -begin -// calculation of coordinates done with hardcoded values like in UDraw.pas -// might need to be adjusted if drawing of SingScreen is modified -// coordinates may still be a bit weird and need adjustment - if Ini.SingWindow = 0 then - begin - Left := 130; - end - else - begin - Left := 30; - end; - Right := 770; - // spawn effect for every player with a perfect line - for P := 0 to PlayersPlay-1 do - if Player[P].LastSentencePerfect then - begin - // calculate area where notes of this player are drawn - case PlayersPlay of - 1: begin - Bottom := Skin_P2_NotesB+10; - Top := Bottom-105; - cScreen := 1; - end; - 2,4: begin - case P of - 0,2: begin - Bottom := Skin_P1_NotesB+10; - Top := Bottom-105; - end; - else begin - Bottom := Skin_P2_NotesB+10; - Top := Bottom-105; - end; - end; - case P of - 0,1: cScreen := 1; - else cScreen := 2; - end; - end; - 3,6: begin - case P of - 0,3: begin - Top := 130; - Bottom := Top+85; - end; - 1,4: begin - Top := 255; - Bottom := Top+85; - end; - 2,5: begin - Top := 380; - Bottom := Top+85; - end; - end; - case P of - 0,1,2: cScreen := 1; - else cScreen := 2; - end; - end; - end; - // spawn Sparkling Stars inside calculated coordinates - for I := 0 to 80 do - begin - Life := RandomRange(8,16); - Spawn(RandomRange(Left,Right), RandomRange(Top,Bottom), cScreen, Life, 16-Life, -1, PerfectLineTwinkle, P); - end; - end; -end; - -end. - diff --git a/src/base/UIni.pas b/src/base/UIni.pas deleted file mode 100644 index 998d19fb..00000000 --- a/src/base/UIni.pas +++ /dev/null @@ -1,1219 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UIni; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - IniFiles, - SysUtils, - ULog, - UTextEncoding, - UFilesystem, - UPath; - -type - // TInputDeviceConfig stores the configuration for an input device. - // Configurations will be stored in the InputDeviceConfig array. - // Note that not all devices listed in InputDeviceConfig are active devices. - // Some might be unplugged and hence unavailable. - // Available devices are held in TAudioInputProcessor.DeviceList. Each - // TAudioInputDevice listed there has a CfgIndex field which is the index to - // its configuration in the InputDeviceConfig array. - // Name: - // the name of the input device - // Input: - // the index of the input source to use for recording - // ChannelToPlayerMap: - // mapping of recording channels to players, e.g. ChannelToPlayerMap[0] = 2 - // maps the channel 0 (left) to player 2. A player index of 0 means that - // the channel is not assigned to a player. - PInputDeviceConfig = ^TInputDeviceConfig; - TInputDeviceConfig = record - Name: string; - Input: integer; - ChannelToPlayerMap: array of integer; - end; - -type - -//Options - - TVisualizerOption = (voOff, voWhenNoVideo, voOn); - TBackgroundMusicOption = (bmoOff, bmoOn); - TIni = class - private - function ExtractKeyIndex(const Key, Prefix, Suffix: string): integer; - function GetMaxKeyIndex(Keys: TStringList; const Prefix, Suffix: string): integer; - function GetArrayIndex(const SearchArray: array of UTF8String; Value: string; CaseInsensitiv: boolean = false): integer; - function ReadArrayIndex(const SearchArray: array of UTF8String; IniFile: TCustomIniFile; - IniSection: string; IniProperty: string; Default: integer): integer; - - procedure TranslateOptionValues; - procedure LoadInputDeviceCfg(IniFile: TMemIniFile); - procedure SaveInputDeviceCfg(IniFile: TIniFile); - procedure LoadThemes(IniFile: TCustomIniFile); - procedure LoadPaths(IniFile: TCustomIniFile); - procedure LoadScreenModes(IniFile: TCustomIniFile); - - public - Name: array[0..11] of UTF8String; - - // Templates for Names Mod - NameTeam: array[0..2] of UTF8String; - NameTemplate: array[0..11] of UTF8String; - - //Filename of the opened iniFile - Filename: IPath; - - // Game - Players: integer; - Difficulty: integer; - Language: integer; - Tabs: integer; - TabsAtStartup: integer; //Tabs at Startup fix - Sorting: integer; - Debug: integer; - - // Graphics - Screens: integer; - Resolution: integer; - Depth: integer; - VisualizerOption: integer; - FullScreen: integer; - TextureSize: integer; - SingWindow: integer; - Oscilloscope: integer; - Spectrum: integer; - Spectrograph: integer; - MovieSize: integer; - - // Sound - MicBoost: integer; - ClickAssist: integer; - BeatClick: integer; - SavePlayback: integer; - ThresholdIndex: integer; - AudioOutputBufferSizeIndex: integer; - VoicePassthrough: integer; - - //Song Preview - PreviewVolume: integer; - PreviewFading: integer; - - // Lyrics - LyricsFont: integer; - LyricsEffect: integer; - Solmization: integer; - NoteLines: integer; - - // Themes - Theme: integer; - SkinNo: integer; - Color: integer; - BackgroundMusicOption: integer; - - // Record - InputDeviceConfig: array of TInputDeviceConfig; - - // Advanced - LoadAnimation: integer; - EffectSing: integer; - ScreenFade: integer; - AskBeforeDel: integer; - OnSongClick: integer; - LineBonus: integer; - PartyPopup: integer; - - // Controller - Joypad: integer; - Mouse: integer; - - procedure Load(); - procedure Save(); - procedure SaveNames; - procedure SaveLevel; - end; - -var - Ini: TIni; - IResolution: array of UTF8String; - ILanguage: array of UTF8String; - ITheme: array of UTF8String; - ISkin: array of UTF8String; - -const - IPlayers: array[0..4] of UTF8String = ('1', '2', '3', '4', '6'); - IPlayersVals: array[0..4] of integer = ( 1 , 2 , 3 , 4 , 6 ); - - IDifficulty: array[0..2] of UTF8String = ('Easy', 'Medium', 'Hard'); - ITabs: array[0..1] of UTF8String = ('Off', 'On'); - - ISorting: array[0..6] of UTF8String = ('Edition', 'Genre', 'Language', 'Folder', 'Title', 'Artist', 'Artist2'); - sEdition = 0; - sGenre = 1; - sLanguage = 2; - sFolder = 3; - sTitle = 4; - sArtist = 5; - sArtist2 = 6; - - IDebug: array[0..1] of UTF8String = ('Off', 'On'); - - IScreens: array[0..1] of UTF8String = ('1', '2'); - IFullScreen: array[0..1] of UTF8String = ('Off', 'On'); - IDepth: array[0..1] of UTF8String = ('16 bit', '32 bit'); - IVisualizer: array[0..2] of UTF8String = ('Off', 'WhenNoVideo','On'); - - IBackgroundMusic: array[0..1] of UTF8String = ('Off', 'On'); - - ITextureSize: array[0..3] of UTF8String = ('64', '128', '256', '512'); - ITextureSizeVals: array[0..3] of integer = ( 64, 128, 256, 512); - - ISingWindow: array[0..1] of UTF8String = ('Small', 'Big'); - - //SingBar Mod - IOscilloscope: array[0..1] of UTF8String = ('Off', 'On'); - - ISpectrum: array[0..1] of UTF8String = ('Off', 'On'); - ISpectrograph: array[0..1] of UTF8String = ('Off', 'On'); - IMovieSize: array[0..2] of UTF8String = ('Half', 'Full [Vid]', 'Full [BG+Vid]'); - - IClickAssist: array[0..1] of UTF8String = ('Off', 'On'); - IBeatClick: array[0..1] of UTF8String = ('Off', 'On'); - ISavePlayback: array[0..1] of UTF8String = ('Off', 'On'); - - IThreshold: array[0..3] of UTF8String = ('5%', '10%', '15%', '20%'); - IThresholdVals: array[0..3] of single = (0.05, 0.10, 0.15, 0.20); - - IVoicePassthrough: array[0..1] of UTF8String = ('Off', 'On'); - - IAudioOutputBufferSize: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - IAudioOutputBufferSizeVals: array[0..9] of integer = ( 0, 256, 512 , 1024 , 2048 , 4096 , 8192 , 16384 , 32768 , 65536 ); - - IAudioInputBufferSize: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - IAudioInputBufferSizeVals: array[0..9] of integer = ( 0, 256, 512 , 1024 , 2048 , 4096 , 8192 , 16384 , 32768 , 65536 ); - - //Song Preview - IPreviewVolume: array[0..10] of UTF8String = ('Off', '10%', '20%', '30%', '40%', '50%', '60%', '70%', '80%', '90%', '100%'); - IPreviewVolumeVals: array[0..10] of single = ( 0, 0.10, 0.20, 0.30, 0.40, 0.50, 0.60, 0.70, 0.80, 0.90, 1.00 ); - - IPreviewFading: array[0..5] of UTF8String = ('Off', '1 Sec', '2 Secs', '3 Secs', '4 Secs', '5 Secs'); - IPreviewFadingVals: array[0..5] of integer = ( 0, 1, 2, 3, 4, 5 ); - - ILyricsFont: array[0..2] of UTF8String = ('Plain', 'OLine1', 'OLine2'); - ILyricsEffect: array[0..4] of UTF8String = ('Simple', 'Zoom', 'Slide', 'Ball', 'Shift'); - ISolmization: array[0..3] of UTF8String = ('Off', 'Euro', 'Jap', 'American'); - INoteLines: array[0..1] of UTF8String = ('Off', 'On'); - - IColor: array[0..8] of UTF8String = ('Blue', 'Green', 'Pink', 'Red', 'Violet', 'Orange', 'Yellow', 'Brown', 'Black'); - - // Advanced - ILoadAnimation: array[0..1] of UTF8String = ('Off', 'On'); - IEffectSing: array[0..1] of UTF8String = ('Off', 'On'); - IScreenFade: array[0..1] of UTF8String = ('Off', 'On'); - IAskbeforeDel: array[0..1] of UTF8String = ('Off', 'On'); - IOnSongClick: array[0..2] of UTF8String = ('Sing', 'Select Players', 'Open Menu'); - sStartSing = 0; - sSelectPlayer = 1; - sOpenMenu = 2; - - ILineBonus: array[0..1] of UTF8String = ('Off', 'On'); - IPartyPopup: array[0..1] of UTF8String = ('Off', 'On'); - - IJoypad: array[0..1] of UTF8String = ('Off', 'On'); - IMouse: array[0..2] of UTF8String = ('Off', 'Hardware Cursor', 'Software Cursor'); - - // Recording options - IChannelPlayer: array[0..6] of UTF8String = ('Off', '1', '2', '3', '4', '5', '6'); - IMicBoost: array[0..3] of UTF8String = ('Off', '+6dB', '+12dB', '+18dB'); - -var - ILanguageTranslated: array of UTF8String; - - IDifficultyTranslated: array[0..2] of UTF8String = ('Easy', 'Medium', 'Hard'); - ITabsTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - ISortingTranslated: array[0..6] of UTF8String = ('Edition', 'Genre', 'Language', 'Folder', 'Title', 'Artist', 'Artist2'); - - IDebugTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - IFullScreenTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IVisualizerTranslated: array[0..2] of UTF8String = ('Off', 'WhenNoVideo','On'); - - IBackgroundMusicTranslated: array[0..1] of UTF8String = ('Off', 'On'); - ISingWindowTranslated: array[0..1] of UTF8String = ('Small', 'Big'); - - //SingBar Mod - IOscilloscopeTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - ISpectrumTranslated: array[0..1] of UTF8String = ('Off', 'On'); - ISpectrographTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IMovieSizeTranslated: array[0..2] of UTF8String = ('Half', 'Full [Vid]', 'Full [BG+Vid]'); - - IClickAssistTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IBeatClickTranslated: array[0..1] of UTF8String = ('Off', 'On'); - ISavePlaybackTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - IVoicePassthroughTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - //Song Preview - IPreviewVolumeTranslated: array[0..10] of UTF8String = ('Off', '10%', '20%', '30%', '40%', '50%', '60%', '70%', '80%', '90%', '100%'); - - IAudioOutputBufferSizeTranslated: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - - IAudioInputBufferSizeTranslated: array[0..9] of UTF8String = ('Auto', '256', '512', '1024', '2048', '4096', '8192', '16384', '32768', '65536'); - - IPreviewFadingTranslated: array[0..5] of UTF8String = ('Off', '1 Sec', '2 Secs', '3 Secs', '4 Secs', '5 Secs'); - - ILyricsFontTranslated: array[0..2] of UTF8String = ('Plain', 'OLine1', 'OLine2'); - ILyricsEffectTranslated: array[0..4] of UTF8String = ('Simple', 'Zoom', 'Slide', 'Ball', 'Shift'); - ISolmizationTranslated: array[0..3] of UTF8String = ('Off', 'Euro', 'Jap', 'American'); - INoteLinesTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - IColorTranslated: array[0..8] of UTF8String = ('Blue', 'Green', 'Pink', 'Red', 'Violet', 'Orange', 'Yellow', 'Brown', 'Black'); - - // Advanced - ILoadAnimationTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IEffectSingTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IScreenFadeTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IAskbeforeDelTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IOnSongClickTranslated: array[0..2] of UTF8String = ('Sing', 'Select Players', 'Open Menu'); - ILineBonusTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IPartyPopupTranslated: array[0..1] of UTF8String = ('Off', 'On'); - - IJoypadTranslated: array[0..1] of UTF8String = ('Off', 'On'); - IMouseTranslated: array[0..2] of UTF8String = ('Off', 'Hardware Cursor', 'Software Cursor'); - - // Recording options - IChannelPlayerTranslated: array[0..6] of UTF8String = ('Off', '1', '2', '3', '4', '5', '6'); - IMicBoostTranslated: array[0..3] of UTF8String = ('Off', '+6dB', '+12dB', '+18dB'); - -implementation - -uses - StrUtils, - SDL, - UCommandLine, - ULanguage, - UPlatform, - UMain, - URecord, - USkins, - UPathUtils, - UUnicodeUtils; - -(** - * Translate and set the values of options, which need translation. - *) -procedure TIni.TranslateOptionValues; -var - I: integer; -begin - // Load Languagefile - if (Params.Language <> -1) then - ULanguage.Language.ChangeLanguage(ILanguage[Params.Language]) - else - ULanguage.Language.ChangeLanguage(ILanguage[Ini.Language]); - - SetLength(ILanguageTranslated, Length(ILanguage)); - for I := 0 to High(ILanguage) do - begin - ILanguageTranslated[I] := ULanguage.Language.Translate( - 'OPTION_VALUE_' + UpperCase(ILanguage[I]) - ); - end; - - IDifficultyTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_EASY'); - IDifficultyTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_MEDIUM'); - IDifficultyTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_HARD'); - - ITabsTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ITabsTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - ISortingTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_EDITION'); - ISortingTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_GENRE'); - ISortingTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_LANGUAGE'); - ISortingTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_FOLDER'); - ISortingTranslated[4] := ULanguage.Language.Translate('OPTION_VALUE_TITLE'); - ISortingTranslated[5] := ULanguage.Language.Translate('OPTION_VALUE_ARTIST'); - ISortingTranslated[6] := ULanguage.Language.Translate('OPTION_VALUE_ARTIST2'); - - IDebugTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IDebugTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IFullScreenTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IFullScreenTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IVisualizerTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IVisualizerTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_WHENNOVIDEO'); - IVisualizerTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IBackgroundMusicTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IBackgroundMusicTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - ISingWindowTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_SMALL'); - ISingWindowTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_BIG'); - - IOscilloscopeTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IOscilloscopeTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - ISpectrumTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ISpectrumTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - ISpectrographTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ISpectrographTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IMovieSizeTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_HALF'); - IMovieSizeTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_FULL_VID'); - IMovieSizeTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_FULL_VID_BG'); - - IClickAssistTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IClickAssistTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IBeatClickTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IBeatClickTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - ISavePlaybackTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ISavePlaybackTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IVoicePassthroughTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IVoicePassthroughTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - ILyricsFontTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_PLAIN'); - ILyricsFontTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_OLINE1'); - ILyricsFontTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_OLINE2'); - - ILyricsEffectTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_SIMPLE'); - ILyricsEffectTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ZOOM'); - ILyricsEffectTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_SLIDE'); - ILyricsEffectTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_BALL'); - ILyricsEffectTranslated[4] := ULanguage.Language.Translate('OPTION_VALUE_SHIFT'); - - ISolmizationTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ISolmizationTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_EURO'); - ISolmizationTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_JAPAN'); - ISolmizationTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_AMERICAN'); - - INoteLinesTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - INoteLinesTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IColorTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_BLUE'); - IColorTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_GREEN'); - IColorTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_PINK'); - IColorTranslated[3] := ULanguage.Language.Translate('OPTION_VALUE_RED'); - IColorTranslated[4] := ULanguage.Language.Translate('OPTION_VALUE_VIOLET'); - IColorTranslated[5] := ULanguage.Language.Translate('OPTION_VALUE_ORANGE'); - IColorTranslated[6] := ULanguage.Language.Translate('OPTION_VALUE_YELLOW'); - IColorTranslated[7] := ULanguage.Language.Translate('OPTION_VALUE_BROWN'); - IColorTranslated[8] := ULanguage.Language.Translate('OPTION_VALUE_BLACK'); - - // Advanced - ILoadAnimationTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ILoadAnimationTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IEffectSingTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IEffectSingTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IScreenFadeTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IScreenFadeTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IAskbeforeDelTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IAskbeforeDelTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IOnSongClickTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_SING'); - IOnSongClickTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_SELECT_PLAYERS'); - IOnSongClickTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_OPEN_MENU'); - - ILineBonusTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - ILineBonusTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IPartyPopupTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IPartyPopupTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IJoypadTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IJoypadTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_ON'); - - IMouseTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IMouseTranslated[1] := ULanguage.Language.Translate('OPTION_VALUE_HARDWARE_CURSOR'); - IMouseTranslated[2] := ULanguage.Language.Translate('OPTION_VALUE_SOFTWARE_CURSOR'); - - IAudioOutputBufferSizeTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_AUTO'); - IAudioOutputBufferSizeTranslated[1] := '256'; - IAudioOutputBufferSizeTranslated[2] := '512'; - IAudioOutputBufferSizeTranslated[3] := '1024'; - IAudioOutputBufferSizeTranslated[4] := '2048'; - IAudioOutputBufferSizeTranslated[5] := '4096'; - IAudioOutputBufferSizeTranslated[6] := '8192'; - IAudioOutputBufferSizeTranslated[7] := '16384'; - IAudioOutputBufferSizeTranslated[8] := '32768'; - IAudioOutputBufferSizeTranslated[9] := '65536'; - - - IAudioInputBufferSizeTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_AUTO'); - IAudioInputBufferSizeTranslated[1] := '256'; - IAudioInputBufferSizeTranslated[2] := '512'; - IAudioInputBufferSizeTranslated[3] := '1024'; - IAudioInputBufferSizeTranslated[4] := '2048'; - IAudioInputBufferSizeTranslated[5] := '4096'; - IAudioInputBufferSizeTranslated[6] := '8192'; - IAudioInputBufferSizeTranslated[7] := '16384'; - IAudioInputBufferSizeTranslated[8] := '32768'; - IAudioInputBufferSizeTranslated[9] := '65536'; - - //Song Preview - IPreviewVolumeTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IPreviewVolumeTranslated[1] := '10%'; - IPreviewVolumeTranslated[2] := '20%'; - IPreviewVolumeTranslated[3] := '30%'; - IPreviewVolumeTranslated[4] := '40%'; - IPreviewVolumeTranslated[5] := '50%'; - IPreviewVolumeTranslated[6] := '60%'; - IPreviewVolumeTranslated[7] := '70%'; - IPreviewVolumeTranslated[8] := '80%'; - IPreviewVolumeTranslated[9] := '90%'; - IPreviewVolumeTranslated[10] := '100%'; - - - IPreviewFadingTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IPreviewFadingTranslated[1] := '1 ' + ULanguage.Language.Translate('OPTION_VALUE_SEC'); - IPreviewFadingTranslated[2] := '2 ' + ULanguage.Language.Translate('OPTION_VALUE_SECS'); - IPreviewFadingTranslated[3] := '3 ' + ULanguage.Language.Translate('OPTION_VALUE_SECS'); - IPreviewFadingTranslated[4] := '4 ' + ULanguage.Language.Translate('OPTION_VALUE_SECS'); - IPreviewFadingTranslated[5] := '5 ' + ULanguage.Language.Translate('OPTION_VALUE_SECS'); - - // Recording options - IChannelPlayerTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IChannelPlayerTranslated[1] := '1'; - IChannelPlayerTranslated[2] := '2'; - IChannelPlayerTranslated[3] := '3'; - IChannelPlayerTranslated[4] := '4'; - IChannelPlayerTranslated[5] := '5'; - IChannelPlayerTranslated[6] := '6'; - - IMicBoostTranslated[0] := ULanguage.Language.Translate('OPTION_VALUE_OFF'); - IMicBoostTranslated[1] := '+6dB'; - IMicBoostTranslated[2] := '+12dB'; - IMicBoostTranslated[3] := '+18dB'; - -end; - -(** - * Extracts an index of a key that is surrounded by a Prefix/Suffix pair. - * Example: ExtractKeyIndex('MyKey[1]', '[', ']') will return 1. - *) -function TIni.ExtractKeyIndex(const Key, Prefix, Suffix: string): integer; -var - Value: string; - Start: integer; - PrefixPos, SuffixPos: integer; -begin - Result := -1; - - PrefixPos := Pos(Prefix, Key); - if (PrefixPos <= 0) then - Exit; - SuffixPos := Pos(Suffix, Key); - if (SuffixPos <= 0) then - Exit; - - Start := PrefixPos + Length(Prefix); - - // copy all between prefix and suffix - Value := Copy(Key, Start, SuffixPos - Start); - Result := StrToIntDef(Value, -1); -end; - -(** - * Finds the maximum key-index in a key-list. - * The indexes of the list are surrounded by Prefix/Suffix, - * e.g. MyKey[1] (Prefix='[', Suffix=']') - *) -function TIni.GetMaxKeyIndex(Keys: TStringList; const Prefix, Suffix: string): integer; -var - i: integer; - KeyIndex: integer; -begin - Result := -1; - - for i := 0 to Keys.Count-1 do - begin - KeyIndex := ExtractKeyIndex(Keys[i], Prefix, Suffix); - if (KeyIndex > Result) then - Result := KeyIndex; - end; -end; - -(** - * Returns the index of Value in SearchArray - * or -1 if Value is not in SearchArray. - *) -function TIni.GetArrayIndex(const SearchArray: array of UTF8String; Value: string; - CaseInsensitiv: boolean = false): integer; -var - i: integer; -begin - Result := -1; - - for i := 0 to High(SearchArray) do - begin - if (SearchArray[i] = Value) or - (CaseInsensitiv and (UpperCase(SearchArray[i]) = UpperCase(Value))) then - begin - Result := i; - Break; - end; - end; -end; - -(** - * Reads the property IniSeaction:IniProperty from IniFile and - * finds its corresponding index in SearchArray. - * If SearchArray does not contain the property value, the default value is - * returned. - *) -function TIni.ReadArrayIndex(const SearchArray: array of UTF8String; IniFile: TCustomIniFile; - IniSection: string; IniProperty: string; Default: integer): integer; -var - StrValue: string; -begin - StrValue := IniFile.ReadString(IniSection, IniProperty, SearchArray[Default]); - Result := GetArrayIndex(SearchArray, StrValue); - if (Result = -1) then - begin - Result := Default; - end; -end; - -procedure TIni.LoadInputDeviceCfg(IniFile: TMemIniFile); -var - DeviceCfg: PInputDeviceConfig; - DeviceIndex: integer; - ChannelCount: integer; - ChannelIndex: integer; - RecordKeys: TStringList; - i: integer; -begin - RecordKeys := TStringList.Create(); - - // read all record-keys for filtering - IniFile.ReadSection('Record', RecordKeys); - - SetLength(InputDeviceConfig, 0); - - for i := 0 to RecordKeys.Count-1 do - begin - // find next device-name - DeviceIndex := ExtractKeyIndex(RecordKeys[i], 'DeviceName[', ']'); - if (DeviceIndex >= 0) then - begin - if not IniFile.ValueExists('Record', Format('DeviceName[%d]', [DeviceIndex])) then - break; - - // resize list - SetLength(InputDeviceConfig, Length(InputDeviceConfig)+1); - - // read an input device's config. - // Note: All devices are appended to the list whether they exist or not. - // Otherwise an external device's config will be lost if it is not - // connected (e.g. singstar mics or USB-Audio devices). - DeviceCfg := @InputDeviceConfig[High(InputDeviceConfig)]; - DeviceCfg.Name := IniFile.ReadString('Record', Format('DeviceName[%d]', [DeviceIndex]), ''); - DeviceCfg.Input := IniFile.ReadInteger('Record', Format('Input[%d]', [DeviceIndex]), 0); - - // find the largest channel-number of the current device in the ini-file - ChannelCount := GetMaxKeyIndex(RecordKeys, 'Channel', Format('[%d]', [DeviceIndex])); - if (ChannelCount < 0) then - ChannelCount := 0; - - SetLength(DeviceCfg.ChannelToPlayerMap, ChannelCount); - - // read channel-to-player mapping for every channel of the current device - // or set non-configured channels to no player (=0). - for ChannelIndex := 0 to High(DeviceCfg.ChannelToPlayerMap) do - begin - DeviceCfg.ChannelToPlayerMap[ChannelIndex] := - IniFile.ReadInteger('Record', Format('Channel%d[%d]', [ChannelIndex+1, DeviceIndex]), 0); - end; - end; - end; - - RecordKeys.Free(); - - // MicBoost - MicBoost := GetArrayIndex(IMicBoost, IniFile.ReadString('Record', 'MicBoost', 'Off')); - // Threshold - ThresholdIndex := GetArrayIndex(IThreshold, IniFile.ReadString('Record', 'Threshold', IThreshold[1])); -end; - -procedure TIni.SaveInputDeviceCfg(IniFile: TIniFile); -var - DeviceIndex: integer; - ChannelIndex: integer; -begin - for DeviceIndex := 0 to High(InputDeviceConfig) do - begin - // DeviceName and DeviceInput - IniFile.WriteString('Record', Format('DeviceName[%d]', [DeviceIndex+1]), - InputDeviceConfig[DeviceIndex].Name); - IniFile.WriteInteger('Record', Format('Input[%d]', [DeviceIndex+1]), - InputDeviceConfig[DeviceIndex].Input); - - // Channel-to-Player Mapping - for ChannelIndex := 0 to High(InputDeviceConfig[DeviceIndex].ChannelToPlayerMap) do - begin - IniFile.WriteInteger('Record', - Format('Channel%d[%d]', [ChannelIndex+1, DeviceIndex+1]), - InputDeviceConfig[DeviceIndex].ChannelToPlayerMap[ChannelIndex]); - end; - end; - - // MicBoost - IniFile.WriteString('Record', 'MicBoost', IMicBoost[MicBoost]); - // Threshold - IniFile.WriteString('Record', 'Threshold', IThreshold[ThresholdIndex]); -end; - -procedure TIni.LoadPaths(IniFile: TCustomIniFile); -var - PathStrings: TStringList; - I: integer; -begin - PathStrings := TStringList.Create; - IniFile.ReadSection('Directories', PathStrings); - - // Load song-paths - for I := 0 to PathStrings.Count-1 do - begin - if (Pos('SONGDIR', UpperCase(PathStrings[I])) = 1) then - begin - AddSongPath(Path(IniFile.ReadString('Directories', PathStrings[I], ''))); - end; - end; - - PathStrings.Free; -end; - -procedure TIni.LoadThemes(IniFile: TCustomIniFile); -var - SearchResult: TSearchRec; - ThemeIni: TMemIniFile; - ThemeName: string; - I: integer; - Iter: IFileIterator; - FileInfo: TFileInfo; -begin - // Theme - SetLength(ITheme, 0); - Log.LogStatus('Searching for Theme : ' + ThemePath.ToNative + '*.ini', 'Theme'); - - - Iter := FileSystem.FileFind(ThemePath.Append('*.ini'), 0); - while (Iter.HasNext) do - begin - FileInfo := Iter.Next; - Log.LogStatus('Found Theme: ' + FileInfo.Name.ToNative, 'Theme'); - - //Read Themename from Theme - ThemeIni := TMemIniFile.Create(FileInfo.Name.ToNative); - ThemeName := UpperCase(ThemeIni.ReadString('Theme','Name', FileInfo.Name.SetExtension('').ToNative)); - ThemeIni.Free; - - //Search for Skins for this Theme - for I := Low(Skin.Skin) to High(Skin.Skin) do - begin - if UpperCase(Skin.Skin[I].Theme) = ThemeName then - begin - SetLength(ITheme, Length(ITheme)+1); - ITheme[High(ITheme)] := FileInfo.Name.SetExtension('').ToNative; - break; - end; - end; - end; - - // No Theme Found - if (Length(ITheme) = 0) then - begin - Log.CriticalError('Could not find any valid Themes.'); - end; - - Theme := GetArrayIndex(ITheme, IniFile.ReadString('Themes', 'Theme', 'DELUXE'), true); - if (Theme = -1) then - Theme := 0; - - // Skin - Skin.onThemeChange; - - SkinNo := GetArrayIndex(ISkin, IniFile.ReadString('Themes', 'Skin', ISkin[0])); -end; - -procedure TIni.LoadScreenModes(IniFile: TCustomIniFile); - - // swap two strings - procedure swap(var s1, s2: UTF8String); - var - s3: string; - begin - s3 := s1; - s1 := s2; - s2 := s3; - end; - -var - Modes: PPSDL_Rect; - I: integer; -begin - // Screens - Screens := GetArrayIndex(IScreens, IniFile.ReadString('Graphics', 'Screens', IScreens[0])); - - // FullScreen - FullScreen := GetArrayIndex(IFullScreen, IniFile.ReadString('Graphics', 'FullScreen', 'On')); - - // Resolution - SetLength(IResolution, 0); - - // Check if there are any modes available - // TODO: we should seperate windowed and fullscreen modes. Otherwise it is not - // possible to select a reasonable fullscreen mode when in windowed mode - if IFullScreen[FullScreen] = 'On' then - Modes := SDL_ListModes(nil, SDL_OPENGL or SDL_FULLSCREEN) - else - Modes := SDL_ListModes(nil, SDL_OPENGL or SDL_RESIZABLE) ; - - if (Modes = nil) then - begin - Log.LogStatus( 'No resolutions Found' , 'Video'); - end - else if (Modes = PPSDL_Rect(-1)) then - begin - // Fallback to some standard resolutions - SetLength(IResolution, 10); - IResolution[0] := '640x480'; - IResolution[1] := '800x600'; - IResolution[2] := '1024x768'; - IResolution[3] := '1152x864'; - IResolution[4] := '1280x800'; - IResolution[5] := '1280x960'; - IResolution[6] := '1400x1050'; - IResolution[7] := '1440x900'; - IResolution[8] := '1600x1200'; - IResolution[9] := '1680x1050'; - - Resolution := GetArrayIndex(IResolution, IniFile.ReadString('Graphics', 'Resolution', '800x600')); - if Resolution = -1 then - begin - SetLength(IResolution, Length(IResolution) + 1); - IResolution[High(IResolution)] := IniFile.ReadString('Graphics', 'Resolution', '800x600'); - Resolution := High(IResolution); - end; - end - else - begin - while assigned( Modes^ ) do //this should solve the biggest wine problem | THANKS Linnex (11.11.07) - begin - Log.LogStatus( 'Found Video Mode : ' + IntToStr(Modes^.w) + 'x' + IntToStr(Modes^.h) , 'Video'); - SetLength(IResolution, Length(IResolution) + 1); - IResolution[High(IResolution)] := IntToStr(Modes^.w) + 'x' + IntToStr(Modes^.h); - Inc(Modes); - end; - - // reverse order - Log.LogStatus( 'Log size of resolution: ' + IntToStr(Length(IResolution)), 'Video'); - for I := 0 to (Length(IResolution) div 2) - 1 do - begin - swap(IResolution[I], IResolution[High(IResolution)-I]); - end; - Resolution := GetArrayIndex(IResolution, IniFile.ReadString('Graphics', 'Resolution', '800x600')); - - if Resolution = -1 then - begin - Resolution := GetArrayIndex(IResolution, '800x600'); - if Resolution = -1 then - Resolution := 0; - end; - end; - - // if no modes were set, then failback to 800x600 - // as per http://sourceforge.net/forum/message.php?msg_id=4544965 - // THANKS : linnex at users.sourceforge.net - if Length(IResolution) < 1 then - begin - Log.LogStatus( 'Found Video Mode : NONE !!! ( Defaulted to 800 x 600 )', 'Video'); - SetLength(IResolution, 1); - IResolution[0] := '800x600'; - Resolution := 0; - Log.LogStatus('SDL_ListModes Defaulted Res To : ' + IResolution[0] , 'Graphics - Resolutions'); - - // Default to fullscreen OFF, in this case ! - FullScreen := 0; - end; - - // Depth - Depth := GetArrayIndex(IDepth, IniFile.ReadString('Graphics', 'Depth', '32 bit')); -end; - -procedure TIni.Load(); -var - IniFile: TMemIniFile; - I: integer; -begin - GamePath := Platform.GetGameUserPath; - - Log.LogStatus( 'GamePath : ' +GamePath.ToNative , '' ); - - if (Params.ConfigFile.IsSet) then - FileName := Params.ConfigFile - else - FileName := GamePath.Append('config.ini'); - - Log.LogStatus('Using config : ' + FileName.ToNative, 'Ini'); - IniFile := TMemIniFile.Create(FileName.ToNative); - - // Name - for I := 0 to 11 do - Name[I] := IniFile.ReadString('Name', 'P'+IntToStr(I+1), 'Player'+IntToStr(I+1)); - - // Templates for Names Mod - for I := 0 to 2 do - NameTeam[I] := IniFile.ReadString('NameTeam', 'T'+IntToStr(I+1), 'Team'+IntToStr(I+1)); - for I := 0 to 11 do - NameTemplate[I] := IniFile.ReadString('NameTemplate', 'Name'+IntToStr(I+1), 'Template'+IntToStr(I+1)); - - // Players - Players := GetArrayIndex(IPlayers, IniFile.ReadString('Game', 'Players', IPlayers[0])); - - // Difficulty - Difficulty := GetArrayIndex(IDifficulty, IniFile.ReadString('Game', 'Difficulty', 'Easy')); - - // Language - Language := GetArrayIndex(ILanguage, IniFile.ReadString('Game', 'Language', 'English')); - - // Tabs - Tabs := GetArrayIndex(ITabs, IniFile.ReadString('Game', 'Tabs', ITabs[0])); - TabsAtStartup := Tabs; //Tabs at Startup fix - - // Song Sorting - Sorting := GetArrayIndex(ISorting, IniFile.ReadString('Game', 'Sorting', ISorting[0])); - - // Debug - Debug := GetArrayIndex(IDebug, IniFile.ReadString('Game', 'Debug', IDebug[0])); - - LoadScreenModes(IniFile); - - // TextureSize - TextureSize := GetArrayIndex(ITextureSize, IniFile.ReadString('Graphics', 'TextureSize', ITextureSize[1])); - - // SingWindow - SingWindow := GetArrayIndex(ISingWindow, IniFile.ReadString('Graphics', 'SingWindow', 'Big')); - - // Oscilloscope - Oscilloscope := GetArrayIndex(IOscilloscope, IniFile.ReadString('Graphics', 'Oscilloscope', IOscilloscope[0])); - - // Spectrum - Spectrum := GetArrayIndex(ISpectrum, IniFile.ReadString('Graphics', 'Spectrum', 'Off')); - - // Spectrograph - Spectrograph := GetArrayIndex(ISpectrograph, IniFile.ReadString('Graphics', 'Spectrograph', 'Off')); - - // MovieSize - MovieSize := GetArrayIndex(IMovieSize, IniFile.ReadString('Graphics', 'MovieSize', IMovieSize[2])); - - // ClickAssist - ClickAssist := GetArrayIndex(IClickAssist, IniFile.ReadString('Sound', 'ClickAssist', 'Off')); - - // BeatClick - BeatClick := GetArrayIndex(IBeatClick, IniFile.ReadString('Sound', 'BeatClick', IBeatClick[0])); - - // SavePlayback - SavePlayback := GetArrayIndex(ISavePlayback, IniFile.ReadString('Sound', 'SavePlayback', ISavePlayback[0])); - - // AudioOutputBufferSize - AudioOutputBufferSizeIndex := ReadArrayIndex(IAudioOutputBufferSize, IniFile, 'Sound', 'AudioOutputBufferSize', 0); - - //Preview Volume - PreviewVolume := GetArrayIndex(IPreviewVolume, IniFile.ReadString('Sound', 'PreviewVolume', IPreviewVolume[7])); - - //Preview Fading - PreviewFading := GetArrayIndex(IPreviewFading, IniFile.ReadString('Sound', 'PreviewFading', IPreviewFading[3])); - - //AudioRepeat aka VoicePassthrough - VoicePassthrough := GetArrayIndex(IVoicePassthrough, IniFile.ReadString('Sound', 'VoicePassthrough', IVoicePassthrough[0])); - - // Lyrics Font - LyricsFont := GetArrayIndex(ILyricsFont, IniFile.ReadString('Lyrics', 'LyricsFont', ILyricsFont[0])); - - // Lyrics Effect - LyricsEffect := GetArrayIndex(ILyricsEffect, IniFile.ReadString('Lyrics', 'LyricsEffect', ILyricsEffect[2])); - - // Solmization - Solmization := GetArrayIndex(ISolmization, IniFile.ReadString('Lyrics', 'Solmization', ISolmization[0])); - - // NoteLines - NoteLines := GetArrayIndex(INoteLines, IniFile.ReadString('Lyrics', 'NoteLines', INoteLines[1])); - - LoadThemes(IniFile); - - // Color - Color := GetArrayIndex(IColor, IniFile.ReadString('Themes', 'Color', IColor[0])); - - LoadInputDeviceCfg(IniFile); - - // LoadAnimation - LoadAnimation := GetArrayIndex(ILoadAnimation, IniFile.ReadString('Advanced', 'LoadAnimation', 'On')); - - // ScreenFade - ScreenFade := GetArrayIndex(IScreenFade, IniFile.ReadString('Advanced', 'ScreenFade', 'On')); - - // Visualizations - // this could be of use later.. - // VisualizerOption := - // TVisualizerOption(GetEnumValue(TypeInfo(TVisualizerOption), - // IniFile.ReadString('Graphics', 'Visualization', 'Off'))); - // || VisualizerOption := TVisualizerOption(GetArrayIndex(IVisualizer, IniFile.ReadString('Graphics', 'Visualization', 'Off'))); - VisualizerOption := GetArrayIndex(IVisualizer, IniFile.ReadString('Graphics', 'Visualization', 'Off')); - -{** - * Background music - *} - BackgroundMusicOption := GetArrayIndex(IBackgroundMusic, IniFile.ReadString('Sound', 'BackgroundMusic', 'Off')); - - // EffectSing - EffectSing := GetArrayIndex(IEffectSing, IniFile.ReadString('Advanced', 'EffectSing', 'On')); - - // AskbeforeDel - AskBeforeDel := GetArrayIndex(IAskbeforeDel, IniFile.ReadString('Advanced', 'AskbeforeDel', 'On')); - - // OnSongClick - OnSongClick := GetArrayIndex(IOnSongClick, IniFile.ReadString('Advanced', 'OnSongClick', 'Sing')); - - // Linebonus - LineBonus := GetArrayIndex(ILineBonus, IniFile.ReadString('Advanced', 'LineBonus', ILineBonus[1])); - - // PartyPopup - PartyPopup := GetArrayIndex(IPartyPopup, IniFile.ReadString('Advanced', 'PartyPopup', 'On')); - - // Joypad - Joypad := GetArrayIndex(IJoypad, IniFile.ReadString('Controller', 'Joypad', IJoypad[0])); - - // Mouse - Mouse := GetArrayIndex(IMouse, IniFile.ReadString('Controller', 'Mouse', IMouse[2])); - - LoadPaths(IniFile); - - TranslateOptionValues; - - IniFile.Free; -end; - -procedure TIni.Save; -var - IniFile: TIniFile; -begin - if (Filename.IsFile and Filename.IsReadOnly) then - begin - Log.LogError('Config-file is read-only', 'TIni.Save'); - Exit; - end; - - IniFile := TIniFile.Create(Filename.ToNative); - - // Players - IniFile.WriteString('Game', 'Players', IPlayers[Players]); - - // Difficulty - IniFile.WriteString('Game', 'Difficulty', IDifficulty[Difficulty]); - - // Language - IniFile.WriteString('Game', 'Language', ILanguage[Language]); - - // Tabs - IniFile.WriteString('Game', 'Tabs', ITabs[Tabs]); - - // Sorting - IniFile.WriteString('Game', 'Sorting', ISorting[Sorting]); - - // Debug - IniFile.WriteString('Game', 'Debug', IDebug[Debug]); - - // Screens - IniFile.WriteString('Graphics', 'Screens', IScreens[Screens]); - - // FullScreen - IniFile.WriteString('Graphics', 'FullScreen', IFullScreen[FullScreen]); - - // Visualization - IniFile.WriteString('Graphics', 'Visualization', IVisualizer[VisualizerOption]); - - // Resolution - IniFile.WriteString('Graphics', 'Resolution', IResolution[Resolution]); - - // Depth - IniFile.WriteString('Graphics', 'Depth', IDepth[Depth]); - - // TextureSize - IniFile.WriteString('Graphics', 'TextureSize', ITextureSize[TextureSize]); - - // Sing Window - IniFile.WriteString('Graphics', 'SingWindow', ISingWindow[SingWindow]); - - // Oscilloscope - IniFile.WriteString('Graphics', 'Oscilloscope', IOscilloscope[Oscilloscope]); - - // Spectrum - IniFile.WriteString('Graphics', 'Spectrum', ISpectrum[Spectrum]); - - // Spectrograph - IniFile.WriteString('Graphics', 'Spectrograph', ISpectrograph[Spectrograph]); - - // Movie Size - IniFile.WriteString('Graphics', 'MovieSize', IMovieSize[MovieSize]); - - // ClickAssist - IniFile.WriteString('Sound', 'ClickAssist', IClickAssist[ClickAssist]); - - // BeatClick - IniFile.WriteString('Sound', 'BeatClick', IBeatClick[BeatClick]); - - // AudioOutputBufferSize - IniFile.WriteString('Sound', 'AudioOutputBufferSize', IAudioOutputBufferSize[AudioOutputBufferSizeIndex]); - - // Background music - IniFile.WriteString('Sound', 'BackgroundMusic', IBackgroundMusic[BackgroundMusicOption]); - - // Song Preview - IniFile.WriteString('Sound', 'PreviewVolume', IPreviewVolume[PreviewVolume]); - - // PreviewFading - IniFile.WriteString('Sound', 'PreviewFading', IPreviewFading[PreviewFading]); - - // SavePlayback - IniFile.WriteString('Sound', 'SavePlayback', ISavePlayback[SavePlayback]); - - // VoicePasstrough - IniFile.WriteString('Sound', 'VoicePassthrough', IVoicePassthrough[VoicePassthrough]); - - // Lyrics Font - IniFile.WriteString('Lyrics', 'LyricsFont', ILyricsFont[LyricsFont]); - - // Lyrics Effect - IniFile.WriteString('Lyrics', 'LyricsEffect', ILyricsEffect[LyricsEffect]); - - // Solmization - IniFile.WriteString('Lyrics', 'Solmization', ISolmization[Solmization]); - - // NoteLines - IniFile.WriteString('Lyrics', 'NoteLines', INoteLines[NoteLines]); - - // Theme - IniFile.WriteString('Themes', 'Theme', ITheme[Theme]); - - // Skin - IniFile.WriteString('Themes', 'Skin', ISkin[SkinNo]); - - // Color - IniFile.WriteString('Themes', 'Color', IColor[Color]); - - SaveInputDeviceCfg(IniFile); - - //LoadAnimation - IniFile.WriteString('Advanced', 'LoadAnimation', ILoadAnimation[LoadAnimation]); - - //EffectSing - IniFile.WriteString('Advanced', 'EffectSing', IEffectSing[EffectSing]); - - //ScreenFade - IniFile.WriteString('Advanced', 'ScreenFade', IScreenFade[ScreenFade]); - - //AskbeforeDel - IniFile.WriteString('Advanced', 'AskbeforeDel', IAskbeforeDel[AskBeforeDel]); - - //OnSongClick - IniFile.WriteString('Advanced', 'OnSongClick', IOnSongClick[OnSongClick]); - - //Line Bonus - IniFile.WriteString('Advanced', 'LineBonus', ILineBonus[LineBonus]); - - //Party Popup - IniFile.WriteString('Advanced', 'PartyPopup', IPartyPopup[PartyPopup]); - - // Joypad - IniFile.WriteString('Controller', 'Joypad', IJoypad[Joypad]); - - // Mouse - IniFile.WriteString('Controller', 'Mouse', IMouse[Mouse]); - - // Directories (add a template if section is missing) - // Note: Value must be ' ' and not '', otherwise no key is generated on Linux - if (not IniFile.SectionExists('Directories')) then - IniFile.WriteString('Directories', 'SongDir1', ' '); - - IniFile.Free; -end; - -procedure TIni.SaveNames; -var - IniFile: TIniFile; - I: integer; -begin - if not Filename.IsReadOnly() then - begin - IniFile := TIniFile.Create(Filename.ToNative); - - //Name Templates for Names Mod - for I := 0 to High(Name) do - IniFile.WriteString('Name', 'P' + IntToStr(I+1), Name[I]); - for I := 0 to High(NameTeam) do - IniFile.WriteString('NameTeam', 'T' + IntToStr(I+1), NameTeam[I]); - for I := 0 to High(NameTemplate) do - IniFile.WriteString('NameTemplate', 'Name' + IntToStr(I+1), NameTemplate[I]); - - IniFile.Free; - end; -end; - -procedure TIni.SaveLevel; -var - IniFile: TIniFile; -begin - if not Filename.IsReadOnly() then - begin - IniFile := TIniFile.Create(Filename.ToNative); - - // Difficulty - IniFile.WriteString('Game', 'Difficulty', IDifficulty[Difficulty]); - - IniFile.Free; - end; -end; - -end. diff --git a/src/base/UJoystick.pas b/src/base/UJoystick.pas deleted file mode 100644 index 30808812..00000000 --- a/src/base/UJoystick.pas +++ /dev/null @@ -1,312 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UJoystick; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL; - -type - TJoyButton = record - State: integer; - Enabled: boolean; - Type_: byte; - Sym: cardinal; - end; - - TJoyHatState = record - State: Boolean; - LastTick: Cardinal; - Enabled: boolean; - Type_: byte; - Sym: cardinal; - end; - - TJoyUnit = record - Button: array[0..15] of TJoyButton; - HatState: Array[0..3] of TJoyHatState; - end; - - TJoy = class - constructor Create; - procedure Update; - end; - -var - Joy: TJoy; - JoyUnit: TJoyUnit; - SDL_Joy: PSDL_Joystick; - JoyEvent: TSDL_Event; - -implementation - -uses SysUtils, - ULog; - -constructor TJoy.Create; -var - B: integer; - //N: integer; -begin - inherited; - - //Old Corvus5 Method - {// joystick support - SDL_JoystickEventState(SDL_IGNORE); - SDL_InitSubSystem(SDL_INIT_JOYSTICK); - if SDL_NumJoysticks <> 1 then - Log.LogStatus('Joystick count <> 1', 'TJoy.Create'); - - SDL_Joy := SDL_JoystickOpen(0); - if SDL_Joy = nil then - Log.LogError('SDL_JoystickOpen failed', 'TJoy.Create'); - - if SDL_JoystickNumButtons(SDL_Joy) <> 16 then - Log.LogStatus('Joystick button count <> 16', 'TJoy.Create'); - -// SDL_JoystickEventState(SDL_ENABLE); - // Events don't work - thay hang the whole application with SDL_JoystickEventState(SDL_ENABLE) - - // clear states - for B := 0 to 15 do - JoyUnit.Button[B].State := 1; - - // mapping - JoyUnit.Button[1].Enabled := true; - JoyUnit.Button[1].Type_ := SDL_KEYDOWN; - JoyUnit.Button[1].Sym := SDLK_RETURN; - JoyUnit.Button[2].Enabled := true; - JoyUnit.Button[2].Type_ := SDL_KEYDOWN; - JoyUnit.Button[2].Sym := SDLK_ESCAPE; - - JoyUnit.Button[12].Enabled := true; - JoyUnit.Button[12].Type_ := SDL_KEYDOWN; - JoyUnit.Button[12].Sym := SDLK_LEFT; - JoyUnit.Button[13].Enabled := true; - JoyUnit.Button[13].Type_ := SDL_KEYDOWN; - JoyUnit.Button[13].Sym := SDLK_DOWN; - JoyUnit.Button[14].Enabled := true; - JoyUnit.Button[14].Type_ := SDL_KEYDOWN; - JoyUnit.Button[14].Sym := SDLK_RIGHT; - JoyUnit.Button[15].Enabled := true; - JoyUnit.Button[15].Type_ := SDL_KEYDOWN; - JoyUnit.Button[15].Sym := SDLK_UP; - } - //New Sarutas method - SDL_JoystickEventState(SDL_IGNORE); - SDL_InitSubSystem(SDL_INIT_JOYSTICK); - if SDL_NumJoysticks < 1 then - begin - Log.LogError('No Joystick found'); - exit; - end; - - - SDL_Joy := SDL_JoystickOpen(0); - if SDL_Joy = nil then - begin - Log.LogError('Could not Init Joystick'); - exit; - end; - //N := SDL_JoystickNumButtons(SDL_Joy); - //if N < 6 then Log.LogStatus('Joystick button count < 6', 'TJoy.Create'); - - for B := 0 to 5 do begin - JoyUnit.Button[B].Enabled := true; - JoyUnit.Button[B].State := 1; - JoyUnit.Button[B].Type_ := SDL_KEYDOWN; - end; - - JoyUnit.Button[0].Sym := SDLK_Return; - JoyUnit.Button[1].Sym := SDLK_Escape; - JoyUnit.Button[2].Sym := SDLK_M; - JoyUnit.Button[3].Sym := SDLK_R; - - JoyUnit.Button[4].Sym := SDLK_RETURN; - JoyUnit.Button[5].Sym := SDLK_ESCAPE; - - //Set HatState - for B := 0 to 3 do begin - JoyUnit.HatState[B].Enabled := true; - JoyUnit.HatState[B].State := False; - JoyUnit.HatState[B].Type_ := SDL_KEYDOWN; - end; - - JoyUnit.HatState[0].Sym := SDLK_UP; - JoyUnit.HatState[1].Sym := SDLK_RIGHT; - JoyUnit.HatState[2].Sym := SDLK_DOWN; - JoyUnit.HatState[3].Sym := SDLK_LEFT; -end; - -procedure TJoy.Update; -var - B: integer; - State: UInt8; - Tick: Cardinal; - Axes: Smallint; -begin - SDL_JoystickUpdate; - - //Manage Buttons - for B := 0 to 15 do begin - if (JoyUnit.Button[B].Enabled) and (JoyUnit.Button[B].State <> SDL_JoystickGetButton(SDL_Joy, B)) and (JoyUnit.Button[B].State = 0) then begin - JoyEvent.type_ := JoyUnit.Button[B].Type_; - JoyEvent.key.keysym.sym := JoyUnit.Button[B].Sym; - SDL_PushEvent(@JoyEvent); - end; - end; - - - for B := 0 to 15 do begin - JoyUnit.Button[B].State := SDL_JoystickGetButton(SDL_Joy, B); - end; - - //Get Tick - Tick := SDL_GetTicks(); - - //Get CoolieHat - if (SDL_JoystickNumHats(SDL_Joy)>=1) then - State := SDL_JoystickGetHat(SDL_Joy, 0) - else - State := 0; - - //Get Axis - if (SDL_JoystickNumAxes(SDL_Joy)>=2) then - begin - //Down - Up (X- Axis) - Axes := SDL_JoystickGetAxis(SDL_Joy, 1); - If Axes >= 15000 then - State := State or SDL_HAT_Down - Else If Axes <= -15000 then - State := State or SDL_HAT_UP; - - //Left - Right (Y- Axis) - Axes := SDL_JoystickGetAxis(SDL_Joy, 0); - If Axes >= 15000 then - State := State or SDL_HAT_Right - Else If Axes <= -15000 then - State := State or SDL_HAT_Left; - end; - - //Manage Hat and joystick Events - if (SDL_JoystickNumHats(SDL_Joy)>=1) OR (SDL_JoystickNumAxes(SDL_Joy)>=2) then - begin - - //Up Button - If (JoyUnit.HatState[0].Enabled) and ((SDL_HAT_UP AND State) = SDL_HAT_UP) then - begin //IF Button is newly Pressed or if he is Pressed longer than 500 msecs - if (JoyUnit.HatState[0].State = False) OR (JoyUnit.HatState[0].Lasttick < Tick) then - begin - //Set Tick and State - if JoyUnit.HatState[0].State then - JoyUnit.HatState[0].Lasttick := Tick + 200 - else - JoyUnit.HatState[0].Lasttick := Tick + 500; - - JoyUnit.HatState[0].State := True; - - JoyEvent.type_ := JoyUnit.HatState[0].Type_; - JoyEvent.key.keysym.sym := JoyUnit.HatState[0].Sym; - SDL_PushEvent(@JoyEvent); - end; - end - else - JoyUnit.HatState[0].State := False; - - //Right Button - If (JoyUnit.HatState[1].Enabled) and ((SDL_HAT_RIGHT AND State) = SDL_HAT_RIGHT) then - begin //IF Button is newly Pressed or if he is Pressed longer than 500 msecs - if (JoyUnit.HatState[1].State = False) OR (JoyUnit.HatState[1].Lasttick < Tick) then - begin - //Set Tick and State - if JoyUnit.HatState[1].State then - JoyUnit.HatState[1].Lasttick := Tick + 200 - else - JoyUnit.HatState[1].Lasttick := Tick + 500; - - JoyUnit.HatState[1].State := True; - - JoyEvent.type_ := JoyUnit.HatState[1].Type_; - JoyEvent.key.keysym.sym := JoyUnit.HatState[1].Sym; - SDL_PushEvent(@JoyEvent); - end; - end - else - JoyUnit.HatState[1].State := False; - - //Down button - If (JoyUnit.HatState[2].Enabled) and ((SDL_HAT_DOWN AND State) = SDL_HAT_DOWN) then - begin //IF Button is newly Pressed or if he is Pressed longer than 230 msecs - if (JoyUnit.HatState[2].State = False) OR (JoyUnit.HatState[2].Lasttick < Tick) then - begin - //Set Tick and State - if JoyUnit.HatState[2].State then - JoyUnit.HatState[2].Lasttick := Tick + 200 - else - JoyUnit.HatState[2].Lasttick := Tick + 500; - - JoyUnit.HatState[2].State := True; - - JoyEvent.type_ := JoyUnit.HatState[2].Type_; - JoyEvent.key.keysym.sym := JoyUnit.HatState[2].Sym; - SDL_PushEvent(@JoyEvent); - end; - end - else - JoyUnit.HatState[2].State := False; - - //Left Button - If (JoyUnit.HatState[3].Enabled) and ((SDL_HAT_LEFT AND State) = SDL_HAT_LEFT) then - begin //IF Button is newly Pressed or if he is Pressed longer than 230 msecs - if (JoyUnit.HatState[3].State = False) OR (JoyUnit.HatState[3].Lasttick < Tick) then - begin - //Set Tick and State - if JoyUnit.HatState[3].State then - JoyUnit.HatState[3].Lasttick := Tick + 200 - else - JoyUnit.HatState[3].Lasttick := Tick + 500; - - JoyUnit.HatState[3].State := True; - - JoyEvent.type_ := JoyUnit.HatState[3].Type_; - JoyEvent.key.keysym.sym := JoyUnit.HatState[3].Sym; - SDL_PushEvent(@JoyEvent); - end; - end - else - JoyUnit.HatState[3].State := False; - end; - -end; - -end. diff --git a/src/base/ULog.pas b/src/base/ULog.pas deleted file mode 100644 index e4ff4862..00000000 --- a/src/base/ULog.pas +++ /dev/null @@ -1,441 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit ULog; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - UPath; - -(* - * LOG_LEVEL_[TYPE] defines the "minimum" index for logs of type TYPE. Each - * level greater than this BUT less or equal than LOG_LEVEL_[TYPE]_MAX is of this type. - * This means a level "LOG_LEVEL_ERROR >= Level <= LOG_LEVEL_ERROR_MAX" e.g. - * "Level := LOG_LEVEL_ERROR+2" is considered an error level. - * This is nice for debugging if you have more or less important debug messages. - * For example you can assign LOG_LEVEL_DEBUG+10 for the more important ones and - * LOG_LEVEL_DEBUG+20 for less important ones and so on. By changing the log-level - * you can hide the less important ones. - *) -const - LOG_LEVEL_DEBUG_MAX = MaxInt; - LOG_LEVEL_DEBUG = 50; - LOG_LEVEL_INFO_MAX = LOG_LEVEL_DEBUG-1; - LOG_LEVEL_INFO = 40; - LOG_LEVEL_STATUS_MAX = LOG_LEVEL_INFO-1; - LOG_LEVEL_STATUS = 30; - LOG_LEVEL_WARN_MAX = LOG_LEVEL_STATUS-1; - LOG_LEVEL_WARN = 20; - LOG_LEVEL_ERROR_MAX = LOG_LEVEL_WARN-1; - LOG_LEVEL_ERROR = 10; - LOG_LEVEL_CRITICAL_MAX = LOG_LEVEL_ERROR-1; - LOG_LEVEL_CRITICAL = 0; - LOG_LEVEL_NONE = -1; - - // define level that Log(File)Level is initialized with - LOG_LEVEL_DEFAULT = LOG_LEVEL_WARN; - LOG_FILE_LEVEL_DEFAULT = LOG_LEVEL_ERROR; - -type - TLog = class - private - LogFile: TextFile; - LogFileOpened: boolean; - BenchmarkFile: TextFile; - BenchmarkFileOpened: boolean; - - LogLevel: integer; - // level of messages written to the log-file - LogFileLevel: integer; - - procedure LogToFile(const Text: string); - public - BenchmarkTimeStart: array[0..31] of real; - BenchmarkTimeLength: array[0..31] of real;//TDateTime; - - Title: String; //Application Title - - // Write log message to log-file - FileOutputEnabled: Boolean; - - constructor Create; - - // destuctor - destructor Destroy; override; - - // benchmark - procedure BenchmarkStart(Number: integer); - procedure BenchmarkEnd(Number: integer); - procedure LogBenchmark(const Text: string; Number: integer); - - procedure SetLogLevel(Level: integer); - function GetLogLevel(): integer; - - procedure LogMsg(const Text: string; Level: integer); overload; - procedure LogMsg(const Msg, Context: string; Level: integer); overload; {$IFDEF HasInline}inline;{$ENDIF} - procedure LogDebug(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} - procedure LogInfo(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} - procedure LogStatus(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} - procedure LogWarn(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} - procedure LogError(const Text: string); overload; {$IFDEF HasInline}inline;{$ENDIF} - procedure LogError(const Msg, Context: string); overload; {$IFDEF HasInline}inline;{$ENDIF} - //Critical Error (Halt + MessageBox) - procedure LogCritical(const Msg, Context: string); {$IFDEF HasInline}inline;{$ENDIF} - procedure CriticalError(const Text: string); {$IFDEF HasInline}inline;{$ENDIF} - - // voice - procedure LogVoice(SoundNr: integer); - // buffer - procedure LogBuffer(const buf : Pointer; const bufLength : Integer; const filename : IPath); - end; - -procedure DebugWriteln(const aString: String); - -var - Log: TLog; - -implementation - -uses - SysUtils, - DateUtils, - URecord, - UMain, - UTime, - UCommon, - UCommandLine, - UPathUtils; - -(* - * Write to console if in debug mode (Thread-safe). - * If debug-mode is disabled nothing is done. - *) -procedure DebugWriteln(const aString: string); -begin - {$IFNDEF DEBUG} - if Params.Debug then - begin - {$ENDIF} - ConsoleWriteLn(aString); - {$IFNDEF DEBUG} - end; - {$ENDIF} -end; - - -constructor TLog.Create; -begin - inherited; - LogLevel := LOG_LEVEL_DEFAULT; - LogFileLevel := LOG_FILE_LEVEL_DEFAULT; - FileOutputEnabled := true; -end; - -destructor TLog.Destroy; -begin - if BenchmarkFileOpened then - CloseFile(BenchmarkFile); - //if AnalyzeFileOpened then - // CloseFile(AnalyzeFile); - if LogFileOpened then - CloseFile(LogFile); - inherited; -end; - -procedure TLog.BenchmarkStart(Number: integer); -begin - BenchmarkTimeStart[Number] := USTime.GetTime; //Time; -end; - -procedure TLog.BenchmarkEnd(Number: integer); -begin - BenchmarkTimeLength[Number] := USTime.GetTime {Time} - BenchmarkTimeStart[Number]; -end; - -procedure TLog.LogBenchmark(const Text: string; Number: integer); -var - Minutes: integer; - Seconds: integer; - Miliseconds: integer; - - MinutesS: string; - SecondsS: string; - MilisecondsS: string; - - ValueText: string; -begin - if (FileOutputEnabled and Params.Benchmark) then - begin - if not BenchmarkFileOpened then - begin - BenchmarkFileOpened := true; - AssignFile(BenchmarkFile, LogPath.Append('Benchmark.log').ToNative); - {$I-} - Rewrite(BenchmarkFile); - if IOResult = 0 then - BenchmarkFileOpened := true; - {$I+} - - //If File is opened write Date to Benchmark File - If (BenchmarkFileOpened) then - begin - WriteLn(BenchmarkFile, Title + ' Benchmark File'); - WriteLn(BenchmarkFile, 'Date: ' + DatetoStr(Now) + ' Time: ' + TimetoStr(Now)); - WriteLn(BenchmarkFile, '-------------------'); - - Flush(BenchmarkFile); - end; - end; - - if BenchmarkFileOpened then - begin - Miliseconds := Trunc(Frac(BenchmarkTimeLength[Number]) * 1000); - Seconds := Trunc(BenchmarkTimeLength[Number]) mod 60; - Minutes := Trunc((BenchmarkTimeLength[Number] - Seconds) / 60); - //ValueText := FloatToStr(BenchmarkTimeLength[Number]); - - { - ValueText := FloatToStr(SecondOf(BenchmarkTimeLength[Number]) + - MilliSecondOf(BenchmarkTimeLength[Number])/1000); - if MinuteOf(BenchmarkTimeLength[Number]) >= 1 then - ValueText := IntToStr(MinuteOf(BenchmarkTimeLength[Number])) + ':' + ValueText; - WriteLn(FileBenchmark, Text + ': ' + ValueText + ' seconds'); - } - - if (Minutes = 0) and (Seconds = 0) then begin - MilisecondsS := IntToStr(Miliseconds); - ValueText := MilisecondsS + ' miliseconds'; - end; - - if (Minutes = 0) and (Seconds >= 1) then begin - MilisecondsS := IntToStr(Miliseconds); - while Length(MilisecondsS) < 3 do - MilisecondsS := '0' + MilisecondsS; - - SecondsS := IntToStr(Seconds); - - ValueText := SecondsS + ',' + MilisecondsS + ' seconds'; - end; - - if Minutes >= 1 then begin - MilisecondsS := IntToStr(Miliseconds); - while Length(MilisecondsS) < 3 do - MilisecondsS := '0' + MilisecondsS; - - SecondsS := IntToStr(Seconds); - while Length(SecondsS) < 2 do - SecondsS := '0' + SecondsS; - - MinutesS := IntToStr(Minutes); - - ValueText := MinutesS + ':' + SecondsS + ',' + MilisecondsS + ' minutes'; - end; - - WriteLn(BenchmarkFile, Text + ': ' + ValueText); - Flush(BenchmarkFile); - end; - end; -end; - -procedure TLog.LogToFile(const Text: string); -begin - if (FileOutputEnabled and not LogFileOpened) then - begin - AssignFile(LogFile, LogPath.Append('Error.log').ToNative); - {$I-} - Rewrite(LogFile); - if IOResult = 0 then - LogFileOpened := true; - {$I+} - - //If File is opened write Date to Error File - if (LogFileOpened) then - begin - WriteLn(LogFile, Title + ' Error Log'); - WriteLn(LogFile, 'Date: ' + DatetoStr(Now) + ' Time: ' + TimetoStr(Now)); - WriteLn(LogFile, '-------------------'); - - Flush(LogFile); - end; - end; - - if LogFileOpened then - begin - try - WriteLn(LogFile, Text); - Flush(LogFile); - except - LogFileOpened := false; - end; - end; -end; - -procedure TLog.SetLogLevel(Level: integer); -begin - LogLevel := Level; -end; - -function TLog.GetLogLevel(): integer; -begin - Result := LogLevel; -end; - -procedure TLog.LogMsg(const Text: string; Level: integer); -var - LogMsg: string; -begin - // TODO: what if (LogFileLevel < LogLevel)? Log to file without printing to - // console or do not log at all? At the moment nothing is logged. - if (Level <= LogLevel) then - begin - if (Level <= LOG_LEVEL_CRITICAL_MAX) then - LogMsg := 'CRITICAL: ' + Text - else if (Level <= LOG_LEVEL_ERROR_MAX) then - LogMsg := 'ERROR: ' + Text - else if (Level <= LOG_LEVEL_WARN_MAX) then - LogMsg := 'WARN: ' + Text - else if (Level <= LOG_LEVEL_STATUS_MAX) then - LogMsg := 'STATUS: ' + Text - else if (Level <= LOG_LEVEL_INFO_MAX) then - LogMsg := 'INFO: ' + Text - else - LogMsg := 'DEBUG: ' + Text; - - // output log-message - if (Level <= LogLevel) then - begin - DebugWriteLn(LogMsg); - end; - - // write message to log-file - if (Level <= LogFileLevel) then - begin - LogToFile(LogMsg); - end; - end; - - // exit application on criticial errors (cannot be turned off) - if (Level <= LOG_LEVEL_CRITICAL_MAX) then - begin - // Show information (window) - ShowMessage(Text, mtError); - Halt; - end; -end; - -procedure TLog.LogMsg(const Msg, Context: string; Level: integer); -begin - LogMsg(Msg + ' ['+Context+']', Level); -end; - -procedure TLog.LogDebug(const Msg, Context: string); -begin - LogMsg(Msg, Context, LOG_LEVEL_DEBUG); -end; - -procedure TLog.LogInfo(const Msg, Context: string); -begin - LogMsg(Msg, Context, LOG_LEVEL_INFO); -end; - -procedure TLog.LogStatus(const Msg, Context: string); -begin - LogMsg(Msg, Context, LOG_LEVEL_STATUS); -end; - -procedure TLog.LogWarn(const Msg, Context: string); -begin - LogMsg(Msg, Context, LOG_LEVEL_WARN); -end; - -procedure TLog.LogError(const Msg, Context: string); -begin - LogMsg(Msg, Context, LOG_LEVEL_ERROR); -end; - -procedure TLog.LogError(const Text: string); -begin - LogMsg(Text, LOG_LEVEL_ERROR); -end; - -procedure TLog.CriticalError(const Text: string); -begin - LogMsg(Text, LOG_LEVEL_CRITICAL); -end; - -procedure TLog.LogCritical(const Msg, Context: string); -begin - LogMsg(Msg, Context, LOG_LEVEL_CRITICAL); -end; - -procedure TLog.LogVoice(SoundNr: integer); -var - FS: TBinaryFileStream; - Prefix: string; - FileName: IPath; - Num: integer; -begin - for Num := 1 to 9999 do begin - Prefix := Format('Voice%.4d', [Num]); - FileName := LogPath.Append(Prefix + '.raw'); - if not FileName.Exists() then - break - end; - - FS := TBinaryFileStream.Create(FileName, fmCreate); - - AudioInputProcessor.Sound[SoundNr].LogBuffer.Seek(0, soBeginning); - FS.CopyFrom(AudioInputProcessor.Sound[SoundNr].LogBuffer, AudioInputProcessor.Sound[SoundNr].LogBuffer.Size); - - FS.Free; -end; - -procedure TLog.LogBuffer(const buf: Pointer; const bufLength: Integer; const filename: IPath); -var - f : TBinaryFileStream; -begin - try - f := TBinaryFileStream.Create( filename, fmCreate); - try - f.Write( buf^, bufLength); - finally - f.Free; - end; - except on e : Exception do - Log.LogError('TLog.LogBuffer: Failed to log buffer into file "' + filename.ToNative + '". ErrMsg: ' + e.Message); - end; -end; - -end. - - diff --git a/src/base/ULyrics.pas b/src/base/ULyrics.pas deleted file mode 100644 index 3f62db9c..00000000 --- a/src/base/ULyrics.pas +++ /dev/null @@ -1,726 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit ULyrics; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - gl, - glext, - UTexture, - UThemes, - UMusic; - -type - // stores two textures for enabled/disabled states - TPlayerIconTex = array [0..1] of TTexture; - - TLyricsEffect = (lfxSimple, lfxZoom, lfxSlide, lfxBall, lfxShift); - - PLyricWord = ^TLyricWord; - TLyricWord = record - X: real; // left corner - Width: real; // width - Start: cardinal; // start of the word in quarters (beats) - Length: cardinal; // length of the word in quarters - Text: UTF8String; // text - Freestyle: boolean; // is freestyle? - end; - TLyricWordArray = array of TLyricWord; - - TLyricLine = class - public - Text: UTF8String; // text - Width: real; // width - Height: real; // height - Words: TLyricWordArray; // words in this line - CurWord: integer; // current active word idx (only valid if line is active) - Start: integer; // start of this line in quarters (Note: negative start values are possible due to gap) - StartNote: integer; // start of the first note of this line in quarters - Length: integer; // length in quarters (from start of first to the end of the last note) - Players: byte; // players that should sing that line (bitset, Player1: 1, Player2: 2, Player3: 4) - LastLine: boolean; // is this the last line of the song? - - constructor Create(); - destructor Destroy(); override; - procedure Reset(); - end; - - TLyricEngine = class - private - LastDrawBeat: real; - UpperLine: TLyricLine; // first line displayed (top) - LowerLine: TLyricLine; // second lind displayed (bottom) - QueueLine: TLyricLine; // third line (will be displayed when lower line is finished) - - IndicatorTex: TTexture; // texture for lyric indikator - BallTex: TTexture; // texture of the ball for the lyric effect - - QueueFull: boolean; // set to true if the queue is full and a line will be replaced with the next AddLine - LCounter: integer; // line counter - - // duet mode - textures for player icons - // FIXME: do not use a fixed player count, use MAX_PLAYERS instead - PlayerIconTex: array[0..5] of TPlayerIconTex; - - // Some helper procedures for lyric drawing - procedure DrawLyrics (Beat: real); - procedure UpdateLineMetrics(LyricLine: TLyricLine); - procedure DrawLyricsWords(LyricLine: TLyricLine; X, Y: real; StartWord, EndWord: integer); - procedure DrawLyricsLine(X, W, Y, H: real; Line: TLyricLine; Beat: real); - procedure DrawPlayerIcon(Player: byte; Enabled: boolean; X, Y: real; Size, Alpha: real); - procedure DrawBall(XBall, YBall, Alpha: real); - - public - // positions, line specific settings - UpperLineX: real; // X start-pos of UpperLine - UpperLineW: real; // Width of UpperLine with icon(s) and text - UpperLineY: real; // Y start-pos of UpperLine - UpperLineH: real; // Max. font-size of lyrics text in UpperLine - - LowerLineX: real; // X start-pos of LowerLine - LowerLineW: real; // Width of LowerLine with icon(s) and text - LowerLineY: real; // Y start-pos of LowerLine - LowerLineH: real; // Max. font-size of lyrics text in LowerLine - - // display propertys - LineColor_en: TRGBA; // Color of words in an enabled line - LineColor_dis: TRGBA; // Color of words in a disabled line - LineColor_act: TRGBA; // Color of the active word - FontStyle: byte; // Font for the lyric text - - { // currently not used - FadeInEffect: byte; // Effect for line fading in: 0: No Effect; 1: Fade Effect; 2: Move Upwards from Bottom to Pos - FadeOutEffect: byte; // Effect for line fading out: 0: No Effect; 1: Fade Effect; 2: Move Upwards - } - - // song specific settings - BPM: real; - Resolution: integer; - - // properties to easily read options of this class - property IsQueueFull: boolean read QueueFull; // line in queue? - property LineCounter: integer read LCounter; // lines that were progressed so far (after last clear) - - procedure AddLine(Line: PLine); // adds a line to the queue, if there is space - procedure Draw (Beat: real); // draw the current (active at beat) lyrics - - // clears all cached song specific information - procedure Clear(cBPM: real = 0; cResolution: integer = 0); - - function GetUpperLine(): TLyricLine; - function GetLowerLine(): TLyricLine; - - function GetUpperLineIndex(): integer; - - constructor Create(ULX, ULY, ULW, ULH, LLX, LLY, LLW, LLH: real); - procedure LoadTextures; - destructor Destroy; override; - end; - -implementation - -uses - SysUtils, - USkins, - TextGL, - UGraphic, - UDisplay, - ULog, - math, - UIni; - -{ TLyricLine } - -constructor TLyricLine.Create(); -begin - inherited; - Reset(); -end; - -destructor TLyricLine.Destroy(); -begin - SetLength(Words, 0); - inherited; -end; - -procedure TLyricLine.Reset(); -begin - Start := 0; - StartNote := 0; - Length := 0; - LastLine := False; - - Text := ''; - Width := 0; - - // duet mode: players of that line (default: all) - Players := $FF; - - SetLength(Words, 0); - CurWord := -1; -end; - - -{ TLyricEngine } - -{** - * Initializes the engine. - *} -constructor TLyricEngine.Create(ULX, ULY, ULW, ULH, LLX, LLY, LLW, LLH: real); -begin - inherited Create(); - - BPM := 0; - Resolution := 0; - LCounter := 0; - QueueFull := False; - - UpperLine := TLyricLine.Create; - LowerLine := TLyricLine.Create; - QueueLine := TLyricLine.Create; - - LastDrawBeat := 0; - - UpperLineX := ULX; - UpperLineW := ULW; - UpperLineY := ULY; - UpperLineH := ULH; - - LowerLineX := LLX; - LowerLineW := LLW; - LowerLineY := LLY; - LowerLineH := LLH; - - LoadTextures; -end; - - -{** - * Frees memory. - *} -destructor TLyricEngine.Destroy; -begin - UpperLine.Free; - LowerLine.Free; - QueueLine.Free; - inherited; -end; - -{** - * Clears all cached Song specific Information. - *} -procedure TLyricEngine.Clear(cBPM: real; cResolution: integer); -begin - BPM := cBPM; - Resolution := cResolution; - LCounter := 0; - QueueFull := False; - - LastDrawBeat:=0; -end; - - -{** - * Loads textures needed for the drawing the lyrics, - * player icons, a ball for the ball effect and the lyric indicator. - *} -procedure TLyricEngine.LoadTextures; -var - I: Integer; -begin - // lyric indicator (bar that indicates when the line start) - IndicatorTex := Texture.LoadTexture(Skin.GetTextureFileName('LyricHelpBar'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - - // ball for current word hover in ball effect - BallTex := Texture.LoadTexture(Skin.GetTextureFileName('Ball'), TEXTURE_TYPE_TRANSPARENT, 0); - - // duet mode: load player icon - for I := 0 to 5 do - begin - PlayerIconTex[I][0] := Texture.LoadTexture(Skin.GetTextureFileName('LyricIcon_P' + InttoStr(I+1)), TEXTURE_TYPE_TRANSPARENT, 0); - PlayerIconTex[I][1] := Texture.LoadTexture(Skin.GetTextureFileName('LyricIconD_P' + InttoStr(I+1)), TEXTURE_TYPE_TRANSPARENT, 0); - end; -end; - -{** - * Adds LyricLine to queue. - * The LyricEngine stores three lines in its queue: - * UpperLine: the upper line displayed in the lyrics - * LowerLine: the lower line displayed in the lyrics - * QueueLine: an offscreen line that precedes LowerLine - * If the queue is full the next call to AddLine will replace UpperLine with - * LowerLine, LowerLine with QueueLine and QueueLine with the Line parameter. - *} -procedure TLyricEngine.AddLine(Line: PLine); -var - LyricLine: TLyricLine; - I: integer; -begin - // only add lines, if there is space - if not IsQueueFull then - begin - // set LyricLine to line to write to - if (LineCounter = 0) then - LyricLine := UpperLine - else if (LineCounter = 1) then - LyricLine := LowerLine - else - begin - // now the queue is full - LyricLine := QueueLine; - QueueFull := True; - end; - end - else - begin // rotate lines (round-robin-like) - LyricLine := UpperLine; - UpperLine := LowerLine; - LowerLine := QueueLine; - QueueLine := LyricLine; - end; - - // reset line state - LyricLine.Reset(); - - // check if sentence has notes - if (Line <> nil) and (Length(Line.Note) > 0) then - begin - // copy values from SongLine to LyricLine - LyricLine.Start := Line.Start; - LyricLine.StartNote := Line.Note[0].Start; - LyricLine.Length := Line.Note[High(Line.Note)].Start + - Line.Note[High(Line.Note)].Length - - Line.Note[0].Start; - LyricLine.LastLine := Line.LastLine; - - // copy words - SetLength(LyricLine.Words, Length(Line.Note)); - for I := 0 to High(Line.Note) do - begin - LyricLine.Words[I].Start := Line.Note[I].Start; - LyricLine.Words[I].Length := Line.Note[I].Length; - LyricLine.Words[I].Text := Line.Note[I].Text; - LyricLine.Words[I].Freestyle := Line.Note[I].NoteType = ntFreestyle; - - LyricLine.Text := LyricLine.Text + LyricLine.Words[I].Text; - end; - - UpdateLineMetrics(LyricLine); - end; - - // increase the counter - Inc(LCounter); -end; - -{** - * Draws Lyrics. - * Draw just manages the Lyrics, drawing is done by a call of DrawLyrics. - * @param Beat: current Beat in Quarters - *} -procedure TLyricEngine.Draw(Beat: real); -begin - DrawLyrics(Beat); - LastDrawBeat := Beat; -end; - -{** - * Main Drawing procedure. - *} -procedure TLyricEngine.DrawLyrics(Beat: real); -begin - DrawLyricsLine(UpperLineX, UpperLineW, UpperLineY, UpperLineH, UpperLine, Beat); - DrawLyricsLine(LowerLineX, LowerLineW, LowerLineY, LowerLineH, LowerLine, Beat); -end; - -{** - * Draws a Player's icon. - *} -procedure TLyricEngine.DrawPlayerIcon(Player: byte; Enabled: boolean; X, Y: real; Size, Alpha: real); -var - IEnabled: byte; -begin - if Enabled then - IEnabled := 0 - else - IEnabled := 1; - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, PlayerIconTex[Player][IEnabled].TexNum); - - glColor4f(1, 1, 1, Alpha); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(X, Y); - glTexCoord2f(0, 1); glVertex2f(X, Y + Size); - glTexCoord2f(1, 1); glVertex2f(X + Size, Y + Size); - glTexCoord2f(1, 0); glVertex2f(X + Size, Y); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -{** - * Draws the Ball over the LyricLine if needed. - *} -procedure TLyricEngine.DrawBall(XBall, YBall, Alpha: real); -begin - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, BallTex.TexNum); - - glColor4f(1, 1, 1, Alpha); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(XBall - 10, YBall); - glTexCoord2f(0, 1); glVertex2f(XBall - 10, YBall + 20); - glTexCoord2f(1, 1); glVertex2f(XBall + 10, YBall + 20); - glTexCoord2f(1, 0); glVertex2f(XBall + 10, YBall); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -procedure TLyricEngine.DrawLyricsWords(LyricLine: TLyricLine; - X, Y: real; StartWord, EndWord: integer); -var - I: integer; - PosX: real; - CurWord: PLyricWord; -begin - PosX := X; - - // set word positions and line size and draw the line - for I := StartWord to EndWord do - begin - CurWord := @LyricLine.Words[I]; - SetFontItalic(CurWord.Freestyle); - SetFontPos(PosX, Y); - glPrint(CurWord.Text); - PosX := PosX + CurWord.Width; - end; -end; - -procedure TLyricEngine.UpdateLineMetrics(LyricLine: TLyricLine); -var - I: integer; - PosX: real; - CurWord: PLyricWord; - RequestWidth, RequestHeight: real; -begin - PosX := 0; - - // setup font - SetFontStyle(FontStyle); - ResetFont(); - - // check if line is lower or upper line and set sizes accordingly - // Note: at the moment upper and lower lines have same width/height - // and this function is just called by AddLine() but this may change - // so that it is called by DrawLyricsLine(). - //if (LyricLine = LowerLine) then - //begin - // RequestWidth := LowerLineW; - // RequestHeight := LowerLineH; - //end - //else - //begin - RequestWidth := UpperLineW; - RequestHeight := UpperLineH; - //end; - - // set font size to a reasonable value - LyricLine.Height := RequestHeight * 0.9; - SetFontSize(LyricLine.Height); - LyricLine.Width := glTextWidth(LyricLine.Text); - - // change font-size to fit into the lyric bar - if (LyricLine.Width > RequestWidth) then - begin - LyricLine.Height := Trunc(LyricLine.Height * (RequestWidth / LyricLine.Width)); - // the line is very loooong, set font to at least 1px - if (LyricLine.Height < 1) then - LyricLine.Height := 1; - - SetFontSize(LyricLine.Height); - LyricLine.Width := glTextWidth(LyricLine.Text); - end; - - // calc word positions and widths - for I := 0 to High(LyricLine.Words) do - begin - CurWord := @LyricLine.Words[I]; - - // - if current word is italic but not the next word get the width of the - // italic font to avoid overlapping. - // - if two italic words follow each other use the normal style's - // width otherwise the spacing between the words will be too big. - // - if it is the line's last word use normal width - if CurWord.Freestyle and - (I+1 < Length(LyricLine.Words)) and - (not LyricLine.Words[I+1].Freestyle) then - begin - SetFontItalic(true); - end; - - CurWord.X := PosX; - CurWord.Width := glTextWidth(CurWord.Text); - PosX := PosX + CurWord.Width; - SetFontItalic(false); - end; -end; - - -{** - * Draws one LyricLine - *} -procedure TLyricEngine.DrawLyricsLine(X, W, Y, H: real; Line: TLyricLine; Beat: real); -var - CurWord: PLyricWord; // current word - LastWord: PLyricWord; // last word in line - NextWord: PLyricWord; // word following current word - Progress: real; // progress of singing the current word - LyricX, LyricY: real; // left/top lyric position - WordY: real; // word y-position - LyricsEffect: TLyricsEffect; - Alpha: real; // alphalevel to fade out at end - ClipPlaneEq: array[0..3] of GLdouble; // clipping plane for slide effect - {// duet mode - IconSize: real; // size of player icons - IconAlpha: real; // alpha level of player icons - } -begin - // do not draw empty lines - if (Length(Line.Words) = 0) then - Exit; - - { - // duet mode - IconSize := (2 * Height); - IconAlpha := Frac(Beat/(Resolution*4)); - - DrawPlayerIcon (0, True, X, Y + (42 - IconSize) / 2 , IconSize, IconAlpha); - DrawPlayerIcon (1, True, X + IconSize + 1, Y + (42 - IconSize) / 2, IconSize, IconAlpha); - DrawPlayerIcon (2, True, X + (IconSize + 1)*2, Y + (42 - IconSize) / 2, IconSize, IconAlpha); - } - - // set font size and style - SetFontStyle(FontStyle); - ResetFont(); - SetFontSize(Line.Height); - - // center lyrics - LyricX := X + (W - Line.Width) / 2; - LyricY := Y + (H - Line.Height) / 2; - // get lyrics effect - LyricsEffect := TLyricsEffect(Ini.LyricsEffect); - - // TODO: what about alpha in freetype outline fonts? - Alpha := 1; - - // check if this line is active (at least its first note must be active) - if (Beat >= Line.StartNote) then - begin - // if this line just got active, CurWord is -1, - // this means we should try to make the first word active - if (Line.CurWord = -1) then - Line.CurWord := 0; - - // check if the current active word is still active. - // Otherwise proceed to the next word if there is one in this line. - // Note: the max. value of Line.CurWord is High(Line.Words) - if (Line.CurWord < High(Line.Words)) and - (Beat >= Line.Words[Line.CurWord + 1].Start) then - begin - Inc(Line.CurWord); - end; - - // determine current and last word in this line. - // If the end of the line is reached use the last word as current word. - LastWord := @Line.Words[High(Line.Words)]; - CurWord := @Line.Words[Line.CurWord]; - if (Line.CurWord+1 < Length(Line.Words)) then - NextWord := @Line.Words[Line.CurWord+1] - else - NextWord := nil; - - // calc the progress of the lyrics effect - Progress := (Beat - CurWord.Start) / CurWord.Length; - if (Progress >= 1) then - Progress := 1; - if (Progress <= 0) then - Progress := 0; - - // last word of this line finished, but this line did not hide -> fade out - if Line.LastLine and - (Beat > LastWord.Start + LastWord.Length) then - begin - Alpha := 1 - (Beat - (LastWord.Start + LastWord.Length)) / 15; - if (Alpha < 0) then - Alpha := 0; - end; - - // draw sentence before current word - if (LyricsEffect in [lfxSimple, lfxBall, lfxShift]) then - // only highlight current word and not that ones before in this line - glColorRGB(LineColor_en, Alpha) - else - glColorRGB(LineColor_act, Alpha); - DrawLyricsWords(Line, LyricX, LyricY, 0, Line.CurWord-1); - - // draw rest of sentence (without current word) - glColorRGB(LineColor_en, Alpha); - if (NextWord <> nil) then - begin - DrawLyricsWords(Line, LyricX + NextWord.X, LyricY, - Line.CurWord+1, High(Line.Words)); - end; - - // draw current word - if (LyricsEffect in [lfxSimple, lfxBall, lfxShift]) then - begin - if (LyricsEffect = lfxShift) then - WordY := LyricY - 8 * (1-Progress) - else - WordY := LyricY; - - // change the color of the current word - glColor4f(LineColor_act.r, LineColor_act.g, LineColor_act.b, Alpha); - DrawLyricsWords(Line, LyricX + CurWord.X, WordY, Line.CurWord, Line.CurWord); - end - // change color and zoom current word - else if (LyricsEffect = lfxZoom) then - begin - glPushMatrix; - - // zoom at word center - glTranslatef(LyricX + CurWord.X + CurWord.Width/2, - LyricY + Line.Height/2, 0); - glScalef(1.0 + (1-Progress) * 0.5, 1.0 + (1-Progress) * 0.5, 1.0); - - glColor4f(LineColor_act.r, LineColor_act.g, LineColor_act.b, Alpha); - DrawLyricsWords(Line, -CurWord.Width/2, -Line.Height/2, Line.CurWord, Line.CurWord); - - glPopMatrix; - end - // split current word into active and non-active part - else if (LyricsEffect = lfxSlide) then - begin - // enable clipping and set clip equation coefficients to zeros - glEnable(GL_CLIP_PLANE0); - FillChar(ClipPlaneEq[0], SizeOf(ClipPlaneEq), 0); - - glPushMatrix; - glTranslatef(LyricX + CurWord.X, LyricY, 0); - - // clip non-active right part of the current word - ClipPlaneEq[0] := -1; - ClipPlaneEq[3] := CurWord.Width * Progress; - glClipPlane(GL_CLIP_PLANE0, @ClipPlaneEq); - // and draw active left part - glColor4f(LineColor_act.r, LineColor_act.g, LineColor_act.b, Alpha); - DrawLyricsWords(Line, 0, 0, Line.CurWord, Line.CurWord); - - // clip active left part of the current word - ClipPlaneEq[0] := -ClipPlaneEq[0]; - ClipPlaneEq[3] := -ClipPlaneEq[3]; - glClipPlane(GL_CLIP_PLANE0, @ClipPlaneEq); - // and draw non-active right part - glColor4f(LineColor_en.r, LineColor_en.g, LineColor_en.b, Alpha); - DrawLyricsWords(Line, 0, 0, Line.CurWord, Line.CurWord); - - glPopMatrix; - - glDisable(GL_CLIP_PLANE0); - end; - - // draw the ball onto the current word - if (LyricsEffect = lfxBall) then - begin - DrawBall(LyricX + CurWord.X + CurWord.Width * Progress, - LyricY - 15 - 15*sin(Progress * Pi), Alpha); - end; - end - else - begin - // this section is called if the whole line can be drawn at once and no - // word is highlighted. - - // enable the upper, disable the lower line - if (Line = UpperLine) then - glColorRGB(LineColor_en) - else - glColorRGB(LineColor_dis); - - DrawLyricsWords(Line, LyricX, LyricY, 0, High(Line.Words)); - end; -end; - -{** - * @returns a reference to the upper line - *} -function TLyricEngine.GetUpperLine(): TLyricLine; -begin - Result := UpperLine; -end; - -{** - * @returns a reference to the lower line - *} -function TLyricEngine.GetLowerLine(): TLyricLine; -begin - Result := LowerLine; -end; - -{** - * @returns the index of the upper line - *} -function TLyricEngine.GetUpperLineIndex(): integer; -const - QUEUE_SIZE = 3; -begin - // no line in queue - if (LineCounter <= 0) then - Result := -1 - // no line has been removed from queue yet - else if (LineCounter <= QUEUE_SIZE) then - Result := 0 - // lines have been removed from queue already - else - Result := LineCounter - QUEUE_SIZE; -end; - -end. - diff --git a/src/base/UMain.pas b/src/base/UMain.pas deleted file mode 100644 index d5e0ccb3..00000000 --- a/src/base/UMain.pas +++ /dev/null @@ -1,569 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMain; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - SDL; - -var - Done: boolean; - Restart: boolean; - -procedure Main; -procedure MainLoop; -procedure CheckEvents; - -type - TMainThreadExecProc = procedure(Data: Pointer); - -const - MAINTHREAD_EXEC_EVENT = SDL_USEREVENT + 2; - -{* - * Delegates execution of procedure Proc to the main thread. - * The Data pointer is passed to the procedure when it is called. - * The main thread is notified by signaling a MAINTHREAD_EXEC_EVENT which - * is handled in CheckEvents. - * Note that Data must not be a pointer to local data. If you want to pass local - * data, use Getmem() or New() or create a temporary object. - *} -procedure MainThreadExec(Proc: TMainThreadExecProc; Data: Pointer); - -implementation - -uses - Math, - gl, - UCatCovers, - UCommandLine, - UCommon, - UConfig, - UCovers, - UDataBase, - UDisplay, - UDLLManager, - UGraphic, - UGraphicClasses, - UIni, - UJoystick, - ULanguage, - ULog, - UPathUtils, - UPlaylist, - UMusic, - UBeatTimer, - UPlatform, - USkins, - USongs, - UThemes, - UParty, - UTime; - -procedure Main; -var - WindowTitle: string; -begin - {$IFNDEF Debug} - try - {$ENDIF} - WindowTitle := USDXVersionStr; - - Platform.Init; - - if Platform.TerminateIfAlreadyRunning(WindowTitle) then - Exit; - - // fix floating-point exceptions (FPE) - DisableFloatingPointExceptions(); - // fix the locale for string-to-float parsing in C-libs - SetDefaultNumericLocale(); - - // setup separators for parsing - // Note: ThousandSeparator must be set because of a bug in TIniFile.ReadFloat - ThousandSeparator := ','; - DecimalSeparator := '.'; - - //------------------------------ - // StartUp - create classes and load files - //------------------------------ - - // initialize SDL - // without SDL_INIT_TIMER SDL_GetTicks() might return strange values - SDL_Init(SDL_INIT_VIDEO or SDL_INIT_TIMER); - SDL_EnableUnicode(1); - - USTime := TTime.Create; - VideoBGTimer := TRelativeTimer.Create; - - // Commandline Parameter Parser - Params := TCMDParams.Create; - - // Log + Benchmark - Log := TLog.Create; - Log.Title := WindowTitle; - Log.FileOutputEnabled := not Params.NoLog; - Log.BenchmarkStart(0); - - // Language - Log.BenchmarkStart(1); - Log.LogStatus('Initialize Paths', 'Initialization'); - InitializePaths; - Log.LogStatus('Load Language', 'Initialization'); - Language := TLanguage.Create; - - // add const values: - Language.AddConst('US_VERSION', USDXVersionStr); - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Language', 1); - -{ - // SDL_ttf (Not used yet, maybe in version 1.5) - Log.BenchmarkStart(1); - Log.LogStatus('Initialize SDL_ttf', 'Initialization'); - TTF_Init(); - Log.BenchmarkEnd(1); - Log.LogBenchmark('Initializing SDL_ttf', 1); -} - - // Skin - Log.BenchmarkStart(1); - Log.LogStatus('Loading Skin List', 'Initialization'); - Skin := TSkin.Create; - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Skin List', 1); - - // Ini + Paths - Log.BenchmarkStart(1); - Log.LogStatus('Load Ini', 'Initialization'); - Ini := TIni.Create; - Ini.Load; - - // it is possible that this is the first run, create a .ini file if neccessary - Log.LogStatus('Write Ini', 'Initialization'); - Ini.Save; - - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Ini', 1); - - // Sound - Log.BenchmarkStart(1); - Log.LogStatus('Initialize Sound', 'Initialization'); - InitializeSound(); - Log.BenchmarkEnd(1); - Log.LogBenchmark('Initializing Sound', 1); - - // Lyrics-engine with media reference timer - LyricsState := TLyricsState.Create(); - - // Theme - Log.BenchmarkStart(1); - Log.LogStatus('Load Themes', 'Initialization'); - Theme := TTheme.Create(ThemePath.Append(ITheme[Ini.Theme] + '.ini'), Ini.Color); - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Themes', 1); - - // Covers Cache - Log.BenchmarkStart(1); - Log.LogStatus('Creating Covers Cache', 'Initialization'); - Covers := TCoverDatabase.Create; - Log.LogBenchmark('Loading Covers Cache Array', 1); - Log.BenchmarkStart(1); - - // Category Covers - Log.BenchmarkStart(1); - Log.LogStatus('Creating Category Covers Array', 'Initialization'); - CatCovers:= TCatCovers.Create; - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Category Covers Array', 1); - - // Songs - //Log.BenchmarkStart(1); - Log.LogStatus('Creating Song Array', 'Initialization'); - Songs := TSongs.Create; - //Songs.LoadSongList; - - Log.LogStatus('Creating 2nd Song Array', 'Initialization'); - CatSongs := TCatSongs.Create; - - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Songs', 1); - - // PluginManager - Log.BenchmarkStart(1); - Log.LogStatus('PluginManager', 'Initialization'); - DLLMan := TDLLMan.Create; // Load PluginList - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading PluginManager', 1); - - // Party Mode Manager - Log.BenchmarkStart(1); - Log.LogStatus('PartySession Manager', 'Initialization'); - PartySession := TPartySession.Create; //Load PartySession - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading PartySession Manager', 1); - - // Graphics - Log.BenchmarkStart(1); - Log.LogStatus('Initialize 3D', 'Initialization'); - Initialize3D(WindowTitle); - Log.BenchmarkEnd(1); - Log.LogBenchmark('Initializing 3D', 1); - - // Score Saving System - Log.BenchmarkStart(1); - Log.LogStatus('DataBase System', 'Initialization'); - DataBase := TDataBaseSystem.Create; - - if (Params.ScoreFile.IsUnset) then - DataBase.Init(Platform.GetGameUserPath.Append('Ultrastar.db')) - else - DataBase.Init(Params.ScoreFile); - - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading DataBase System', 1); - - // Playlist Manager - Log.BenchmarkStart(1); - Log.LogStatus('Playlist Manager', 'Initialization'); - PlaylistMan := TPlaylistManager.Create; - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Playlist Manager', 1); - - // GoldenStarsTwinkleMod - Log.BenchmarkStart(1); - Log.LogStatus('Effect Manager', 'Initialization'); - GoldenRec := TEffectManager.Create; - Log.BenchmarkEnd(1); - Log.LogBenchmark('Loading Particle System', 1); - - // Joypad - if (Ini.Joypad = 1) or (Params.Joypad) then - begin - Log.BenchmarkStart(1); - Log.LogStatus('Initialize Joystick', 'Initialization'); - Joy := TJoy.Create; - Log.BenchmarkEnd(1); - Log.LogBenchmark('Initializing Joystick', 1); - end; - - Log.BenchmarkEnd(0); - Log.LogBenchmark('Loading Time', 0); - - Log.LogStatus('Creating Core', 'Initialization'); -{ - Core := TCore.Create( - USDXShortVersionStr, - MakeVersion(USDX_VERSION_MAJOR, - USDX_VERSION_MINOR, - USDX_VERSION_RELEASE, - chr(0)) - ); -} - - Log.LogStatus('Running Core', 'Initialization'); - //Core.Run; - - //------------------------------ - // Start Mainloop - //------------------------------ - Log.LogStatus('Main Loop', 'Initialization'); - MainLoop; - - {$IFNDEF Debug} - finally - {$ENDIF} - //------------------------------ - // Finish Application - //------------------------------ - - // TODO: - // call an uninitialize routine for every initialize step - // or at least use the corresponding Free methods - - FinalizeMedia(); - - //TTF_Quit(); - SDL_Quit(); - - if assigned(Log) then - begin - Log.LogStatus('Main Loop', 'Finished'); - Log.Free; - end; - {$IFNDEF Debug} - end; - {$ENDIF} -end; - -procedure MainLoop; -var - Delay: integer; -const - MAX_FPS = 100; -begin - SDL_EnableKeyRepeat(125, 125); - - CountSkipTime(); // JB - for some reason this seems to be needed when we use the SDL Timer functions. - while not Done do - begin - // joypad - if (Ini.Joypad = 1) or (Params.Joypad) then - Joy.Update; - - // keyboard events - CheckEvents; - - // display - Done := not Display.Draw; - SwapBuffers; - - // delay - CountMidTime; - - Delay := Floor(1000 / MAX_FPS - 1000 * TimeMid); - - if Delay >= 1 then - SDL_Delay(Delay); // dynamic, maximum is 100 fps - - CountSkipTime; - - // reinitialization of graphics - if Restart then - begin - Reinitialize3D; - Restart := false; - end; - - end; -end; - -procedure DoQuit; -begin - // if question option is enabled then show exit popup - if (Ini.AskbeforeDel = 1) then - begin - Display.CurrentScreen^.CheckFadeTo(nil,'MSG_QUIT_USDX'); - end - else // if ask-for-exit is disabled then simply exit - begin - Display.Fade := 0; - Display.NextScreenWithCheck := nil; - Display.CheckOK := true; - end; -end; - -procedure CheckEvents; -var - Event: TSDL_event; - mouseDown: boolean; - mouseBtn: integer; -begin - while (SDL_PollEvent(@Event) <> 0) do - begin - case Event.type_ of - SDL_QUITEV: - begin - Display.Fade := 0; - Display.NextScreenWithCheck := nil; - Display.CheckOK := true; - end; - - SDL_MOUSEMOTION, SDL_MOUSEBUTTONDOWN, SDL_MOUSEBUTTONUP: - begin - if (Ini.Mouse > 0) then - begin - case Event.type_ of - SDL_MOUSEMOTION: - begin - mouseDown := false; - mouseBtn := 0; - end; - SDL_MOUSEBUTTONDOWN: - begin - mouseDown := true; - mouseBtn := Event.button.button; - - if (mouseBtn = SDL_BUTTON_LEFT) or (mouseBtn = SDL_BUTTON_RIGHT) then - Display.OnMouseButton(true); - end; - SDL_MOUSEBUTTONUP: - begin - mouseDown := false; - mouseBtn := Event.button.button; - - if (mouseBtn = SDL_BUTTON_LEFT) or (mouseBtn = SDL_BUTTON_RIGHT) then - Display.OnMouseButton(false); - end; - end; - - Display.MoveCursor(Event.button.X * 800 / Screen.w, - Event.button.Y * 600 / Screen.h); - - if not Assigned(Display.NextScreen) then - begin //drop input when changing screens - if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then - done := not ScreenPopupError.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) - else if (ScreenPopupInfo <> nil) and (ScreenPopupInfo.Visible) then - done := not ScreenPopupInfo.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) - else if (ScreenPopupCheck <> nil) and (ScreenPopupCheck.Visible) then - done := not ScreenPopupCheck.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y) - else - begin - done := not Display.CurrentScreen^.ParseMouse(mouseBtn, mouseDown, Event.button.x, Event.button.y); - - // if screen wants to exit - if done then - DoQuit; - end; - end; - end; - end; - SDL_VIDEORESIZE: - begin - ScreenW := Event.resize.w; - ScreenH := Event.resize.h; - // Note: do NOT call SDL_SetVideoMode on Windows and MacOSX here. - // This would create a new OpenGL render-context and all texture data - // would be invalidated. - // On Linux the mode MUST be reset, otherwise graphics will be corrupted. - {$IF Defined(Linux) or Defined(FreeBSD)} - if boolean( Ini.FullScreen ) then - SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_FULLSCREEN) - else - SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_RESIZABLE); - {$IFEND} - end; - SDL_KEYDOWN: - begin - // translate CTRL-A (ASCII 1) - CTRL-Z (ASCII 26) to correct charcodes. - // keysyms (SDLK_A, ...) could be used instead but they ignore the - // current key mapping (if 'a' is pressed on a French keyboard the - // .unicode field will be 'a' and .sym SDLK_Q). - // IMPORTANT: if CTRL is pressed with a key different than 'A'-'Z' SDL - // will set .unicode to 0. There is no possibility to obtain a - // translated charcode. Use keysyms instead. - //if (Event.key.keysym.unicode in [1 .. 26]) then - // Event.key.keysym.unicode := Ord('A') + Event.key.keysym.unicode - 1; - - // remap the "keypad enter" key to the "standard enter" key - if (Event.key.keysym.sym = SDLK_KP_ENTER) then - Event.key.keysym.sym := SDLK_RETURN; - - if not Assigned(Display.NextScreen) then - begin //drop input when changing screens - { to-do : F11 was used for fullscreen toggle, too here - but we also use the key in screenname and some other - screens. It is droped although fullscreen toggle doesn't - even work on windows. - should we add (Event.key.keysym.sym = SDLK_F11) here - anyway? } - if ((Event.key.keysym.sym = SDLK_RETURN) and - ((Event.key.keysym.modifier and KMOD_ALT) <> 0)) then // toggle full screen - begin - Ini.FullScreen := integer( not boolean( Ini.FullScreen ) ); - - // FIXME: SDL_SetVideoMode creates a new OpenGL RC so we have to - // reload all texture data (-> whitescreen bug). - // Only Linux and FreeBSD are able to handle screen-switching this way. - {$IF Defined(Linux) or Defined(FreeBSD)} - if boolean( Ini.FullScreen ) then - begin - SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_FULLSCREEN); - end - else - begin - SDL_SetVideoMode(ScreenW, ScreenH, (Ini.Depth+1) * 16, SDL_OPENGL or SDL_RESIZABLE); - end; - - Display.SetCursor; - - glViewPort(0, 0, ScreenW, ScreenH); - {$IFEND} - end - // if print is pressed -> make screenshot and save to screenshot path - else if (Event.key.keysym.sym = SDLK_SYSREQ) or (Event.key.keysym.sym = SDLK_PRINT) then - Display.SaveScreenShot - // if there is a visible popup then let it handle input instead of underlying screen - // shoud be done in a way to be sure the topmost popup has preference (maybe error, then check) - else if (ScreenPopupError <> nil) and (ScreenPopupError.Visible) then - Done := not ScreenPopupError.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true) - else if (ScreenPopupInfo <> nil) and (ScreenPopupInfo.Visible) then - Done := not ScreenPopupInfo.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true) - else if (ScreenPopupCheck <> nil) and (ScreenPopupCheck.Visible) then - Done := not ScreenPopupCheck.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true) - else - begin - // check if screen wants to exit - Done := not Display.ParseInput(Event.key.keysym.sym, Event.key.keysym.unicode, true); - - // if screen wants to exit - if Done then - DoQuit; - - end; - end; - end; - SDL_JOYAXISMOTION: - begin - // not implemented - end; - SDL_JOYBUTTONDOWN: - begin - // not implemented - end; - MAINTHREAD_EXEC_EVENT: - with Event.user do - begin - TMainThreadExecProc(data1)(data2); - end; - end; // case - end; // while -end; - -procedure MainThreadExec(Proc: TMainThreadExecProc; Data: Pointer); -var - Event: TSDL_Event; -begin - with Event.user do - begin - type_ := MAINTHREAD_EXEC_EVENT; - code := 0; // not used at the moment - data1 := @Proc; - data2 := Data; - end; - SDL_PushEvent(@Event); -end; - -end. diff --git a/src/base/UMusic.pas b/src/base/UMusic.pas deleted file mode 100644 index e1184da8..00000000 --- a/src/base/UMusic.pas +++ /dev/null @@ -1,1139 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMusic; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - UTime, - UBeatTimer, - UPath; - -type - TNoteType = (ntFreestyle, ntNormal, ntGolden); - -const - // ScoreFactor defines how a notehit of a specified notetype is - // measured in comparison to the other types - // 0 means this notetype is not rated at all - // 2 means a hit of this notetype will be rated w/ twice as much - // points as a hit of a notetype w/ ScoreFactor 1 - ScoreFactor: array[TNoteType] of integer = (0, 1, 2); - -type - (** - * TLineFragment represents a fragment of a lyrics line. - * This is a text-fragment (e.g. a syllable) assigned to a note pitch, - * represented by a bar in the sing-screen. - *) - PLineFragment = ^TLineFragment; - TLineFragment = record - Color: integer; - Start: integer; // beat the fragment starts at - Length: integer; // length in beats - Tone: integer; // full range tone - Text: UTF8String; // text assigned to this fragment (a syllable, word, etc.) - NoteType: TNoteType; // note-type: golden-note/freestyle etc. - end; - - (** - * TLine represents one lyrics line and consists of multiple - * notes. - *) - PLine = ^TLine; - TLine = record - Start: integer; // the start beat of this line (<> start beat of the first note of this line) - Lyric: UTF8String; - //LyricWidth: real; // @deprecated: width of the line in pixels. - // Do not use this as the width is not correct. - // Use TLyricsEngine.GetUpperLine().Width instead. - End_: integer; - BaseNote: integer; - HighNote: integer; // index of last note in line (= High(Note)?) - TotalNotes: integer; // value of all notes in the line - LastLine: boolean; - Note: array of TLineFragment; - end; - - (** - * TLines stores sets of lyric lines and information on them. - * Normally just one set is defined but in duet mode it might for example - * contain two sets. - *) - TLines = record - Current: integer; // for drawing of current line - High: integer; // = High(Line)! - Number: integer; - Resolution: integer; - NotesGAP: integer; - ScoreValue: integer; - Line: array of TLine; - end; - -const - FFTSize = 512; // size of FFT data (output: FFTSize/2 values) -type - TFFTData = array[0..(FFTSize div 2)-1] of Single; - -type - PPCMStereoSample = ^TPCMStereoSample; - TPCMStereoSample = array[0..1] of SmallInt; - TPCMData = array[0..511] of TPCMStereoSample; - -type - TStreamStatus = (ssStopped, ssPlaying, ssPaused); -const - StreamStatusStr: array[TStreamStatus] of string = - ('Stopped', 'Playing', 'Paused'); - -type - TAudioSampleFormat = ( - asfU8, asfS8, // unsigned/signed 8 bits - asfU16LSB, asfS16LSB, // unsigned/signed 16 bits (endianness: LSB) - asfU16MSB, asfS16MSB, // unsigned/signed 16 bits (endianness: MSB) - asfU16, asfS16, // unsigned/signed 16 bits (endianness: System) - asfS32, // signed 32 bits (endianness: System) - asfFloat, // float - asfDouble // double - ); - -const - // Size of one sample (one channel only) in bytes - AudioSampleSize: array[TAudioSampleFormat] of integer = ( - 1, 1, // asfU8, asfS8 - 2, 2, // asfU16LSB, asfS16LSB - 2, 2, // asfU16MSB, asfS16MSB - 2, 2, // asfU16, asfS16 - 3, // asfS24 - 4, // asfS32 - 4 // asfFloat - ); - -const - CHANNELMAP_LEFT = 1; - CHANNELMAP_RIGHT = 2; - CHANNELMAP_FRONT = CHANNELMAP_LEFT or CHANNELMAP_RIGHT; - -type - TAudioFormatInfo = class - private - fSampleRate : double; - fChannels : byte; - fFormat : TAudioSampleFormat; - fFrameSize : integer; - - procedure SetChannels(Channels: byte); - procedure SetFormat(Format: TAudioSampleFormat); - procedure UpdateFrameSize(); - function GetBytesPerSec(): double; - public - constructor Create(Channels: byte; SampleRate: double; Format: TAudioSampleFormat); - function Copy(): TAudioFormatInfo; - - (** - * Returns the inverse ratio of the size of data in this format to its - * size in a given target format. - * Example: SrcSize*SrcInfo.GetRatio(TgtInfo) = TgtSize - *) - function GetRatio(TargetInfo: TAudioFormatInfo): double; - - property SampleRate: double read fSampleRate write fSampleRate; - property Channels: byte read fChannels write SetChannels; - property Format: TAudioSampleFormat read fFormat write SetFormat; - property FrameSize: integer read fFrameSize; - property BytesPerSec: double read GetBytesPerSec; - end; - -type - TSoundEffect = class - public - EngineData: Pointer; // can be used for engine-specific data - procedure Callback(Buffer: PByteArray; BufSize: integer); virtual; abstract; - end; - - TVoiceRemoval = class(TSoundEffect) - public - procedure Callback(Buffer: PByteArray; BufSize: integer); override; - end; - -type - ISyncSource = interface - function GetClock(): real; - end; - - TAudioProcessingStream = class; - TOnCloseHandler = procedure(Stream: TAudioProcessingStream); - - TAudioProcessingStream = class - protected - OnCloseHandlers: array of TOnCloseHandler; - - function GetLength(): real; virtual; abstract; - function GetPosition(): real; virtual; abstract; - procedure SetPosition(Time: real); virtual; abstract; - function GetLoop(): boolean; virtual; abstract; - procedure SetLoop(Enabled: boolean); virtual; abstract; - - procedure PerformOnClose(); - public - function GetAudioFormatInfo(): TAudioFormatInfo; virtual; abstract; - procedure Close(); virtual; abstract; - - (** - * Adds a new OnClose action handler. - * The handlers are performed in the order they were added. - * If not stated explicitely, member-variables might have been invalidated - * already. So do not use any member (variable/method/...) if you are not - * sure it is valid. - *) - procedure AddOnCloseHandler(Handler: TOnCloseHandler); - - property Length: real read GetLength; - property Position: real read GetPosition write SetPosition; - property Loop: boolean read GetLoop write SetLoop; - end; - - TAudioSourceStream = class(TAudioProcessingStream) - protected - function IsEOF(): boolean; virtual; abstract; - function IsError(): boolean; virtual; abstract; - public - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; virtual; abstract; - - property EOF: boolean read IsEOF; - property Error: boolean read IsError; - end; - - (* - * State-Chart for playback-stream state transitions - * []: Transition, (): State - * - * /---[Play/FadeIn]--->-\ /-------[Pause]----->-\ - * -[Create]->(Stop) (Play) (Pause) - * \\-<-[Stop/EOF*/Error]-/ \-<---[Play/FadeIn]--// - * \-<------------[Stop/EOF*/Error]--------------/ - * - * *: if not looped, otherwise stream is repeated - * Note: SetPosition() does not change the state. - *) - - TAudioPlaybackStream = class(TAudioProcessingStream) - protected - SyncSource: ISyncSource; - AvgSyncDiff: double; - SourceStream: TAudioSourceStream; - - function GetLatency(): double; virtual; abstract; - function GetStatus(): TStreamStatus; virtual; abstract; - function GetVolume(): single; virtual; abstract; - procedure SetVolume(Volume: single); virtual; abstract; - function Synchronize(BufferSize: integer; FormatInfo: TAudioFormatInfo): integer; - procedure FillBufferWithFrame(Buffer: PByteArray; BufferSize: integer; Frame: PByteArray; FrameSize: integer); - public - (** - * Opens a SourceStream for playback. - * Note that the caller (not the TAudioPlaybackStream) is responsible to - * free the SourceStream after the Playback-Stream is closed. - * You may use an OnClose-handler to achieve this. GetSourceStream() - * guarantees to deliver this method's SourceStream parameter to - * the OnClose-handler. Freeing SourceStream at OnClose is allowed. - *) - function Open(SourceStream: TAudioSourceStream): boolean; virtual; abstract; - - procedure Play(); virtual; abstract; - procedure Pause(); virtual; abstract; - procedure Stop(); virtual; abstract; - procedure FadeIn(Time: real; TargetVolume: single); virtual; abstract; - - procedure GetFFTData(var data: TFFTData); virtual; abstract; - function GetPCMData(var data: TPCMData): Cardinal; virtual; abstract; - - procedure AddSoundEffect(Effect: TSoundEffect); virtual; abstract; - procedure RemoveSoundEffect(Effect: TSoundEffect); virtual; abstract; - - procedure SetSyncSource(SyncSource: ISyncSource); - function GetSourceStream(): TAudioSourceStream; - - property Status: TStreamStatus read GetStatus; - property Volume: single read GetVolume write SetVolume; - end; - - TAudioDecodeStream = class(TAudioSourceStream) - end; - - TAudioVoiceStream = class(TAudioSourceStream) - protected - FormatInfo: TAudioFormatInfo; - ChannelMap: integer; - public - destructor Destroy; override; - - function Open(ChannelMap: integer; FormatInfo: TAudioFormatInfo): boolean; virtual; - procedure Close(); override; - - procedure WriteData(Buffer: PByteArray; BufferSize: integer); virtual; abstract; - function GetAudioFormatInfo(): TAudioFormatInfo; override; - - function GetLength(): real; override; - function GetPosition(): real; override; - procedure SetPosition(Time: real); override; - function GetLoop(): boolean; override; - procedure SetLoop(Enabled: boolean); override; - end; - -type - // soundcard output-devices information - TAudioOutputDevice = class - public - Name: UTF8String; // soundcard name - end; - TAudioOutputDeviceList = array of TAudioOutputDevice; - -type - IGenericPlayback = Interface - ['{63A5EBC3-3F4D-4F23-8DFB-B5165FCE33DD}'] - function GetName: String; - - function Open(const Filename: IPath): boolean; // true if succeed - procedure Close; - - procedure Play; - procedure Pause; - procedure Stop; - - procedure SetPosition(Time: real); - function GetPosition: real; - - property Position: real read GetPosition write SetPosition; - end; - - IVideoPlayback = Interface( IGenericPlayback ) - ['{3574C40C-28AE-4201-B3D1-3D1F0759B131}'] - function Init(): boolean; - function Finalize: boolean; - - procedure GetFrame(Time: Extended); // WANT TO RENAME THESE TO BE MORE GENERIC - procedure DrawGL(Screen: integer); // WANT TO RENAME THESE TO BE MORE GENERIC - - end; - - IVideoVisualization = Interface( IVideoPlayback ) - ['{5AC17D60-B34D-478D-B632-EB00D4078017}'] - end; - - IAudioPlayback = Interface( IGenericPlayback ) - ['{E4AE0B40-3C21-4DC5-847C-20A87E0DFB96}'] - function InitializePlayback: boolean; - function FinalizePlayback: boolean; - - function GetOutputDeviceList(): TAudioOutputDeviceList; - - procedure SetAppVolume(Volume: single); - procedure SetVolume(Volume: single); - procedure SetLoop(Enabled: boolean); - - procedure FadeIn(Time: real; TargetVolume: single); - procedure SetSyncSource(SyncSource: ISyncSource); - - procedure Rewind; - function Finished: boolean; - function Length: real; - - // Sounds - // TODO: - // add a TMediaDummyPlaybackStream implementation that will - // be used by the TSoundLib whenever OpenSound() fails, so checking for - // nil-pointers is not neccessary anymore. - // PlaySound/StopSound will be removed then, OpenSound will be renamed to - // CreateSound. - function OpenSound(const Filename: IPath): TAudioPlaybackStream; - procedure PlaySound(Stream: TAudioPlaybackStream); - procedure StopSound(Stream: TAudioPlaybackStream); - - // Equalizer - procedure GetFFTData(var Data: TFFTData); - - // Interface for Visualizer - function GetPCMData(var Data: TPCMData): Cardinal; - - function CreateVoiceStream(ChannelMap: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; - end; - - IGenericDecoder = Interface - ['{557B0E9A-604D-47E4-B826-13769F3E10B7}'] - function GetName(): string; - function InitializeDecoder(): boolean; - function FinalizeDecoder(): boolean; - //function IsSupported(const Filename: string): boolean; - end; - - (* - IVideoDecoder = Interface( IGenericDecoder ) - ['{2F184B2B-FE69-44D5-9031-0A2462391DCA}'] - function Open(const Filename: IPath): TVideoDecodeStream; - end; - *) - - IAudioDecoder = Interface( IGenericDecoder ) - ['{AB47B1B6-2AA9-4410-BF8C-EC79561B5478}'] - function Open(const Filename: IPath): TAudioDecodeStream; - end; - - IAudioInput = Interface - ['{A5C8DA92-2A0C-4AB2-849B-2F7448C6003A}'] - function GetName: String; - function InitializeRecord: boolean; - function FinalizeRecord(): boolean; - - procedure CaptureStart; - procedure CaptureStop; - end; - -type - TAudioConverter = class - protected - fSrcFormatInfo: TAudioFormatInfo; - fDstFormatInfo: TAudioFormatInfo; - public - function Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; virtual; - destructor Destroy(); override; - - (** - * Converts the InputBuffer and stores the result in OutputBuffer. - * If the result is not -1, InputSize will be set to the actual number of - * input-buffer bytes used. - * Returns the number of bytes written to the output-buffer or -1 if an error occured. - *) - function Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; virtual; abstract; - - (** - * Destination/Source size ratio - *) - function GetRatio(): double; virtual; abstract; - - function GetOutputBufferSize(InputSize: integer): integer; virtual; abstract; - property SrcFormatInfo: TAudioFormatInfo read fSrcFormatInfo; - property DstFormatInfo: TAudioFormatInfo read fDstFormatInfo; - end; - -(* TODO -const - SOUNDID_START = 0; - SOUNDID_BACK = 1; - SOUNDID_SWOOSH = 2; - SOUNDID_CHANGE = 3; - SOUNDID_OPTION = 4; - SOUNDID_CLICK = 5; - LAST_SOUNDID = SOUNDID_CLICK; - - BaseSoundFilenames: array[0..LAST_SOUNDID] of IPath = ( - '%SOUNDPATH%/Common start.mp3', // Start - '%SOUNDPATH%/Common back.mp3', // Back - '%SOUNDPATH%/menu swoosh.mp3', // Swoosh - '%SOUNDPATH%/select music change music 50.mp3', // Change - '%SOUNDPATH%/option change col.mp3', // Option - '%SOUNDPATH%/rimshot022b.mp3' // Click - { - '%SOUNDPATH%/bassdrumhard076b.mp3', // Drum (unused) - '%SOUNDPATH%/hihatclosed068b.mp3', // Hihat (unused) - '%SOUNDPATH%/claps050b.mp3', // Clap (unused) - '%SOUNDPATH%/Shuffle.mp3' // Shuffle (unused) - } - ); -*) - -type - TSoundLibrary = class - private - // TODO - //Sounds: array of TAudioPlaybackStream; - public - // TODO: move sounds to the private section - // and provide IDs instead. - Start: TAudioPlaybackStream; - Back: TAudioPlaybackStream; - Swoosh: TAudioPlaybackStream; - Change: TAudioPlaybackStream; - Option: TAudioPlaybackStream; - Click: TAudioPlaybackStream; - BGMusic: TAudioPlaybackStream; - - constructor Create(); - destructor Destroy(); override; - - procedure LoadSounds(); - procedure UnloadSounds(); - - procedure StartBgMusic(); - procedure PauseBgMusic(); - // TODO - //function AddSound(Filename: IPath): integer; - //procedure RemoveSound(ID: integer); - //function GetSound(ID: integer): TAudioPlaybackStream; - //property Sound[ID: integer]: TAudioPlaybackStream read GetSound; default; - end; - -var - // TODO: JB --- THESE SHOULD NOT BE GLOBAL - Lines: array of TLines; - LyricsState: TLyricsState; - SoundLib: TSoundLibrary; - - -procedure InitializeSound; -procedure InitializeVideo; -procedure FinalizeMedia; - -function Visualization(): IVideoPlayback; -function VideoPlayback(): IVideoPlayback; -function AudioPlayback(): IAudioPlayback; -function AudioInput(): IAudioInput; -function AudioDecoders(): TInterfaceList; - -function MediaManager: TInterfaceList; - -procedure DumpMediaInterfaces(); - -implementation - -uses - math, - UIni, - UNote, - UCommandLine, - URecord, - ULog, - UPathUtils; - -var - DefaultVideoPlayback : IVideoPlayback; - DefaultVisualization : IVideoPlayback; - DefaultAudioPlayback : IAudioPlayback; - DefaultAudioInput : IAudioInput; - AudioDecoderList : TInterfaceList; - MediaInterfaceList : TInterfaceList; - - -constructor TAudioFormatInfo.Create(Channels: byte; SampleRate: double; Format: TAudioSampleFormat); -begin - inherited Create(); - fChannels := Channels; - fSampleRate := SampleRate; - fFormat := Format; - UpdateFrameSize(); -end; - -procedure TAudioFormatInfo.SetChannels(Channels: byte); -begin - fChannels := Channels; - UpdateFrameSize(); -end; - -procedure TAudioFormatInfo.SetFormat(Format: TAudioSampleFormat); -begin - fFormat := Format; - UpdateFrameSize(); -end; - -function TAudioFormatInfo.GetBytesPerSec(): double; -begin - Result := FrameSize * SampleRate; -end; - -procedure TAudioFormatInfo.UpdateFrameSize(); -begin - fFrameSize := AudioSampleSize[fFormat] * fChannels; -end; - -function TAudioFormatInfo.Copy(): TAudioFormatInfo; -begin - Result := TAudioFormatInfo.Create(Self.Channels, Self.SampleRate, Self.Format); -end; - -function TAudioFormatInfo.GetRatio(TargetInfo: TAudioFormatInfo): double; -begin - Result := (TargetInfo.FrameSize / Self.FrameSize) * - (TargetInfo.SampleRate / Self.SampleRate) -end; - - -function MediaManager: TInterfaceList; -begin - if (not assigned(MediaInterfaceList)) then - MediaInterfaceList := TInterfaceList.Create(); - Result := MediaInterfaceList; -end; - -function VideoPlayback(): IVideoPlayback; -begin - Result := DefaultVideoPlayback; -end; - -function Visualization(): IVideoPlayback; -begin - Result := DefaultVisualization; -end; - -function AudioPlayback(): IAudioPlayback; -begin - Result := DefaultAudioPlayback; -end; - -function AudioInput(): IAudioInput; -begin - Result := DefaultAudioInput; -end; - -function AudioDecoders(): TInterfaceList; -begin - Result := AudioDecoderList; -end; - -procedure FilterInterfaceList(const IID: TGUID; InList, OutList: TInterfaceList); -var - i: integer; - obj: IInterface; -begin - if (not assigned(OutList)) then - Exit; - - OutList.Clear; - for i := 0 to InList.Count-1 do - begin - if assigned(InList[i]) then - begin - // add object to list if it implements the interface searched for - if (InList[i].QueryInterface(IID, obj) = 0) then - OutList.Add(obj); - end; - end; -end; - -procedure InitializeSound; -var - i: integer; - InterfaceList: TInterfaceList; - CurrentAudioDecoder: IAudioDecoder; - CurrentAudioPlayback: IAudioPlayback; - CurrentAudioInput: IAudioInput; -begin - // create a temporary list for interface enumeration - InterfaceList := TInterfaceList.Create(); - - // initialize all audio-decoders first - FilterInterfaceList(IAudioDecoder, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - begin - CurrentAudioDecoder := InterfaceList[i] as IAudioDecoder; - if (not CurrentAudioDecoder.InitializeDecoder()) then - begin - Log.LogError('Initialize failed, Removing - '+ CurrentAudioDecoder.GetName); - MediaManager.Remove(CurrentAudioDecoder); - end; - end; - - // create and setup decoder-list (see AudioDecoders()) - AudioDecoderList := TInterfaceList.Create; - FilterInterfaceList(IAudioDecoder, MediaManager, AudioDecoders); - - // find and initialize playback interface - DefaultAudioPlayback := nil; - FilterInterfaceList(IAudioPlayback, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - begin - CurrentAudioPlayback := InterfaceList[i] as IAudioPlayback; - if (CurrentAudioPlayback.InitializePlayback()) then - begin - DefaultAudioPlayback := CurrentAudioPlayback; - break; - end; - Log.LogError('Initialize failed, Removing - '+ CurrentAudioPlayback.GetName); - MediaManager.Remove(CurrentAudioPlayback); - end; - - // find and initialize input interface - DefaultAudioInput := nil; - FilterInterfaceList(IAudioInput, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - begin - CurrentAudioInput := InterfaceList[i] as IAudioInput; - if (CurrentAudioInput.InitializeRecord()) then - begin - DefaultAudioInput := CurrentAudioInput; - break; - end; - Log.LogError('Initialize failed, Removing - '+ CurrentAudioInput.GetName); - MediaManager.Remove(CurrentAudioInput); - end; - - InterfaceList.Free; - - // Update input-device list with registered devices - AudioInputProcessor.UpdateInputDeviceConfig(); - - // Load in-game sounds - SoundLib := TSoundLibrary.Create; -end; - -procedure InitializeVideo(); -var - i: integer; - InterfaceList: TInterfaceList; - VideoInterface: IVideoPlayback; - VisualInterface: IVideoVisualization; -begin - InterfaceList := TInterfaceList.Create; - - // initialize and set video-playback singleton - DefaultVideoPlayback := nil; - FilterInterfaceList(IVideoPlayback, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - begin - VideoInterface := InterfaceList[i] as IVideoPlayback; - if (VideoInterface.Init()) then - begin - DefaultVideoPlayback := VideoInterface; - break; - end; - Log.LogError('Initialize failed, Removing - '+ VideoInterface.GetName); - MediaManager.Remove(VideoInterface); - end; - - // initialize and set visualization singleton - DefaultVisualization := nil; - FilterInterfaceList(IVideoVisualization, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - begin - VisualInterface := InterfaceList[i] as IVideoVisualization; - if (VisualInterface.Init()) then - begin - DefaultVisualization := VisualInterface; - break; - end; - Log.LogError('Initialize failed, Removing - '+ VisualInterface.GetName); - MediaManager.Remove(VisualInterface); - end; - - InterfaceList.Free; - - // now that we have all interfaces, we can dump them - // TODO: move this to another place - if FindCmdLineSwitch(cMediaInterfaces) then - begin - DumpMediaInterfaces(); - halt; - end; -end; - -procedure UnloadMediaModules; -var - i: integer; - InterfaceList: TInterfaceList; -begin - FreeAndNil(AudioDecoderList); - DefaultAudioPlayback := nil; - DefaultAudioInput := nil; - DefaultVideoPlayback := nil; - DefaultVisualization := nil; - - // create temporary interface list - InterfaceList := TInterfaceList.Create(); - - // finalize audio playback interfaces (should be done before the decoders) - FilterInterfaceList(IAudioPlayback, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - (InterfaceList[i] as IAudioPlayback).FinalizePlayback(); - - // finalize audio input interfaces - FilterInterfaceList(IAudioInput, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - (InterfaceList[i] as IAudioInput).FinalizeRecord(); - - // finalize audio decoder interfaces - FilterInterfaceList(IAudioDecoder, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - (InterfaceList[i] as IAudioDecoder).FinalizeDecoder(); - - // finalize video interfaces - FilterInterfaceList(IVideoPlayback, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - (InterfaceList[i] as IVideoPlayback).Finalize(); - - // finalize audio decoder interfaces - FilterInterfaceList(IVideoVisualization, MediaManager, InterfaceList); - for i := 0 to InterfaceList.Count-1 do - (InterfaceList[i] as IVideoVisualization).Finalize(); - - InterfaceList.Free; - - // finally free interfaces (by removing all references to them) - FreeAndNil(MediaInterfaceList); -end; - -procedure FinalizeMedia; -begin - // stop, close and free sounds - SoundLib.Free; - - // stop and close music stream - if (AudioPlayback <> nil) then - AudioPlayback.Close; - - // stop any active captures - if (AudioInput <> nil) then - AudioInput.CaptureStop; - - if (VideoPlayback <> nil) then - VideoPlayback.Close; - - if (Visualization <> nil) then - Visualization.Close; - - UnloadMediaModules(); -end; - -procedure DumpMediaInterfaces(); -begin - writeln( '' ); - writeln( '--------------------------------------------------------------' ); - writeln( ' In-use Media Interfaces ' ); - writeln( '--------------------------------------------------------------' ); - writeln( 'Registered Audio Playback Interface : ' + AudioPlayback.GetName ); - writeln( 'Registered Audio Input Interface : ' + AudioInput.GetName ); - writeln( 'Registered Video Playback Interface : ' + VideoPlayback.GetName ); - writeln( 'Registered Visualization Interface : ' + Visualization.GetName ); - writeln( '--------------------------------------------------------------' ); - writeln( '' ); -end; - - -{ TSoundLibrary } - -constructor TSoundLibrary.Create(); -begin - inherited; - LoadSounds(); -end; - -destructor TSoundLibrary.Destroy(); -begin - UnloadSounds(); - inherited; -end; - -procedure TSoundLibrary.LoadSounds(); -begin - UnloadSounds(); - - Start := AudioPlayback.OpenSound(SoundPath.Append('Common start.mp3')); - Back := AudioPlayback.OpenSound(SoundPath.Append('Common back.mp3')); - Swoosh := AudioPlayback.OpenSound(SoundPath.Append('menu swoosh.mp3')); - Change := AudioPlayback.OpenSound(SoundPath.Append('select music change music 50.mp3')); - Option := AudioPlayback.OpenSound(SoundPath.Append('option change col.mp3')); - Click := AudioPlayback.OpenSound(SoundPath.Append('rimshot022b.mp3')); - - BGMusic := AudioPlayback.OpenSound(SoundPath.Append('Bebeto_-_Loop010.mp3')); - - if (BGMusic <> nil) then - BGMusic.Loop := True; -end; - -procedure TSoundLibrary.UnloadSounds(); -begin - FreeAndNil(Start); - FreeAndNil(Back); - FreeAndNil(Swoosh); - FreeAndNil(Change); - FreeAndNil(Option); - FreeAndNil(Click); - FreeAndNil(BGMusic); -end; - -(* TODO -function TSoundLibrary.GetSound(ID: integer): TAudioPlaybackStream; -begin - if ((ID >= 0) and (ID < Length(Sounds))) then - Result := Sounds[ID] - else - Result := nil; -end; -*) - -procedure TSoundLibrary.StartBgMusic(); -begin - if (TBackgroundMusicOption(Ini.BackgroundMusicOption) = bmoOn) and - (Soundlib.BGMusic <> nil) and not (Soundlib.BGMusic.Status = ssPlaying) then - begin - AudioPlayback.PlaySound(Soundlib.BGMusic); - end; -end; - -procedure TSoundLibrary.PauseBgMusic(); -begin - If (Soundlib.BGMusic <> nil) then - begin - Soundlib.BGMusic.Pause; - end; -end; - -{ TVoiceRemoval } - -procedure TVoiceRemoval.Callback(Buffer: PByteArray; BufSize: integer); -var - FrameIndex, FrameSize: integer; - Value: integer; - Sample: PPCMStereoSample; -begin - FrameSize := 2 * SizeOf(SmallInt); - for FrameIndex := 0 to (BufSize div FrameSize)-1 do - begin - Sample := PPCMStereoSample(Buffer); - // channel difference - Value := Sample[0] - Sample[1]; - // clip - if (Value > High(SmallInt)) then - Value := High(SmallInt) - else if (Value < Low(SmallInt)) then - Value := Low(SmallInt); - // assign result - Sample[0] := Value; - Sample[1] := Value; - // increase to next frame - Inc(Buffer, FrameSize); - end; -end; - -{ TAudioConverter } - -function TAudioConverter.Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; -begin - fSrcFormatInfo := SrcFormatInfo.Copy(); - fDstFormatInfo := DstFormatInfo.Copy(); - Result := true; -end; - -destructor TAudioConverter.Destroy(); -begin - FreeAndNil(fSrcFormatInfo); - FreeAndNil(fDstFormatInfo); -end; - - -{ TAudioProcessingStream } - -procedure TAudioProcessingStream.AddOnCloseHandler(Handler: TOnCloseHandler); -begin - if (@Handler <> nil) then - begin - SetLength(OnCloseHandlers, System.Length(OnCloseHandlers)+1); - OnCloseHandlers[High(OnCloseHandlers)] := @Handler; - end; -end; - -procedure TAudioProcessingStream.PerformOnClose(); -var i: integer; -begin - for i := 0 to High(OnCloseHandlers) do - begin - OnCloseHandlers[i](Self); - end; -end; - - -{ TAudioPlaybackStream } - -function TAudioPlaybackStream.GetSourceStream(): TAudioSourceStream; -begin - Result := SourceStream; -end; - -procedure TAudioPlaybackStream.SetSyncSource(SyncSource: ISyncSource); -begin - Self.SyncSource := SyncSource; - AvgSyncDiff := -1; -end; - -(* - * Results an adjusted size of the input buffer size to keep the stream in sync - * with the SyncSource. If no SyncSource was assigned to this stream, the - * input buffer size will be returned, so this method will have no effect. - * - * These are the possible cases: - * - Result > BufferSize: stream is behind the sync-source (stream is too slow), - * (Result-BufferSize) bytes of the buffer must be skipped. - * - Result = BufferSize: stream is in sync, - * there is nothing to do. - * - Result < BufferSize: stream is ahead of the sync-source (stream is too fast), - * (BufferSize-Result) bytes of the buffer must be padded. - *) -function TAudioPlaybackStream.Synchronize(BufferSize: integer; FormatInfo: TAudioFormatInfo): integer; -var - TimeDiff: double; - TimeCorrectionFactor: double; -const - AVG_HISTORY_FACTOR = 0.9; - SYNC_THRESHOLD = 0.045; - MAX_SYNC_DIFF_TIME = 0.002; -begin - Result := BufferSize; - - if (not assigned(SyncSource)) then - Exit; - - if (BufferSize <= 0) then - Exit; - - // difference between sync-source and stream position - // (negative if the music-stream's position is ahead of the master clock) - TimeDiff := SyncSource.GetClock() - (Position - GetLatency()); - - // calculate average time difference (some sort of weighted mean). - // The bigger AVG_HISTORY_FACTOR is, the smoother is the average diff. - // This means that older diffs are weighted more with a higher history factor - // than with a lower. Do not use a too low history factor. FFmpeg produces - // very instable timestamps (pts) for ogg due to some bugs. They may differ - // +-50ms from the real stream position. Without filtering those glitches we - // would synch without any need, resulting in ugly plopping sounds. - if (AvgSyncDiff = -1) then - AvgSyncDiff := TimeDiff - else - AvgSyncDiff := TimeDiff * (1-AVG_HISTORY_FACTOR) + - AvgSyncDiff * AVG_HISTORY_FACTOR; - - // check if sync needed - if (Abs(AvgSyncDiff) >= SYNC_THRESHOLD) then - begin - // TODO: use SetPosition if diff is too large (>5s) - if (TimeDiff < 1) then - TimeCorrectionFactor := Sign(TimeDiff)*TimeDiff*TimeDiff - else - TimeCorrectionFactor := TimeDiff; - - // calculate adapted buffer size - // reduce size of data to fetch if music is ahead, increase otherwise - Result := BufferSize + Round(TimeCorrectionFactor * FormatInfo.SampleRate) * FormatInfo.FrameSize; - if (Result < 0) then - Result := 0; - - // reset average - AvgSyncDiff := -1; - end; - - (* - DebugWriteln('Diff: ' + floattostrf(TimeDiff, ffFixed, 15, 3) + - '| SyS: ' + floattostrf(SyncSource.GetClock(), ffFixed, 15, 3) + - '| Pos: ' + floattostrf(Position, ffFixed, 15, 3) + - '| Avg: ' + floattostrf(AvgSyncDiff, ffFixed, 15, 3)); - *) -end; - -(* - * Fills a buffer with copies of the given frame or with 0 if frame. - *) -procedure TAudioPlaybackStream.FillBufferWithFrame(Buffer: PByteArray; BufferSize: integer; Frame: PByteArray; FrameSize: integer); -var - i: integer; - FrameCopyCount: integer; -begin - // the buffer must at least contain place for one copy of the frame. - if ((Buffer = nil) or (BufferSize <= 0) or (BufferSize < FrameSize)) then - Exit; - - // no valid frame -> fill with 0 - if ((Frame = nil) or (FrameSize <= 0)) then - begin - FillChar(Buffer[0], BufferSize, 0); - Exit; - end; - - // number of frames to copy - FrameCopyCount := BufferSize div FrameSize; - // insert as many copies of frame into the buffer as possible - for i := 0 to FrameCopyCount-1 do - Move(Frame[0], Buffer[i*FrameSize], FrameSize); -end; - -{ TAudioVoiceStream } - -function TAudioVoiceStream.Open(ChannelMap: integer; FormatInfo: TAudioFormatInfo): boolean; -begin - Self.ChannelMap := ChannelMap; - Self.FormatInfo := FormatInfo.Copy(); - // a voice stream is always mono, reassure the the format is correct - Self.FormatInfo.Channels := 1; - Result := true; -end; - -destructor TAudioVoiceStream.Destroy; -begin - Close(); - inherited; -end; - -procedure TAudioVoiceStream.Close(); -begin - PerformOnClose(); - FreeAndNil(FormatInfo); -end; - -function TAudioVoiceStream.GetAudioFormatInfo(): TAudioFormatInfo; -begin - Result := FormatInfo; -end; - -function TAudioVoiceStream.GetLength(): real; -begin - Result := -1; -end; - -function TAudioVoiceStream.GetPosition(): real; -begin - Result := -1; -end; - -procedure TAudioVoiceStream.SetPosition(Time: real); -begin -end; - -function TAudioVoiceStream.GetLoop(): boolean; -begin - Result := false; -end; - -procedure TAudioVoiceStream.SetLoop(Enabled: boolean); -begin -end; - - -end. diff --git a/src/base/UNote.pas b/src/base/UNote.pas deleted file mode 100644 index 8e5b709a..00000000 --- a/src/base/UNote.pas +++ /dev/null @@ -1,591 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UNote; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - SDL, - UMusic, - URecord, - UTime, - UDisplay, - UIni, - ULog, - ULyrics, - UScreenSing, - USong, - gl; - -type - PPLayerNote = ^TPlayerNote; - TPlayerNote = record - Start: integer; - Length: integer; - Detect: real; // accurate place, detected in the note - Tone: real; - Perfect: boolean; // true if the note matches the original one, light the star - Hit: boolean; // true if the note hits the line - end; - - PPLayer = ^TPlayer; - TPlayer = record - Name: UTF8String; - - // Index in Teaminfo record - TeamID: byte; - PlayerID: byte; - - // Scores - Score: real; - ScoreLine: real; - ScoreGolden: real; - - ScoreInt: integer; - ScoreLineInt: integer; - ScoreGoldenInt: integer; - ScoreTotalInt: integer; - - // LineBonus - ScoreLast: real; // Last Line Score - - // PerfectLineTwinkle (effect) - LastSentencePerfect: boolean; - - HighNote: integer; // index of last note (= High(Note)?) - LengthNote: integer; // number of notes (= Length(Note)?). - Note: array of TPlayerNote; - end; - -var - - // player and music info - Player: array of TPlayer; - PlayersPlay: integer; - - CurrentSong: TSong; - -const - MAX_SONG_SCORE = 10000; // max. achievable points per song - MAX_SONG_LINE_BONUS = 1000; // max. achievable line bonus per song - -procedure Sing(Screen: TScreenSing); -procedure NewSentence(Screen: TScreenSing); -procedure NewBeatClick(Screen: TScreenSing); // executed when on then new beat for click -procedure NewBeatDetect(Screen: TScreenSing); // executed when on then new beat for detection -procedure NewNote(Screen: TScreenSing); // detect note -function GetMidBeat(Time: real): real; -function GetTimeFromBeat(Beat: integer): real; - -implementation - -uses - Math, - StrUtils, - USongs, - UJoystick, - UCommandLine, - ULanguage, - //SDL_ttf, - USkins, - UCovers, - UCatCovers, - UDataBase, - UPlaylist, - UDLLManager, - UParty, - UConfig, - UCommon, - UGraphic, - UGraphicClasses, - UPathUtils, - UPlatform, - UThemes; - -function GetTimeForBeats(BPM, Beats: real): real; -begin - Result := 60 / BPM * Beats; -end; - -function GetBeats(BPM, msTime: real): real; -begin - Result := BPM * msTime / 60; -end; - -procedure GetMidBeatSub(BPMNum: integer; var Time: real; var CurBeat: real); -var - NewTime: real; -begin - if High(CurrentSong.BPM) = BPMNum then - begin - // last BPM - CurBeat := CurrentSong.BPM[BPMNum].StartBeat + GetBeats(CurrentSong.BPM[BPMNum].BPM, Time); - Time := 0; - end - else - begin - // not last BPM - // count how much time is it for start of the new BPM and store it in NewTime - NewTime := GetTimeForBeats(CurrentSong.BPM[BPMNum].BPM, CurrentSong.BPM[BPMNum+1].StartBeat - CurrentSong.BPM[BPMNum].StartBeat); - - // compare it to remaining time - if (Time - NewTime) > 0 then - begin - // there is still remaining time - CurBeat := CurrentSong.BPM[BPMNum].StartBeat; - Time := Time - NewTime; - end - else - begin - // there is no remaining time - CurBeat := CurrentSong.BPM[BPMNum].StartBeat + GetBeats(CurrentSong.BPM[BPMNum].BPM, Time); - Time := 0; - end; // if - end; // if -end; - -function GetMidBeat(Time: real): real; -var - CurBeat: real; - CurBPM: integer; -begin - // static BPM - if Length(CurrentSong.BPM) = 1 then - begin - Result := Time * CurrentSong.BPM[0].BPM / 60; - end - // variable BPM - else if Length(CurrentSong.BPM) > 1 then - begin - CurBeat := 0; - CurBPM := 0; - while (Time > 0) do - begin - GetMidBeatSub(CurBPM, Time, CurBeat); - Inc(CurBPM); - end; - - Result := CurBeat; - end - // invalid BPM - else - begin - Result := 0; - end; -end; - -function GetTimeFromBeat(Beat: integer): real; -var - CurBPM: integer; -begin - // static BPM - if Length(CurrentSong.BPM) = 1 then - begin - Result := CurrentSong.GAP / 1000 + Beat * 60 / CurrentSong.BPM[0].BPM; - end - // variable BPM - else if Length(CurrentSong.BPM) > 1 then - begin - Result := CurrentSong.GAP / 1000; - CurBPM := 0; - while (CurBPM <= High(CurrentSong.BPM)) and - (Beat > CurrentSong.BPM[CurBPM].StartBeat) do - begin - if (CurBPM < High(CurrentSong.BPM)) and - (Beat >= CurrentSong.BPM[CurBPM+1].StartBeat) then - begin - // full range - Result := Result + (60 / CurrentSong.BPM[CurBPM].BPM) * - (CurrentSong.BPM[CurBPM+1].StartBeat - CurrentSong.BPM[CurBPM].StartBeat); - end; - - if (CurBPM = High(CurrentSong.BPM)) or - (Beat < CurrentSong.BPM[CurBPM+1].StartBeat) then - begin - // in the middle - Result := Result + (60 / CurrentSong.BPM[CurBPM].BPM) * - (Beat - CurrentSong.BPM[CurBPM].StartBeat); - end; - Inc(CurBPM); - end; - - { - while (Time > 0) do - begin - GetMidBeatSub(CurBPM, Time, CurBeat); - Inc(CurBPM); - end; - } - end - // invalid BPM - else - begin - Result := 0; - end; -end; - -procedure Sing(Screen: TScreenSing); -var - Count: integer; - CountGr: integer; - CP: integer; -begin - LyricsState.UpdateBeats(); - - // sentences routines - for CountGr := 0 to 0 do //High(Lines) - begin; - CP := CountGr; - // old parts - LyricsState.OldLine := Lines[CP].Current; - - // choose current parts - for Count := 0 to Lines[CP].High do - begin - if LyricsState.CurrentBeat >= Lines[CP].Line[Count].Start then - Lines[CP].Current := Count; - end; - - // clean player note if there is a new line - // (optimization on halfbeat time) - if Lines[CP].Current <> LyricsState.OldLine then - NewSentence(Screen); - - end; // for CountGr - - // make some operations on clicks - if {(LyricsState.CurrentBeatC >= 0) and }(LyricsState.OldBeatC <> LyricsState.CurrentBeatC) then - NewBeatClick(Screen); - - // make some operations when detecting new voice pitch - if (LyricsState.CurrentBeatD >= 0) and (LyricsState.OldBeatD <> LyricsState.CurrentBeatD) then - NewBeatDetect(Screen); -end; - -procedure NewSentence(Screen: TScreenSing); -var - i: integer; -begin - // clean note of player - for i := 0 to High(Player) do - begin - Player[i].LengthNote := 0; - Player[i].HighNote := -1; - SetLength(Player[i].Note, 0); - end; - - // on sentence change... - Screen.onSentenceChange(Lines[0].Current); -end; - -procedure NewBeatClick; -var - Count: integer; -begin - // beat click - if ((Ini.BeatClick = 1) and - ((LyricsState.CurrentBeatC + Lines[0].Resolution + Lines[0].NotesGAP) mod Lines[0].Resolution = 0)) then - begin - AudioPlayback.PlaySound(SoundLib.Click); - end; - - for Count := 0 to Lines[0].Line[Lines[0].Current].HighNote do - begin - if (Lines[0].Line[Lines[0].Current].Note[Count].Start = LyricsState.CurrentBeatC) then - begin - // click assist - if Ini.ClickAssist = 1 then - AudioPlayback.PlaySound(SoundLib.Click); - - // drum machine - (* - TempBeat := LyricsState.CurrentBeat; // + 2; - if (TempBeat mod 8 = 0) then Music.PlayDrum; - if (TempBeat mod 8 = 4) then Music.PlayClap; - //if (TempBeat mod 4 = 2) then Music.PlayHihat; - if (TempBeat mod 4 <> 0) then Music.PlayHihat; - *) - end; - end; -end; - -procedure NewBeatDetect(Screen: TScreenSing); -begin - NewNote(Screen); -end; - -procedure NewNote(Screen: TScreenSing); -var - LineFragmentIndex: integer; - CurrentLineFragment: PLineFragment; - PlayerIndex: integer; - CurrentSound: TCaptureBuffer; - CurrentPlayer: PPlayer; - LastPlayerNote: PPlayerNote; - Line: PLine; - SentenceIndex: integer; - SentenceMin: integer; - SentenceMax: integer; - SentenceDetected: integer; // sentence of detected note - NoteAvailable: boolean; - NewNote: boolean; - Range: integer; - NoteHit: boolean; - MaxSongPoints: integer; // max. points for the song (without line bonus) - CurNotePoints: real; // Points for the cur. Note (PointsperNote * ScoreFactor[CurNote]) -begin - // TODO: add duet mode support - // use Lines[LineSetIndex] with LineSetIndex depending on the current player - - // count min and max sentence range for checking - // (detection is delayed to the notes we see on the screen) - SentenceMin := Lines[0].Current-1; - if (SentenceMin < 0) then - SentenceMin := 0; - SentenceMax := Lines[0].Current; - - // check for an active note at the current time defined in the lyrics - NoteAvailable := false; - SentenceDetected := SentenceMin; - for SentenceIndex := SentenceMin to SentenceMax do - begin - Line := @Lines[0].Line[SentenceIndex]; - for LineFragmentIndex := 0 to Line.HighNote do - begin - CurrentLineFragment := @Line.Note[LineFragmentIndex]; - // check if line is active - if ((CurrentLineFragment.Start <= LyricsState.CurrentBeatD) and - (CurrentLineFragment.Start + CurrentLineFragment.Length-1 >= LyricsState.CurrentBeatD)) and - (CurrentLineFragment.NoteType <> ntFreestyle) and // but ignore FreeStyle notes - (CurrentLineFragment.Length > 0) then // and make sure the note length is at least 1 - begin - SentenceDetected := SentenceIndex; - NoteAvailable := true; - Break; - end; - end; - // TODO: break here, if NoteAvailable is true? We would then use the first instead - // of the last note matching the current beat if notes overlap. But notes - // should not overlap at all. - // if (NoteAvailable) then - // Break; - end; - - // analyze player signals - for PlayerIndex := 0 to PlayersPlay-1 do - begin - CurrentPlayer := @Player[PlayerIndex]; - CurrentSound := AudioInputProcessor.Sound[PlayerIndex]; - - // at the beginning of the song there is no previous note - if (Length(CurrentPlayer.Note) > 0) then - LastPlayerNote := @CurrentPlayer.Note[CurrentPlayer.HighNote] - else - LastPlayerNote := nil; - - // analyze buffer - CurrentSound.AnalyzeBuffer; - - // add some noise - // TODO: do we need this? - //LyricsState.Tone := LyricsState.Tone + Round(Random(3)) - 1; - - // add note if possible - if (CurrentSound.ToneValid and NoteAvailable) then - begin - Line := @Lines[0].Line[SentenceDetected]; - - // process until last note - for LineFragmentIndex := 0 to Line.HighNote do - begin - CurrentLineFragment := @Line.Note[LineFragmentIndex]; - if (CurrentLineFragment.Start <= LyricsState.OldBeatD+1) and - (CurrentLineFragment.Start + CurrentLineFragment.Length > LyricsState.OldBeatD+1) then - begin - // compare notes (from song-file and from player) - - // move players tone to proper octave - while (CurrentSound.Tone - CurrentLineFragment.Tone > 6) do - CurrentSound.Tone := CurrentSound.Tone - 12; - - while (CurrentSound.Tone - CurrentLineFragment.Tone < -6) do - CurrentSound.Tone := CurrentSound.Tone + 12; - - // half size notes patch - NoteHit := false; - - // if Ini.Difficulty = 0 then Range := 2; - // if Ini.Difficulty = 1 then Range := 1; - // if Ini.Difficulty = 2 then Range := 0; - Range := 2 - Ini.Difficulty; - - // check if the player hit the correct tone within the tolerated range - if (Abs(CurrentLineFragment.Tone - CurrentSound.Tone) <= Range) then - begin - // adjust the players tone to the correct one - // TODO: do we need to do this? - // Philipp: I think we do, at least when we draw the notes. - // Otherwise the notehit thing would be shifted to the - // correct unhit note. I think this will look kind of strange. - CurrentSound.Tone := CurrentLineFragment.Tone; - - // half size notes patch - NoteHit := true; - - if (Ini.LineBonus > 0) then - MaxSongPoints := MAX_SONG_SCORE - MAX_SONG_LINE_BONUS - else - MaxSongPoints := MAX_SONG_SCORE; - - // Note: ScoreValue is the sum of all note values of the song - // (MaxSongPoints / ScoreValue) is the points that a player - // gets for a hit of one beat of a normal note - // CurNotePoints is the amount of points that is meassured - // for a hit of the note per full beat - CurNotePoints := (MaxSongPoints / Lines[0].ScoreValue) * ScoreFactor[CurrentLineFragment.NoteType]; - - case CurrentLineFragment.NoteType of - ntNormal: CurrentPlayer.Score := CurrentPlayer.Score + CurNotePoints; - ntGolden: CurrentPlayer.ScoreGolden := CurrentPlayer.ScoreGolden + CurNotePoints; - end; - - // a problem if we use floor instead of round is that a score of - // 10000 points is only possible if the last digit of the total points - // for golden and normal notes is 0. - // if we use round, the max score is 10000 for most songs - // but a score of 10010 is possible if the last digit of the total - // points for golden and normal notes is 5 - // the best solution is to use round for one of these scores - // and round the other score in the opposite direction - // so we assure that the highest possible score is 10000 in every case. - CurrentPlayer.ScoreInt := round(CurrentPlayer.Score / 10) * 10; - - if (CurrentPlayer.ScoreInt < CurrentPlayer.Score) then - //normal score is floored so we have to ceil golden notes score - CurrentPlayer.ScoreGoldenInt := ceil(CurrentPlayer.ScoreGolden / 10) * 10 - else - //normal score is ceiled so we have to floor golden notes score - CurrentPlayer.ScoreGoldenInt := floor(CurrentPlayer.ScoreGolden / 10) * 10; - - - CurrentPlayer.ScoreTotalInt := CurrentPlayer.ScoreInt + - CurrentPlayer.ScoreGoldenInt + - CurrentPlayer.ScoreLineInt; - end; - - end; // operation - end; // for - - // check if we have to add a new note or extend the note's length - if (SentenceDetected = SentenceMax) then - begin - // we will add a new note - NewNote := true; - - // if previous note (if any) was the same, extend previous note - if ((CurrentPlayer.LengthNote > 0) and - (LastPlayerNote <> nil) and - (LastPlayerNote.Tone = CurrentSound.Tone) and - ((LastPlayerNote.Start + LastPlayerNote.Length) = LyricsState.CurrentBeatD)) then - begin - NewNote := false; - end; - - // if is not as new note to control - for LineFragmentIndex := 0 to Line.HighNote do - begin - if (Line.Note[LineFragmentIndex].Start = LyricsState.CurrentBeatD) then - NewNote := true; - end; - - // add new note - if NewNote then - begin - // new note - Inc(CurrentPlayer.LengthNote); - Inc(CurrentPlayer.HighNote); - SetLength(CurrentPlayer.Note, CurrentPlayer.LengthNote); - - // update player's last note - LastPlayerNote := @CurrentPlayer.Note[CurrentPlayer.HighNote]; - with LastPlayerNote^ do - begin - Start := LyricsState.CurrentBeatD; - Length := 1; - Tone := CurrentSound.Tone; // Tone || ToneAbs - Detect := LyricsState.MidBeat; - Hit := NoteHit; // half note patch - end; - end - else - begin - // extend note length - if (LastPlayerNote <> nil) then - Inc(LastPlayerNote.Length); - end; - - // check for perfect note and then light the star (on Draw) - for LineFragmentIndex := 0 to Line.HighNote do - begin - CurrentLineFragment := @Line.Note[LineFragmentIndex]; - if (CurrentLineFragment.Start = LastPlayerNote.Start) and - (CurrentLineFragment.Length = LastPlayerNote.Length) and - (CurrentLineFragment.Tone = LastPlayerNote.Tone) then - begin - LastPlayerNote.Perfect := true; - end; - end; - end; // if SentenceDetected = SentenceMax - - end; // if Detected - end; // for PlayerIndex - - //Log.LogStatus('EndBeat', 'NewBeat'); - - // on sentence end -> for LineBonus and display of SingBar (rating pop-up) - if (SentenceDetected >= Low(Lines[0].Line)) and - (SentenceDetected <= High(Lines[0].Line)) then - begin - Line := @Lines[0].Line[SentenceDetected]; - CurrentLineFragment := @Line.Note[Line.HighNote]; - if ((CurrentLineFragment.Start + CurrentLineFragment.Length - 1) = LyricsState.CurrentBeatD) then - begin - if assigned(Screen) then - Screen.OnSentenceEnd(SentenceDetected); - end; - end; - -end; - -end. diff --git a/src/base/UParty.pas b/src/base/UParty.pas deleted file mode 100644 index 52eb5a05..00000000 --- a/src/base/UParty.pas +++ /dev/null @@ -1,388 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UParty; - -interface - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -{$I switches.inc} - -uses - ModiSDK; - -type - TRoundInfo = record - Plugin: word; - Winner: byte; - end; - - TeamOrderEntry = record - TeamNum: byte; - Score: byte; - end; - - TeamOrderArray = array[0..5] of byte; - - TPartyPlugin = record - ID: byte; - TimesPlayed: byte; - end; - - TPartySession = class - private - function GetRandomPlayer(Team: byte): byte; - function GetRandomPlugin(Plugins: array of TPartyPlugin): byte; - function IsWinner(Player, Winner: byte): boolean; - procedure GenScores; - public - Teams: TTeamInfo; - Rounds: array of TRoundInfo; - CurRound: byte; - - constructor Create; - - procedure StartNewParty(NumRounds: byte); - procedure StartRound; - procedure EndRound; - function GetTeamOrder: TeamOrderArray; - function GetWinnerString(Round: byte): UTF8String; - end; - -var - PartySession: TPartySession; - -implementation - -uses - UDLLManager, - UGraphic, - UNote, - ULanguage, - ULog; - -constructor TPartySession.Create; -begin - inherited; -end; - -//---------- -// Returns a number of a random plugin -//---------- -function TPartySession.GetRandomPlugin(Plugins: array of TPartyPlugin): byte; -var - LowestTP: byte; - NumPwithLTP: word; - I: integer; - R: word; -begin - LowestTP := high(byte); - NumPwithLTP := 0; - - //Search for Plugins not often played yet - for I := 0 to high(Plugins) do - begin - if (Plugins[I].TimesPlayed < lowestTP) then - begin - lowestTP := Plugins[I].TimesPlayed; - NumPwithLTP := 1; - end - else if (Plugins[I].TimesPlayed = lowestTP) then - begin - Inc(NumPwithLTP); - end; - end; - - //Create random no - R := Random(NumPwithLTP); - - //Search for random plugin - for I := 0 to high(Plugins) do - begin - if Plugins[I].TimesPlayed = LowestTP then - begin - //Plugin found - if (R = 0) then - begin - Result := Plugins[I].ID; - Inc(Plugins[I].TimesPlayed); - Break; - end; - Dec(R); - end; - end; -end; - -//---------- -//StartNewParty - Reset and prepares for new party -//---------- -procedure TPartySession.StartNewParty(NumRounds: byte); -var - Plugins: array of TPartyPlugin; - TeamMode: boolean; - Len: integer; - I, J: integer; -begin - //Set current round to 1 - CurRound := 255; - - PlayersPlay := Teams.NumTeams; - - //Get team-mode and set joker, also set TimesPlayed - TeamMode := true; - for I := 0 to Teams.NumTeams - 1 do - begin - if Teams.Teaminfo[I].NumPlayers < 2 then - begin - TeamMode := false; - end; - //Set player attributes - for J := 0 to Teams.TeamInfo[I].NumPlayers-1 do - begin - Teams.TeamInfo[I].Playerinfo[J].TimesPlayed := 0; - end; - Teams.Teaminfo[I].Joker := Round(NumRounds * 0.7); - Teams.Teaminfo[I].Score := 0; - end; - - //Fill plugin array - SetLength(Plugins, 0); - for I := 0 to high(DLLMan.Plugins) do - begin - if TeamMode or (not DLLMan.Plugins[I].TeamModeOnly) then - begin - //Add only those plugins playable with current PlayerConfiguration - Len := Length(Plugins); - SetLength(Plugins, Len + 1); - Plugins[Len].ID := I; - Plugins[Len].TimesPlayed := 0; - end; - end; - - //Set rounds - if (Length(Plugins) >= 1) then - begin - SetLength (Rounds, NumRounds); - for I := 0 to NumRounds - 1 do - begin - PartySession.Rounds[I].Plugin := GetRandomPlugin(Plugins); - PartySession.Rounds[I].Winner := 255; - end; - end - else - SetLength (Rounds, 0); -end; - -{** - * Returns a random player to play next round - *} -function TPartySession.GetRandomPlayer(Team: byte): byte; -var - I, R: integer; - LowestTP: byte; - NumPwithLTP: byte; -begin - LowestTP := high(byte); - NumPwithLTP := 0; - Result := 0; - - //Search for players that have not often played yet - for I := 0 to Teams.Teaminfo[Team].NumPlayers - 1 do - begin - if (Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed < lowestTP) then - begin - lowestTP := Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed; - NumPwithLTP := 1; - end - else if (Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed = lowestTP) then - begin - Inc(NumPwithLTP); - end; - end; - - //Create random number - R := Random(NumPwithLTP); - - //Search for random player - for I := 0 to Teams.Teaminfo[Team].NumPlayers - 1 do - begin - if Teams.Teaminfo[Team].Playerinfo[I].TimesPlayed = lowestTP then - begin - //Player found - if (R = 0) then - begin - Result := I; - Break; - end; - - Dec(R); - end; - end; -end; - -{** - * Prepares ScreenSingModi for next round and loads plugin - *} -procedure TPartySession.StartRound; -var - I: integer; -begin - if ((CurRound < high(Rounds)) or (CurRound = high(CurRound))) then - begin - // Increase Current Round but not beyond its limit - // CurRound is set to 255 to begin with! - // Ugly solution if you ask me. - if CurRound < high(CurRound) then - Inc(CurRound) - else - CurRound := 0; - - Rounds[CurRound].Winner := 255; - DllMan.LoadPlugin(Rounds[CurRound].Plugin); - - //Select Players - for I := 0 to Teams.NumTeams - 1 do - Teams.Teaminfo[I].CurPlayer := GetRandomPlayer(I); - - //Set ScreenSingModie Variables - ScreenSingModi.TeamInfo := Teams; - end; -end; - -//---------- -//EndRound - Get Winner from ScreenSingModi and Save Data to RoundArray -//---------- -procedure TPartySession.EndRound; -var - I: Integer; -begin - //Copy Winner - Rounds[CurRound].Winner := ScreenSingModi.Winner; - //Set Scores - GenScores; - - //Increase TimesPlayed 4 all Players - For I := 0 to Teams.NumTeams-1 do - Inc(Teams.Teaminfo[I].Playerinfo[Teams.Teaminfo[I].CurPlayer].TimesPlayed); - -end; - -//---------- -//IsWinner - returns true if the player's bit is set in the winner byte -//---------- -function TPartySession.IsWinner(Player, Winner: byte): boolean; -var - Mask: byte; -begin - Mask := 1 shl Player; - Result := (Winner and Mask) <> 0; -end; - -//---------- -//GenScores - increase scores for current round -//---------- -procedure TPartySession.GenScores; -var - I: byte; -begin - for I := 0 to Teams.NumTeams - 1 do - begin - if isWinner(I, Rounds[CurRound].Winner) then - Inc(Teams.Teaminfo[I].Score); - end; -end; - -//---------- -//GetTeamOrder - returns the placement of each Team [First Position of Array is Teamnum of first placed Team, ...] -//---------- -function TPartySession.GetTeamOrder: TeamOrderArray; -var - I, J: integer; - ATeams: array [0..5] of TeamOrderEntry; - TempTeam: TeamOrderEntry; -begin - // TODO: PartyMode: Write this in another way, so that teams with the same score get the same place - //Fill Team array - for I := 0 to Teams.NumTeams - 1 do - begin - ATeams[I].Teamnum := I; - ATeams[I].Score := Teams.Teaminfo[I].Score; - end; - - //Sort teams - for J := 0 to Teams.NumTeams - 1 do - for I := 1 to Teams.NumTeams - 1 do - if ATeams[I].Score > ATeams[I-1].Score then - begin - TempTeam := ATeams[I-1]; - ATeams[I-1] := ATeams[I]; - ATeams[I] := TempTeam; - end; - - //Copy to Result - for I := 0 to Teams.NumTeams-1 do - Result[I] := ATeams[I].TeamNum; -end; - -//---------- -//GetWinnerString - Get string with WinnerTeam Name, when there is more than one Winner than Connect with and or , -//---------- -function TPartySession.GetWinnerString(Round: byte): UTF8String; -var - Winners: array of UTF8String; - I: integer; -begin - Result := Language.Translate('PARTY_NOBODY'); - - if (Round > High(Rounds)) then - exit; - - if (Rounds[Round].Winner = 0) then - begin - exit; - end; - - if (Rounds[Round].Winner = 255) then - begin - Result := Language.Translate('PARTY_NOTPLAYEDYET'); - exit; - end; - - SetLength(Winners, 0); - for I := 0 to Teams.NumTeams - 1 do - begin - if isWinner(I, Rounds[Round].Winner) then - begin - SetLength(Winners, Length(Winners) + 1); - Winners[high(Winners)] := Teams.TeamInfo[I].Name; - end; - end; - Result := Language.Implode(Winners); -end; - -end. diff --git a/src/base/UPathUtils.pas b/src/base/UPathUtils.pas deleted file mode 100644 index c2bcdd4b..00000000 --- a/src/base/UPathUtils.pas +++ /dev/null @@ -1,196 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UPathUtils; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Classes, - UPath; - -var - // Absolute Paths - GamePath: IPath; - SoundPath: IPath; - SongPaths: IInterfaceList; - LogPath: IPath; - ThemePath: IPath; - SkinsPath: IPath; - ScreenshotsPath: IPath; - CoverPaths: IInterfaceList; - LanguagesPath: IPath; - PluginPath: IPath; - VisualsPath: IPath; - FontPath: IPath; - ResourcesPath: IPath; - PlaylistPath: IPath; - -function FindPath(out PathResult: IPath; const RequestedPath: IPath; NeedsWritePermission: boolean): boolean; -procedure InitializePaths; -procedure AddSongPath(const Path: IPath); - -implementation - -uses - StrUtils, - UPlatform, - UCommandLine, - ULog; - -procedure AddSpecialPath(var PathList: IInterfaceList; const Path: IPath); -var - Index: integer; - PathAbs, PathTmp: IPath; - OldPath, OldPathAbs, OldPathTmp: IPath; -begin - if (PathList = nil) then - PathList := TInterfaceList.Create; - - if Path.Equals(PATH_NONE) or not Path.CreateDirectory(true) then - Exit; - - PathTmp := Path.GetAbsolutePath(); - PathAbs := PathTmp.AppendPathDelim(); - - // check if path or a part of the path was already added - for Index := 0 to PathList.Count-1 do - begin - OldPath := PathList[Index] as IPath; - OldPathTmp := OldPath.GetAbsolutePath(); - OldPathAbs := OldPathTmp.AppendPathDelim(); - - // check if the new directory is a sub-directory of a previously added one. - // This is also true, if both paths point to the same directories. - if (OldPathAbs.IsChildOf(PathAbs, false) or OldPathAbs.Equals(PathAbs)) then - begin - // ignore the new path - Exit; - end; - - // check if a previously added directory is a sub-directory of the new one. - if (PathAbs.IsChildOf(OldPathAbs, false)) then - begin - // replace the old with the new one. - PathList[Index] := PathAbs; - Exit; - end; - end; - - PathList.Add(PathAbs); -end; - -procedure AddSongPath(const Path: IPath); -begin - AddSpecialPath(SongPaths, Path); -end; - -procedure AddCoverPath(const Path: IPath); -begin - AddSpecialPath(CoverPaths, Path); -end; - -(** - * Initialize a path variable - * After setting paths, make sure that paths exist - *) -function FindPath( - out PathResult: IPath; - const RequestedPath: IPath; - NeedsWritePermission: boolean): boolean; -begin - Result := false; - - if (RequestedPath.Equals(PATH_NONE)) then - Exit; - - // Make sure the directory exists - if (not RequestedPath.CreateDirectory(true)) then - begin - PathResult := PATH_NONE; - Exit; - end; - - PathResult := RequestedPath.AppendPathDelim(); - - if (NeedsWritePermission) and RequestedPath.IsReadOnly() then - Exit; - - Result := true; -end; - -(** - * Function sets all absolute paths e.g. song path and makes sure the directorys exist - *) -procedure InitializePaths; -var - SharedPath, UserPath: IPath; -begin - // Log directory (must be writable) - if (not FindPath(LogPath, Platform.GetLogPath, true)) then - begin - Log.FileOutputEnabled := false; - Log.LogWarn('Log directory "'+ Platform.GetLogPath.ToNative +'" not available', 'InitializePaths'); - end; - - SharedPath := Platform.GetGameSharedPath; - UserPath := Platform.GetGameUserPath; - - FindPath(SoundPath, SharedPath.Append('sounds'), false); - FindPath(ThemePath, SharedPath.Append('themes'), false); - FindPath(SkinsPath, SharedPath.Append('themes'), false); - FindPath(LanguagesPath, SharedPath.Append('languages'), false); - FindPath(PluginPath, SharedPath.Append('plugins'), false); - FindPath(VisualsPath, SharedPath.Append('visuals'), false); - FindPath(FontPath, SharedPath.Append('fonts'), false); - FindPath(ResourcesPath, SharedPath.Append('resources'), false); - - // Playlists are not shared as we need one directory to write too - FindPath(PlaylistPath, UserPath.Append('playlists'), true); - - // Screenshot directory (must be writable) - if (not FindPath(ScreenshotsPath, UserPath.Append('screenshots'), true)) then - begin - Log.LogWarn('Screenshot directory "'+ UserPath.ToNative +'" not available', 'InitializePaths'); - end; - - // Add song paths - AddSongPath(Params.SongPath); - AddSongPath(SharedPath.Append('songs')); - AddSongPath(UserPath.Append('songs')); - - // Add category cover paths - AddCoverPath(SharedPath.Append('covers')); - AddCoverPath(UserPath.Append('covers')); -end; - -end. diff --git a/src/base/UPlatform.pas b/src/base/UPlatform.pas deleted file mode 100644 index 11c67fa7..00000000 --- a/src/base/UPlatform.pas +++ /dev/null @@ -1,135 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UPlatform; - -// Comment by Eddie: -// This unit defines an interface for platform specific utility functions. -// The Interface is implemented in separate files for each platform: -// UPlatformWindows, UPlatformLinux and UPlatformMacOSX. - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - UPath; - -type - TPlatform = class - function GetExecutionDir(): IPath; - procedure Init; virtual; - - function TerminateIfAlreadyRunning(var WndTitle: string): boolean; virtual; - procedure Halt; virtual; - - function GetLogPath: IPath; virtual; abstract; - function GetGameSharedPath: IPath; virtual; abstract; - function GetGameUserPath: IPath; virtual; abstract; - end; - - function Platform(): TPlatform; - -implementation - -uses - SysUtils, - {$IF Defined(MSWINDOWS)} - UPlatformWindows, - {$ELSEIF Defined(DARWIN)} - UPlatformMacOSX, - {$ELSEIF Defined(UNIX)} - UPlatformLinux, - {$IFEND} - ULog, - UUnicodeUtils, - UFilesystem; - - -// I modified it to use the Platform_singleton in this location (in the implementation) -// so that this variable can NOT be overwritten from anywhere else in the application. -// the accessor function platform, emulates all previous calls to work the same way. -var - Platform_singleton: TPlatform; - -function Platform: TPlatform; -begin - Result := Platform_singleton; -end; - -(** - * Default Init() implementation - *) -procedure TPlatform.Init; -begin -end; - -(** - * Default Halt() implementation - *) -procedure TPlatform.Halt; -begin - // Note: Application.terminate is NOT the same - System.Halt; -end; - -{** - * Returns the directory of the executable - *} -function TPlatform.GetExecutionDir(): IPath; -var - ExecName, ExecDir: IPath; -begin - ExecName := Path(ParamStr(0)); - ExecDir := ExecName.GetPath; - Result := ExecDir.GetAbsolutePath(); -end; - -(** - * Default TerminateIfAlreadyRunning() implementation - *) -function TPlatform.TerminateIfAlreadyRunning(var WndTitle: string): boolean; -begin - Result := false; -end; - -initialization -{$IF Defined(MSWINDOWS)} - Platform_singleton := TPlatformWindows.Create; -{$ELSEIF Defined(DARWIN)} - Platform_singleton := TPlatformMacOSX.Create; -{$ELSEIF Defined(UNIX)} - Platform_singleton := TPlatformLinux.Create; -{$IFEND} - -finalization - Platform_singleton.Free; - -end. diff --git a/src/base/UPlatformLinux.pas b/src/base/UPlatformLinux.pas deleted file mode 100644 index 693facaa..00000000 --- a/src/base/UPlatformLinux.pas +++ /dev/null @@ -1,149 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UPlatformLinux; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - UPlatform, - UConfig, - UPath; - -type - TPlatformLinux = class(TPlatform) - private - UseLocalDirs: boolean; - - procedure DetectLocalExecution(); - function GetHomeDir(): IPath; - public - procedure Init; override; - - function GetLogPath : IPath; override; - function GetGameSharedPath : IPath; override; - function GetGameUserPath : IPath; override; - end; - -implementation - -uses - UCommandLine, - BaseUnix, - pwd, - SysUtils, - ULog; - -const - {$I paths.inc} - -procedure TPlatformLinux.Init; -begin - inherited Init(); - DetectLocalExecution(); -end; - -{** - * Detects whether the game was executed locally or globally. - * - It is local if it was not installed and directly executed from - * within the game folder. In this case resources (themes, language-files) - * reside in the directory of the executable. - * - It is global if the game was installed (e.g. to /usr/bin) and - * the resources are in a separate folder (e.g. /usr/share/ultrastardx) - * which name is stored in the INSTALL_DATADIR constant in paths.inc. - * - * Sets UseLocalDirs to true if the game is executed locally, false otherwise. - *} -procedure TPlatformLinux.DetectLocalExecution(); -var - LocalDir, LanguageDir: IPath; -begin - // we just check if the 'languages' folder exists in the - // directory of the executable. If so -> local execution. - LocalDir := GetExecutionDir(); - LanguageDir := LocalDir.Append('languages'); - UseLocalDirs := LanguageDir.IsDirectory; -end; - -function TPlatformLinux.GetLogPath: IPath; -begin - if UseLocalDirs then - Result := GetExecutionDir() - else - Result := GetGameUserPath().Append('logs', pdAppend); - - // create non-existing directories - Result.CreateDirectory(true); -end; - -function TPlatformLinux.GetGameSharedPath: IPath; -begin - if UseLocalDirs then - Result := GetExecutionDir() - else - Result := Path(INSTALL_DATADIR, pdAppend); -end; - -function TPlatformLinux.GetGameUserPath: IPath; -begin - if UseLocalDirs then - Result := GetExecutionDir() - else - Result := GetHomeDir().Append('.ultrastardx', pdAppend); -end; - -{** - * Returns the user's home directory terminated by a path delimiter - *} -function TPlatformLinux.GetHomeDir(): IPath; -var - PasswdEntry: PPasswd; -begin - Result := PATH_NONE; - - // try to retrieve the info from passwd - PasswdEntry := FpGetpwuid(FpGetuid()); - if (PasswdEntry <> nil) then - Result := Path(PasswdEntry.pw_dir); - // fallback if passwd does not contain the path - if (Result.IsUnset) then - Result := Path(GetEnvironmentVariable('HOME')); - // add trailing path delimiter (normally '/') - if (Result.IsSet) then - Result := Result.AppendPathDelim(); - - // GetUserDir() is another function that returns a user path. - // It uses env-var HOME or a fallback to a temp-dir. - //Result := GetUserDir(); -end; - -end. diff --git a/src/base/UPlatformMacOSX.pas b/src/base/UPlatformMacOSX.pas deleted file mode 100644 index 1dc0014a..00000000 --- a/src/base/UPlatformMacOSX.pas +++ /dev/null @@ -1,279 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UPlatformMacOSX; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - ULog, - UPlatform, - UFilesystem, - UPath; - -type - {** - * @abstract(Provides Mac OS X specific details.) - * @lastmod(August 1, 2008) - * The UPlatformMacOSX unit takes care of setting paths to resource folders. - * - * (Note for non-Maccies: "folder" is the Mac name for directory.) - * - * Note on the resource folders: - * 1. Installation of an application on the mac works as follows: Extract and - * copy an application and if you don't like or need the application - * anymore you move the folder to the trash - and you're done. - * 2. The use of folders in the user's home directory is against Apple's - * guidelines and strange to an average user. - * 3. Even worse is using /usr/local/... since all lowercase folders in / are - * not visible to an average user in the Finder, at least not without some - * "tricks". - * - * The best way would be to store everything within the application bundle. - * However, this requires USDX to offer the handling of the resources. Until - * this is implemented, the second best solution is as follows: - * - * According to Aple guidelines handling of resources and folders should follow - * these lines: - * - * Acceptable places for files are folders named UltraStarDeluxe either in - * /Library/Application Support/ - * or - * ~/Library/Application Support/ - * - * So - * GetGameSharedPath could return - * /Library/Application Support/UltraStarDeluxe/. - * GetGameUserPath could return - * ~/Library/Application Support/UltraStarDeluxe/. - * - * Right now, only $HOME/Library/Application Support/UltraStarDeluxe - * is used. So every user needs the complete set of files and folders. - * Future versions may also use shared resources in - * /Library/Application Support/UltraStarDeluxe. However, this is - * not treated yet in the code outside this unit. - * - * USDX checks, whether GetGameUserPath exists. If not, USDX creates it. - * The existence of needed files is then checked and if a file is missing - * it is copied to there from within the folder Contents in the Application - * bundle, which contains the default files. USDX should not delete files or - * folders in Application Support/UltraStarDeluxe automatically or without - * user confirmation. - *} - TPlatformMacOSX = class(TPlatform) - private - {** - * GetBundlePath returns the path to the application bundle - * UltraStarDeluxe.app. - *} - function GetBundlePath: IPath; - - {** - * GetApplicationSupportPath returns the path to - * $HOME/Library/Application Support/UltraStarDeluxe. - *} - function GetApplicationSupportPath: IPath; - - {** - * see the description of @link(Init). - *} - procedure CreateUserFolders(); - - function GetHomeDir(): IPath; - - public - {** - * Init simply calls @link(CreateUserFolders), which in turn scans the - * folder UltraStarDeluxe.app/Contents for all files and - * folders. $HOME/Library/Application Support/UltraStarDeluxe - * is then checked for their presence and missing ones are copied. - *} - procedure Init; override; - - {** - * GetLogPath returns the path for log messages. Currently it is set to - * $HOME/Library/Application Support/UltraStarDeluxe/Log. - *} - function GetLogPath : IPath; override; - - {** - * GetGameSharedPath returns the path for shared resources. Currently it - * is set to /Library/Application Support/UltraStarDeluxe. - * However it is not used. - *} - function GetGameSharedPath : IPath; override; - - {** - * GetGameUserPath returns the path for user resources. Currently it is - * set to $HOME/Library/Application Support/UltraStarDeluxe. - * This is where a user can add songs, themes, .... - *} - function GetGameUserPath : IPath; override; - end; - -implementation - -uses - SysUtils; - -procedure TPlatformMacOSX.Init; -begin - CreateUserFolders(); -end; - -procedure TPlatformMacOSX.CreateUserFolders(); -var - RelativePath: IPath; - // BaseDir contains the path to the folder, where a search is performed. - // It is set to the entries in @link(DirectoryList) one after the other. - BaseDir: IPath; - // OldBaseDir contains the path to the folder, where the search started. - // It is used to return to it, when the search is completed in all folders. - OldBaseDir: IPath; - Iter: IFileIterator; - FileInfo: TFileInfo; - CurPath: IPath; - // These two lists contain all folder and file names found - // within the folder @link(BaseDir). - DirectoryList, FileList: IInterfaceList; - // DirectoryIsFinished contains the index of the folder in @link(DirectoryList), - // which is the last one completely searched. Later folders are still to be - // searched for additional files and folders. - DirectoryIsFinished: longint; - I: longint; - // These three are for creating directories, due to possible symlinks - CreatedDirectory: boolean; - FileAttrs: integer; - DirectoryPath: IPath; - UserPath: IPath; - SrcFile, TgtFile: IPath; -begin - // Get the current folder and save it in OldBaseDir for returning to it, when - // finished. - OldBaseDir := FileSystem.GetCurrentDir(); - - // UltraStarDeluxe.app/Contents contains all the default files and folders. - BaseDir := OldBaseDir.Append('UltraStarDeluxe.app/Contents'); - FileSystem.SetCurrentDir(BaseDir); - - // Right now, only $HOME/Library/Application Support/UltraStarDeluxe is used. - UserPath := GetGameUserPath(); - - DirectoryIsFinished := 0; - // replace with IInterfaceList - DirectoryList := TInterfaceList.Create(); - FileList := TInterfaceList.Create(); - DirectoryList.Add(Path('.')); - - // create the folder and file lists - repeat - RelativePath := (DirectoryList[DirectoryIsFinished] as IPath); - FileSystem.SetCurrentDir(BaseDir.Append(RelativePath)); - Iter := FileSystem.FileFind(Path('*'), faAnyFile); - while (Iter.HasNext) do - begin - FileInfo := Iter.Next; - CurPath := FileInfo.Name; - if CurPath.IsDirectory() then - begin - if (not CurPath.Equals('.')) and (not CurPath.Equals('..')) then - DirectoryList.Add(RelativePath.Append(CurPath)); - end - else - Filelist.Add(RelativePath.Append(CurPath)); - end; - Inc(DirectoryIsFinished); - until (DirectoryIsFinished = DirectoryList.Count); - - // create missing folders - UserPath.CreateDirectory(true); // should not be necessary since (UserPathName+'/.') is created. - for I := 0 to DirectoryList.Count-1 do - begin - CurPath := DirectoryList[I] as IPath; - DirectoryPath := UserPath.Append(CurPath); - CreatedDirectory := DirectoryPath.CreateDirectory(); - FileAttrs := DirectoryPath.GetAttr(); - // Maybe analyse the target of the link with FpReadlink(). - // Let's assume the symlink is pointing to an existing directory. - if (not CreatedDirectory) and (FileAttrs and faSymLink > 0) then - Log.LogError('Failed to create the folder "'+ DirectoryPath.ToNative +'"', - 'TPlatformMacOSX.CreateUserFolders'); - end; - - // copy missing files - for I := 0 to Filelist.Count-1 do - begin - CurPath := Filelist[I] as IPath; - SrcFile := BaseDir.Append(CurPath); - TgtFile := UserPath.Append(CurPath); - SrcFile.CopyFile(TgtFile, true); - end; - - // go back to the initial folder - FileSystem.SetCurrentDir(OldBaseDir); -end; - -function TPlatformMacOSX.GetBundlePath: IPath; -begin - // Mac applications are packaged in folders. - // Cutting the last two folders yields the application folder. - Result := GetExecutionDir().GetParent().GetParent(); -end; - -function TPlatformMacOSX.GetApplicationSupportPath: IPath; -const - PathName: string = 'Library/Application Support/UltraStarDeluxe'; -begin - Result := GetHomeDir().Append(PathName, pdAppend); -end; - -function TPlatformMacOSX.GetHomeDir(): IPath; -begin - Result := Path(GetEnvironmentVariable('HOME')); -end; - -function TPlatformMacOSX.GetLogPath: IPath; -begin - Result := GetApplicationSupportPath.Append('Logs'); -end; - -function TPlatformMacOSX.GetGameSharedPath: IPath; -begin - Result := GetApplicationSupportPath; -end; - -function TPlatformMacOSX.GetGameUserPath: IPath; -begin - Result := GetApplicationSupportPath; -end; - -end. diff --git a/src/base/UPlatformWindows.pas b/src/base/UPlatformWindows.pas deleted file mode 100644 index a0372dad..00000000 --- a/src/base/UPlatformWindows.pas +++ /dev/null @@ -1,128 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UPlatformWindows; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -// turn off messages for platform specific symbols -{$WARN SYMBOL_PLATFORM OFF} - -uses - Classes, - UPlatform, - UPath; - -type - TPlatformWindows = class(TPlatform) - private - function GetSpecialPath(CSIDL: integer): IPath; - public - function TerminateIfAlreadyRunning(var WndTitle: String): Boolean; override; - - function GetLogPath: IPath; override; - function GetGameSharedPath: IPath; override; - function GetGameUserPath: IPath; override; - end; - -implementation - -uses - SysUtils, - ShlObj, - Windows, - UConfig; - -//------------------------------ -//Start more than One Time Prevention -//------------------------------ -function TPlatformWindows.TerminateIfAlreadyRunning(var WndTitle: String): Boolean; -var - hWnd: THandle; - I: Integer; -begin - Result := false; - hWnd:= FindWindow(nil, PChar(WndTitle)); - //Programm already started - if (hWnd <> 0) then - begin - I := Messagebox(0, PChar('Another Instance of Ultrastar is already running. Continue ?'), PChar(WndTitle), MB_ICONWARNING or MB_YESNO); - if (I = IDYes) then - begin - I := 1; - repeat - Inc(I); - hWnd := FindWindow(nil, PChar(WndTitle + ' Instance ' + InttoStr(I))); - until (hWnd = 0); - WndTitle := WndTitle + ' Instance ' + InttoStr(I); - end - else - Result := true; - end; -end; - -(** - * Returns the path of a special folder. - * - * Some Folder IDs: - * CSIDL_APPDATA (e.g. C:\Documents and Settings\username\Application Data) - * CSIDL_LOCAL_APPDATA (e.g. C:\Documents and Settings\username\Local Settings\Application Data) - * CSIDL_PROFILE (e.g. C:\Documents and Settings\username) - * CSIDL_PERSONAL (e.g. C:\Documents and Settings\username\My Documents) - * CSIDL_MYMUSIC (e.g. C:\Documents and Settings\username\My Documents\My Music) - *) -function TPlatformWindows.GetSpecialPath(CSIDL: integer): IPath; -var - Buffer: array [0..MAX_PATH-1] of WideChar; -begin - if (SHGetSpecialFolderPathW(0, @Buffer, CSIDL, false)) then - Result := Path(Buffer) - else - Result := PATH_NONE; -end; - -function TPlatformWindows.GetLogPath: IPath; -begin - Result := GetExecutionDir(); -end; - -function TPlatformWindows.GetGameSharedPath: IPath; -begin - Result := GetExecutionDir(); -end; - -function TPlatformWindows.GetGameUserPath: IPath; -begin - //Result := GetSpecialPath(CSIDL_APPDATA).Append('UltraStarDX', pdAppend); - Result := GetExecutionDir(); -end; - -end. diff --git a/src/base/UPlaylist.pas b/src/base/UPlaylist.pas deleted file mode 100644 index 527eca7b..00000000 --- a/src/base/UPlaylist.pas +++ /dev/null @@ -1,520 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UPlaylist; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - USong, - UPath, - UPathUtils; - -type - TPlaylistItem = record - Artist: UTF8String; - Title: UTF8String; - SongID: Integer; - end; - - APlaylistItem = array of TPlaylistItem; - - TPlaylist = record - Name: UTF8String; - Filename: IPath; - Items: APlaylistItem; - end; - - APlaylist = array of TPlaylist; - - //---------- - //TPlaylistManager - Class for Managing Playlists (Loading, Displaying, Saving) - //---------- - TPlaylistManager = class - private - - public - Mode: TSingMode; //Current Playlist Mode for SongScreen - CurPlayList: Cardinal; - CurItem: Cardinal; - - Playlists: APlaylist; - - constructor Create; - procedure LoadPlayLists; - function LoadPlayList(Index: Cardinal; const Filename: IPath): Boolean; - procedure SavePlayList(Index: Cardinal); - - procedure SetPlayList(Index: Cardinal); - - function AddPlaylist(const Name: UTF8String): Cardinal; - procedure DelPlaylist(const Index: Cardinal); - - procedure AddItem(const SongID: Cardinal; const iPlaylist: Integer = -1); - procedure DelItem(const iItem: Cardinal; const iPlaylist: Integer = -1); - - procedure GetNames(var PLNames: array of UTF8String); - function GetIndexbySongID(const SongID: Cardinal; const iPlaylist: Integer = -1): Integer; - end; - - {Modes: - 0: Standard Mode - 1: Category Mode - 2: PlayList Mode} - - var - PlayListMan: TPlaylistManager; - - -implementation - -uses - SysUtils, - USongs, - ULog, - UMain, - UFilesystem, - UGraphic, - UThemes, - UUnicodeUtils; - -//---------- -//Create - Construct Class - Dummy for now -//---------- -constructor TPlayListManager.Create; -begin - inherited; - LoadPlayLists; -end; - -//---------- -//LoadPlayLists - Load list of Playlists from PlayList Folder -//---------- -Procedure TPlayListManager.LoadPlayLists; -var - Len: Integer; - PlayListBuffer: TPlayList; - Iter: IFileIterator; - FileInfo: TFileInfo; -begin - SetLength(Playlists, 0); - - Iter := FileSystem.FileFind(PlayListPath.Append('*.upl'), 0); - while (Iter.HasNext) do - begin - Len := Length(Playlists); - SetLength(Playlists, Len + 1); - - FileInfo := Iter.Next; - - if not LoadPlayList(Len, FileInfo.Name) then - SetLength(Playlists, Len) - else - begin - // Sort the Playlists - Insertion Sort - PlayListBuffer := Playlists[Len]; - Dec(Len); - while (Len >= 0) AND (CompareText(Playlists[Len].Name, PlayListBuffer.Name) >= 0) do - begin - Playlists[Len+1] := Playlists[Len]; - Dec(Len); - end; - Playlists[Len+1] := PlayListBuffer; - end; - end; -end; - -//---------- -//LoadPlayList - Load a Playlist in the Array -//---------- -function TPlayListManager.LoadPlayList(Index: Cardinal; const Filename: IPath): Boolean; - - function FindSong(Artist, Title: UTF8String): Integer; - var I: Integer; - begin - Result := -1; - - For I := low(CatSongs.Song) to high(CatSongs.Song) do - begin - if (CatSongs.Song[I].Title = Title) and (CatSongs.Song[I].Artist = Artist) then - begin - Result := I; - Break; - end; - end; - end; - -var - TextStream: TTextFileStream; - Line: UTF8String; - PosDelimiter: Integer; - SongID: Integer; - Len: Integer; - FilenameAbs: IPath; -begin - //Load File - try - FilenameAbs := PlaylistPath.Append(Filename); - TextStream := TMemTextFileStream.Create(FilenameAbs, fmOpenRead); - except - begin - Log.LogError('Could not load Playlist: ' + FilenameAbs.ToNative); - Result := False; - Exit; - end; - end; - Result := True; - - //Set Filename - Playlists[Index].Filename := Filename; - Playlists[Index].Name := ''; - - //Read Until End of File - while TextStream.ReadLine(Line) do - begin - if (Length(Line) > 0) then - begin - PosDelimiter := UTF8Pos(':', Line); - if (PosDelimiter <> 0) then - begin - //Comment or Name String - if (Line[1] = '#') then - begin - //Found Name Value - if (Uppercase(Trim(copy(Line, 2, PosDelimiter - 2))) = 'NAME') then - PlayLists[Index].Name := Trim(copy(Line, PosDelimiter + 1,Length(Line) - PosDelimiter)) - - end - //Song Entry - else - begin - SongID := FindSong(Trim(copy(Line, 1, PosDelimiter - 1)), Trim(copy(Line, PosDelimiter + 1, Length(Line) - PosDelimiter))); - if (SongID <> -1) then - begin - Len := Length(PlayLists[Index].Items); - SetLength(PlayLists[Index].Items, Len + 1); - - PlayLists[Index].Items[Len].SongID := SongID; - - PlayLists[Index].Items[Len].Artist := Trim(copy(Line, 1, PosDelimiter - 1)); - PlayLists[Index].Items[Len].Title := Trim(copy(Line, PosDelimiter + 1, Length(Line) - PosDelimiter)); - end - else Log.LogError('Could not find Song in Playlist: ' + PlayLists[Index].Filename.ToNative + ', ' + Line); - end; - end; - end; - end; - - //If no special name is given, use Filename - if PlayLists[Index].Name = '' then - begin - PlayLists[Index].Name := FileName.SetExtension('').ToUTF8; - end; - - //Finish (Close File) - TextStream.Free; -end; - -{** - * Saves the specified Playlist - *} -procedure TPlayListManager.SavePlayList(Index: Cardinal); -var - TextStream: TTextFileStream; - PlaylistFile: IPath; - I: Integer; -begin - PlaylistFile := PlaylistPath.Append(Playlists[Index].Filename); - - // cannot update read-only file - if PlaylistFile.IsFile() and PlaylistFile.IsReadOnly() then - Exit; - - // open file for rewriting - TextStream := TMemTextFileStream.Create(PlaylistFile, fmCreate); - try - // Write version (not nessecary but helpful) - TextStream.WriteLine('######################################'); - TextStream.WriteLine('#Ultrastar Deluxe Playlist Format v1.0'); - TextStream.WriteLine(Format('#Playlist %s with %d Songs.', - [ Playlists[Index].Name, Length(Playlists[Index].Items) ])); - TextStream.WriteLine('######################################'); - - // Write name information - TextStream.WriteLine('#Name: ' + Playlists[Index].Name); - - // Write song information - TextStream.WriteLine('#Songs:'); - - for I := 0 to high(Playlists[Index].Items) do - begin - TextStream.WriteLine(Playlists[Index].Items[I].Artist + ' : ' + Playlists[Index].Items[I].Title); - end; - except - Log.LogError('Could not write Playlistfile "' + Playlists[Index].Name + '"'); - end; - TextStream.Free; -end; - -{** - * Display a Playlist in CatSongs - *} -procedure TPlayListManager.SetPlayList(Index: Cardinal); -var - I: Integer; -begin - if (Int(Index) > High(PlayLists)) then - exit; - - //Hide all Songs - for I := 0 to high(CatSongs.Song) do - CatSongs.Song[I].Visible := False; - - //Show Songs in PL - for I := 0 to high(PlayLists[Index].Items) do - begin - CatSongs.Song[PlayLists[Index].Items[I].SongID].Visible := True; - end; - - //Set CatSongsMode + Playlist Mode - CatSongs.CatNumShow := -3; - Mode := smPlayListRandom; - - //Set CurPlaylist - CurPlaylist := Index; - - //Show Cat in Topleft: - ScreenSong.ShowCatTLCustom(Format(Theme.Playlist.CatText,[Playlists[Index].Name])); - - //Fix SongSelection - ScreenSong.Interaction := 0; - ScreenSong.SelectNext(true); - ScreenSong.FixSelected; - - //Play correct Music - ScreenSong.ChangeMusic; -end; - -//---------- -//AddPlaylist - Adds a Playlist and Returns the Index -//---------- -function TPlayListManager.AddPlaylist(const Name: UTF8String): cardinal; -var - I: Integer; - PlaylistFile: IPath; -begin - Result := Length(Playlists); - SetLength(Playlists, Result + 1); - - // Sort the Playlists - Insertion Sort - while (Result > 0) and (CompareText(Playlists[Result - 1].Name, Name) >= 0) do - begin - Dec(Result); - Playlists[Result+1] := Playlists[Result]; - end; - Playlists[Result].Name := Name; - - // clear playlist items - SetLength(Playlists[Result].Items, 0); - - I := 1; - PlaylistFile := PlaylistPath.Append(Name + '.upl'); - while (PlaylistFile.Exists) do - begin - Inc(I); - PlaylistFile := PlaylistPath.Append(Name + InttoStr(I) + '.upl'); - end; - Playlists[Result].Filename := PlaylistFile.GetName; - - //Save new Playlist - SavePlayList(Result); -end; - -//---------- -//DelPlaylist - Deletes a Playlist -//---------- -procedure TPlayListManager.DelPlaylist(const Index: Cardinal); -var - I: Integer; - Filename: IPath; -begin - if Int(Index) > High(Playlists) then - Exit; - - Filename := PlaylistPath.Append(Playlists[Index].Filename); - - //If not FileExists or File is not Writeable then exit - if (not Filename.IsFile()) or (Filename.IsReadOnly()) then - Exit; - - - //Delete Playlist from FileSystem - if not Filename.DeleteFile() then - Exit; - - //Delete Playlist from Array - //move all PLs to the Hole - for I := Index to High(Playlists)-1 do - PlayLists[I] := PlayLists[I+1]; - - //Delete last Playlist - SetLength (Playlists, High(Playlists)); - - //If Playlist is Displayed atm - //-> Display Songs - if (CatSongs.CatNumShow = -3) and (Index = CurPlaylist) then - begin - ScreenSong.UnLoadDetailedCover; - ScreenSong.HideCatTL; - CatSongs.SetFilter('', fltAll); - ScreenSong.Interaction := 0; - ScreenSong.FixSelected; - ScreenSong.ChangeMusic; - end; -end; - -//---------- -//AddItem - Adds an Item to a specific Playlist -//---------- -Procedure TPlayListManager.AddItem(const SongID: Cardinal; const iPlaylist: Integer); -var - P: Cardinal; - Len: Cardinal; -begin - if iPlaylist = -1 then - P := CurPlaylist - else if (iPlaylist >= 0) AND (iPlaylist <= high(Playlists)) then - P := iPlaylist - else - exit; - - if (Int(SongID) <= High(CatSongs.Song)) AND (NOT CatSongs.Song[SongID].Main) then - begin - Len := Length(Playlists[P].Items); - SetLength(Playlists[P].Items, Len + 1); - - Playlists[P].Items[Len].SongID := SongID; - Playlists[P].Items[Len].Title := CatSongs.Song[SongID].Title; - Playlists[P].Items[Len].Artist := CatSongs.Song[SongID].Artist; - - //Save Changes - SavePlayList(P); - - //Correct Display when Editing current Playlist - if (CatSongs.CatNumShow = -3) and (P = CurPlaylist) then - SetPlaylist(P); - end; -end; - -//---------- -//DelItem - Deletes an Item from a specific Playlist -//---------- -Procedure TPlayListManager.DelItem(const iItem: Cardinal; const iPlaylist: Integer); -var - I: Integer; - P: Cardinal; -begin - if iPlaylist = -1 then - P := CurPlaylist - else if (iPlaylist >= 0) AND (iPlaylist <= high(Playlists)) then - P := iPlaylist - else - exit; - - if (Int(iItem) <= high(Playlists[P].Items)) then - begin - //Move all entrys behind deleted one to Front - For I := iItem to High(Playlists[P].Items) - 1 do - Playlists[P].Items[I] := Playlists[P].Items[I + 1]; - - //Delete Last Entry - SetLength(PlayLists[P].Items, Length(PlayLists[P].Items) - 1); - - //Save Changes - SavePlayList(P); - end; - - //Delete Playlist if Last Song is deleted - if (Length(PlayLists[P].Items) = 0) then - begin - DelPlaylist(P); - end - //Correct Display when Editing current Playlist - else if (CatSongs.CatNumShow = -3) and (P = CurPlaylist) then - SetPlaylist(P); -end; - -//---------- -//GetNames - Writes Playlist Names in a Array -//---------- -procedure TPlayListManager.GetNames(var PLNames: array of UTF8String); -var - I: Integer; - Len: Integer; -begin - Len := High(Playlists); - - if (Length(PLNames) <> Len + 1) then - exit; - - For I := 0 to Len do - PLNames[I] := Playlists[I].Name; -end; - -//---------- -//GetIndexbySongID - Returns Index in the specified Playlist of the given Song -//---------- -Function TPlayListManager.GetIndexbySongID(const SongID: Cardinal; const iPlaylist: Integer): Integer; -var - P: Integer; - I: Integer; -begin - Result := -1; - - if iPlaylist = -1 then - P := CurPlaylist - else if (iPlaylist >= 0) AND (iPlaylist <= high(Playlists)) then - P := iPlaylist - else - exit; - - For I := 0 to high(Playlists[P].Items) do - begin - if (Playlists[P].Items[I].SongID = Int(SongID)) then - begin - Result := I; - Break; - end; - end; -end; - -end. diff --git a/src/base/URecord.pas b/src/base/URecord.pas deleted file mode 100644 index 2c2093a0..00000000 --- a/src/base/URecord.pas +++ /dev/null @@ -1,777 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit URecord; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - Math, - sdl, - SysUtils, - UCommon, - UMusic, - UIni; - -const - BaseToneFreq = 65.4064; // lowest (half-)tone to analyze (C2 = 65.4064 Hz) - NumHalftones = 36; // C2-B4 (for Whitney and my high voice) - -type - TCaptureBuffer = class - private - VoiceStream: TAudioVoiceStream; // stream for voice passthrough - AnalysisBufferLock: PSDL_Mutex; - - function GetToneString: string; // converts a tone to its string represenatation; - - procedure BoostBuffer(Buffer: PByteArray; Size: integer); - procedure ProcessNewBuffer(Buffer: PByteArray; BufferSize: integer); - - // we call it to analyze sound by checking Autocorrelation - procedure AnalyzeByAutocorrelation; - // use this to check one frequency by Autocorrelation - function AnalyzeAutocorrelationFreq(Freq: real): real; - public - AnalysisBuffer: array[0..4095] of smallint; // newest 4096 samples - AnalysisBufferSize: integer; // number of samples of BufferArray to analyze - - LogBuffer: TMemoryStream; // full buffer - - AudioFormat: TAudioFormatInfo; - - // pitch detection - // TODO: remove ToneValid, set Tone/ToneAbs=-1 if invalid instead - ToneValid: boolean; // true if Tone contains a valid value (otherwise it contains noise) - Tone: integer; // tone relative to one octave (e.g. C2=C3=C4). Range: 0-11 - ToneAbs: integer; // absolute (full range) tone (e.g. C2<>C3). Range: 0..NumHalftones-1 - - // methods - constructor Create; - destructor Destroy; override; - - procedure Clear; - - // use to analyze sound from buffers to get new pitch - procedure AnalyzeBuffer; - procedure LockAnalysisBuffer(); {$IFDEF HasInline}inline;{$ENDIF} - procedure UnlockAnalysisBuffer(); {$IFDEF HasInline}inline;{$ENDIF} - - function MaxSampleVolume: single; - property ToneString: string READ GetToneString; - end; - -const - DEFAULT_SOURCE_NAME = '[Default]'; - -type - TAudioInputSource = record - Name: string; - end; - - // soundcard input-devices information - TAudioInputDevice = class - public - CfgIndex: integer; // index of this device in Ini.InputDeviceConfig - Name: string; // soundcard name - Source: array of TAudioInputSource; // soundcard input-sources - SourceRestore: integer; // source-index that will be selected after capturing (-1: not detected) - MicSource: integer; // source-index of mic (-1: none detected) - - AudioFormat: TAudioFormatInfo; // capture format info (e.g. 44.1kHz SInt16 stereo) - CaptureChannel: array of TCaptureBuffer; // sound-buffer references used for mono or stereo channel's capture data - - destructor Destroy; override; - - procedure LinkCaptureBuffer(ChannelIndex: integer; Sound: TCaptureBuffer); - - // TODO: add Open/Close functions so Start/Stop becomes faster - //function Open(): boolean; virtual; abstract; - //function Close(): boolean; virtual; abstract; - function Start(): boolean; virtual; abstract; - function Stop(): boolean; virtual; abstract; - - function GetVolume(): single; virtual; abstract; - procedure SetVolume(Volume: single); virtual; abstract; - end; - - TAudioInputProcessor = class - public - Sound: array of TCaptureBuffer; // sound-buffers for every player - DeviceList: array of TAudioInputDevice; - - constructor Create; - destructor Destroy; override; - - procedure UpdateInputDeviceConfig; - - // handle microphone input - procedure HandleMicrophoneData(Buffer: PByteArray; Size: integer; - InputDevice: TAudioInputDevice); - end; - - TAudioInputBase = class( TInterfacedObject, IAudioInput ) - private - Started: boolean; - protected - function UnifyDeviceName(const name: string; deviceIndex: integer): string; - public - function GetName: String; virtual; abstract; - function InitializeRecord: boolean; virtual; abstract; - function FinalizeRecord: boolean; virtual; - - procedure CaptureStart; - procedure CaptureStop; - end; - - TSmallIntArray = array [0..(MaxInt div SizeOf(SmallInt))-1] of SmallInt; - PSmallIntArray = ^TSmallIntArray; - - function AudioInputProcessor(): TAudioInputProcessor; - -implementation - -uses - ULog, - UNote; - -var - singleton_AudioInputProcessor : TAudioInputProcessor = nil; - -{ Global } - -function AudioInputProcessor(): TAudioInputProcessor; -begin - if singleton_AudioInputProcessor = nil then - singleton_AudioInputProcessor := TAudioInputProcessor.create(); - - result := singleton_AudioInputProcessor; -end; - -{ TAudioInputDevice } - -destructor TAudioInputDevice.Destroy; -begin - Stop(); - Source := nil; - CaptureChannel := nil; - FreeAndNil(AudioFormat); - inherited Destroy; -end; - -procedure TAudioInputDevice.LinkCaptureBuffer(ChannelIndex: integer; Sound: TCaptureBuffer); -var - DeviceCfg: PInputDeviceConfig; - OldSound: TCaptureBuffer; -begin - // check bounds - if ((ChannelIndex < 0) or (ChannelIndex > High(CaptureChannel))) then - Exit; - - // reset previously assigned (old) capture-buffer - OldSound := CaptureChannel[ChannelIndex]; - if (OldSound <> nil) then - begin - // close voice stream - FreeAndNil(OldSound.VoiceStream); - // free old audio-format info - FreeAndNil(OldSound.AudioFormat); - end; - - // set audio-format of new capture-buffer - if (Sound <> nil) then - begin - // copy the input-device audio-format ... - Sound.AudioFormat := AudioFormat.Copy; - // and adjust it because capture buffers are always mono - Sound.AudioFormat.Channels := 1; - DeviceCfg := @Ini.InputDeviceConfig[CfgIndex]; - - if (Ini.VoicePassthrough = 1) then - begin - // TODO: map odd players to the left and even players to the right speaker - Sound.VoiceStream := AudioPlayback.CreateVoiceStream(CHANNELMAP_FRONT, AudioFormat); - end; - end; - - // replace old with new buffer (Note: Sound might be nil) - CaptureChannel[ChannelIndex] := Sound; -end; - -{ TSound } - -constructor TCaptureBuffer.Create; -begin - inherited; - LogBuffer := TMemoryStream.Create; - AnalysisBufferLock := SDL_CreateMutex(); - AnalysisBufferSize := Length(AnalysisBuffer); -end; - -destructor TCaptureBuffer.Destroy; -begin - FreeAndNil(LogBuffer); - FreeAndNil(VoiceStream); - FreeAndNil(AudioFormat); - SDL_DestroyMutex(AnalysisBufferLock); - inherited; -end; - -procedure TCaptureBuffer.LockAnalysisBuffer(); -begin - SDL_mutexP(AnalysisBufferLock); -end; - -procedure TCaptureBuffer.UnlockAnalysisBuffer(); -begin - SDL_mutexV(AnalysisBufferLock); -end; - -procedure TCaptureBuffer.Clear; -begin - if assigned(LogBuffer) then - LogBuffer.Clear; - LockAnalysisBuffer(); - FillChar(AnalysisBuffer[0], Length(AnalysisBuffer) * SizeOf(SmallInt), 0); - UnlockAnalysisBuffer(); -end; - -procedure TCaptureBuffer.ProcessNewBuffer(Buffer: PByteArray; BufferSize: integer); -var - BufferOffset: integer; - SampleCount: integer; - i: integer; -begin - // apply software boost - BoostBuffer(Buffer, BufferSize); - - // voice passthrough (send data to playback-device) - if (assigned(VoiceStream)) then - VoiceStream.WriteData(Buffer, BufferSize); - - // we assume that samples are in S16Int format - // TODO: support float too - if (AudioFormat.Format <> asfS16) then - Exit; - - // process BufferArray - BufferOffset := 0; - - SampleCount := BufferSize div SizeOf(SmallInt); - - // check if we have more new samples than we can store - if (SampleCount > Length(AnalysisBuffer)) then - begin - // discard the oldest of the new samples - BufferOffset := (SampleCount - Length(AnalysisBuffer)) * SizeOf(SmallInt); - SampleCount := Length(AnalysisBuffer); - end; - - LockAnalysisBuffer(); - try - - // move old samples to the beginning of the array (if necessary) - for i := 0 to High(AnalysisBuffer)-SampleCount do - AnalysisBuffer[i] := AnalysisBuffer[i+SampleCount]; - - // copy new samples to analysis buffer - Move(Buffer[BufferOffset], AnalysisBuffer[Length(AnalysisBuffer)-SampleCount], - SampleCount * SizeOf(SmallInt)); - - finally - UnlockAnalysisBuffer(); - end; - - // save capture-data to BufferLong if enabled - if (Ini.SavePlayback = 1) then - begin - // this is just for debugging (approx 15MB per player for a 3min song!!!) - // For an in-game replay-mode we need to compress data so we do not - // waste that much memory. Maybe ogg-vorbis with voice-preset in fast-mode? - // Or we could use a faster but not that efficient lossless compression. - LogBuffer.WriteBuffer(Buffer, BufferSize); - end; -end; - -procedure TCaptureBuffer.AnalyzeBuffer; -var - Volume: single; - MaxVolume: single; - SampleIndex: integer; - Threshold: single; -begin - ToneValid := false; - ToneAbs := -1; - Tone := -1; - - LockAnalysisBuffer(); - try - - // find maximum volume of first 1024 samples - MaxVolume := 0; - for SampleIndex := 0 to 1023 do - begin - Volume := Abs(AnalysisBuffer[SampleIndex]) / -Low(Smallint); - if Volume > MaxVolume then - MaxVolume := Volume; - end; - - Threshold := IThresholdVals[Ini.ThresholdIndex]; - - // check if signal has an acceptable volume (ignore background-noise) - if MaxVolume >= Threshold then - begin - // analyse the current voice pitch - AnalyzeByAutocorrelation; - ToneValid := true; - end; - - finally - UnlockAnalysisBuffer(); - end; -end; - -procedure TCaptureBuffer.AnalyzeByAutocorrelation; -var - ToneIndex: integer; - CurFreq: real; - CurWeight: real; - MaxWeight: real; - MaxTone: integer; -const - HalftoneBase = 1.05946309436; // 2^(1/12) -> HalftoneBase^12 = 2 (one octave) -begin - // prepare to analyze - MaxWeight := -1; - MaxTone := 0; // this is not needed, but it satifies the compiler - - // analyze halftones - // Note: at the lowest tone (~65Hz) and a buffer-size of 4096 - // at 44.1 (or 48kHz) only 6 (or 5) samples are compared, this might be - // too few samples -> use a bigger buffer-size - for ToneIndex := 0 to NumHalftones-1 do - begin - CurFreq := BaseToneFreq * Power(HalftoneBase, ToneIndex); - CurWeight := AnalyzeAutocorrelationFreq(CurFreq); - - // TODO: prefer higher frequencies (use >= or use downto) - if (CurWeight > MaxWeight) then - begin - // this frequency has a higher weight - MaxWeight := CurWeight; - MaxTone := ToneIndex; - end; - end; - - ToneAbs := MaxTone; - Tone := MaxTone mod 12; -end; - -// result medium difference -function TCaptureBuffer.AnalyzeAutocorrelationFreq(Freq: real): real; -var - Dist: real; // distance (0=equal .. 1=totally different) between correlated samples - AccumDist: real; // accumulated distances - SampleIndex: integer; // index of sample to analyze - CorrelatingSampleIndex: integer; // index of sample one period ahead - SamplesPerPeriod: integer; // samples in one period -begin - SampleIndex := 0; - SamplesPerPeriod := Round(AudioFormat.SampleRate/Freq); - CorrelatingSampleIndex := SampleIndex + SamplesPerPeriod; - - AccumDist := 0; - - // compare correlating samples - while (CorrelatingSampleIndex < AnalysisBufferSize) do - begin - // calc distance (correlation: 1-dist) to corresponding sample in next period - Dist := Abs(AnalysisBuffer[SampleIndex] - AnalysisBuffer[CorrelatingSampleIndex]) / - High(Word); - AccumDist := AccumDist + Dist; - Inc(SampleIndex); - Inc(CorrelatingSampleIndex); - end; - - // return "inverse" average distance (=correlation) - Result := 1 - AccumDist / AnalysisBufferSize; -end; - -function TCaptureBuffer.MaxSampleVolume: single; -var - lSampleIndex: integer; - lMaxVol: longint; -begin; - LockAnalysisBuffer(); - try - lMaxVol := 0; - for lSampleIndex := 0 to High(AnalysisBuffer) do - begin - if Abs(AnalysisBuffer[lSampleIndex]) > lMaxVol then - lMaxVol := Abs(AnalysisBuffer[lSampleIndex]); - end; - finally - UnlockAnalysisBuffer(); - end; - - result := lMaxVol / -Low(Smallint); -end; - -const - ToneStrings: array[0..11] of string = ( - 'C', 'C#', 'D', 'D#', 'E', 'F', 'F#', 'G', 'G#', 'A', 'A#', 'B' - ); - -function TCaptureBuffer.GetToneString: string; -begin - if (ToneValid) then - Result := ToneStrings[Tone] + IntToStr(ToneAbs div 12 + 2) - else - Result := '-'; -end; - -procedure TCaptureBuffer.BoostBuffer(Buffer: PByteArray; Size: integer); -var - i: integer; - Value: longint; - SampleCount: integer; - SampleBuffer: PSmallIntArray; // buffer handled as array of samples - Boost: byte; -begin - // TODO: set boost per device - case Ini.MicBoost of - 0: Boost := 1; - 1: Boost := 2; - 2: Boost := 4; - 3: Boost := 8; - else Boost := 1; - end; - - // at the moment we will boost SInt16 data only - if (AudioFormat.Format = asfS16) then - begin - // interpret buffer as buffer of bytes - SampleBuffer := PSmallIntArray(Buffer); - SampleCount := Size div AudioFormat.FrameSize; - - // boost buffer - for i := 0 to SampleCount-1 do - begin - Value := SampleBuffer^[i] * Boost; - - if Value > High(Smallint) then - Value := High(Smallint); - - if Value < Low(Smallint) then - Value := Low(Smallint); - - SampleBuffer^[i] := Value; - end; - end; -end; - -{ TAudioInputProcessor } - -constructor TAudioInputProcessor.Create; -var - i: integer; -begin - inherited; - SetLength(Sound, 6 {max players});//Ini.Players+1); - for i := 0 to High(Sound) do - Sound[i] := TCaptureBuffer.Create; -end; - -destructor TAudioInputProcessor.Destroy; -var - i: integer; -begin - for i := 0 to High(Sound) do - Sound[i].Free; - SetLength(Sound, 0); - inherited; -end; - -// updates InputDeviceConfig with current input-device information -// See: TIni.LoadInputDeviceCfg() -procedure TAudioInputProcessor.UpdateInputDeviceConfig; -var - deviceIndex: integer; - newDevice: boolean; - deviceIniIndex: integer; - deviceCfg: PInputDeviceConfig; - device: TAudioInputDevice; - channelCount: integer; - channelIndex: integer; - i: integer; -begin - // Input devices - append detected soundcards - for deviceIndex := 0 to High(DeviceList) do - begin - newDevice := true; - //Search for Card in List - for deviceIniIndex := 0 to High(Ini.InputDeviceConfig) do - begin - deviceCfg := @Ini.InputDeviceConfig[deviceIniIndex]; - device := DeviceList[deviceIndex]; - - if (deviceCfg.Name = Trim(device.Name)) then - begin - newDevice := false; - - // store highest channel index as an offset for the new channels - channelIndex := High(deviceCfg.ChannelToPlayerMap); - // add missing channels or remove non-existing ones - SetLength(deviceCfg.ChannelToPlayerMap, device.AudioFormat.Channels); - // initialize added channels to 0 - for i := channelIndex+1 to High(deviceCfg.ChannelToPlayerMap) do - begin - deviceCfg.ChannelToPlayerMap[i] := 0; - end; - - // associate ini-index with device - device.CfgIndex := deviceIniIndex; - break; - end; - end; - - //If not in List -> Add - if newDevice then - begin - // resize list - SetLength(Ini.InputDeviceConfig, Length(Ini.InputDeviceConfig)+1); - deviceCfg := @Ini.InputDeviceConfig[High(Ini.InputDeviceConfig)]; - device := DeviceList[deviceIndex]; - - // associate ini-index with device - device.CfgIndex := High(Ini.InputDeviceConfig); - - deviceCfg.Name := Trim(device.Name); - deviceCfg.Input := 0; - - channelCount := device.AudioFormat.Channels; - SetLength(deviceCfg.ChannelToPlayerMap, channelCount); - - for channelIndex := 0 to channelCount-1 do - begin - // set default at first start of USDX (1st device, 1st channel -> player1) - if ((channelIndex = 0) and (device.CfgIndex = 0)) then - deviceCfg.ChannelToPlayerMap[0] := 1 - else - deviceCfg.ChannelToPlayerMap[channelIndex] := 0; - end; - end; - end; -end; - -{* - * Handles captured microphone input data. - * Params: - * Buffer - buffer of signed 16bit interleaved stereo PCM-samples. - * Interleaved means that a right-channel sample follows a left- - * channel sample and vice versa (0:left[0],1:right[0],2:left[1],...). - * Length - number of bytes in Buffer - * Input - Soundcard-Input used for capture - *} -procedure TAudioInputProcessor.HandleMicrophoneData(Buffer: PByteArray; Size: integer; InputDevice: TAudioInputDevice); -var - MultiChannelBuffer: PByteArray; // buffer handled as array of bytes (offset relative to channel) - SingleChannelBuffer: PByteArray; // temporary buffer for new samples per channel - SingleChannelBufferSize: integer; - ChannelIndex: integer; - CaptureChannel: TCaptureBuffer; - AudioFormat: TAudioFormatInfo; - SampleSize: integer; - SamplesPerChannel: integer; - i: integer; -begin - AudioFormat := InputDevice.AudioFormat; - SampleSize := AudioSampleSize[AudioFormat.Format]; - SamplesPerChannel := Size div AudioFormat.FrameSize; - - SingleChannelBufferSize := SamplesPerChannel * SampleSize; - GetMem(SingleChannelBuffer, SingleChannelBufferSize); - - // process channels - for ChannelIndex := 0 to High(InputDevice.CaptureChannel) do - begin - CaptureChannel := InputDevice.CaptureChannel[ChannelIndex]; - // check if a capture buffer was assigned, otherwise there is nothing to do - if (CaptureChannel <> nil) then - begin - // set offset according to channel index - MultiChannelBuffer := @Buffer[ChannelIndex * SampleSize]; - // separate channel-data from interleaved multi-channel (e.g. stereo) data - for i := 0 to SamplesPerChannel-1 do - begin - Move(MultiChannelBuffer[i*AudioFormat.FrameSize], - SingleChannelBuffer[i*SampleSize], - SampleSize); - end; - CaptureChannel.ProcessNewBuffer(SingleChannelBuffer, SingleChannelBufferSize); - end; - end; - - FreeMem(SingleChannelBuffer); -end; - -{ TAudioInputBase } - -function TAudioInputBase.FinalizeRecord: boolean; -var - i: integer; -begin - for i := 0 to High(AudioInputProcessor.DeviceList) do - AudioInputProcessor.DeviceList[i].Free(); - AudioInputProcessor.DeviceList := nil; - Result := true; -end; - -{* - * Start capturing on all used input-device. - *} -procedure TAudioInputBase.CaptureStart; -var - S: integer; - DeviceIndex: integer; - ChannelIndex: integer; - Device: TAudioInputDevice; - DeviceCfg: PInputDeviceConfig; - DeviceUsed: boolean; - Player: integer; -begin - if (Started) then - CaptureStop(); - - // reset buffers - for S := 0 to High(AudioInputProcessor.Sound) do - AudioInputProcessor.Sound[S].Clear; - - // start capturing on each used device - for DeviceIndex := 0 to High(AudioInputProcessor.DeviceList) do - begin - Device := AudioInputProcessor.DeviceList[DeviceIndex]; - if not assigned(Device) then - continue; - DeviceCfg := @Ini.InputDeviceConfig[Device.CfgIndex]; - - DeviceUsed := false; - - // check if device is used - for ChannelIndex := 0 to High(DeviceCfg.ChannelToPlayerMap) do - begin - Player := DeviceCfg.ChannelToPlayerMap[ChannelIndex]-1; - if (Player < 0) or (Player >= PlayersPlay) then - begin - Device.LinkCaptureBuffer(ChannelIndex, nil); - end - else - begin - Device.LinkCaptureBuffer(ChannelIndex, AudioInputProcessor.Sound[Player]); - DeviceUsed := true; - end; - end; - - // start device if used - if (DeviceUsed) then - begin - //Log.BenchmarkStart(2); - Device.Start(); - //Log.BenchmarkEnd(2); - //Log.LogBenchmark('Device.Start', 2) ; - end; - end; - - Started := true; -end; - -{* - * Stop input-capturing on all soundcards. - *} -procedure TAudioInputBase.CaptureStop; -var - DeviceIndex: integer; - ChannelIndex: integer; - Device: TAudioInputDevice; - DeviceCfg: PInputDeviceConfig; -begin - for DeviceIndex := 0 to High(AudioInputProcessor.DeviceList) do - begin - Device := AudioInputProcessor.DeviceList[DeviceIndex]; - if not assigned(Device) then - continue; - - Device.Stop(); - - // disconnect capture buffers - DeviceCfg := @Ini.InputDeviceConfig[Device.CfgIndex]; - for ChannelIndex := 0 to High(DeviceCfg.ChannelToPlayerMap) do - Device.LinkCaptureBuffer(ChannelIndex, nil); - end; - - Started := false; -end; - -function TAudioInputBase.UnifyDeviceName(const name: string; deviceIndex: integer): string; -var - count: integer; // count of devices with this name - - function IsDuplicate(const name: string): boolean; - var - i: integer; - begin - Result := false; - // search devices with same description - for i := 0 to deviceIndex-1 do - begin - if (AudioInputProcessor.DeviceList[i].Name = name) then - begin - Result := true; - Break; - end; - end; - end; - -begin - count := 1; - result := name; - - // if there is another device with the same ID, search for an available name - while (IsDuplicate(result)) do - begin - Inc(count); - // set description - result := name + ' ('+IntToStr(count)+')'; - end; -end; - -end. diff --git a/src/base/USingScores.pas b/src/base/USingScores.pas deleted file mode 100644 index f280900e..00000000 --- a/src/base/USingScores.pas +++ /dev/null @@ -1,1122 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit USingScores; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - gl, - UThemes, - UTexture; - -////////////////////////////////////////////////////////////// -// ATTENTION: // -// Enabled flag does not work atm. This should cause popups // -// not to move and scores to stay until re-enabling. // -// To use e.g. in pause mode // -// also invisible flag causes attributes not to change. // -// This should be fixed after next draw when visible = true,// -// but not tested yet // -////////////////////////////////////////////////////////////// - -// some constants containing options that could change by time -const - MaxPlayers = 6; // maximum of players that could be added - MaxPositions = 6; // maximum of score positions that could be added - -type - //----------- - // TScorePlayer - record containing information about a players score - //----------- - TScorePlayer = record - Position: byte; // index of the position where the player should be drawn - Enabled: boolean; // is the score display enabled - Visible: boolean; // is the score display visible - Score: word; // current score of the player - ScoreDisplayed: word; // score cur. displayed (for counting up) - ScoreBG: TTexture; // texture of the players scores bg - Color: TRGB; // the players color - RBPos: real; // cur. percentille of the rating bar - RBTarget: real; // target position of rating bar - RBVisible: boolean; // is rating bar drawn - end; - aScorePlayer = array [0..MaxPlayers-1] of TScorePlayer; - - //----------- - // TScorePosition - record containing information about a score position, that can be used - //----------- - PScorePosition = ^TScorePosition; - TScorePosition = record - // the position is used for which playercount - PlayerCount: byte; - // 1 - 1 player per screen - // 2 - 2 players per screen - // 4 - 3 players per screen - // 6 would be 2 and 3 players per screen - - BGX: real; // x position of the score bg - BGY: real; // y position of the score bg - BGW: real; // width of the score bg - BGH: real; // height of the score bg - - RBX: real; // x position of the rating bar - RBY: real; // y position of the rating bar - RBW: real; // width of the rating bar - RBH: real; // height of the rating bar - - TextX: real; // x position of the score text - TextY: real; // y position of the score text - TextFont: byte; // font of the score text - TextSize: integer; // size of the score text - - PUW: real; // width of the line bonus popup - PUH: real; // height of the line bonus popup - PUFont: byte; // font for the popups - PUFontSize: integer; // font size for the popups - PUStartX: real; // x start position of the line bonus popup - PUStartY: real; // y start position of the line bonus popup - PUTargetX: real; // x target position of the line bonus popup - PUTargetY: real; // y target position of the line bonus popup - end; - aScorePosition = array [0..MaxPositions-1] of TScorePosition; - - //----------- - // TScorePopUp - record containing information about a line bonus popup - // list, next item is saved in next attribute - //----------- - PScorePopUp = ^TScorePopUp; - TScorePopUp = record - Player: byte; // index of the popups player - TimeStamp: cardinal; // timestamp of popups spawn - Rating: integer; // 0 to 8, type of rating (cool, bad, etc.) - ScoreGiven: integer; // score that has already been given to the player - ScoreDiff: integer; // difference between cur score at spawn and old score - Next: PScorePopUp; // next item in list - end; - aScorePopUp = array of TScorePopUp; - - //----------- - // TSingScores - class containing scores positions and drawing scores, rating bar + popups - //----------- - TSingScores = class - private - Positions: aScorePosition; - aPlayers: aScorePlayer; - oPositionCount: byte; - oPlayerCount: byte; - - // saves the first and last popup of the list - FirstPopUp: PScorePopUp; - LastPopUp: PScorePopUp; - - // only defined during draw, time passed between - // current and previous call of draw - TimePassed: Cardinal; - - // draws a popup by pointer - procedure DrawPopUp(const PopUp: PScorePopUp); - - // raises players score if RaiseScore was called - // has to be called after DrawPopUp and before - // DrawScore - procedure DoRaiseScore(const Index: integer); - - // draws a score by playerindex - procedure DrawScore(const Index: integer); - - // draws the rating bar by playerindex - procedure DrawRatingBar(const Index: integer); - - // removes a popup w/o destroying the list - procedure KillPopUp(const last, cur: PScorePopUp); - - // calculate the amount of points for a player that is - // still in popups and therfore not displayed - function GetPopUpPoints(const Index: integer): integer; - public - Settings: record // Record containing some Displaying Options - Phase1Time: real; // time for phase 1 to complete (in msecs) - // the plop up of the popup - Phase2Time: real; // time for phase 2 to complete (in msecs) - // the moving (mainly upwards) of the popup - Phase3Time: real; // time for phase 3 to complete (in msecs) - // the fade out and score adding - - PopUpTex: array [0..8] of TTexture; // textures for every popup rating - - RatingBar_BG_Tex: TTexture; // rating bar texs - RatingBar_FG_Tex: TTexture; - RatingBar_Bar_Tex: TTexture; - - end; - - Visible: boolean; // visibility of all scores - Enabled: boolean; // scores are changed, popups are moved etc. - RBVisible: boolean; // visibility of all rating bars - - // properties for reading position and playercount - property PositionCount: byte read oPositionCount; - property PlayerCount: byte read oPlayerCount; - property Players: aScorePlayer read aPlayers; - - // constructor just sets some standard settings - constructor Create; - - // adds a position to array and increases position count - procedure AddPosition(const pPosition: PScorePosition); - - // adds a player to array and increases player count - procedure AddPlayer(const ScoreBG: TTexture; const Color: TRGB; const Score: word = 0; const Enabled: boolean = true; const Visible: boolean = true); - - // change a players visibility, enable - procedure ChangePlayerVisibility(const Index: byte; const pVisible: boolean); - procedure ChangePlayerEnabled(const Index: byte; const pEnabled: boolean); - - // deletes all player information - procedure ClearPlayers; - - // deletes positions and playerinformation - procedure Clear; - - // loads some settings and the positions from theme - procedure LoadfromTheme; - - // has to be called after positions and players have been added, before first call of draw - // it gives every player a score position - procedure Init; - - // raises the score of a specified player to the specified score - procedure RaiseScore(Player: byte; Score: integer); - - // sets the score of a specified player to the specified score - procedure SetScore(Player: byte; Score: integer); - - // spawns a new line bonus popup for the player - procedure SpawnPopUp(const PlayerIndex: byte; const Rating: integer; const Score: integer); - - // removes all popups from mem - procedure KillAllPopUps; - - // draws scores and line bonus popups - procedure Draw; - end; - -implementation - -uses - SysUtils, - Math, - SDL, - TextGL, - ULog, - UGraphic; - -{** - * sets some standard settings - *} -constructor TSingScores.Create; -begin - inherited; - - // clear popuplist pointers - FirstPopUp := nil; - LastPopUp := nil; - - // clear variables - Visible := true; - Enabled := true; - RBVisible := true; - - // clear position index - oPositionCount := 0; - oPlayerCount := 0; - - Settings.Phase1Time := 350; // plop it up . -> [ ] - Settings.Phase2Time := 550; // shift it up ^[ ]^ - Settings.Phase3Time := 200; // increase score [s++] - - Settings.PopUpTex[0].TexNum := 0; - Settings.PopUpTex[1].TexNum := 0; - Settings.PopUpTex[2].TexNum := 0; - Settings.PopUpTex[3].TexNum := 0; - Settings.PopUpTex[4].TexNum := 0; - Settings.PopUpTex[5].TexNum := 0; - Settings.PopUpTex[6].TexNum := 0; - Settings.PopUpTex[7].TexNum := 0; - Settings.PopUpTex[8].TexNum := 0; - - Settings.RatingBar_BG_Tex.TexNum := 0; - Settings.RatingBar_FG_Tex.TexNum := 0; - Settings.RatingBar_Bar_Tex.TexNum := 0; -end; - -{** - * adds a position to array and increases position count - *} -procedure TSingScores.AddPosition(const pPosition: PScorePosition); -begin - if (PositionCount < MaxPositions) then - begin - Positions[PositionCount] := pPosition^; - Inc(oPositionCount); - end; -end; - -{** - * adds a player to array and increases player count - *} -procedure TSingScores.AddPlayer(const ScoreBG: TTexture; const Color: TRGB; const Score: word; const Enabled: boolean; const Visible: boolean); -begin - if (PlayerCount < MaxPlayers) then - begin - aPlayers[PlayerCount].Position := High(byte); - aPlayers[PlayerCount].Enabled := Enabled; - aPlayers[PlayerCount].Visible := Visible; - aPlayers[PlayerCount].Score := Score; - aPlayers[PlayerCount].ScoreDisplayed := Score; - aPlayers[PlayerCount].ScoreBG := ScoreBG; - aPlayers[PlayerCount].Color := Color; - aPlayers[PlayerCount].RBPos := 0.5; - aPlayers[PlayerCount].RBTarget := 0.5; - aPlayers[PlayerCount].RBVisible := true; - - Inc(oPlayerCount); - end; -end; - -{** - * change a players visibility - *} -procedure TSingScores.ChangePlayerVisibility(const Index: byte; const pVisible: boolean); -begin - if (Index < MaxPlayers) then - aPlayers[Index].Visible := pVisible; -end; - -{** - * change player enabled - *} -procedure TSingScores.ChangePlayerEnabled(const Index: byte; const pEnabled: boolean); -begin - if (Index < MaxPlayers) then - aPlayers[Index].Enabled := pEnabled; -end; - -{** - * procedure deletes all player information - *} -procedure TSingScores.ClearPlayers; -begin - KillAllPopUps; - oPlayerCount := 0; - TimePassed := 0; -end; - -{** - * procedure deletes positions and playerinformation - *} -procedure TSingScores.Clear; -begin - KillAllPopUps; - oPlayerCount := 0; - oPositionCount := 0; - TimePassed := 0; -end; - -{** - * procedure loads some settings and the positions from theme - *} -procedure TSingScores.LoadfromTheme; -var - I: integer; - procedure AddbyStatics(const PC: byte; const ScoreStatic, SingBarStatic: TThemeStatic; ScoreText: TThemeText); - var - nPosition: TScorePosition; - begin - nPosition.PlayerCount := PC; // only for one player playing - - nPosition.BGX := ScoreStatic.X; - nPosition.BGY := ScoreStatic.Y; - nPosition.BGW := ScoreStatic.W; - nPosition.BGH := ScoreStatic.H; - - nPosition.TextX := ScoreText.X; - nPosition.TextY := ScoreText.Y; - nPosition.TextFont := ScoreText.Font; - nPosition.TextSize := ScoreText.Size; - - nPosition.RBX := SingBarStatic.X; - nPosition.RBY := SingBarStatic.Y; - nPosition.RBW := SingBarStatic.W; - nPosition.RBH := SingBarStatic.H; - - nPosition.PUW := nPosition.BGW; - nPosition.PUH := nPosition.BGH; - - nPosition.PUFont := 2; - nPosition.PUFontSize := 18; - - nPosition.PUStartX := nPosition.BGX; - nPosition.PUStartY := nPosition.TextY + 65; - - nPosition.PUTargetX := nPosition.BGX; - nPosition.PUTargetY := nPosition.TextY; - - AddPosition(@nPosition); - end; -begin - Clear; - - // set textures - // popup tex - for I := 0 to 8 do - Settings.PopUpTex[I] := Tex_SingLineBonusBack[I]; - - // rating bar tex - Settings.RatingBar_BG_Tex := Tex_SingBar_Back; - Settings.RatingBar_FG_Tex := Tex_SingBar_Front; - Settings.RatingBar_Bar_Tex := Tex_SingBar_Bar; - - // load positions from theme - - // player 1: - AddByStatics(1, Theme.Sing.StaticP1ScoreBG, Theme.Sing.StaticP1SingBar, Theme.Sing.TextP1Score); - AddByStatics(2, Theme.Sing.StaticP1TwoPScoreBG, Theme.Sing.StaticP1TwoPSingBar, Theme.Sing.TextP1TwoPScore); - AddByStatics(4, Theme.Sing.StaticP1ThreePScoreBG, Theme.Sing.StaticP1ThreePSingBar, Theme.Sing.TextP1ThreePScore); - - // player 2: - AddByStatics(2, Theme.Sing.StaticP2RScoreBG, Theme.Sing.StaticP2RSingBar, Theme.Sing.TextP2RScore); - AddByStatics(4, Theme.Sing.StaticP2MScoreBG, Theme.Sing.StaticP2MSingBar, Theme.Sing.TextP2MScore); - - // player 3: - AddByStatics(4, Theme.Sing.StaticP3RScoreBG, Theme.Sing.StaticP3SingBar, Theme.Sing.TextP3RScore); -end; - -{** - * raises the score of a specified player to the specified score - *} -procedure TSingScores.RaiseScore(Player: byte; Score: integer); -begin - if (Player <= PlayerCount - 1) then - aPlayers[Player].Score := Score; -end; - -{** - * sets the score of a specified player to the specified score - *} -procedure TSingScores.SetScore(Player: byte; Score: integer); - var - Diff: Integer; -begin - if (Player <= PlayerCount - 1) then - begin - Diff := Score - Players[Player].Score; - aPlayers[Player].Score := Score; - Inc(aPlayers[Player].ScoreDisplayed, Diff); - end; -end; - -{** - * spawns a new line bonus popup for the player - *} -procedure TSingScores.SpawnPopUp(const PlayerIndex: byte; const Rating: integer; const Score: integer); -var - Cur: PScorePopUp; -begin - if (PlayerIndex < PlayerCount) then - begin - // get memory and add data - GetMem(Cur, SizeOf(TScorePopUp)); - - Cur.Player := PlayerIndex; - Cur.TimeStamp := SDL_GetTicks; - - // limit rating value to 0..8 - // a higher value would cause a crash when selecting the bg texture - if (Rating > 8) then - Cur.Rating := 8 - else if (Rating < 0) then - Cur.Rating := 0 - else - Cur.Rating := Rating; - - Cur.ScoreGiven:= 0; - if (Players[PlayerIndex].Score < Score) then - begin - Cur.ScoreDiff := Score - Players[PlayerIndex].Score; - aPlayers[PlayerIndex].Score := Score; - end - else - Cur.ScoreDiff := 0; - Cur.Next := nil; - - // Log.LogError('TSingScores.SpawnPopUp| Player: ' + InttoStr(PlayerIndex) + ', Score: ' + InttoStr(Score) + ', ScoreDiff: ' + InttoStr(Cur.ScoreDiff)); - - // add it to the chain - if (FirstPopUp = nil) then - // the first popup in the list - FirstPopUp := Cur - else - // second or earlier popup - LastPopUp.Next := Cur; - - // set new popup to last popup in the list - LastPopUp := Cur; - end - else - Log.LogError('TSingScores: Try to add popup for non-existing player'); -end; - -{** - * removes a popup w/o destroying the list - *} -procedure TSingScores.KillPopUp(const last, cur: PScorePopUp); -begin - // give player the last points that missing till now - aPlayers[Cur.Player].ScoreDisplayed := aPlayers[Cur.Player].ScoreDisplayed + Cur.ScoreDiff - Cur.ScoreGiven; - - // change bars position - if (Cur.ScoreDiff > 0) THEN - begin // popup w/ scorechange -> give missing percentille - aPlayers[Cur.Player].RBTarget := aPlayers[Cur.Player].RBTarget + - (Cur.ScoreDiff - Cur.ScoreGiven) / Cur.ScoreDiff - * (Cur.Rating / 20 - 0.26); - end - else - begin // popup w/o scorechange -> give complete percentille - aPlayers[Cur.Player].RBTarget := aPlayers[Cur.Player].RBTarget + - (Cur.Rating / 20 - 0.26); - end; - - if (aPlayers[Cur.Player].RBTarget > 1) then - aPlayers[Cur.Player].RBTarget := 1 - else - if (aPlayers[Cur.Player].RBTarget < 0) then - aPlayers[Cur.Player].RBTarget := 0; - - // if this is the first popup => make next popup the first - if (Cur = FirstPopUp) then - FirstPopUp := Cur.Next - // else => remove curent popup from chain - else - Last.Next := Cur.Next; - - // if this is the last popup, make popup before the last - if (Cur = LastPopUp) then - LastPopUp := Last; - - // free the memory - FreeMem(Cur, SizeOf(TScorePopUp)); -end; - -{** - * removes all popups from mem - *} -procedure TSingScores.KillAllPopUps; -var - Cur: PScorePopUp; - Last: PScorePopUp; -begin - Cur := FirstPopUp; - - // remove all popups: - while (Cur <> nil) do - begin - Last := Cur; - Cur := Cur.Next; - FreeMem(Last, SizeOf(TScorePopUp)); - end; - - FirstPopUp := nil; - LastPopUp := nil; -end; - -{** - * calculate the amount of points for a player that is - * still in popups and therfore not displayed - *} -function TSingScores.GetPopUpPoints(const Index: integer): integer; - var - CurPopUp: PScorePopUp; -begin - Result := 0; - - // only check points if there is a difference between actual - // and displayed points - if (Players[Index].Score > Players[Index].ScoreDisplayed) then - begin - CurPopUp := FirstPopUp; - while (CurPopUp <> nil) do - begin - if (CurPopUp.Player = Index) then - begin // add points left "in" popup to result - Inc(Result, CurPopUp.ScoreDiff - CurPopUp.ScoreGiven); - end; - CurPopUp := CurPopUp.Next; - end; - end; -end; - -{** - * has to be called after positions and players have been added, before first call of draw - * it gives each player a score position - *} -procedure TSingScores.Init; -var - PlC: array [0..1] of byte; // playercount first screen and second screen - I, J: integer; - MaxPlayersperScreen: byte; - CurPlayer: byte; - - function GetPositionCountbyPlayerCount(bPlayerCount: byte): byte; - var - I: integer; - begin - Result := 0; - bPlayerCount := 1 shl (bPlayerCount - 1); - - for I := 0 to PositionCount - 1 do - begin - if ((Positions[I].PlayerCount and bPlayerCount) <> 0) then - Inc(Result); - end; - end; - - function GetPositionbyPlayernum(bPlayerCount, bPlayer: byte): byte; - var - I: integer; - begin - bPlayerCount := 1 shl (bPlayerCount - 1); - Result := High(byte); - - for I := 0 to PositionCount - 1 do - begin - if ((Positions[I].PlayerCount and bPlayerCount) <> 0) then - begin - if (bPlayer = 0) then - begin - Result := I; - Break; - end - else - Dec(bPlayer); - end; - end; - end; - -begin - MaxPlayersPerScreen := 0; - - for I := 1 to 6 do - begin - // if there are enough positions -> write to maxplayers - if (GetPositionCountbyPlayerCount(I) = I) then - MaxPlayersPerScreen := I - else - Break; - end; - - // split players to both screens or display on one screen - if (Screens = 2) and (MaxPlayersPerScreen < PlayerCount) then - begin - PlC[0] := PlayerCount div 2 + PlayerCount mod 2; - PlC[1] := PlayerCount div 2; - end - else - begin - PlC[0] := PlayerCount; - PlC[1] := 0; - end; - - // check if there are enough positions for all players - for I := 0 to Screens - 1 do - begin - if (PlC[I] > MaxPlayersperScreen) then - begin - PlC[I] := MaxPlayersperScreen; - Log.LogError('More Players than available Positions, TSingScores'); - end; - end; - - CurPlayer := 0; - // give every player a position - for I := 0 to Screens - 1 do - for J := 0 to PlC[I]-1 do - begin - aPlayers[CurPlayer].Position := GetPositionbyPlayernum(PlC[I], J) or (I shl 7); - // Log.LogError('Player ' + InttoStr(CurPlayer) + ' gets Position: ' + InttoStr(aPlayers[CurPlayer].Position)); - Inc(CurPlayer); - end; -end; - -{** - * draws scores and linebonus popups - *} -procedure TSingScores.Draw; -var - I: integer; - CurTime: cardinal; - CurPopUp, LastPopUp: PScorePopUp; -begin - CurTime := SDL_GetTicks; - if (TimePassed <> 0) then - TimePassed := CurTime - TimePassed; - - if Visible then - begin - // draw popups - LastPopUp := nil; - CurPopUp := FirstPopUp; - - while (CurPopUp <> nil) do - begin - if (CurTime - CurPopUp.TimeStamp > Settings.Phase1Time + Settings.Phase2Time + Settings.Phase3Time) then - begin - KillPopUp(LastPopUp, CurPopUp); - if (LastPopUp = nil) then - CurPopUp := FirstPopUp - else - CurPopUp := LastPopUp.Next; - end - else - begin - DrawPopUp(CurPopUp); - LastPopUp := CurPopUp; - CurPopUp := LastPopUp.Next; - end; - end; - - - if (RBVisible) then - // draw players w/ rating bar - for I := 0 to PlayerCount-1 do - begin - DoRaiseScore(I); - DrawScore(I); - DrawRatingBar(I); - end - else - // draw players w/o rating bar - for I := 0 to PlayerCount-1 do - begin - DoRaiseScore(I); - DrawScore(I); - end; - - end; // eo visible - - TimePassed := CurTime; -end; - -{** - * raises players score if RaiseScore was called - * has to be called after DrawPopUp and before - * DrawScore - *} -procedure TSingScores.DoRaiseScore(const Index: integer); - var - S: integer; - Diff: integer; - const - RaisePerSecond = 500; -begin - S := (Players[Index].Score - (Players[Index].ScoreDisplayed + GetPopUpPoints(Index))); - - if (S <> 0) then - begin - if (S > 0) then - Diff := Min(Round(RoundTo((RaisePerSecond * TimePassed) / 1000, 1)), S) - else - Diff := Max(Round(RoundTo((RaisePerSecond * TimePassed) / 1000, 1)), S); - - Inc(aPlayers[Index].ScoreDisplayed, Diff); - end; -end; - -{** - * draws a popup by pointer - *} -procedure TSingScores.DrawPopUp(const PopUp: PScorePopUp); -var - Progress: real; - CurTime: cardinal; - X, Y, W, H, Alpha: real; - FontSize: integer; - FontOffset: real; - TimeDiff: cardinal; - PIndex: byte; - TextLen: real; - ScoretoAdd: word; - PosDiff: real; -begin - if (PopUp <> nil) then - begin - // only draw if player has a position - PIndex := Players[PopUp.Player].Position; - if PIndex <> High(byte) then - begin - // only draw if player is on cur screen - if ((Players[PopUp.Player].Position and 128) = 0) = (ScreenAct = 1) then - begin - CurTime := SDL_GetTicks; - if not (Enabled and Players[PopUp.Player].Enabled) then - // increase timestamp with tiem where there is no movement ... - begin - // Inc(PopUp.TimeStamp, LastRender); - end; - TimeDiff := CurTime - PopUp.TimeStamp; - - // get position of popup - PIndex := PIndex and 127; - - - // check for phase ... - if (TimeDiff <= Settings.Phase1Time) then - begin - // phase 1 - the ploping up - Progress := TimeDiff / Settings.Phase1Time; - - - W := Positions[PIndex].PUW * Sin(Progress/2*Pi); - H := Positions[PIndex].PUH * Sin(Progress/2*Pi); - - X := Positions[PIndex].PUStartX + (Positions[PIndex].PUW - W)/2; - Y := Positions[PIndex].PUStartY + (Positions[PIndex].PUH - H)/2; - - FontSize := Round(Progress * Positions[PIndex].PUFontSize); - FontOffset := (H - FontSize) / 2; - Alpha := 1; - end - - else if (TimeDiff <= Settings.Phase2Time + Settings.Phase1Time) then - begin - // phase 2 - the moving - Progress := (TimeDiff - Settings.Phase1Time) / Settings.Phase2Time; - - W := Positions[PIndex].PUW; - H := Positions[PIndex].PUH; - - PosDiff := Positions[PIndex].PUTargetX - Positions[PIndex].PUStartX; - if PosDiff > 0 then - PosDiff := PosDiff + W; - X := Positions[PIndex].PUStartX + PosDiff * sqr(Progress); - - PosDiff := Positions[PIndex].PUTargetY - Positions[PIndex].PUStartY; - if PosDiff < 0 then - PosDiff := PosDiff + Positions[PIndex].BGH; - Y := Positions[PIndex].PUStartY + PosDiff * sqr(Progress); - - FontSize := Positions[PIndex].PUFontSize; - FontOffset := (H - FontSize) / 2; - Alpha := 1 - 0.3 * Progress; - end - - else - begin - // phase 3 - the fading out + score adding - Progress := (TimeDiff - Settings.Phase1Time - Settings.Phase2Time) / Settings.Phase3Time; - - if (PopUp.Rating > 0) then - begin - // add scores if player enabled - if (Enabled and Players[PopUp.Player].Enabled) then - begin - ScoreToAdd := Round(PopUp.ScoreDiff * Progress) - PopUp.ScoreGiven; - Inc(PopUp.ScoreGiven, ScoreToAdd); - aPlayers[PopUp.Player].ScoreDisplayed := Players[PopUp.Player].ScoreDisplayed + ScoreToAdd; - - // change bar positions - if PopUp.ScoreDiff = 0 then - Log.LogError('TSingScores.DrawPopUp', 'PopUp.ScoreDiff is 0 and we want to divide by it. No idea how this happens.') - else - aPlayers[PopUp.Player].RBTarget := aPlayers[PopUp.Player].RBTarget + ScoreToAdd/PopUp.ScoreDiff * (PopUp.Rating / 20 - 0.26); - if (aPlayers[PopUp.Player].RBTarget > 1) then - aPlayers[PopUp.Player].RBTarget := 1 - else if (aPlayers[PopUp.Player].RBTarget < 0) then - aPlayers[PopUp.Player].RBTarget := 0; - end; - - // set positions etc. - Alpha := 0.7 - 0.7 * Progress; - - W := Positions[PIndex].PUW; - H := Positions[PIndex].PUH; - - PosDiff := Positions[PIndex].PUTargetX - Positions[PIndex].PUStartX; - if (PosDiff > 0) then - PosDiff := W - else - PosDiff := 0; - X := Positions[PIndex].PUTargetX + PosDiff * Progress; - - PosDiff := Positions[PIndex].PUTargetY - Positions[PIndex].PUStartY; - if (PosDiff < 0) then - PosDiff := -Positions[PIndex].BGH - else - PosDiff := 0; - Y := Positions[PIndex].PUTargetY - PosDiff * (1 - Progress); - - FontSize := Positions[PIndex].PUFontSize; - FontOffset := (H - FontSize) / 2; - end - else - begin - // here the effect that should be shown if a popup without score is drawn - // and or spawn with the graphicobjects etc. - // some work for blindy to do :p - - // atm: just let it slide in the scores just like the normal popup - Alpha := 0; - end; - end; - - // draw popup - - if (Alpha > 0) and (Players[PopUp.Player].Visible) then - begin - // draw bg: - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glColor4f(1,1,1, Alpha); - glBindTexture(GL_TEXTURE_2D, Settings.PopUpTex[PopUp.Rating].TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(X, Y); - glTexCoord2f(0, Settings.PopUpTex[PopUp.Rating].TexH); glVertex2f(X, Y + H); - glTexCoord2f(Settings.PopUpTex[PopUp.Rating].TexW, Settings.PopUpTex[PopUp.Rating].TexH); glVertex2f(X + W, Y + H); - glTexCoord2f(Settings.PopUpTex[PopUp.Rating].TexW, 0); glVertex2f(X + W, Y); - glEnd; - - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - - // set font style and size - SetFontStyle(Positions[PIndex].PUFont); - SetFontItalic(false); - SetFontSize(FontSize); - SetFontReflection(false, 0); - - // draw text - TextLen := glTextWidth(Theme.Sing.LineBonusText[PopUp.Rating]); - - // color and pos - SetFontPos (X + (W - TextLen) / 2, Y + FontOffset); - glColor4f(1, 1, 1, Alpha); - - // draw - glPrint(Theme.Sing.LineBonusText[PopUp.Rating]); - end; // eo alpha check - end; // eo right screen - end; // eo player has position - end - else - Log.LogError('TSingScores: Try to draw a non-existing popup'); -end; - -{** - * draws a score by playerindex - *} -procedure TSingScores.DrawScore(const Index: integer); -var - Position: PScorePosition; - ScoreStr: String; -begin - // only draw if player has a position - if Players[Index].Position <> High(byte) then - begin - // only draw if player is on cur screen - if (((Players[Index].Position and 128) = 0) = (ScreenAct = 1)) and Players[Index].Visible then - begin - Position := @Positions[Players[Index].Position and 127]; - - // draw scorebg - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glColor4f(1,1,1, 1); - glBindTexture(GL_TEXTURE_2D, Players[Index].ScoreBG.TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(Position.BGX, Position.BGY); - glTexCoord2f(0, Players[Index].ScoreBG.TexH); glVertex2f(Position.BGX, Position.BGY + Position.BGH); - glTexCoord2f(Players[Index].ScoreBG.TexW, Players[Index].ScoreBG.TexH); glVertex2f(Position.BGX + Position.BGW, Position.BGY + Position.BGH); - glTexCoord2f(Players[Index].ScoreBG.TexW, 0); glVertex2f(Position.BGX + Position.BGW, Position.BGY); - glEnd; - - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - - // draw score text - SetFontStyle(Position.TextFont); - SetFontItalic(false); - SetFontSize(Position.TextSize); - SetFontPos(Position.TextX, Position.TextY); - SetFontReflection(false, 0); - - ScoreStr := InttoStr(Players[Index].ScoreDisplayed div 10) + '0'; - while (Length(ScoreStr) < 5) do - ScoreStr := '0' + ScoreStr; - - glPrint(ScoreStr); - - end; // eo right screen - end; // eo player has position -end; - - -procedure TSingScores.DrawRatingBar(const Index: integer); -var - Position: PScorePosition; - R, G, B: real; - Size, Diff: real; -begin - // only draw if player has a position - if Players[Index].Position <> High(byte) then - begin - // only draw if player is on cur screen - if (((Players[Index].Position and 128) = 0) = (ScreenAct = 1) and - Players[index].RBVisible and - Players[index].Visible) then - begin - Position := @Positions[Players[Index].Position and 127]; - - if (Enabled and Players[Index].Enabled) then - begin - // move position if enabled - Diff := Players[Index].RBTarget - Players[Index].RBPos; - if (Abs(Diff) < 0.02) then - aPlayers[Index].RBPos := aPlayers[Index].RBTarget - else - aPlayers[Index].RBPos := aPlayers[Index].RBPos + Diff*0.1; - end; - - // get colors for rating bar - if (Players[index].RBPos <= 0.22) then - begin - R := 1; - G := 0; - B := 0; - end - else if (Players[index].RBPos <= 0.42) then - begin - R := 1; - G := Players[index].RBPos * 5; - B := 0; - end - else if (Players[index].RBPos <= 0.57) then - begin - R := 1; - G := 1; - B := 0; - end - else if (Players[index].RBPos <= 0.77) then - begin - R := 1 - (Players[index].RBPos - 0.57) * 5; - G := 1; - B := 0; - end - else - begin - R := 0; - G := 1; - B := 0; - end; - - // enable all glfuncs needed - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - // draw rating bar bg - glColor4f(1, 1, 1, 0.8); - glBindTexture(GL_TEXTURE_2D, Settings.RatingBar_BG_Tex.TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); - glVertex2f(Position.RBX, Position.RBY); - - glTexCoord2f(0, Settings.RatingBar_BG_Tex.TexH); - glVertex2f(Position.RBX, Position.RBY+Position.RBH); - - glTexCoord2f(Settings.RatingBar_BG_Tex.TexW, Settings.RatingBar_BG_Tex.TexH); - glVertex2f(Position.RBX+Position.RBW, Position.RBY+Position.RBH); - - glTexCoord2f(Settings.RatingBar_BG_Tex.TexW, 0); - glVertex2f(Position.RBX+Position.RBW, Position.RBY); - glEnd; - - // draw rating bar itself - Size := Position.RBX + Position.RBW * Players[Index].RBPos; - glColor4f(R, G, B, 1); - glBindTexture(GL_TEXTURE_2D, Settings.RatingBar_Bar_Tex.TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); - glVertex2f(Position.RBX, Position.RBY); - - glTexCoord2f(0, Settings.RatingBar_Bar_Tex.TexH); - glVertex2f(Position.RBX, Position.RBY + Position.RBH); - - glTexCoord2f(Settings.RatingBar_Bar_Tex.TexW, Settings.RatingBar_Bar_Tex.TexH); - glVertex2f(Size, Position.RBY + Position.RBH); - - glTexCoord2f(Settings.RatingBar_Bar_Tex.TexW, 0); - glVertex2f(Size, Position.RBY); - glEnd; - - // draw rating bar fg (the thing with the 3 lines to get better readability) - glColor4f(1, 1, 1, 0.6); - glBindTexture(GL_TEXTURE_2D, Settings.RatingBar_FG_Tex.TexNum); - glBegin(GL_QUADS); - glTexCoord2f(0, 0); - glVertex2f(Position.RBX, Position.RBY); - - glTexCoord2f(0, Settings.RatingBar_FG_Tex.TexH); - glVertex2f(Position.RBX, Position.RBY + Position.RBH); - - glTexCoord2f(Settings.RatingBar_FG_Tex.TexW, Settings.RatingBar_FG_Tex.TexH); - glVertex2f(Position.RBX + Position.RBW, Position.RBY + Position.RBH); - - glTexCoord2f(Settings.RatingBar_FG_Tex.TexW, 0); - glVertex2f(Position.RBX + Position.RBW, Position.RBY); - glEnd; - - // disable all enabled glfuncs - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - end; // eo Right Screen - end; // eo Player has Position -end; - -end. diff --git a/src/base/USkins.pas b/src/base/USkins.pas deleted file mode 100644 index 6ef5c596..00000000 --- a/src/base/USkins.pas +++ /dev/null @@ -1,220 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit USkins; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UPath; - -type - TSkinTexture = record - Name: string; - FileName: IPath; - end; - - TSkinEntry = record - Theme: string; - Name: string; - Path: IPath; - FileName: IPath; - Creator: string; // not used yet - end; - - TSkin = class - Skin: array of TSkinEntry; - SkinTexture: array of TSkinTexture; - SkinPath: IPath; - Color: integer; - constructor Create; - procedure LoadList; - procedure ParseDir(Dir: IPath); - procedure LoadHeader(FileName: IPath); - procedure LoadSkin(Name: string); - function GetTextureFileName(TextureName: string): IPath; - function GetSkinNumber(Name: string): integer; - procedure onThemeChange; - end; - -var - Skin: TSkin; - -implementation - -uses - IniFiles, - Classes, - SysUtils, - UIni, - ULog, - UMain, - UPathUtils, - UFileSystem; - -constructor TSkin.Create; -begin - inherited; - LoadList; -// LoadSkin('...'); -// SkinColor := Color; -end; - -procedure TSkin.LoadList; -var - Iter: IFileIterator; - DirInfo: TFileInfo; -begin - Iter := FileSystem.FileFind(SkinsPath.Append('*'), faDirectory); - while Iter.HasNext do - begin - DirInfo := Iter.Next(); - if (not DirInfo.Name.Equals('.')) and (not DirInfo.Name.Equals('..')) then - ParseDir(SkinsPath.Append(DirInfo.Name, pdAppend)); - end; -end; - -procedure TSkin.ParseDir(Dir: IPath); -var - Iter: IFileIterator; - IniInfo: TFileInfo; -begin - Iter := FileSystem.FileFind(Dir.Append('*.ini'), 0); - while Iter.HasNext do - begin - IniInfo := Iter.Next; - LoadHeader(Dir.Append(IniInfo.Name)); - end; -end; - -procedure TSkin.LoadHeader(FileName: IPath); -var - SkinIni: TMemIniFile; - S: integer; -begin - SkinIni := TMemIniFile.Create(FileName.ToNative); - - S := Length(Skin); - SetLength(Skin, S+1); - - Skin[S].Path := FileName.GetPath; - Skin[S].FileName := FileName.GetName; - Skin[S].Theme := SkinIni.ReadString('Skin', 'Theme', ''); - Skin[S].Name := SkinIni.ReadString('Skin', 'Name', ''); - Skin[S].Creator := SkinIni.ReadString('Skin', 'Creator', ''); - - SkinIni.Free; -end; - -procedure TSkin.LoadSkin(Name: string); -var - SkinIni: TMemIniFile; - SL: TStringList; - T: integer; - S: integer; -begin - S := GetSkinNumber(Name); - SkinPath := Skin[S].Path; - - SkinIni := TMemIniFile.Create(SkinPath.Append(Skin[S].FileName).ToNative); - - SL := TStringList.Create; - SkinIni.ReadSection('Textures', SL); - - SetLength(SkinTexture, SL.Count); - for T := 0 to SL.Count-1 do - begin - SkinTexture[T].Name := SL.Strings[T]; - SkinTexture[T].FileName := Path(SkinIni.ReadString('Textures', SL.Strings[T], '')); - end; - - SL.Free; - SkinIni.Free; -end; - -function TSkin.GetTextureFileName(TextureName: string): IPath; -var - T: integer; -begin - Result := PATH_NONE; - - for T := 0 to High(SkinTexture) do - begin - if (SkinTexture[T].Name = TextureName) and - (SkinTexture[T].FileName.IsSet) then - begin - Result := SkinPath.Append(SkinTexture[T].FileName); - end; - end; - - if (TextureName <> '') and (Result.IsSet) then - begin - //Log.LogError('', '-----------------------------------------'); - //Log.LogError(TextureName+' - '+ Result, 'TSkin.GetTextureFileName'); - end; - -{ Result := SkinPath + 'Bar.jpg'; - if TextureName = 'Ball' then - Result := SkinPath + 'Ball.bmp'; - if Copy(TextureName, 1, 4) = 'Gray' then - Result := SkinPath + 'Ball.bmp'; - if Copy(TextureName, 1, 6) = 'NoteBG' then - Result := SkinPath + 'Ball.bmp';} -end; - -function TSkin.GetSkinNumber(Name: string): integer; -var - S: integer; -begin - Result := 0; // set default to the first available skin - for S := 0 to High(Skin) do - if Skin[S].Name = Name then - Result := S; -end; - -procedure TSkin.onThemeChange; -var - S: integer; - Name: String; -begin - Ini.SkinNo:=0; - SetLength(ISkin, 0); - Name := Uppercase(ITheme[Ini.Theme]); - for S := 0 to High(Skin) do - if Name = Uppercase(Skin[S].Theme) then - begin - SetLength(ISkin, Length(ISkin)+1); - ISkin[High(ISkin)] := Skin[S].Name; - end; - -end; - -end. diff --git a/src/base/USong.pas b/src/base/USong.pas deleted file mode 100644 index 705206c4..00000000 --- a/src/base/USong.pas +++ /dev/null @@ -1,1348 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit USong; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - {$IFDEF MSWINDOWS} - Windows, - {$ELSE} - {$IFNDEF DARWIN} - syscall, - {$ENDIF} - baseunix, - UnixType, - {$ENDIF} - SysUtils, - Classes, - UPlatform, - ULog, - UTexture, - UCommon, - {$IFDEF DARWIN} - cthreads, - {$ENDIF} - {$IFDEF USE_PSEUDO_THREAD} - PseudoThread, - {$ENDIF} - UCatCovers, - UXMLSong, - UUnicodeUtils, - UTextEncoding, - UFilesystem, - UPath; - -type - - TSingMode = ( smNormal, smPartyMode, smPlaylistRandom ); - - TBPM = record - BPM: real; - StartBeat: real; - end; - - TScore = record - Name: UTF8String; - Score: integer; - Date: UTF8String; - end; - - { used to hold header tags that are not supported by this version of - usdx (e.g. some tags from ultrastar 0.7.0) when songs are loaded in - songeditor. They will be written the end of the song header } - TCustomHeaderTag = record - Tag: UTF8String; - Content: UTF8String; - end; - - TSong = class - private - FileLineNo : integer; // line, which is read last, for error reporting - - function DecodeFilename(Filename: RawByteString): IPath; - function Solmizate(Note: integer; Type_: integer): string; - procedure ParseNote(LineNumber: integer; TypeP: char; StartP, DurationP, NoteP: integer; LyricS: UTF8String); - procedure NewSentence(LineNumberP: integer; Param1, Param2: integer); - - function ParseLyricStringParam(const Line: RawByteString; var LinePos: integer): RawByteString; - function ParseLyricIntParam(const Line: RawByteString; var LinePos: integer): integer; - function ParseLyricFloatParam(const Line: RawByteString; var LinePos: integer): extended; - function ParseLyricCharParam(const Line: RawByteString; var LinePos: integer): AnsiChar; - function ParseLyricText(const Line: RawByteString; var LinePos: integer): RawByteString; - - function ReadTXTHeader(SongFile: TTextFileStream; ReadCustomTags: Boolean): boolean; - function ReadXMLHeader(const aFileName: IPath): boolean; - - function GetFolderCategory(const aFileName: IPath): UTF8String; - function FindSongFile(Dir: IPath; Mask: UTF8String): IPath; - public - Path: IPath; // kust path component of file (only set if file was found) - Folder: UTF8String; // for sorting by folder (only set if file was found) - FileName: IPath; // just name component of file (only set if file was found) - - // filenames - Cover: IPath; - Mp3: IPath; - Background: IPath; - Video: IPath; - - // sorting methods - Genre: UTF8String; - Edition: UTF8String; - Language: UTF8String; - Year: Integer; - - Title: UTF8String; - Artist: UTF8String; - - Creator: UTF8String; - - CoverTex: TTexture; - - VideoGAP: real; - NotesGAP: integer; - Start: real; // in seconds - Finish: integer; // in miliseconds - Relative: boolean; - Resolution: integer; - BPM: array of TBPM; - GAP: real; // in miliseconds - - Encoding: TEncoding; - - CustomTags: array of TCustomHeaderTag; - - Score: array[0..2] of array of TScore; - - // these are used when sorting is enabled - Visible: boolean; // false if hidden, true if visible - Main: boolean; // false for songs, true for category buttons - OrderNum: integer; // has a number of category for category buttons and songs - OrderTyp: integer; // type of sorting for this button (0=name) - CatNumber: integer; // Count of Songs in Category for Cats and Number of Song in Category for Songs - - Base : array[0..1] of integer; - Rel : array[0..1] of integer; - Mult : integer; - MultBPM : integer; - - LastError: AnsiString; - function GetErrorLineNo: integer; - property ErrorLineNo: integer read GetErrorLineNo; - - - constructor Create(); overload; - constructor Create(const aFileName : IPath); overload; - function LoadSong: boolean; - function LoadXMLSong: boolean; - function Analyse(const ReadCustomTags: Boolean = false): boolean; - function AnalyseXML(): boolean; - procedure Clear(); - end; - -implementation - -uses - StrUtils, - TextGL, - UIni, - UPathUtils, - UMusic, //needed for Lines - UNote; //needed for Player - -const - DEFAULT_ENCODING = encAuto; - -constructor TSong.Create(); -begin - inherited; - - // to-do : special create for category "songs" - //dirty fix to fix folders=on - Self.Path := PATH_NONE(); - Self.FileName := PATH_NONE(); - Self.Cover := PATH_NONE(); - Self.Mp3 := PATH_NONE(); - Self.Background:= PATH_NONE(); - Self.Video := PATH_NONE(); -end; - -// This may be changed, when we rewrite song select code. -// it is some kind of dirty, but imho the best possible -// solution as we do atm not support nested categorys. -// it works like the folder sorting in 1.0.1a -// folder is set to the first folder under the songdir -// so songs ~/.ultrastardx/songs/punk is in the same -// category as songs in shared/ultrastardx/songs are. -// note: folder is just the name of a category it has -// nothing to do with the path used for file loading -function TSong.GetFolderCategory(const aFileName: IPath): UTF8String; -var - I: Integer; - CurSongPath: IPath; - CurSongPathRel: IPath; -begin - Result := 'Unknown'; //default folder category, if we can't locate the song dir - - for I := 0 to SongPaths.Count-1 do - begin - CurSongPath := SongPaths[I] as IPath; - if (aFileName.IsChildOf(CurSongPath, false)) then - begin - if (aFileName.IsChildOf(CurSongPath, true)) then - begin - // songs are in the "root" of the songdir => use songdir for the categorys name - Result := CurSongPath.RemovePathDelim.ToUTF8; - end - else - begin - // use the first subdirectory below CurSongPath as the category name - CurSongPathRel := aFileName.GetRelativePath(CurSongPath.AppendPathDelim); - Result := CurSongPathRel.SplitDirs[0].RemovePathDelim.ToUTF8; - end; - Exit; - end; - end; -end; - -constructor TSong.Create(const aFileName: IPath); -begin - inherited Create(); - - Mult := 1; - MultBPM := 4; - - LastError := ''; - - Self.Path := aFileName.GetPath; - Self.FileName := aFileName.GetName; - Self.Folder := GetFolderCategory(aFileName); - - (* - if (aFileName.IsFile) then - begin - if ReadTXTHeader(aFileName) then - begin - LoadSong(); - end - else - begin - Log.LogError('Error Loading SongHeader, abort Song Loading'); - Exit; - end; - end; - *) -end; - -function TSong.FindSongFile(Dir: IPath; Mask: UTF8String): IPath; -var - Iter: IFileIterator; - FileInfo: TFileInfo; - FileName: IPath; -begin - Iter := FileSystem.FileFind(Dir.Append(Mask), faDirectory); - if (Iter.HasNext) then - Result := Iter.Next.Name - else - Result := PATH_NONE; -end; - -function TSong.DecodeFilename(Filename: RawByteString): IPath; -begin - Result := UPath.Path(DecodeStringUTF8(Filename, Encoding)); -end; - -type - EUSDXParseException = class(Exception); - -{** - * Parses the Line string starting from LinePos for a parameter. - * Leading whitespace is trimmed, same applies to the first trailing whitespace. - * After the call LinePos will point to the position after the first trailing - * whitespace. - * - * Raises an EUSDXParseException if no string was found. - * - * Example: - * ParseLyricParam(Line:'Param0 Param1 Param2', LinePos:8, ...) - * -> Param:'Param1', LinePos:16 (= start of 'Param2') - *} -function TSong.ParseLyricStringParam(const Line: RawByteString; var LinePos: integer): RawByteString; -var - Start: integer; - OldLinePos: integer; -const - Whitespace = [#9, ' ']; -begin - OldLinePos := LinePos; - - Start := 0; - while (LinePos <= Length(Line)) do - begin - if (Line[LinePos] in Whitespace) then - begin - // check for end of param - if (Start > 0) then - Break; - end - // check for beginning of param - else if (Start = 0) then - begin - Start := LinePos; - end; - Inc(LinePos); - end; - - // check if param was found - if (Start = 0) then - begin - LinePos := OldLinePos; - raise EUSDXParseException.Create('String expected'); - end - else - begin - // copy param without trailing whitespace - Result := Copy(Line, Start, LinePos-Start); - // skip first trailing whitespace (if not at EOL) - if (LinePos <= Length(Line)) then - Inc(LinePos); - end; -end; - -function TSong.ParseLyricIntParam(const Line: RawByteString; var LinePos: integer): integer; -var - Str: RawByteString; - OldLinePos: integer; -begin - OldLinePos := LinePos; - Str := ParseLyricStringParam(Line, LinePos); - - if not TryStrToInt(Str, Result) then - begin // on convert error - Result := 0; - LinePos := OldLinePos; - raise EUSDXParseException.Create('Integer expected'); - end; -end; - -function TSong.ParseLyricFloatParam(const Line: RawByteString; var LinePos: integer): extended; -var - Str: RawByteString; - OldLinePos: integer; -begin - OldLinePos := LinePos; - Str := ParseLyricStringParam(Line, LinePos); - - if not TryStrToFloat(Str, Result) then - begin // on convert error - Result := 0; - LinePos := OldLinePos; - raise EUSDXParseException.Create('Float expected'); - end; -end; - -function TSong.ParseLyricCharParam(const Line: RawByteString; var LinePos: integer): AnsiChar; -var - Str: RawByteString; - OldLinePos: integer; -begin - OldLinePos := LinePos; - Str := ParseLyricStringParam(Line, LinePos); - if (Length(Str) <> 1) then - begin - { to-do : decide what to do here - usdx < 1.1 does not nead a whitespace after a char param - so we may just write a warning to error.log and use the - first non whitespace character instead of raising an - exception that causes the song not to load. So the more - error resistant code is: - LinePos := OldLinePos + 1; - // raise EUSDXParseException.Create('Character expected'); } - LinePos := OldLinePos; - raise EUSDXParseException.Create('Character expected'); - end; - Result := Str[1]; -end; - -{** - * Returns the rest of the line from LinePos as lyric text. - * Leading and trailing whitespace is not trimmed. - *} -function TSong.ParseLyricText(const Line: RawByteString; var LinePos: integer): RawByteString; -begin - if (LinePos > Length(Line)) then - Result := '' - else - begin - Result := Copy(Line, LinePos, Length(Line)-LinePos+1); - LinePos := Length(Line)+1; - end; -end; - -//Load TXT Song -function TSong.LoadSong(): boolean; -var - CurLine: RawByteString; - LinePos: integer; - Count: integer; - Both: boolean; - - Param0: AnsiChar; - Param1: integer; - Param2: integer; - Param3: integer; - ParamLyric: UTF8String; - - I: integer; - NotesFound: boolean; - SongFile: TTextFileStream; - FileNamePath: IPath; -begin - Result := false; - LastError := ''; - - FileNamePath := Path.Append(FileName); - if not FileNamePath.IsFile() then - begin - LastError := 'ERROR_CORRUPT_SONG_FILE_NOT_FOUND'; - Log.LogError('File not found: "' + FileNamePath.ToNative + '"', 'TSong.LoadSong()'); - Exit; - end; - - MultBPM := 4; // multiply beat-count of note by 4 - Mult := 1; // accuracy of measurement of note - Rel[0] := 0; - Both := false; - - if Length(Player) = 2 then - Both := true; - - try - // Open song file for reading..... - SongFile := TMemTextFileStream.Create(FileNamePath, fmOpenRead); - try - //Search for Note Beginning - FileLineNo := 0; - NotesFound := false; - while (SongFile.ReadLine(CurLine)) do - begin - Inc(FileLineNo); - if (Length(CurLine) > 0) and (CurLine[1] in [':', 'F', '*']) then - begin - NotesFound := true; - Break; - end; - end; - - if (not NotesFound) then - begin //Song File Corrupted - No Notes - Log.LogError('Could not load txt File, no notes found: ' + FileNamePath.ToNative); - LastError := 'ERROR_CORRUPT_SONG_NO_NOTES'; - Exit; - end; - - SetLength(Lines, 2); - for Count := 0 to High(Lines) do - begin - Lines[Count].High := 0; - Lines[Count].Number := 1; - Lines[Count].Current := 0; - Lines[Count].Resolution := self.Resolution; - Lines[Count].NotesGAP := self.NotesGAP; - Lines[Count].ScoreValue := 0; - - //Add first line and set some standard values to fields - //see procedure NewSentence for further explantation - //concerning most of these values - SetLength(Lines[Count].Line, 1); - Lines[Count].Line[0].HighNote := -1; - Lines[Count].Line[0].LastLine := false; - Lines[Count].Line[0].BaseNote := High(Integer); - Lines[Count].Line[0].TotalNotes := 0; - end; - - while true do - begin - LinePos := 1; - - Param0 := ParseLyricCharParam(CurLine, LinePos); - if (Param0 = 'E') then - begin - Break - end - else if (Param0 in [':', '*', 'F']) then - begin - // read notes - Param1 := ParseLyricIntParam(CurLine, LinePos); - Param2 := ParseLyricIntParam(CurLine, LinePos); - Param3 := ParseLyricIntParam(CurLine, LinePos); - ParamLyric := ParseLyricText(CurLine, LinePos); - - //Check for ZeroNote - if Param2 = 0 then - Log.LogWarn(Format('"%s" in line %d: %s', - [FileNamePath.ToNative, FileLineNo, 'found note with length zero -> note ignored']), 'TSong.LoadSong') - //Log.LogError('Found zero-length note at "'+Param0+' '+IntToStr(Param1)+' '+IntToStr(Param2)+' '+IntToStr(Param3)+ParamLyric+'" -> Note ignored!') - else - begin - // add notes - if not Both then - // P1 - ParseNote(0, Param0, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamLyric) - else - begin - // P1 + P2 - ParseNote(0, Param0, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamLyric); - ParseNote(1, Param0, (Param1+Rel[1]) * Mult, Param2 * Mult, Param3, ParamLyric); - end; - end; //Zeronote check - end // if - - else if Param0 = '-' then - begin - // reads sentence - Param1 := ParseLyricIntParam(CurLine, LinePos); - if self.Relative then - Param2 := ParseLyricIntParam(CurLine, LinePos); // read one more data for relative system - - // new sentence - if not Both then - // P1 - NewSentence(0, (Param1 + Rel[0]) * Mult, Param2) - else - begin - // P1 + P2 - NewSentence(0, (Param1 + Rel[0]) * Mult, Param2); - NewSentence(1, (Param1 + Rel[1]) * Mult, Param2); - end; - end // if - - else if Param0 = 'B' then - begin - SetLength(self.BPM, Length(self.BPM) + 1); - self.BPM[High(self.BPM)].StartBeat := ParseLyricFloatParam(CurLine, LinePos); - self.BPM[High(self.BPM)].StartBeat := self.BPM[High(self.BPM)].StartBeat + Rel[0]; - - self.BPM[High(self.BPM)].BPM := ParseLyricFloatParam(CurLine, LinePos); - self.BPM[High(self.BPM)].BPM := self.BPM[High(self.BPM)].BPM * Mult * MultBPM; - end; - - // Read next line in File - if (not SongFile.ReadLine(CurLine)) then - Break; - - Inc(FileLineNo); - end; // while - finally - SongFile.Free; - end; - except - on E: Exception do - begin - Log.LogError(Format('Error loading file: "%s" in line %d,%d: %s', - [FileNamePath.ToNative, FileLineNo, LinePos, E.Message])); - Exit; - end; - end; - - for I := 0 to High(Lines) do - begin - if ((Both) or (I = 0)) then - begin - if (Length(Lines[I].Line) < 2) then - begin - LastError := 'ERROR_CORRUPT_SONG_NO_BREAKS'; - Log.LogError('Error loading file: Can''t find any linebreaks in "' + FileNamePath.ToNative + '"'); - exit; - end; - - if (Lines[I].Line[Lines[I].High].HighNote < 0) then - begin - SetLength(Lines[I].Line, Lines[I].Number - 1); - Lines[I].High := Lines[I].High - 1; - Lines[I].Number := Lines[I].Number - 1; - Log.LogError('Error loading Song, sentence w/o note found in last line before E: ' + FileNamePath.ToNative); - end; - end; - end; - - for Count := 0 to High(Lines) do - begin - if (High(Lines[Count].Line) >= 0) then - Lines[Count].Line[High(Lines[Count].Line)].LastLine := true; - end; - - Result := true; -end; - -//Load XML Song -function TSong.LoadXMLSong(): boolean; -var - Count: integer; - Both: boolean; - Param1: integer; - Param2: integer; - Param3: integer; - ParamS: string; - I, J: integer; - NoteIndex: integer; - - NoteType: char; - SentenceEnd, Rest, Time: integer; - Parser: TParser; - FileNamePath: IPath; -begin - Result := false; - LastError := ''; - - FileNamePath := Path.Append(FileName); - if not FileNamePath.IsFile() then - begin - Log.LogError('File not found: "' + FileNamePath.ToNative + '"', 'TSong.LoadSong()'); - exit; - end; - - MultBPM := 4; // multiply beat-count of note by 4 - Mult := 1; // accuracy of measurement of note - Lines[0].ScoreValue := 0; - self.Relative := false; - Rel[0] := 0; - Both := false; - - if Length(Player) = 2 then - Both := true; - - Parser := TParser.Create; - Parser.Settings.DashReplacement := '~'; - - for Count := 0 to High(Lines) do - begin - Lines[Count].High := 0; - Lines[Count].Number := 1; - Lines[Count].Current := 0; - Lines[Count].Resolution := self.Resolution; - Lines[Count].NotesGAP := self.NotesGAP; - Lines[Count].ScoreValue := 0; - - //Add first line and set some standard values to fields - //see procedure NewSentence for further explantation - //concerning most of these values - SetLength(Lines[Count].Line, 1); - Lines[Count].Line[0].HighNote := -1; - Lines[Count].Line[0].LastLine := false; - Lines[Count].Line[0].BaseNote := High(Integer); - Lines[Count].Line[0].TotalNotes := 0; - end; - - //Try to Parse the Song - - if Parser.ParseSong(FileNamePath) then - begin - //Writeln('XML Inputfile Parsed succesful'); - - //Start write parsed information to Song - //Notes Part - for I := 0 to High(Parser.SongInfo.Sentences) do - begin - //Add Notes - for J := 0 to High(Parser.SongInfo.Sentences[I].Notes) do - begin - case Parser.SongInfo.Sentences[I].Notes[J].NoteTyp of - NT_Normal: NoteType := ':'; - NT_Golden: NoteType := '*'; - NT_Freestyle: NoteType := 'F'; - end; - - Param1:=Parser.SongInfo.Sentences[I].Notes[J].Start; //Note Start - Param2:=Parser.SongInfo.Sentences[I].Notes[J].Duration; //Note Duration - Param3:=Parser.SongInfo.Sentences[I].Notes[J].Tone; //Note Tone - ParamS:=' ' + Parser.SongInfo.Sentences[I].Notes[J].Lyric; //Note Lyric - - if not Both then - // P1 - ParseNote(0, NoteType, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamS) - else - begin - // P1 + P2 - ParseNote(0, NoteType, (Param1+Rel[0]) * Mult, Param2 * Mult, Param3, ParamS); - ParseNote(1, NoteType, (Param1+Rel[1]) * Mult, Param2 * Mult, Param3, ParamS); - end; - - end; //J Forloop - - //Add Sentence break - if (I < High(Parser.SongInfo.Sentences)) then - begin - SentenceEnd := Parser.SongInfo.Sentences[I].Notes[High(Parser.SongInfo.Sentences[I].Notes)].Start + Parser.SongInfo.Sentences[I].Notes[High(Parser.SongInfo.Sentences[I].Notes)].Duration; - Rest := Parser.SongInfo.Sentences[I+1].Notes[0].Start - SentenceEnd; - - //Calculate Time - case Rest of - 0, 1: Time := Parser.SongInfo.Sentences[I+1].Notes[0].Start; - 2: Time := Parser.SongInfo.Sentences[I+1].Notes[0].Start - 1; - 3: Time := Parser.SongInfo.Sentences[I+1].Notes[0].Start - 2; - else - if (Rest >= 4) then - Time := SentenceEnd + 2 - else //Sentence overlapping :/ - Time := Parser.SongInfo.Sentences[I+1].Notes[0].Start; - end; - // new sentence - if not Both then // P1 - NewSentence(0, (Time + Rel[0]) * Mult, Param2) - else - begin // P1 + P2 - NewSentence(0, (Time + Rel[0]) * Mult, Param2); - NewSentence(1, (Time + Rel[1]) * Mult, Param2); - end; - - end; - end; - //End write parsed information to Song - Parser.Free; - end - else - begin - Log.LogError('Could not parse inputfile: ' + FileNamePath.ToNative); - exit; - end; - - for Count := 0 to High(Lines) do - begin - Lines[Count].Line[High(Lines[Count].Line)].LastLine := true; - end; - - Result := true; -end; - -function TSong.ReadXMLHeader(const aFileName : IPath): boolean; -var - Done : byte; - Parser : TParser; - FileNamePath: IPath; -begin - Result := true; - Done := 0; - - //Parse XML - Parser := TParser.Create; - Parser.Settings.DashReplacement := '~'; - - FileNamePath := Self.Path.Append(Self.FileName); - if Parser.ParseSong(FileNamePath) then - begin - //----------- - //Required Attributes - //----------- - - //Title - self.Title := Parser.SongInfo.Header.Title; - - //Add Title Flag to Done - Done := Done or 1; - - //Artist - self.Artist := Parser.SongInfo.Header.Artist; - - //Add Artist Flag to Done - Done := Done or 2; - - //MP3 File //Test if Exists - Self.Mp3 := FindSongFile(Self.Path, '*.mp3'); - //Add Mp3 Flag to Done - if (Self.Path.Append(Self.Mp3).IsFile()) then - Done := Done or 4; - - //Beats per Minute - SetLength(self.BPM, 1); - self.BPM[0].StartBeat := 0; - - self.BPM[0].BPM := (Parser.SongInfo.Header.BPM * Parser.SongInfo.Header.Resolution/4 ) * Mult * MultBPM; - - //Add BPM Flag to Done - if self.BPM[0].BPM <> 0 then - Done := Done or 8; - - //--------- - //Additional Header Information - //--------- - - // Gap - self.GAP := Parser.SongInfo.Header.Gap; - - //Cover Picture - self.Cover := FindSongFile(Path, '*[CO].jpg'); - - //Background Picture - self.Background := FindSongFile(Path, '*[BG].jpg'); - - // Video File - // self.Video := Value - - // Video Gap - // self.VideoGAP := StrtoFloatI18n( Value ) - - //Genre Sorting - self.Genre := Parser.SongInfo.Header.Genre; - - //Edition Sorting - self.Edition := Parser.SongInfo.Header.Edition; - - //Year Sorting - //Parser.SongInfo.Header.Year - - //Language Sorting - self.Language := Parser.SongInfo.Header.Language; - end - else - Log.LogError('File incomplete or not SingStar XML (A): ' + aFileName.ToNative); - - Parser.Free; - - //Check if all Required Values are given - if (Done <> 15) then - begin - Result := false; - if (Done and 8) = 0 then //No BPM Flag - Log.LogError('BPM tag missing: ' + self.FileName.ToNative) - else if (Done and 4) = 0 then //No MP3 Flag - Log.LogError('MP3 tag/file missing: ' + self.FileName.ToNative) - else if (Done and 2) = 0 then //No Artist Flag - Log.LogError('Artist tag missing: ' + self.FileName.ToNative) - else if (Done and 1) = 0 then //No Title Flag - Log.LogError('Title tag missing: ' + self.FileName.ToNative) - else //unknown Error - Log.LogError('File incomplete or not SingStar XML (B - '+ inttostr(Done) +'): ' + aFileName.ToNative); - end; - -end; - -{** - * "International" StrToFloat variant. Uses either ',' or '.' as decimal - * separator. - *} -function StrToFloatI18n(const Value: string): extended; -var - TempValue : string; -begin - TempValue := Value; - if (Pos(',', TempValue) <> 0) then - TempValue[Pos(',', TempValue)] := '.'; - Result := StrToFloatDef(TempValue, 0); -end; - -function TSong.ReadTXTHeader(SongFile: TTextFileStream; ReadCustomTags: Boolean): boolean; -var - Line, Identifier: string; - Value: string; - SepPos: integer; // separator position - Done: byte; // bit-vector of mandatory fields - EncFile: IPath; // encoded filename - FullFileName: string; - - { adds a custom header tag to the song - if there is no ':' in the read line, Tag should be empty - and the whole line should be in Content } - procedure AddCustomTag(const Tag, Content: String); - var Len: Integer; - begin - if ReadCustomTags then - begin - Len := Length(CustomTags); - SetLength(CustomTags, Len + 1); - CustomTags[Len].Tag := DecodeStringUTF8(Tag, Encoding); - CustomTags[Len].Content := DecodeStringUTF8(Content, Encoding); - end; - end; -begin - Result := true; - Done := 0; - - FullFileName := Path.Append(Filename).ToNative; - - //Read first Line - SongFile.ReadLine(Line); - if (Length(Line) <= 0) then - begin - Log.LogError('File starts with empty line: ' + FullFileName, - 'TSong.ReadTXTHeader'); - Result := false; - Exit; - end; - - // check if file begins with a UTF-8 BOM, if so set encoding to UTF-8 - if (CheckReplaceUTF8BOM(Line)) then - Encoding := encUTF8; - - //Read Lines while Line starts with # or its empty - while (Length(Line) = 0) or (Line[1] = '#') do - begin - //Increase Line Number - Inc (FileLineNo); - SepPos := Pos(':', Line); - - //Line has no Seperator, ignore non header field - if (SepPos = 0) then - begin - AddCustomTag('', Copy(Line, 2, Length(Line) - 1)); - // read next line - if (not SongFile.ReadLine(Line)) then - begin - Result := false; - Log.LogError('File incomplete or not Ultrastar txt (A): ' + FullFileName); - Break; - end; - Continue; - end; - - //Read Identifier and Value - Identifier := UpperCase(Trim(Copy(Line, 2, SepPos - 2))); //Uppercase is for Case Insensitive Checks - Value := Trim(Copy(Line, SepPos + 1, Length(Line) - SepPos)); - - //Check the Identifier (If Value is given) - if (Length(Value) = 0) then - begin - Log.LogWarn('Empty field "'+Identifier+'" in file ' + FullFileName, - 'TSong.ReadTXTHeader'); - AddCustomTag(Identifier, ''); - end - else - begin - - //----------- - //Required Attributes - //----------- - - if (Identifier = 'TITLE') then - begin - DecodeStringUTF8(Value, Title, Encoding); - //Add Title Flag to Done - Done := Done or 1; - end - - else if (Identifier = 'ARTIST') then - begin - DecodeStringUTF8(Value, Artist, Encoding); - //Add Artist Flag to Done - Done := Done or 2; - end - - //MP3 File - else if (Identifier = 'MP3') then - begin - EncFile := DecodeFilename(Value); - if (Self.Path.Append(EncFile).IsFile) then - begin - self.Mp3 := EncFile; - - //Add Mp3 Flag to Done - Done := Done or 4; - end; - end - - //Beats per Minute - else if (Identifier = 'BPM') then - begin - SetLength(self.BPM, 1); - self.BPM[0].StartBeat := 0; - - self.BPM[0].BPM := StrToFloatI18n( Value ) * Mult * MultBPM; - - if self.BPM[0].BPM <> 0 then - begin - //Add BPM Flag to Done - Done := Done or 8; - end; - end - - //--------- - //Additional Header Information - //--------- - - // Gap - else if (Identifier = 'GAP') then - begin - self.GAP := StrToFloatI18n(Value); - end - - //Cover Picture - else if (Identifier = 'COVER') then - begin - self.Cover := DecodeFilename(Value); - end - - //Background Picture - else if (Identifier = 'BACKGROUND') then - begin - self.Background := DecodeFilename(Value); - end - - // Video File - else if (Identifier = 'VIDEO') then - begin - EncFile := DecodeFilename(Value); - if (self.Path.Append(EncFile).IsFile) then - self.Video := EncFile - else - Log.LogError('Can''t find video file in song: ' + FullFileName); - end - - // Video Gap - else if (Identifier = 'VIDEOGAP') then - begin - self.VideoGAP := StrToFloatI18n( Value ) - end - - //Genre Sorting - else if (Identifier = 'GENRE') then - begin - DecodeStringUTF8(Value, Genre, Encoding) - end - - //Edition Sorting - else if (Identifier = 'EDITION') then - begin - DecodeStringUTF8(Value, Edition, Encoding) - end - - //Creator Tag - else if (Identifier = 'CREATOR') then - begin - DecodeStringUTF8(Value, Creator, Encoding) - end - - //Language Sorting - else if (Identifier = 'LANGUAGE') then - begin - DecodeStringUTF8(Value, Language, Encoding) - end - - //Language Sorting - else if (Identifier = 'YEAR') then - begin - TryStrtoInt(Value, self.Year) - end - - // Song Start - else if (Identifier = 'START') then - begin - self.Start := StrToFloatI18n( Value ) - end - - // Song Ending - else if (Identifier = 'END') then - begin - TryStrtoInt(Value, self.Finish) - end - - // Resolution - else if (Identifier = 'RESOLUTION') then - begin - TryStrtoInt(Value, self.Resolution) - end - - // Notes Gap - else if (Identifier = 'NOTESGAP') then - begin - TryStrtoInt(Value, self.NotesGAP) - end - - // Relative Notes - else if (Identifier = 'RELATIVE') then - begin - if (UpperCase(Value) = 'YES') then - self.Relative := true; - end - - // File encoding - else if (Identifier = 'ENCODING') then - begin - self.Encoding := ParseEncoding(Value, DEFAULT_ENCODING); - end - - // unsupported tag - else - begin - AddCustomTag(Identifier, Value); - end; - - end; // End check for non-empty Value - - // read next line - if (not SongFile.ReadLine(Line)) then - begin - Result := false; - Log.LogError('File incomplete or not Ultrastar txt (A): ' + FullFileName); - Break; - end; - end; // while - - if self.Cover.IsUnset then - self.Cover := FindSongFile(Path, '*[CO].jpg'); - - //Check if all Required Values are given - if (Done <> 15) then - begin - Result := false; - if (Done and 8) = 0 then //No BPM Flag - Log.LogError('BPM tag missing: ' + FullFileName) - else if (Done and 4) = 0 then //No MP3 Flag - Log.LogError('MP3 tag/file missing: ' + FullFileName) - else if (Done and 2) = 0 then //No Artist Flag - Log.LogError('Artist tag missing: ' + FullFileName) - else if (Done and 1) = 0 then //No Title Flag - Log.LogError('Title tag missing: ' + FullFileName) - else //unknown Error - Log.LogError('File incomplete or not Ultrastar txt (B - '+ inttostr(Done) +'): ' + FullFileName); - end; -end; - -function TSong.GetErrorLineNo: integer; -begin - if (LastError='ERROR_CORRUPT_SONG_ERROR_IN_LINE') then - Result := FileLineNo - else - Result := -1; -end; - -function TSong.Solmizate(Note: integer; Type_: integer): string; -begin - case (Type_) of - 1: // european - begin - case (Note mod 12) of - 0..1: Result := ' do '; - 2..3: Result := ' re '; - 4: Result := ' mi '; - 5..6: Result := ' fa '; - 7..8: Result := ' sol '; - 9..10: Result := ' la '; - 11: Result := ' si '; - end; - end; - 2: // japanese - begin - case (Note mod 12) of - 0..1: Result := ' do '; - 2..3: Result := ' re '; - 4: Result := ' mi '; - 5..6: Result := ' fa '; - 7..8: Result := ' so '; - 9..10: Result := ' la '; - 11: Result := ' shi '; - end; - end; - 3: // american - begin - case (Note mod 12) of - 0..1: Result := ' do '; - 2..3: Result := ' re '; - 4: Result := ' mi '; - 5..6: Result := ' fa '; - 7..8: Result := ' sol '; - 9..10: Result := ' la '; - 11: Result := ' ti '; - end; - end; - end; // case -end; - -procedure TSong.ParseNote(LineNumber: integer; TypeP: char; StartP, DurationP, NoteP: integer; LyricS: UTF8String); -begin - if (Ini.Solmization <> 0) then - LyricS := Solmizate(NoteP, Ini.Solmization); - - with Lines[LineNumber].Line[Lines[LineNumber].High] do - begin - SetLength(Note, Length(Note) + 1); - HighNote := High(Note); - - Note[HighNote].Start := StartP; - if HighNote = 0 then - begin - if Lines[LineNumber].Number = 1 then - Start := -100; - //Start := Note[HighNote].Start; - end; - - Note[HighNote].Length := DurationP; - - // back to the normal system with normal, golden and now freestyle notes - case TypeP of - 'F': Note[HighNote].NoteType := ntFreestyle; - ':': Note[HighNote].NoteType := ntNormal; - '*': Note[HighNote].NoteType := ntGolden; - end; - - //add this notes value ("notes length" * "notes scorefactor") to the current songs entire value - Inc(Lines[LineNumber].ScoreValue, Note[HighNote].Length * ScoreFactor[Note[HighNote].NoteType]); - - //and to the current lines entire value - Inc(TotalNotes, Note[HighNote].Length * ScoreFactor[Note[HighNote].NoteType]); - - - Note[HighNote].Tone := NoteP; - - //if a note w/ a deeper pitch then the current basenote is found - //we replace the basenote w/ the current notes pitch - if Note[HighNote].Tone < BaseNote then - BaseNote := Note[HighNote].Tone; - - Note[HighNote].Color := 1; // default color to 1 for editor - - DecodeStringUTF8(LyricS, Note[HighNote].Text, Encoding); - Lyric := Lyric + Note[HighNote].Text; - - End_ := Note[HighNote].Start + Note[HighNote].Length; - end; // with -end; - -procedure TSong.NewSentence(LineNumberP: integer; Param1, Param2: integer); -var - I: integer; -begin - - if (Lines[LineNumberP].Line[Lines[LineNumberP].High].HighNote <> -1) then - begin //create a new line - SetLength(Lines[LineNumberP].Line, Lines[LineNumberP].Number + 1); - Inc(Lines[LineNumberP].High); - Inc(Lines[LineNumberP].Number); - end - else - begin //use old line if it there were no notes added since last call of NewSentence - Log.LogError('Error loading Song, sentence w/o note found in line ' + - InttoStr(FileLineNo) + ': ' + Filename.ToNative); - end; - - Lines[LineNumberP].Line[Lines[LineNumberP].High].HighNote := -1; - - //set the current lines value to zero - //it will be incremented w/ the value of every added note - Lines[LineNumberP].Line[Lines[LineNumberP].High].TotalNotes := 0; - - //basenote is the pitch of the deepest note, it is used for note drawing. - //if a note with a less value than the current sentences basenote is found, - //basenote will be set to this notes pitch. Therefore the initial value of - //this field has to be very high. - Lines[LineNumberP].Line[Lines[LineNumberP].High].BaseNote := High(Integer); - - - if self.Relative then - begin - Lines[LineNumberP].Line[Lines[LineNumberP].High].Start := Param1; - Rel[LineNumberP] := Rel[LineNumberP] + Param2; - end - else - Lines[LineNumberP].Line[Lines[LineNumberP].High].Start := Param1; - - Lines[LineNumberP].Line[Lines[LineNumberP].High].LastLine := false; -end; - -procedure TSong.Clear(); -begin - //Main Information - Title := ''; - Artist := ''; - - //Sortings: - Genre := 'Unknown'; - Edition := 'Unknown'; - Language := 'Unknown'; - Year := 0; - - // set to default encoding - Encoding := DEFAULT_ENCODING; - - // clear custom header tags - SetLength(CustomTags, 0); - - //Required Information - Mp3 := PATH_NONE; - SetLength(BPM, 0); - - GAP := 0; - Start := 0; - Finish := 0; - - //Additional Information - Background := PATH_NONE; - Cover := PATH_NONE; - Video := PATH_NONE; - VideoGAP := 0; - NotesGAP := 0; - Resolution := 4; - Creator := ''; - - Relative := false; -end; - -function TSong.Analyse(const ReadCustomTags: Boolean): boolean; -var - SongFile: TTextFileStream; -begin - Result := false; - - //Reset LineNo - FileLineNo := 0; - - //Open File and set File Pointer to the beginning - SongFile := TMemTextFileStream.Create(Self.Path.Append(Self.FileName), fmOpenRead); - try - //Clear old Song Header - Self.clear; - - //Read Header - Result := Self.ReadTxTHeader(SongFile, ReadCustomTags) - finally - SongFile.Free; - end; -end; - - -function TSong.AnalyseXML(): boolean; - -begin - Result := false; - - //Reset LineNo - FileLineNo := 0; - - //Clear old Song Header - self.clear; - - //Read Header - Result := self.ReadXMLHeader( FileName ); - -end; - -end. diff --git a/src/base/USongs.pas b/src/base/USongs.pas deleted file mode 100644 index baeec13a..00000000 --- a/src/base/USongs.pas +++ /dev/null @@ -1,845 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit USongs; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -{$IFDEF DARWIN} - {$IFDEF DEBUG} - {$DEFINE USE_PSEUDO_THREAD} - {$ENDIF} -{$ENDIF} - -uses - SysUtils, - Classes, - {$IFDEF MSWINDOWS} - Windows, - DirWatch, - {$ELSE} - {$IFNDEF DARWIN} - syscall, - {$ENDIF} - baseunix, - UnixType, - {$ENDIF} - UPlatform, - ULog, - UTexture, - UCommon, - {$IFDEF USE_PSEUDO_THREAD} - PseudoThread, - {$ENDIF} - UPath, - USong, - UCatCovers; - -type - TSongFilter = ( - fltAll, - fltTitle, - fltArtist - ); - - TBPM = record - BPM: real; - StartBeat: real; - end; - - TScore = record - Name: UTF8String; - Score: integer; - Length: string; - end; - - TPathDynArray = array of IPath; - - {$IFDEF USE_PSEUDO_THREAD} - TSongs = class(TPseudoThread) - {$ELSE} - TSongs = class(TThread) - {$ENDIF} - private - fNotify, fWatch: longint; - fParseSongDirectory: boolean; - fProcessing: boolean; - {$ifdef MSWINDOWS} - fDirWatch: TDirectoryWatch; - {$endif} - procedure int_LoadSongList; - procedure DoDirChanged(Sender: TObject); - protected - procedure Execute; override; - public - SongList: TList; // array of songs - Selected: integer; // selected song index - constructor Create(); - destructor Destroy(); override; - - - procedure LoadSongList; // load all songs - procedure FindFilesByExtension(const Dir: IPath; const Ext: IPath; Recursive: Boolean; var Files: TPathDynArray); - procedure BrowseDir(Dir: IPath); // should return number of songs in the future - procedure BrowseTXTFiles(Dir: IPath); - procedure BrowseXMLFiles(Dir: IPath); - procedure Sort(Order: integer); - property Processing: boolean read fProcessing; - end; - - - TCatSongs = class - Song: array of TSong; // array of categories with songs - Selected: integer; // selected song index - Order: integer; // order type (0=title) - CatNumShow: integer; // Category Number being seen - CatCount: integer; // Number of Categorys - - procedure SortSongs(); - procedure Refresh; // refreshes arrays by recreating them from Songs array - procedure ShowCategory(Index: integer); // expands all songs in category - procedure HideCategory(Index: integer); // hides all songs in category - procedure ClickCategoryButton(Index: integer); // uses ShowCategory and HideCategory when needed - procedure ShowCategoryList; // Hides all Songs And Show the List of all Categorys - function FindNextVisible(SearchFrom: integer): integer; // Find Next visible Song - function VisibleSongs: integer; // returns number of visible songs (for tabs) - function VisibleIndex(Index: integer): integer; // returns visible song index (skips invisible) - - function SetFilter(FilterStr: UTF8String; Filter: TSongFilter): cardinal; - end; - -var - Songs: TSongs; // all songs - CatSongs: TCatSongs; // categorized songs - -const - IN_ACCESS = $00000001; //* File was accessed */ - IN_MODIFY = $00000002; //* File was modified */ - IN_ATTRIB = $00000004; //* Metadata changed */ - IN_CLOSE_WRITE = $00000008; //* Writtable file was closed */ - IN_CLOSE_NOWRITE = $00000010; //* Unwrittable file closed */ - IN_OPEN = $00000020; //* File was opened */ - IN_MOVED_FROM = $00000040; //* File was moved from X */ - IN_MOVED_TO = $00000080; //* File was moved to Y */ - IN_CREATE = $00000100; //* Subfile was created */ - IN_DELETE = $00000200; //* Subfile was deleted */ - IN_DELETE_SELF = $00000400; //* Self was deleted */ - - -implementation - -uses - StrUtils, - UCovers, - UFiles, - UGraphic, - UMain, - UIni, - UPathUtils, - UNote, - UFilesystem, - UUnicodeUtils; - -constructor TSongs.Create(); -begin - // do not start thread BEFORE initialization (suspended = true) - inherited Create(true); - Self.FreeOnTerminate := true; - - SongList := TList.Create(); - - // FIXME: threaded loading does not work this way. - // It will just cause crashes but nothing else at the moment. -(* - {$ifdef MSWINDOWS} - fDirWatch := TDirectoryWatch.create(nil); - fDirWatch.OnChange := DoDirChanged; - fDirWatch.Directory := SongPath; - fDirWatch.WatchSubDirs := true; - fDirWatch.active := true; - {$ENDIF} - - // now we can start the thread - Resume(); -*) - - // until it is fixed, simply load the song-list - int_LoadSongList(); -end; - -destructor TSongs.Destroy(); -begin - FreeAndNil(SongList); - inherited; -end; - -procedure TSongs.DoDirChanged(Sender: TObject); -begin - LoadSongList(); -end; - -procedure TSongs.Execute(); -var - fChangeNotify: THandle; -begin -{$IFDEF USE_PSEUDO_THREAD} - int_LoadSongList(); -{$ELSE} - fParseSongDirectory := true; - - while not terminated do - begin - - if fParseSongDirectory then - begin - Log.LogStatus('Calling int_LoadSongList', 'TSongs.Execute'); - int_LoadSongList(); - end; - - Suspend(); - end; -{$ENDIF} -end; - -procedure TSongs.int_LoadSongList; -var - I: integer; -begin - try - fProcessing := true; - - Log.LogStatus('Searching For Songs', 'SongList'); - - // browse directories - for I := 0 to SongPaths.Count-1 do - BrowseDir(SongPaths[I] as IPath); - - if assigned(CatSongs) then - CatSongs.Refresh; - - if assigned(CatCovers) then - CatCovers.Load; - - //if assigned(Covers) then - // Covers.Load; - - if assigned(ScreenSong) then - begin - ScreenSong.GenerateThumbnails(); - ScreenSong.OnShow; // refresh ScreenSong - end; - - finally - Log.LogStatus('Search Complete', 'SongList'); - - fParseSongDirectory := false; - fProcessing := false; - end; -end; - - -procedure TSongs.LoadSongList; -begin - fParseSongDirectory := true; - Resume(); -end; - -procedure TSongs.BrowseDir(Dir: IPath); -begin - BrowseTXTFiles(Dir); - BrowseXMLFiles(Dir); -end; - -procedure TSongs.FindFilesByExtension(const Dir: IPath; const Ext: IPath; Recursive: Boolean; var Files: TPathDynArray); -var - Iter: IFileIterator; - FileInfo: TFileInfo; - FileName: IPath; -begin - // search for all files and directories - Iter := FileSystem.FileFind(Dir.Append('*'), faAnyFile); - while (Iter.HasNext) do - begin - FileInfo := Iter.Next; - FileName := FileInfo.Name; - if ((FileInfo.Attr and faDirectory) <> 0) then - begin - if Recursive and (not FileName.Equals('.')) and (not FileName.Equals('..')) then - FindFilesByExtension(Dir.Append(FileName), Ext, true, Files); - end - else - begin - if (Ext.Equals(FileName.GetExtension(), true)) then - begin - SetLength(Files, Length(Files)+1); - Files[High(Files)] := Dir.Append(FileName); - end; - end; - end; -end; - -procedure TSongs.BrowseTXTFiles(Dir: IPath); -var - I: integer; - Files: TPathDynArray; - Song: TSong; - Extension: IPath; -begin - SetLength(Files, 0); - Extension := Path('.txt'); - FindFilesByExtension(Dir, Extension, true, Files); - - for I := 0 to High(Files) do - begin - Song := TSong.Create(Files[I]); - - if Song.Analyse then - SongList.Add(Song) - else - begin - Log.LogError('AnalyseFile failed for "' + Files[I].ToNative + '".'); - FreeAndNil(Song); - end; - end; - - SetLength(Files, 0); -end; - -procedure TSongs.BrowseXMLFiles(Dir: IPath); -var - I: integer; - Files: TPathDynArray; - Song: TSong; - Extension: IPath; -begin - SetLength(Files, 0); - Extension := Path('.xml'); - FindFilesByExtension(Dir, Extension, true, Files); - - for I := 0 to High(Files) do - begin - Song := TSong.Create(Files[I]); - - if Song.AnalyseXML then - SongList.Add(Song) - else - begin - Log.LogError('AnalyseFile failed for "' + Files[I].ToNative + '".'); - FreeAndNil(Song); - end; - end; - - SetLength(Files, 0); -end; - -(* - * Comparison functions for sorting - *) - -function CompareByEdition(Song1, Song2: Pointer): integer; -begin - Result := UTF8CompareText(TSong(Song1).Edition, TSong(Song2).Edition); -end; - -function CompareByGenre(Song1, Song2: Pointer): integer; -begin - Result := UTF8CompareText(TSong(Song1).Genre, TSong(Song2).Genre); -end; - -function CompareByTitle(Song1, Song2: Pointer): integer; -begin - Result := UTF8CompareText(TSong(Song1).Title, TSong(Song2).Title); -end; - -function CompareByArtist(Song1, Song2: Pointer): integer; -begin - Result := UTF8CompareText(TSong(Song1).Artist, TSong(Song2).Artist); -end; - -function CompareByFolder(Song1, Song2: Pointer): integer; -begin - Result := UTF8CompareText(TSong(Song1).Folder, TSong(Song2).Folder); -end; - -function CompareByLanguage(Song1, Song2: Pointer): integer; -begin - Result := UTF8CompareText(TSong(Song1).Language, TSong(Song2).Language); -end; - -procedure TSongs.Sort(Order: integer); -var - CompareFunc: TListSortCompare; -begin - // FIXME: what is the difference between artist and artist2, etc.? - case Order of - sEdition: // by edition - CompareFunc := CompareByEdition; - sGenre: // by genre - CompareFunc := CompareByGenre; - sTitle: // by title - CompareFunc := CompareByTitle; - sArtist: // by artist - CompareFunc := CompareByArtist; - sFolder: // by folder - CompareFunc := CompareByFolder; - sArtist2: // by artist2 - CompareFunc := CompareByArtist; - sLanguage: // by Language - CompareFunc := CompareByLanguage; - else - Log.LogCritical('Unsupported comparison', 'TSongs.Sort'); - Exit; // suppress warning - end; // case - - // Note: Do not use TList.Sort() as it uses QuickSort which is instable. - // For example, if a list is sorted by title first and - // by artist afterwards, the songs of an artist will not be sorted by title anymore. - // The stable MergeSort guarantees to maintain this order. - MergeSort(SongList, CompareFunc); -end; - -procedure TCatSongs.SortSongs(); -begin - case Ini.Sorting of - sEdition: begin - Songs.Sort(sTitle); - Songs.Sort(sArtist); - Songs.Sort(sEdition); - end; - sGenre: begin - Songs.Sort(sTitle); - Songs.Sort(sArtist); - Songs.Sort(sGenre); - end; - sLanguage: begin - Songs.Sort(sTitle); - Songs.Sort(sArtist); - Songs.Sort(sLanguage); - end; - sFolder: begin - Songs.Sort(sTitle); - Songs.Sort(sArtist); - Songs.Sort(sFolder); - end; - sTitle: begin - Songs.Sort(sTitle); - end; - sArtist: begin - Songs.Sort(sTitle); - Songs.Sort(sArtist); - end; - sArtist2: begin - Songs.Sort(sTitle); - Songs.Sort(sArtist2); - end; - end; // case -end; - -procedure TCatSongs.Refresh; -var - SongIndex: integer; - CurSong: TSong; - CatIndex: integer; // index of current song in Song - Letter: UCS4Char; // current letter for sorting using letter - CurCategory: UTF8String; // current edition for sorting using edition, genre etc. - Order: integer; // number used for ordernum - LetterTmp: UCS4Char; - CatNumber: integer; // Number of Song in Category - - procedure AddCategoryButton(const CategoryName: UTF8String); - var - PrevCatBtnIndex: integer; - begin - Inc(Order); - CatIndex := Length(Song); - SetLength(Song, CatIndex+1); - Song[CatIndex] := TSong.Create(); - Song[CatIndex].Artist := '[' + CategoryName + ']'; - Song[CatIndex].Main := true; - Song[CatIndex].OrderTyp := 0; - Song[CatIndex].OrderNum := Order; - Song[CatIndex].Cover := CatCovers.GetCover(Ini.Sorting, CategoryName); - Song[CatIndex].Visible := true; - - // set number of songs in previous category - PrevCatBtnIndex := CatIndex - CatNumber - 1; - if ((PrevCatBtnIndex >= 0) and Song[PrevCatBtnIndex].Main) then - Song[PrevCatBtnIndex].CatNumber := CatNumber; - - CatNumber := 0; - end; - -begin - CatNumShow := -1; - - SortSongs(); - - CurCategory := ''; - Order := 0; - CatNumber := 0; - - // Note: do NOT set Letter to ' ', otherwise no category-button will be - // created for songs beginning with ' ' if songs of this category exist. - // TODO: trim song-properties so ' ' will not occur as first chararcter. - Letter := 0; - - // clear song-list - for SongIndex := 0 to Songs.SongList.Count - 1 do - begin - // free category buttons - // Note: do NOT delete songs, they are just references to Songs.SongList entries - CurSong := TSong(Songs.SongList[SongIndex]); - if (CurSong.Main) then - CurSong.Free; - end; - SetLength(Song, 0); - - for SongIndex := 0 to Songs.SongList.Count - 1 do - begin - CurSong := TSong(Songs.SongList[SongIndex]); - // if tabs are on, add section buttons for each new section - if (Ini.Tabs = 1) then - begin - case (Ini.Sorting) of - sEdition: begin - if (CompareText(CurCategory, CurSong.Edition) <> 0) then - begin - CurCategory := CurSong.Edition; - - // add Category Button - AddCategoryButton(CurCategory); - end; - end; - - sGenre: begin - if (CompareText(CurCategory, CurSong.Genre) <> 0) then - begin - CurCategory := CurSong.Genre; - // add Genre Button - AddCategoryButton(CurCategory); - end; - end; - - sLanguage: begin - if (CompareText(CurCategory, CurSong.Language) <> 0) then - begin - CurCategory := CurSong.Language; - // add Language Button - AddCategoryButton(CurCategory); - end - end; - - sTitle: begin - if (Length(CurSong.Title) >= 1) then - begin - LetterTmp := UCS4UpperCase(UTF8ToUCS4String(CurSong.Title)[0]); - { all numbers and some punctuation chars are put into a - category named '#' - we can't put the other punctuation chars into this category - because they are not in order, so there will be two different - categories named '#' } - if (LetterTmp in [Ord('!') .. Ord('?')]) then - LetterTmp := Ord('#') - else - LetterTmp := UCS4UpperCase(LetterTmp); - if (Letter <> LetterTmp) then - begin - Letter := LetterTmp; - // add a letter Category Button - AddCategoryButton(UCS4ToUTF8String(Letter)); - end; - end; - end; - - sArtist: begin - if (Length(CurSong.Artist) >= 1) then - begin - LetterTmp := UCS4UpperCase(UTF8ToUCS4String(CurSong.Artist)[0]); - { all numbers and some punctuation chars are put into a - category named '#' - we can't put the other punctuation chars into this category - because they are not in order, so there will be two different - categories named '#' } - if (LetterTmp in [Ord('!') .. Ord('?')]) then - LetterTmp := Ord('#') - else - LetterTmp := UCS4UpperCase(LetterTmp); - - if (Letter <> LetterTmp) then - begin - Letter := LetterTmp; - // add a letter Category Button - AddCategoryButton(UCS4ToUTF8String(Letter)); - end; - end; - end; - - sFolder: begin - if (UTF8CompareText(CurCategory, CurSong.Folder) <> 0) then - begin - CurCategory := CurSong.Folder; - // add folder tab - AddCategoryButton(CurCategory); - end; - end; - - sArtist2: begin - { this new sorting puts all songs by the same artist into - a single category } - if (UTF8CompareText(CurCategory, CurSong.Artist) <> 0) then - begin - CurCategory := CurSong.Artist; - // add folder tab - AddCategoryButton(CurCategory); - end; - end; - - end; // case (Ini.Sorting) - end; // if (Ini.Tabs = 1) - - CatIndex := Length(Song); - SetLength(Song, CatIndex+1); - - Inc(CatNumber); // increase number of songs in category - - // copy reference to current song - Song[CatIndex] := CurSong; - - // set song's category info - CurSong.OrderNum := Order; // assigns category - CurSong.CatNumber := CatNumber; - - if (Ini.Tabs = 0) then - CurSong.Visible := true - else if (Ini.Tabs = 1) then - CurSong.Visible := false; -{ - if (Ini.Tabs = 1) and (Order = 1) then - begin - //open first tab - CurSong.Visible := true; - end; - CurSong.Visible := true; -} - end; - - // set CatNumber of last category - if (Ini.TabsAtStartup = 1) and (High(Song) >= 1) then - begin - // set number of songs in previous category - SongIndex := CatIndex - CatNumber; - if ((SongIndex >= 0) and Song[SongIndex].Main) then - Song[SongIndex].CatNumber := CatNumber; - end; - - // update number of categories - CatCount := Order; -end; - -procedure TCatSongs.ShowCategory(Index: integer); -var - S: integer; // song -begin - CatNumShow := Index; - for S := 0 to high(CatSongs.Song) do - begin -{ - if (CatSongs.Song[S].OrderNum = Index) and (not CatSongs.Song[S].Main) then - CatSongs.Song[S].Visible := true - else - CatSongs.Song[S].Visible := false; -} -// KMS: This should be the same, but who knows :-) - CatSongs.Song[S].Visible := ((CatSongs.Song[S].OrderNum = Index) and (not CatSongs.Song[S].Main)); - end; -end; - -procedure TCatSongs.HideCategory(Index: integer); // hides all songs in category -var - S: integer; // song -begin - for S := 0 to high(CatSongs.Song) do - begin - if not CatSongs.Song[S].Main then - CatSongs.Song[S].Visible := false // hides all at now - end; -end; - -procedure TCatSongs.ClickCategoryButton(Index: integer); -var - Num: integer; -begin - Num := CatSongs.Song[Index].OrderNum; - if Num <> CatNumShow then - begin - ShowCategory(Num); - end - else - begin - ShowCategoryList; - end; -end; - -//Hide Categorys when in Category Hack -procedure TCatSongs.ShowCategoryList; -var - S: integer; -begin - // Hide All Songs Show All Cats - for S := 0 to high(CatSongs.Song) do - CatSongs.Song[S].Visible := CatSongs.Song[S].Main; - CatSongs.Selected := CatNumShow; //Show last shown Category - CatNumShow := -1; -end; -//Hide Categorys when in Category Hack End - -// Wrong song selected when tabs on bug -function TCatSongs.FindNextVisible(SearchFrom:integer): integer;// Find next Visible Song -var - I: integer; -begin - Result := -1; - I := SearchFrom; - while (Result = -1) do - begin - Inc (I); - - if (I > High(CatSongs.Song)) then - I := Low(CatSongs.Song); - if (I = SearchFrom) then // Make One Round and no song found->quit - Break; - - if (CatSongs.Song[I].Visible) then - Result := I; - end; -end; -// Wrong song selected when tabs on bug End - -(** - * Returns the number of visible songs. - *) -function TCatSongs.VisibleSongs: integer; -var - SongIndex: integer; -begin - Result := 0; - for SongIndex := 0 to High(CatSongs.Song) do - begin - if (CatSongs.Song[SongIndex].Visible) then - Inc(Result); - end; -end; - -(** - * Returns the index of a song in the subset of all visible songs. - * If all songs are visible, the result will be equal to the Index parameter. - *) -function TCatSongs.VisibleIndex(Index: integer): integer; -var - SongIndex: integer; -begin - Result := 0; - for SongIndex := 0 to Index - 1 do - begin - if (CatSongs.Song[SongIndex].Visible) then - Inc(Result); - end; -end; - -function TCatSongs.SetFilter(FilterStr: UTF8String; Filter: TSongFilter): cardinal; -var - I, J: integer; - TmpString: UTF8String; - WordArray: array of UTF8String; -begin - FilterStr := Trim(FilterStr); - if (FilterStr <> '') then - begin - Result := 0; - - // initialize word array - SetLength(WordArray, 1); - - // Copy words to SearchStr - I := Pos(' ', FilterStr); - while (I <> 0) do - begin - WordArray[High(WordArray)] := Copy(FilterStr, 1, I-1); - SetLength(WordArray, Length(WordArray) + 1); - - FilterStr := TrimLeft(Copy(FilterStr, I+1, Length(FilterStr)-I)); - I := Pos(' ', FilterStr); - end; - - // Copy last word - WordArray[High(WordArray)] := FilterStr; - - for I := 0 to High(Song) do - begin - if not Song[i].Main then - begin - case Filter of - fltAll: - TmpString := Song[I].Artist + ' ' + Song[i].Title + ' ' + Song[i].Folder; - fltTitle: - TmpString := Song[I].Title; - fltArtist: - TmpString := Song[I].Artist; - end; - Song[i].Visible := true; - // Look for every searched word - for J := 0 to High(WordArray) do - begin - Song[i].Visible := Song[i].Visible and - UTF8ContainsText(TmpString, WordArray[J]) - end; - if Song[i].Visible then - Inc(Result); - end - else - Song[i].Visible := false; - end; - CatNumShow := -2; - end - else - begin - for i := 0 to High(Song) do - begin - Song[i].Visible := (Ini.Tabs = 1) = Song[i].Main; - CatNumShow := -1; - end; - Result := 0; - end; -end; - -// ----------------------------------------------------------------------------- - -end. diff --git a/src/base/UTextEncoding.pas b/src/base/UTextEncoding.pas deleted file mode 100644 index 148cd5d4..00000000 --- a/src/base/UTextEncoding.pas +++ /dev/null @@ -1,247 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UTextEncoding; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - UUnicodeUtils; - -type - TEncoding = ( - encLocale, // current locale (needs cwstring on linux) - encUTF8, // UTF-8 - encCP1250, // Windows-1250 Central/Eastern Europe (used by Ultrastar) - encCP1252, // Windows-1252 Western Europe (used by UltraStar Deluxe < 1.1) - encAuto // try to match the w3c regex and decode as unicode on match - // and as fallback if not match - ); - -const - UTF8_BOM: UTF8String = #$EF#$BB#$BF; - -{** - * Decodes Src encoded in SrcEncoding to a UTF-16 or UTF-8 encoded Dst string. - * Returns true if the conversion was successful. - *} -function DecodeString(const Src: RawByteString; out Dst: WideString; SrcEncoding: TEncoding): boolean; overload; -function DecodeString(const Src: RawByteString; SrcEncoding: TEncoding): WideString; overload; -function DecodeStringUTF8(const Src: RawByteString; out Dst: UTF8String; SrcEncoding: TEncoding): boolean; overload; -function DecodeStringUTF8(const Src: RawByteString; SrcEncoding: TEncoding): UTF8String; overload; - -{** - * Encodes the UTF-16 or UTF-8 encoded Src string to Dst using DstEncoding - * Returns true if the conversion was successful. - *} -function EncodeString(const Src: WideString; out Dst: RawByteString; DstEncoding: TEncoding): boolean; overload; -function EncodeString(const Src: WideString; DstEncoding: TEncoding): RawByteString; overload; -function EncodeStringUTF8(const Src: UTF8String; out Dst: RawByteString; DstEncoding: TEncoding): boolean; overload; -function EncodeStringUTF8(const Src: UTF8String; DstEncoding: TEncoding): RawByteString; overload; - -{** - * If Text starts with an UTF-8 BOM, the BOM is removed and true will - * be returned. - *} -function CheckReplaceUTF8BOM(var Text: RawByteString): boolean; - -{** - * Parses an encoding string to its TEncoding equivalent. - * Surrounding whitespace and dashes ('-') are removed, the upper-cased - * resulting value is then compared with TEncodingNames. - * If the encoding was not found, the result is set to the Default encoding. - *} -function ParseEncoding(const EncodingStr: AnsiString; Default: TEncoding): TEncoding; - -{** - * Returns the name of an encoding. - *} -function EncodingName(Encoding: TEncoding): AnsiString; - -implementation - -uses - StrUtils, - pcre, - ULog; - -type - IEncoder = interface - function GetName(): AnsiString; - function Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; - function Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; - end; - - TEncoder = class(TInterfacedObject, IEncoder) - public - function GetName(): AnsiString; virtual; abstract; - function Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; virtual; abstract; - function Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; virtual; abstract; - end; - - TSingleByteEncoder = class(TEncoder) - public - function Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; override; - function Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; override; - function DecodeChar(InChr: AnsiChar; out OutChr: UCS4Char): boolean; virtual; abstract; - function EncodeChar(InChr: UCS4Char; out OutChr: AnsiChar): boolean; virtual; abstract; - end; - -const - ERROR_CHAR = '?'; - -var - Encoders: array[TEncoding] of IEncoder; - -function TSingleByteEncoder.Encode(const InStr: UCS4String; out OutStr: RawByteString): boolean; -var - I: integer; -begin - SetLength(OutStr, LengthUCS4(InStr)); - Result := true; - for I := 1 to Length(OutStr) do - begin - if (not EncodeChar(InStr[I-1], OutStr[I])) then - Result := false; - end; -end; - -function TSingleByteEncoder.Decode(const InStr: RawByteString; out OutStr: UCS4String): boolean; -var - I: integer; -begin - SetLength(OutStr, Length(InStr)+1); - Result := true; - for I := 1 to Length(InStr) do - begin - if (not DecodeChar(InStr[I], OutStr[I-1])) then - Result := false; - end; - OutStr[High(OutStr)] := 0; -end; - -function DecodeString(const Src: RawByteString; out Dst: WideString; SrcEncoding: TEncoding): boolean; -var - DstUCS4: UCS4String; -begin - Result := Encoders[SrcEncoding].Decode(Src, DstUCS4); - Dst := UCS4StringToWideString(DstUCS4); -end; - -function DecodeString(const Src: RawByteString; SrcEncoding: TEncoding): WideString; -begin - DecodeString(Src, Result, SrcEncoding); -end; - -function DecodeStringUTF8(const Src: RawByteString; out Dst: UTF8String; SrcEncoding: TEncoding): boolean; -var - DstUCS4: UCS4String; -begin - Result := Encoders[SrcEncoding].Decode(Src, DstUCS4); - Dst := UCS4ToUTF8String(DstUCS4); -end; - -function DecodeStringUTF8(const Src: RawByteString; SrcEncoding: TEncoding): UTF8String; -begin - DecodeStringUTF8(Src, Result, SrcEncoding); -end; - -function EncodeString(const Src: WideString; out Dst: RawByteString; DstEncoding: TEncoding): boolean; -begin - Result := Encoders[DstEncoding].Encode(WideStringToUCS4String(Src), Dst); -end; - -function EncodeString(const Src: WideString; DstEncoding: TEncoding): RawByteString; -begin - EncodeString(Src, Result, DstEncoding); -end; - -function EncodeStringUTF8(const Src: UTF8String; out Dst: RawByteString; DstEncoding: TEncoding): boolean; -begin - Result := Encoders[DstEncoding].Encode(UTF8ToUCS4String(Src), Dst); -end; - -function EncodeStringUTF8(const Src: UTF8String; DstEncoding: TEncoding): RawByteString; -begin - EncodeStringUTF8(Src, Result, DstEncoding); -end; - -function CheckReplaceUTF8BOM(var Text: RawByteString): boolean; -begin - if AnsiStartsStr(UTF8_BOM, Text) then - begin - Text := Copy(Text, Length(UTF8_BOM)+1, Length(Text)-Length(UTF8_BOM)); - Result := true; - Exit; - end; - Result := false; -end; - -function ParseEncoding(const EncodingStr: AnsiString; Default: TEncoding): TEncoding; -var - PrepStr: AnsiString; // prepared encoding string - Encoding: TEncoding; -begin - // remove surrounding whitespace, replace dashes, to upper case - PrepStr := UpperCase(AnsiReplaceStr(Trim(EncodingStr), '-', '')); - for Encoding := Low(TEncoding) to High(TEncoding) do - begin - if (Encoders[Encoding].GetName() = PrepStr) then - begin - Result := Encoding; - Exit; - end; - end; - Result := Default; -end; - -function EncodingName(Encoding: TEncoding): AnsiString; -begin - Result := Encoders[Encoding].GetName(); -end; - -{$I ..\\encoding\\Locale.inc} -{$I ..\\encoding\\UTF8.inc} -{$I ..\\encoding\\CP1250.inc} -{$I ..\\encoding\\CP1252.inc} -{$I ..\\encoding\\Auto.inc} - -initialization - Encoders[encLocale] := TEncoderLocale.Create; - Encoders[encUTF8] := TEncoderUTF8.Create; - Encoders[encCP1250] := TEncoderCP1250.Create; - Encoders[encCP1252] := TEncoderCP1252.Create; - - // use USDX < 1.1 encoding for backward compatibility (encCP1252) - Encoders[encAuto] := TEncoderAuto.Create(Encoders[encUTF8], Encoders[encCP1252]); - -end. diff --git a/src/base/UTexture.pas b/src/base/UTexture.pas deleted file mode 100644 index e477dbb1..00000000 --- a/src/base/UTexture.pas +++ /dev/null @@ -1,547 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UTexture; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - gl, - glu, - glext, - Classes, - SysUtils, - UCommon, - UPath, - SDL, - SDL_Image; - -type - PTexture = ^TTexture; - TTexture = record - TexNum: GLuint; - X: real; - Y: real; - Z: real; - W: real; - H: real; - ScaleW: real; // for dynamic scalling while leaving width constant - ScaleH: real; // for dynamic scalling while leaving height constant - Rot: real; // 0 - 2*pi - Int: real; // intensity - ColR: real; - ColG: real; - ColB: real; - TexW: real; // percentage of width to use [0..1] - TexH: real; // percentage of height to use [0..1] - TexX1: real; - TexY1: real; - TexX2: real; - TexY2: real; - Alpha: real; - Name: IPath; // experimental for handling cache images. maybe it's useful for dynamic skins - end; - -type - TTextureType = ( - TEXTURE_TYPE_PLAIN, // Plain (alpha = 1) - TEXTURE_TYPE_TRANSPARENT, // Alpha is used - TEXTURE_TYPE_COLORIZED // Alpha is used; Hue of the HSV color-model will be replaced by a new value - ); - -const - TextureTypeStr: array[TTextureType] of string = ( - 'Plain', - 'Transparent', - 'Colorized' - ); - -function TextureTypeToStr(TexType: TTextureType): string; -function ParseTextureType(const TypeStr: string; Default: TTextureType): TTextureType; - -procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: TTextureType); - -type - PTextureEntry = ^TTextureEntry; - TTextureEntry = record - Name: IPath; - Typ: TTextureType; - Color: cardinal; - - // we use normal TTexture, it's easier to implement and if needed - we copy ready data - Texture: TTexture; // Full-size texture - TextureCache: TTexture; // Thumbnail texture - end; - - TTextureDatabase = class - private - Texture: array of TTextureEntry; - public - procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Color: cardinal; Cache: boolean); - function FindTexture(const Name: IPath; Typ: TTextureType; Color: cardinal): integer; - end; - - TTextureUnit = class - private - TextureDatabase: TTextureDatabase; - public - Limit: integer; - - procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Cache: boolean = false); overload; - procedure AddTexture(var Tex: TTexture; Typ: TTextureType; Color: cardinal; Cache: boolean = false); overload; - function GetTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean = false): TTexture; overload; - function GetTexture(const Name: IPath; Typ: TTextureType; Col: LongWord; FromCache: boolean = false): TTexture; overload; - function LoadTexture(FromRegistry: boolean; const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; overload; - function LoadTexture(const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; overload; - function LoadTexture(const Identifier: IPath): TTexture; overload; - function CreateTexture(Data: PChar; const Name: IPath; Width, Height: word; BitsPerPixel: byte): TTexture; - procedure UnloadTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean); overload; - procedure UnloadTexture(const Name: IPath; Typ: TTextureType; Col: cardinal; FromCache: boolean); overload; - //procedure FlushTextureDatabase(); - - constructor Create; - destructor Destroy; override; - end; - -var - Texture: TTextureUnit; - -implementation - -uses - DateUtils, - StrUtils, - Math, - ULog, - UCovers, - UThemes, - UImage; - -procedure AdjustPixelFormat(var TexSurface: PSDL_Surface; Typ: TTextureType); -var - TempSurface: PSDL_Surface; - NeededPixFmt: PSDL_Pixelformat; -begin - if (Typ = TEXTURE_TYPE_PLAIN) then - NeededPixFmt := @PixelFmt_RGB - else if (Typ = TEXTURE_TYPE_TRANSPARENT) or - (Typ = TEXTURE_TYPE_COLORIZED) then - NeededPixFmt := @PixelFmt_RGBA - else - NeededPixFmt := @PixelFmt_RGB; - - if not PixelformatEquals(TexSurface^.format, NeededPixFmt) then - begin - TempSurface := TexSurface; - TexSurface := SDL_ConvertSurface(TempSurface, NeededPixFmt, SDL_SWSURFACE); - SDL_FreeSurface(TempSurface); - end; -end; - -{ TTextureDatabase } - -procedure TTextureDatabase.AddTexture(var Tex: TTexture; Typ: TTextureType; Color: cardinal; Cache: boolean); -var - TextureIndex: integer; -begin - TextureIndex := FindTexture(Tex.Name, Typ, Color); - if (TextureIndex = -1) then - begin - TextureIndex := Length(Texture); - SetLength(Texture, TextureIndex+1); - - Texture[TextureIndex].Name := Tex.Name; - Texture[TextureIndex].Typ := Typ; - Texture[TextureIndex].Color := Color; - end; - - if (Cache) then - Texture[TextureIndex].TextureCache := Tex - else - Texture[TextureIndex].Texture := Tex; -end; - -function TTextureDatabase.FindTexture(const Name: IPath; Typ: TTextureType; Color: cardinal): integer; -var - TextureIndex: integer; - CurrentTexture: PTextureEntry; -begin - Result := -1; - for TextureIndex := 0 to High(Texture) do - begin - CurrentTexture := @Texture[TextureIndex]; - if (CurrentTexture.Name.Equals(Name)) and - (CurrentTexture.Typ = Typ) then - begin - // colorized textures must match in their color too - if (CurrentTexture.Typ <> TEXTURE_TYPE_COLORIZED) or - (CurrentTexture.Color = Color) then - begin - Result := TextureIndex; - Break; - end; - end; - end; -end; - -{ TTextureUnit } - -constructor TTextureUnit.Create; -begin - inherited Create; - TextureDatabase := TTextureDatabase.Create; -end; - -destructor TTextureUnit.Destroy; -begin - TextureDatabase.Free; - inherited Destroy; -end; - -procedure TTextureUnit.AddTexture(var Tex: TTexture; Typ: TTextureType; Cache: boolean); -begin - TextureDatabase.AddTexture(Tex, Typ, 0, Cache); -end; - -procedure TTextureUnit.AddTexture(var Tex: TTexture; Typ: TTextureType; Color: cardinal; Cache: boolean); -begin - TextureDatabase.AddTexture(Tex, Typ, Color, Cache); -end; - -function TTextureUnit.LoadTexture(FromRegistry: boolean; const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; -begin - // FIXME: what is the FromRegistry parameter supposed to do? - Result := LoadTexture(Identifier, Typ, Col); -end; - -function TTextureUnit.LoadTexture(const Identifier: IPath): TTexture; -begin - Result := LoadTexture(Identifier, TEXTURE_TYPE_PLAIN, 0); -end; - -function TTextureUnit.LoadTexture(const Identifier: IPath; Typ: TTextureType; Col: LongWord): TTexture; -var - TexSurface: PSDL_Surface; - newWidth, newHeight: integer; - oldWidth, oldHeight: integer; - ActTex: GLuint; -begin - // zero texture data - FillChar(Result, SizeOf(Result), 0); - - // load texture data into memory - TexSurface := LoadImage(Identifier); - if not assigned(TexSurface) then - begin - Log.LogError('Could not load texture: "' + Identifier.ToNative +'" with type "'+ TextureTypeToStr(Typ) +'"', - 'TTextureUnit.LoadTexture'); - Exit; - end; - - // convert pixel format as needed - AdjustPixelFormat(TexSurface, Typ); - - // adjust texture size (scale down, if necessary) - newWidth := TexSurface.W; - newHeight := TexSurface.H; - - if (newWidth > Limit) then - newWidth := Limit; - - if (newHeight > Limit) then - newHeight := Limit; - - if (TexSurface.W > newWidth) or (TexSurface.H > newHeight) then - ScaleImage(TexSurface, newWidth, newHeight); - - // now we might colorize the whole thing - if (Typ = TEXTURE_TYPE_COLORIZED) then - ColorizeImage(TexSurface, Col); - - // save actual dimensions of our texture - oldWidth := newWidth; - oldHeight := newHeight; - - // make texture dimensions be powers of 2 - newWidth := Round(Power(2, Ceil(Log2(newWidth)))); - newHeight := Round(Power(2, Ceil(Log2(newHeight)))); - if (newHeight <> oldHeight) or (newWidth <> oldWidth) then - FitImage(TexSurface, newWidth, newHeight); - - // at this point we have the image in memory... - // scaled so that dimensions are powers of 2 - // and converted to either RGB or RGBA - - // if we got a Texture of Type Plain, Transparent or Colorized, - // then we're done manipulating it - // and could now create our openGL texture from it - - // prepare OpenGL texture - glGenTextures(1, @ActTex); - - glBindTexture(GL_TEXTURE_2D, ActTex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - - // load data into gl texture - if (Typ = TEXTURE_TYPE_TRANSPARENT) or - (Typ = TEXTURE_TYPE_COLORIZED) then - begin - {$IFDEF FPC_BIG_ENDIAN} - glTexImage2D(GL_TEXTURE_2D, 0, 4, newWidth, newHeight, 0, GL_RGBA, GL_UNSIGNED_INT_8_8_8_8_REV, TexSurface.pixels); - {$ELSE} - glTexImage2D(GL_TEXTURE_2D, 0, 4, newWidth, newHeight, 0, GL_RGBA, GL_UNSIGNED_BYTE, TexSurface.pixels); - {$ENDIF} - end - else //if Typ = TEXTURE_TYPE_PLAIN then - begin - {$IFDEF FPC_BIG_ENDIAN} - glTexImage2D(GL_TEXTURE_2D, 0, 3, newWidth, newHeight, 0, GL_BGR, GL_UNSIGNED_BYTE, TexSurface.pixels); - {$ELSE} - glTexImage2D(GL_TEXTURE_2D, 0, 3, newWidth, newHeight, 0, GL_RGB, GL_UNSIGNED_BYTE, TexSurface.pixels); - {$ENDIF} - end; - - // setup texture struct - with Result do - begin - X := 0; - Y := 0; - Z := 0; - W := oldWidth; - H := oldHeight; - ScaleW := 1; - ScaleH := 1; - Rot := 0; - TexNum := ActTex; - TexW := oldWidth / newWidth; - TexH := oldHeight / newHeight; - - Int := 1; - ColR := 1; - ColG := 1; - ColB := 1; - Alpha := 1; - - // new test - default use whole texure, taking TexW and TexH as const and changing these - TexX1 := 0; - TexY1 := 0; - TexX2 := 1; - TexY2 := 1; - - Name := Identifier; - end; - - SDL_FreeSurface(TexSurface); -end; - -function TTextureUnit.GetTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean): TTexture; -begin - Result := GetTexture(Name, Typ, 0, FromCache); -end; - -function TTextureUnit.GetTexture(const Name: IPath; Typ: TTextureType; Col: LongWord; FromCache: boolean): TTexture; -var - TextureIndex: integer; -begin - if (Name.IsUnset) then - begin - // zero texture data - FillChar(Result, SizeOf(Result), 0); - Exit; - end; - - if (FromCache) then - begin - // use texture - TextureIndex := TextureDatabase.FindTexture(Name, Typ, Col); - if (TextureIndex > -1) then - Result := TextureDatabase.Texture[TextureIndex].TextureCache; - Exit; - end; - - // find texture entry in database - TextureIndex := TextureDatabase.FindTexture(Name, Typ, Col); - if (TextureIndex = -1) then - begin - // create texture entry in database - TextureIndex := Length(TextureDatabase.Texture); - SetLength(TextureDatabase.Texture, TextureIndex+1); - - TextureDatabase.Texture[TextureIndex].Name := Name; - TextureDatabase.Texture[TextureIndex].Typ := Typ; - TextureDatabase.Texture[TextureIndex].Color := Col; - - // inform database that no textures have been loaded into memory - TextureDatabase.Texture[TextureIndex].Texture.TexNum := 0; - TextureDatabase.Texture[TextureIndex].TextureCache.TexNum := 0; - end; - - // load full texture - if (TextureDatabase.Texture[TextureIndex].Texture.TexNum = 0) then - TextureDatabase.Texture[TextureIndex].Texture := LoadTexture(false, Name, Typ, Col); - - // use texture - Result := TextureDatabase.Texture[TextureIndex].Texture; -end; - -function TTextureUnit.CreateTexture(Data: PChar; const Name: IPath; Width, Height: word; BitsPerPixel: byte): TTexture; -var - //Error: integer; - ActTex: GLuint; -begin - glGenTextures(1, @ActTex); // ActText = new texture number - glBindTexture(GL_TEXTURE_2D, ActTex); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_S, GL_CLAMP_TO_EDGE); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_WRAP_T, GL_CLAMP_TO_EDGE); - - {$IFDEF FPC_BIG_ENDIAN} - glTexImage2D(GL_TEXTURE_2D, 0, 3, Width, Height, 0, GL_BGR, GL_UNSIGNED_BYTE, Data); - {$ELSE} - glTexImage2D(GL_TEXTURE_2D, 0, 3, Width, Height, 0, GL_RGB, GL_UNSIGNED_BYTE, Data); - {$ENDIF} - -{ - if Mipmapping then - begin - Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 3, W, H, GL_RGB, GL_UNSIGNED_BYTE, @Data[0]); -// FPC_BIG_ENDIAN Error := gluBuild2DMipmaps(GL_TEXTURE_2D, 3, W, H, GL_BGR, GL_UNSIGNED_BYTE, @Data[0]); - if Error > 0 then - Log.LogError('gluBuild2DMipmaps() failed', 'TTextureUnit.CreateTexture'); - end; -} - - Result.X := 0; - Result.Y := 0; - Result.Z := 0; - Result.W := 0; - Result.H := 0; - Result.ScaleW := 1; - Result.ScaleH := 1; - Result.Rot := 0; - Result.TexNum := ActTex; - Result.TexW := 1; - Result.TexH := 1; - - Result.Int := 1; - Result.ColR := 1; - Result.ColG := 1; - Result.ColB := 1; - Result.Alpha := 1; - - // new test - default use whole texure, taking TexW and TexH as const and changing these - Result.TexX1 := 0; - Result.TexY1 := 0; - Result.TexX2 := 1; - Result.TexY2 := 1; - - Result.Name := Name; -end; - -procedure TTextureUnit.UnloadTexture(const Name: IPath; Typ: TTextureType; FromCache: boolean); -begin - UnloadTexture(Name, Typ, 0, FromCache); -end; - -procedure TTextureUnit.UnloadTexture(const Name: IPath; Typ: TTextureType; Col: cardinal; FromCache: boolean); -var - T: integer; - TexNum: GLuint; -begin - T := TextureDatabase.FindTexture(Name, Typ, Col); - - if not FromCache then - begin - TexNum := TextureDatabase.Texture[T].Texture.TexNum; - if TexNum > 0 then - begin - glDeleteTextures(1, PGLuint(@TexNum)); - TextureDatabase.Texture[T].Texture.TexNum := 0; - //Log.LogError('Unload texture no '+IntToStr(TexNum)); - end; - end - else - begin - TexNum := TextureDatabase.Texture[T].TextureCache.TexNum; - if TexNum > 0 then - begin - glDeleteTextures(1, @TexNum); - TextureDatabase.Texture[T].TextureCache.TexNum := 0; - //Log.LogError('Unload texture cache no '+IntToStr(TexNum)); - end; - end; -end; - -(* This needs some work -procedure TTextureUnit.FlushTextureDatabase(); -var - i: integer; - Tex: ^TTexture; -begin - for i := 0 to High(TextureDatabase.Texture) do - begin - // only delete non-cached entries - if (TextureDatabase.Texture[i].Texture.TexNum > 0) then - begin - Tex := @TextureDatabase.Texture[i].Texture; - glDeleteTextures(1, PGLuint(Tex^.TexNum)); - Tex^.TexNum := 0; - end; - end; -end; -*) - -function TextureTypeToStr(TexType: TTextureType): string; -begin - Result := TextureTypeStr[TexType]; -end; - -function ParseTextureType(const TypeStr: string; Default: TTextureType): TTextureType; -var - TextureType: TTextureType; - UpCaseStr: string; -begin - UpCaseStr := UpperCase(TypeStr); - for TextureType := Low(TextureTypeStr) to High(TextureTypeStr) do - begin - if (UpCaseStr = UpperCase(TextureTypeStr[TextureType])) then - begin - Result := TextureType; - Exit; - end; - end; - Log.LogWarn('Unknown texture type: "' + TypeStr + '". Using default texture type "' + TextureTypeToStr(Default) + '"', 'ParseTextureType'); - Result := Default; -end; - -end. diff --git a/src/base/UThemes.pas b/src/base/UThemes.pas deleted file mode 100644 index 4322815e..00000000 --- a/src/base/UThemes.pas +++ /dev/null @@ -1,2397 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UThemes; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - IniFiles, - SysUtils, - Classes, - ULog, - UTexture, - UPath; - -type - TRGB = record - R: single; - G: single; - B: single; - end; - - TRGBA = record - R, G, B, A: double; - end; - -type - TBackgroundType = - (bgtNone, bgtColor, bgtTexture, bgtVideo, bgtFade, bgtAuto); - -const - BGT_Names: array [TBackgroundType] of string = - ('none', 'color', 'texture', 'video', 'fade', 'auto'); - -type - TThemeBackground = record - BGType: TBackgroundType; - Color: TRGB; - Tex: string; - Alpha: real; - end; - -const - //Defaul Background for Screens w/o Theme e.g. editor - DEFAULT_BACKGROUND: TThemeBackground = ( - BGType: bgtColor; - Color: (R:1; G:1; B:1); - Tex: ''; - Alpha: 1.0 - ); - - -type - TThemeStatic = record - X: integer; - Y: integer; - Z: real; - W: integer; - H: integer; - Color: string; - ColR: real; - ColG: real; - ColB: real; - Tex: string; - Typ: TTextureType; - TexX1: real; - TexY1: real; - TexX2: real; - TexY2: real; - //Reflection - Reflection: boolean; - Reflectionspacing: real; - end; - AThemeStatic = array of TThemeStatic; - - TThemeText = record - X: integer; - Y: integer; - W: integer; - Z: real; - Color: string; - ColR: real; - ColG: real; - ColB: real; - Font: integer; - Size: integer; - Align: integer; - Text: UTF8String; - //Reflection - Reflection: boolean; - ReflectionSpacing: real; - end; - AThemeText = array of TThemeText; - - TThemeButton = record - Text: AThemeText; - X: integer; - Y: integer; - Z: real; - W: integer; - H: integer; - Color: string; - ColR: real; - ColG: real; - ColB: real; - Int: real; - DColor: string; - DColR: real; - DColG: real; - DColB: real; - DInt: real; - Tex: string; - Typ: TTextureType; - - Visible: boolean; - - //Reflection Mod - Reflection: boolean; - Reflectionspacing: real; - //Fade Mod - SelectH: integer; - SelectW: integer; - Fade: boolean; - FadeText: boolean; - DeSelectReflectionspacing : real; - FadeTex: string; - FadeTexPos: integer; - - //Button Collection Mod - Parent: byte; //Number of the Button Collection this Button is assigned to. IF 0: No Assignement - end; - - //Button Collection Mod - TThemeButtonCollection = record - Style: TThemeButton; - ChildCount: byte; //No of assigned Childs - FirstChild: byte; //No of Child on whose Interaction Position the Button should be - end; - - AThemeButtonCollection = array of TThemeButtonCollection; - PAThemeButtonCollection = ^AThemeButtonCollection; - - TThemeSelectSlide = record - Tex: string; - TexSBG: string; - X: integer; - Y: integer; - W: integer; - H: integer; - Z: real; - SBGW: integer; - - TextSize: integer; - - showArrows:boolean; - oneItemOnly:boolean; - - Text: UTF8String; - ColR, ColG, ColB, Int: real; - DColR, DColG, DColB, DInt: real; - TColR, TColG, TColB, TInt: real; - TDColR, TDColG, TDColB, TDInt: real; - SBGColR, SBGColG, SBGColB, SBGInt: real; - SBGDColR, SBGDColG, SBGDColB, SBGDInt: real; - STColR, STColG, STColB, STInt: real; - STDColR, STDColG, STDColB, STDInt: real; - SkipX: integer; - end; - - TThemeEqualizer = record - Visible: boolean; - Direction: boolean; - Alpha: real; - X: integer; - Y: integer; - Z: real; - W: integer; - H: integer; - Space: integer; - Bands: integer; - Length: integer; - ColR, ColG, ColB: real; - Reflection: boolean; - Reflectionspacing: real; - end; - - PThemeBasic = ^TThemeBasic; - TThemeBasic = class - Background: TThemeBackground; - Text: AThemeText; - Static: AThemeStatic; - - //Button Collection Mod - ButtonCollection: AThemeButtonCollection; - end; - - TThemeLoading = class(TThemeBasic) - StaticAnimation: TThemeStatic; - TextLoading: TThemeText; - end; - - TThemeMain = class(TThemeBasic) - ButtonSolo: TThemeButton; - ButtonMulti: TThemeButton; - ButtonStat: TThemeButton; - ButtonEditor: TThemeButton; - ButtonOptions: TThemeButton; - ButtonExit: TThemeButton; - - TextDescription: TThemeText; - TextDescriptionLong: TThemeText; - Description: array[0..5] of UTF8String; - DescriptionLong: array[0..5] of UTF8String; - end; - - TThemeName = class(TThemeBasic) - ButtonPlayer: array[1..6] of TThemeButton; - end; - - TThemeLevel = class(TThemeBasic) - ButtonEasy: TThemeButton; - ButtonMedium: TThemeButton; - ButtonHard: TThemeButton; - end; - - TThemeSong = class(TThemeBasic) - TextArtist: TThemeText; - TextTitle: TThemeText; - TextNumber: TThemeText; - - //Video Icon Mod - VideoIcon: TThemeStatic; - - //Show Cat in TopLeft Mod - TextCat: TThemeText; - StaticCat: TThemeStatic; - - //Cover Mod - Cover: record - Reflections: boolean; - X: integer; - Y: integer; - Z: integer; - W: integer; - H: integer; - Style: integer; - end; - - //Equalizer Mod - Equalizer: TThemeEqualizer; - - - //Party and Non Party specific Statics and Texts - StaticParty: AThemeStatic; - TextParty: AThemeText; - - StaticNonParty: AThemeStatic; - TextNonParty: AThemeText; - - //Party Mode - StaticTeam1Joker1: TThemeStatic; - StaticTeam1Joker2: TThemeStatic; - StaticTeam1Joker3: TThemeStatic; - StaticTeam1Joker4: TThemeStatic; - StaticTeam1Joker5: TThemeStatic; - StaticTeam2Joker1: TThemeStatic; - StaticTeam2Joker2: TThemeStatic; - StaticTeam2Joker3: TThemeStatic; - StaticTeam2Joker4: TThemeStatic; - StaticTeam2Joker5: TThemeStatic; - StaticTeam3Joker1: TThemeStatic; - StaticTeam3Joker2: TThemeStatic; - StaticTeam3Joker3: TThemeStatic; - StaticTeam3Joker4: TThemeStatic; - StaticTeam3Joker5: TThemeStatic; - - - end; - - TThemeSing = class(TThemeBasic) - - //TimeBar mod - StaticTimeProgress: TThemeStatic; - TextTimeText : TThemeText; - //eoa TimeBar mod - - StaticP1: TThemeStatic; - TextP1: TThemeText; - StaticP1ScoreBG: TThemeStatic; //Static for ScoreBG - TextP1Score: TThemeText; - - //moveable singbar mod - StaticP1SingBar: TThemeStatic; - StaticP1ThreePSingBar: TThemeStatic; - StaticP1TwoPSingBar: TThemeStatic; - StaticP2RSingBar: TThemeStatic; - StaticP2MSingBar: TThemeStatic; - StaticP3SingBar: TThemeStatic; - //eoa moveable singbar - - //added for ps3 skin - //game in 2/4 player modi - StaticP1TwoP: TThemeStatic; - StaticP1TwoPScoreBG: TThemeStatic; //Static for ScoreBG - TextP1TwoP: TThemeText; - TextP1TwoPScore: TThemeText; - //game in 3/6 player modi - StaticP1ThreeP: TThemeStatic; - StaticP1ThreePScoreBG: TThemeStatic; //Static for ScoreBG - TextP1ThreeP: TThemeText; - TextP1ThreePScore: TThemeText; - //eoa - - StaticP2R: TThemeStatic; - StaticP2RScoreBG: TThemeStatic; //Static for ScoreBG - TextP2R: TThemeText; - TextP2RScore: TThemeText; - - StaticP2M: TThemeStatic; - StaticP2MScoreBG: TThemeStatic; //Static for ScoreBG - TextP2M: TThemeText; - TextP2MScore: TThemeText; - - StaticP3R: TThemeStatic; - StaticP3RScoreBG: TThemeStatic; //Static for ScoreBG - TextP3R: TThemeText; - TextP3RScore: TThemeText; - - //Linebonus Translations - LineBonusText: array [0..8] of UTF8String; - - //Pause Popup - PausePopUp: TThemeStatic; - end; - - TThemeLyricBar = record - IndicatorYOffset, UpperX, UpperW, UpperY, UpperH, - LowerX, LowerW, LowerY, LowerH : integer; - end; - - TThemeScore = class(TThemeBasic) - TextArtist: TThemeText; - TextTitle: TThemeText; - - TextArtistTitle: TThemeText; - - PlayerStatic: array[1..6] of AThemeStatic; - PlayerTexts: array[1..6] of AThemeText; - - TextName: array[1..6] of TThemeText; - TextScore: array[1..6] of TThemeText; - - TextNotes: array[1..6] of TThemeText; - TextNotesScore: array[1..6] of TThemeText; - TextLineBonus: array[1..6] of TThemeText; - TextLineBonusScore: array[1..6] of TThemeText; - TextGoldenNotes: array[1..6] of TThemeText; - TextGoldenNotesScore: array[1..6] of TThemeText; - TextTotal: array[1..6] of TThemeText; - TextTotalScore: array[1..6] of TThemeText; - - StaticBoxLightest: array[1..6] of TThemeStatic; - StaticBoxLight: array[1..6] of TThemeStatic; - StaticBoxDark: array[1..6] of TThemeStatic; - - StaticRatings: array[1..6] of TThemeStatic; - - StaticBackLevel: array[1..6] of TThemeStatic; - StaticBackLevelRound: array[1..6] of TThemeStatic; - StaticLevel: array[1..6] of TThemeStatic; - StaticLevelRound: array[1..6] of TThemeStatic; - -// Description: array[0..5] of string;} - end; - - TThemeTop5 = class(TThemeBasic) - TextLevel: TThemeText; - TextArtistTitle: TThemeText; - - StaticNumber: AThemeStatic; - TextNumber: AThemeText; - TextName: AThemeText; - TextScore: AThemeText; - TextDate: AThemeText; - end; - - TThemeOptions = class(TThemeBasic) - ButtonGame: TThemeButton; - ButtonGraphics: TThemeButton; - ButtonSound: TThemeButton; - ButtonLyrics: TThemeButton; - ButtonThemes: TThemeButton; - ButtonRecord: TThemeButton; - ButtonAdvanced: TThemeButton; - ButtonExit: TThemeButton; - - TextDescription: TThemeText; - Description: array[0..7] of UTF8String; - end; - - TThemeOptionsGame = class(TThemeBasic) - SelectPlayers: TThemeSelectSlide; - SelectDifficulty: TThemeSelectSlide; - SelectLanguage: TThemeSelectSlide; - SelectTabs: TThemeSelectSlide; - SelectSorting: TThemeSelectSlide; - SelectDebug: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeOptionsGraphics = class(TThemeBasic) - SelectFullscreen: TThemeSelectSlide; - SelectResolution: TThemeSelectSlide; - SelectDepth: TThemeSelectSlide; - SelectVisualizer: TThemeSelectSlide; - SelectOscilloscope: TThemeSelectSlide; - SelectLineBonus: TThemeSelectSlide; - SelectMovieSize: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeOptionsSound = class(TThemeBasic) - SelectMicBoost: TThemeSelectSlide; - SelectBackgroundMusic: TThemeSelectSlide; - SelectClickAssist: TThemeSelectSlide; - SelectBeatClick: TThemeSelectSlide; - SelectThreshold: TThemeSelectSlide; - SelectSlidePreviewVolume: TThemeSelectSlide; - SelectSlidePreviewFading: TThemeSelectSlide; - SelectSlideVoicePassthrough: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeOptionsLyrics = class(TThemeBasic) - SelectLyricsFont: TThemeSelectSlide; - SelectLyricsEffect: TThemeSelectSlide; -// SelectSolmization: TThemeSelectSlide; - SelectNoteLines: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeOptionsThemes = class(TThemeBasic) - SelectTheme: TThemeSelectSlide; - SelectSkin: TThemeSelectSlide; - SelectColor: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeOptionsRecord = class(TThemeBasic) - SelectSlideCard: TThemeSelectSlide; - SelectSlideInput: TThemeSelectSlide; - SelectSlideChannel: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeOptionsAdvanced = class(TThemeBasic) - SelectLoadAnimation: TThemeSelectSlide; - SelectEffectSing: TThemeSelectSlide; - SelectScreenFade: TThemeSelectSlide; - SelectLineBonus: TThemeSelectSlide; - SelectAskbeforeDel: TThemeSelectSlide; - SelectOnSongClick: TThemeSelectSlide; - SelectPartyPopup: TThemeSelectSlide; - ButtonExit: TThemeButton; - end; - - TThemeEdit = class(TThemeBasic) - ButtonConvert: TThemeButton; - ButtonExit: TThemeButton; - - TextDescription: TThemeText; - TextDescriptionLong: TThemeText; - Description: array[0..5] of UTF8string; - DescriptionLong: array[0..5] of UTF8string; - end; - - //Error- and Check-Popup - TThemeError = class(TThemeBasic) - Button1: TThemeButton; - TextError: TThemeText; - end; - - TThemeCheck = class(TThemeBasic) - Button1: TThemeButton; - Button2: TThemeButton; - TextCheck: TThemeText; - end; - - - //ScreenSong Menue - TThemeSongMenu = class(TThemeBasic) - Button1: TThemeButton; - Button2: TThemeButton; - Button3: TThemeButton; - Button4: TThemeButton; - - SelectSlide3: TThemeSelectSlide; - - TextMenu: TThemeText; - end; - - TThemeSongJumpTo = class(TThemeBasic) - ButtonSearchText: TThemeButton; - SelectSlideType: TThemeSelectSlide; - TextFound: TThemeText; - - //Translated Texts - Songsfound: UTF8String; - NoSongsfound: UTF8String; - CatText: UTF8String; - IType: array [0..2] of UTF8String; - end; - - //Party Screens - TThemePartyNewRound = class(TThemeBasic) - TextRound1: TThemeText; - TextRound2: TThemeText; - TextRound3: TThemeText; - TextRound4: TThemeText; - TextRound5: TThemeText; - TextRound6: TThemeText; - TextRound7: TThemeText; - TextWinner1: TThemeText; - TextWinner2: TThemeText; - TextWinner3: TThemeText; - TextWinner4: TThemeText; - TextWinner5: TThemeText; - TextWinner6: TThemeText; - TextWinner7: TThemeText; - TextNextRound: TThemeText; - TextNextRoundNo: TThemeText; - TextNextPlayer1: TThemeText; - TextNextPlayer2: TThemeText; - TextNextPlayer3: TThemeText; - - StaticRound1: TThemeStatic; - StaticRound2: TThemeStatic; - StaticRound3: TThemeStatic; - StaticRound4: TThemeStatic; - StaticRound5: TThemeStatic; - StaticRound6: TThemeStatic; - StaticRound7: TThemeStatic; - - TextScoreTeam1: TThemeText; - TextScoreTeam2: TThemeText; - TextScoreTeam3: TThemeText; - TextNameTeam1: TThemeText; - TextNameTeam2: TThemeText; - TextNameTeam3: TThemeText; - TextTeam1Players: TThemeText; - TextTeam2Players: TThemeText; - TextTeam3Players: TThemeText; - - StaticTeam1: TThemeStatic; - StaticTeam2: TThemeStatic; - StaticTeam3: TThemeStatic; - StaticNextPlayer1: TThemeStatic; - StaticNextPlayer2: TThemeStatic; - StaticNextPlayer3: TThemeStatic; - end; - - TThemePartyScore = class(TThemeBasic) - TextScoreTeam1: TThemeText; - TextScoreTeam2: TThemeText; - TextScoreTeam3: TThemeText; - TextNameTeam1: TThemeText; - TextNameTeam2: TThemeText; - TextNameTeam3: TThemeText; - StaticTeam1: TThemeStatic; - StaticTeam1BG: TThemeStatic; - StaticTeam1Deco: TThemeStatic; - StaticTeam2: TThemeStatic; - StaticTeam2BG: TThemeStatic; - StaticTeam2Deco: TThemeStatic; - StaticTeam3: TThemeStatic; - StaticTeam3BG: TThemeStatic; - StaticTeam3Deco: TThemeStatic; - - DecoTextures: record - ChangeTextures: boolean; - - FirstTexture: string; - FirstTyp: TTextureType; - FirstColor: string; - - SecondTexture: string; - SecondTyp: TTextureType; - SecondColor: string; - - ThirdTexture: string; - ThirdTyp: TTextureType; - ThirdColor: string; - end; - - - TextWinner: TThemeText; - end; - - TThemePartyWin = class(TThemeBasic) - TextScoreTeam1: TThemeText; - TextScoreTeam2: TThemeText; - TextScoreTeam3: TThemeText; - TextNameTeam1: TThemeText; - TextNameTeam2: TThemeText; - TextNameTeam3: TThemeText; - StaticTeam1: TThemeStatic; - StaticTeam1BG: TThemeStatic; - StaticTeam1Deco: TThemeStatic; - StaticTeam2: TThemeStatic; - StaticTeam2BG: TThemeStatic; - StaticTeam2Deco: TThemeStatic; - StaticTeam3: TThemeStatic; - StaticTeam3BG: TThemeStatic; - StaticTeam3Deco: TThemeStatic; - - TextWinner: TThemeText; - end; - - TThemePartyOptions = class(TThemeBasic) - SelectLevel: TThemeSelectSlide; - SelectPlayList: TThemeSelectSlide; - SelectPlayList2: TThemeSelectSlide; - SelectRounds: TThemeSelectSlide; - SelectTeams: TThemeSelectSlide; - SelectPlayers1: TThemeSelectSlide; - SelectPlayers2: TThemeSelectSlide; - SelectPlayers3: TThemeSelectSlide; - - {ButtonNext: TThemeButton; - ButtonPrev: TThemeButton;} - end; - - TThemePartyPlayer = class(TThemeBasic) - Team1Name: TThemeButton; - Player1Name: TThemeButton; - Player2Name: TThemeButton; - Player3Name: TThemeButton; - Player4Name: TThemeButton; - - Team2Name: TThemeButton; - Player5Name: TThemeButton; - Player6Name: TThemeButton; - Player7Name: TThemeButton; - Player8Name: TThemeButton; - - Team3Name: TThemeButton; - Player9Name: TThemeButton; - Player10Name: TThemeButton; - Player11Name: TThemeButton; - Player12Name: TThemeButton; - - {ButtonNext: TThemeButton; - ButtonPrev: TThemeButton;} - end; - - //Stats Screens - TThemeStatMain = class(TThemeBasic) - ButtonScores: TThemeButton; - ButtonSingers: TThemeButton; - ButtonSongs: TThemeButton; - ButtonBands: TThemeButton; - ButtonExit: TThemeButton; - - TextOverview: TThemeText; - end; - - TThemeStatDetail = class(TThemeBasic) - ButtonNext: TThemeButton; - ButtonPrev: TThemeButton; - ButtonReverse: TThemeButton; - ButtonExit: TThemeButton; - - TextDescription: TThemeText; - TextPage: TThemeText; - TextList: AThemeText; - - Description: array[0..3] of UTF8String; - DescriptionR: array[0..3] of UTF8String; - FormatStr: array[0..3] of UTF8String; - PageStr: UTF8String; - end; - - //Playlist Translations - TThemePlaylist = record - CatText: UTF8String; - end; - - TTheme = class - private - {$IFDEF THEMESAVE} - ThemeIni: TIniFile; - {$ELSE} - ThemeIni: TMemIniFile; - {$ENDIF} - - LastThemeBasic: TThemeBasic; - procedure CreateThemeObjects(); - - public - Loading: TThemeLoading; - Main: TThemeMain; - Name: TThemeName; - Level: TThemeLevel; - Song: TThemeSong; - Sing: TThemeSing; - LyricBar: TThemeLyricBar; - Score: TThemeScore; - Top5: TThemeTop5; - Options: TThemeOptions; - OptionsGame: TThemeOptionsGame; - OptionsGraphics: TThemeOptionsGraphics; - OptionsSound: TThemeOptionsSound; - OptionsLyrics: TThemeOptionsLyrics; - OptionsThemes: TThemeOptionsThemes; - OptionsRecord: TThemeOptionsRecord; - OptionsAdvanced: TThemeOptionsAdvanced; - //edit - Edit: TThemeEdit; - //error and check popup - ErrorPopup: TThemeError; - CheckPopup: TThemeCheck; - //ScreenSong extensions - SongMenu: TThemeSongMenu; - SongJumpto: TThemeSongJumpTo; - //Party Screens: - PartyNewRound: TThemePartyNewRound; - PartyScore: TThemePartyScore; - PartyWin: TThemePartyWin; - PartyOptions: TThemePartyOptions; - PartyPlayer: TThemePartyPlayer; - - //Stats Screens: - StatMain: TThemeStatMain; - StatDetail: TThemeStatDetail; - - Playlist: TThemePlaylist; - - ILevel: array[0..2] of UTF8String; - - constructor Create(const FileName: IPath); overload; // Initialize theme system - constructor Create(const FileName: IPath; Color: integer); overload; // Initialize theme system with color - function LoadTheme(const FileName: IPath; sColor: integer): boolean; // Load some theme settings from file - - procedure LoadColors; - - procedure ThemeLoadBasic(Theme: TThemeBasic; const Name: string); - procedure ThemeLoadBackground(var ThemeBackground: TThemeBackground; const Name: string); - procedure ThemeLoadText(var ThemeText: TThemeText; const Name: string); - procedure ThemeLoadTexts(var ThemeText: AThemeText; const Name: string); - procedure ThemeLoadStatic(var ThemeStatic: TThemeStatic; const Name: string); - procedure ThemeLoadStatics(var ThemeStatic: AThemeStatic; const Name: string); - procedure ThemeLoadButton(var ThemeButton: TThemeButton; const Name: string; Collections: PAThemeButtonCollection = nil); - procedure ThemeLoadButtonCollection(var Collection: TThemeButtonCollection; const Name: string); - procedure ThemeLoadButtonCollections(var Collections: AThemeButtonCollection; const Name: string); - procedure ThemeLoadSelectSlide(var ThemeSelectS: TThemeSelectSlide; const Name: string); - procedure ThemeLoadEqualizer(var ThemeEqualizer: TThemeEqualizer; const Name: string); - - procedure ThemeSave(const FileName: string); - procedure ThemeSaveBasic(Theme: TThemeBasic; const Name: string); - procedure ThemeSaveBackground(ThemeBackground: TThemeBackground; const Name: string); - procedure ThemeSaveStatic(ThemeStatic: TThemeStatic; const Name: string); - procedure ThemeSaveStatics(ThemeStatic: AThemeStatic; const Name: string); - procedure ThemeSaveText(ThemeText: TThemeText; const Name: string); - procedure ThemeSaveTexts(ThemeText: AThemeText; const Name: string); - procedure ThemeSaveButton(ThemeButton: TThemeButton; const Name: string); - end; - - TColor = record - Name: string; - RGB: TRGB; - end; - -procedure glColorRGB(Color: TRGB); overload; -procedure glColorRGB(Color: TRGB; Alpha: real); overload; -procedure glColorRGB(Color: TRGBA); overload; -procedure glColorRGB(Color: TRGBA; Alpha: real); overload; - -function ColorExists(Name: string): integer; -procedure LoadColor(var R, G, B: real; ColorName: string); -function GetSystemColor(Color: integer): TRGB; -function ColorSqrt(RGB: TRGB): TRGB; - -var - //Skin: TSkin; - Theme: TTheme; - Color: array of TColor; - -implementation - -uses - UCommon, - ULanguage, - USkins, - UIni, - gl, - glext, - math; - -//----------- -//Helper procs to use TRGB in Opengl ...maybe this should be somewhere else -//----------- -procedure glColorRGB(Color: TRGB); overload; -begin - glColor3f(Color.R, Color.G, Color.B); -end; - -procedure glColorRGB(Color: TRGB; Alpha: real); overload; -begin - glColor4f(Color.R, Color.G, Color.B, Alpha); -end; - -procedure glColorRGB(Color: TRGBA); overload; -begin - glColor4f(Color.R, Color.G, Color.B, Color.A); -end; - -procedure glColorRGB(Color: TRGBA; Alpha: real); overload; -begin - glColor4f(Color.R, Color.G, Color.B, Min(Color.A, Alpha)); -end; - -constructor TTheme.Create(const FileName: IPath); -begin - Create(FileName, 0); -end; - -constructor TTheme.Create(const FileName: IPath; Color: integer); -begin - inherited Create(); - - Loading := TThemeLoading.Create; - Main := TThemeMain.Create; - Name := TThemeName.Create; - Level := TThemeLevel.Create; - Song := TThemeSong.Create; - Sing := TThemeSing.Create; - Score := TThemeScore.Create; - Top5 := TThemeTop5.Create; - Options := TThemeOptions.Create; - OptionsGame := TThemeOptionsGame.Create; - OptionsGraphics := TThemeOptionsGraphics.Create; - OptionsSound := TThemeOptionsSound.Create; - OptionsLyrics := TThemeOptionsLyrics.Create; - OptionsThemes := TThemeOptionsThemes.Create; - OptionsRecord := TThemeOptionsRecord.Create; - OptionsAdvanced := TThemeOptionsAdvanced.Create; - - Edit := TThemeEdit.Create; - - ErrorPopup := TThemeError.Create; - CheckPopup := TThemeCheck.Create; - - SongMenu := TThemeSongMenu.Create; - SongJumpto := TThemeSongJumpto.Create; - //Party Screens - PartyNewRound := TThemePartyNewRound.Create; - PartyWin := TThemePartyWin.Create; - PartyScore := TThemePartyScore.Create; - PartyOptions := TThemePartyOptions.Create; - PartyPlayer := TThemePartyPlayer.Create; - - //Stats Screens: - StatMain := TThemeStatMain.Create; - StatDetail := TThemeStatDetail.Create; - - LoadTheme(FileName, Color); - -end; - -function TTheme.LoadTheme(const FileName: IPath; sColor: integer): boolean; -var - I: integer; -begin - Result := false; - - CreateThemeObjects(); - - Log.LogStatus('Loading: '+ FileName.ToNative, 'TTheme.LoadTheme'); - - if not FileName.IsFile() then - begin - Log.LogError('Theme does not exist ('+ FileName.ToNative +')', 'TTheme.LoadTheme'); - end; - - if FileName.IsFile() then - begin - Result := true; - - {$IFDEF THEMESAVE} - ThemeIni := TIniFile.Create(FileName.ToNative); - {$ELSE} - ThemeIni := TMemIniFile.Create(FileName.ToNative); - {$ENDIF} - - if ThemeIni.ReadString('Theme', 'Name', '') <> '' then - begin - - {Skin.SkinName := ThemeIni.ReadString('Theme', 'Name', 'Singstar'); - Skin.SkinPath := 'Skins\' + Skin.SkinName + '\'; - Skin.SkinReg := false; } - Skin.Color := sColor; - - Skin.LoadSkin(ISkin[Ini.SkinNo]); - - LoadColors; - -// ThemeIni.Free; -// ThemeIni := TIniFile.Create('Themes\Singstar\Main.ini'); - - // Loading - ThemeLoadBasic(Loading, 'Loading'); - ThemeLoadText(Loading.TextLoading, 'LoadingTextLoading'); - ThemeLoadStatic(Loading.StaticAnimation, 'LoadingStaticAnimation'); - - // Main - ThemeLoadBasic(Main, 'Main'); - - ThemeLoadText(Main.TextDescription, 'MainTextDescription'); - ThemeLoadText(Main.TextDescriptionLong, 'MainTextDescriptionLong'); - ThemeLoadButton(Main.ButtonSolo, 'MainButtonSolo'); - ThemeLoadButton(Main.ButtonMulti, 'MainButtonMulti'); - ThemeLoadButton(Main.ButtonStat, 'MainButtonStats'); - ThemeLoadButton(Main.ButtonEditor, 'MainButtonEditor'); - ThemeLoadButton(Main.ButtonOptions, 'MainButtonOptions'); - ThemeLoadButton(Main.ButtonExit, 'MainButtonExit'); - - //Main Desc Text Translation Start - - Main.Description[0] := Language.Translate('SING_SING'); - Main.DescriptionLong[0] := Language.Translate('SING_SING_DESC'); - Main.Description[1] := Language.Translate('SING_MULTI'); - Main.DescriptionLong[1] := Language.Translate('SING_MULTI_DESC'); - Main.Description[2] := Language.Translate('SING_STATS'); - Main.DescriptionLong[2] := Language.Translate('SING_STATS_DESC'); - Main.Description[3] := Language.Translate('SING_EDITOR'); - Main.DescriptionLong[3] := Language.Translate('SING_EDITOR_DESC'); - Main.Description[4] := Language.Translate('SING_GAME_OPTIONS'); - Main.DescriptionLong[4] := Language.Translate('SING_GAME_OPTIONS_DESC'); - Main.Description[5] := Language.Translate('SING_EXIT'); - Main.DescriptionLong[5] := Language.Translate('SING_EXIT_DESC'); - - //Main Desc Text Translation End - - Main.TextDescription.Text := Main.Description[0]; - Main.TextDescriptionLong.Text := Main.DescriptionLong[0]; - - // Name - ThemeLoadBasic(Name, 'Name'); - - for I := 1 to 6 do - ThemeLoadButton(Name.ButtonPlayer[I], 'NameButtonPlayer'+IntToStr(I)); - - // Level - ThemeLoadBasic(Level, 'Level'); - - ThemeLoadButton(Level.ButtonEasy, 'LevelButtonEasy'); - ThemeLoadButton(Level.ButtonMedium, 'LevelButtonMedium'); - ThemeLoadButton(Level.ButtonHard, 'LevelButtonHard'); - - - // Song - ThemeLoadBasic(Song, 'Song'); - - ThemeLoadText(Song.TextArtist, 'SongTextArtist'); - ThemeLoadText(Song.TextTitle, 'SongTextTitle'); - ThemeLoadText(Song.TextNumber, 'SongTextNumber'); - - //Video Icon Mod - ThemeLoadStatic(Song.VideoIcon, 'SongVideoIcon'); - - //Show Cat in TopLeft Mod - ThemeLoadStatic(Song.StaticCat, 'SongStaticCat'); - ThemeLoadText(Song.TextCat, 'SongTextCat'); - - //Load Cover Pos and Size from Theme Mod - Song.Cover.X := ThemeIni.ReadInteger('SongCover', 'X', 300); - Song.Cover.Y := ThemeIni.ReadInteger('SongCover', 'Y', 190); - Song.Cover.W := ThemeIni.ReadInteger('SongCover', 'W', 300); - Song.Cover.H := ThemeIni.ReadInteger('SongCover', 'H', 200); - Song.Cover.Style := ThemeIni.ReadInteger('SongCover', 'Style', 4); - Song.Cover.Reflections := (ThemeIni.ReadInteger('SongCover', 'Reflections', 0) = 1); - //Load Cover Pos and Size from Theme Mod End - - ThemeLoadEqualizer(Song.Equalizer, 'SongEqualizer'); - - //Party and Non Party specific Statics and Texts - ThemeLoadStatics (Song.StaticParty, 'SongStaticParty'); - ThemeLoadTexts (Song.TextParty, 'SongTextParty'); - - ThemeLoadStatics (Song.StaticNonParty, 'SongStaticNonParty'); - ThemeLoadTexts (Song.TextNonParty, 'SongTextNonParty'); - - //Party Mode - ThemeLoadStatic(Song.StaticTeam1Joker1, 'SongStaticTeam1Joker1'); - ThemeLoadStatic(Song.StaticTeam1Joker2, 'SongStaticTeam1Joker2'); - ThemeLoadStatic(Song.StaticTeam1Joker3, 'SongStaticTeam1Joker3'); - ThemeLoadStatic(Song.StaticTeam1Joker4, 'SongStaticTeam1Joker4'); - ThemeLoadStatic(Song.StaticTeam1Joker5, 'SongStaticTeam1Joker5'); - - ThemeLoadStatic(Song.StaticTeam2Joker1, 'SongStaticTeam2Joker1'); - ThemeLoadStatic(Song.StaticTeam2Joker2, 'SongStaticTeam2Joker2'); - ThemeLoadStatic(Song.StaticTeam2Joker3, 'SongStaticTeam2Joker3'); - ThemeLoadStatic(Song.StaticTeam2Joker4, 'SongStaticTeam2Joker4'); - ThemeLoadStatic(Song.StaticTeam2Joker5, 'SongStaticTeam2Joker5'); - - ThemeLoadStatic(Song.StaticTeam3Joker1, 'SongStaticTeam3Joker1'); - ThemeLoadStatic(Song.StaticTeam3Joker2, 'SongStaticTeam3Joker2'); - ThemeLoadStatic(Song.StaticTeam3Joker3, 'SongStaticTeam3Joker3'); - ThemeLoadStatic(Song.StaticTeam3Joker4, 'SongStaticTeam3Joker4'); - ThemeLoadStatic(Song.StaticTeam3Joker5, 'SongStaticTeam3Joker5'); - - - //LyricBar asd - LyricBar.UpperX := ThemeIni.ReadInteger('SingLyricsUpperBar', 'X', 0); - LyricBar.UpperW := ThemeIni.ReadInteger('SingLyricsUpperBar', 'W', 0); - LyricBar.UpperY := ThemeIni.ReadInteger('SingLyricsUpperBar', 'Y', 0); - LyricBar.UpperH := ThemeIni.ReadInteger('SingLyricsUpperBar', 'H', 0); - LyricBar.IndicatorYOffset := ThemeIni.ReadInteger('SingLyricsUpperBar', 'IndicatorYOffset', 0); - LyricBar.LowerX := ThemeIni.ReadInteger('SingLyricsLowerBar', 'X', 0); - LyricBar.LowerW := ThemeIni.ReadInteger('SingLyricsLowerBar', 'W', 0); - LyricBar.LowerY := ThemeIni.ReadInteger('SingLyricsLowerBar', 'Y', 0); - LyricBar.LowerH := ThemeIni.ReadInteger('SingLyricsLowerBar', 'H', 0); - - // Sing - ThemeLoadBasic(Sing, 'Sing'); - //TimeBar mod - ThemeLoadStatic(Sing.StaticTimeProgress, 'SingTimeProgress'); - ThemeLoadText(Sing.TextTimeText, 'SingTimeText'); - //eoa TimeBar mod - - //moveable singbar mod - ThemeLoadStatic(Sing.StaticP1SingBar, 'SingP1SingBar'); - ThemeLoadStatic(Sing.StaticP1TwoPSingBar, 'SingP1TwoPSingBar'); - ThemeLoadStatic(Sing.StaticP1ThreePSingBar, 'SingP1ThreePSingBar'); - ThemeLoadStatic(Sing.StaticP2RSingBar, 'SingP2RSingBar'); - ThemeLoadStatic(Sing.StaticP2MSingBar, 'SingP2MSingBar'); - ThemeLoadStatic(Sing.StaticP3SingBar, 'SingP3SingBar'); - //eoa moveable singbar - - ThemeLoadStatic(Sing.StaticP1, 'SingP1Static'); - ThemeLoadText(Sing.TextP1, 'SingP1Text'); - ThemeLoadStatic(Sing.StaticP1ScoreBG, 'SingP1Static2'); - ThemeLoadText(Sing.TextP1Score, 'SingP1TextScore'); - //Added for ps3 skin - //This one is shown in 2/4P mode - //if it exists, otherwise the one Player equivaltents are used - if (ThemeIni.SectionExists('SingP1TwoPTextScore')) then - begin - ThemeLoadStatic(Sing.StaticP1TwoP, 'SingP1TwoPStatic'); - ThemeLoadText(Sing.TextP1TwoP, 'SingP1TwoPText'); - ThemeLoadStatic(Sing.StaticP1TwoPScoreBG, 'SingP1TwoPStatic2'); - ThemeLoadText(Sing.TextP1TwoPScore, 'SingP1TwoPTextScore'); - end - else - begin - Sing.StaticP1TwoP := Sing.StaticP1; - Sing.TextP1TwoP := Sing.TextP1; - Sing.StaticP1TwoPScoreBG := Sing.StaticP1ScoreBG; - Sing.TextP1TwoPScore := Sing.TextP1Score; - end; - - //This one is shown in 3/6P mode - //if it exists, otherwise the one Player equivaltents are used - if (ThemeIni.SectionExists('SingP1TwoPTextScore')) then - begin - ThemeLoadStatic(Sing.StaticP1ThreeP, 'SingP1ThreePStatic'); - ThemeLoadText(Sing.TextP1ThreeP, 'SingP1ThreePText'); - ThemeLoadStatic(Sing.StaticP1ThreePScoreBG, 'SingP1ThreePStatic2'); - ThemeLoadText(Sing.TextP1ThreePScore, 'SingP1ThreePTextScore'); - end - else - begin - Sing.StaticP1ThreeP := Sing.StaticP1; - Sing.TextP1ThreeP := Sing.TextP1; - Sing.StaticP1ThreePScoreBG := Sing.StaticP1ScoreBG; - Sing.TextP1ThreePScore := Sing.TextP1Score; - end; - //eoa - ThemeLoadStatic(Sing.StaticP2R, 'SingP2RStatic'); - ThemeLoadText(Sing.TextP2R, 'SingP2RText'); - ThemeLoadStatic(Sing.StaticP2RScoreBG, 'SingP2RStatic2'); - ThemeLoadText(Sing.TextP2RScore, 'SingP2RTextScore'); - - ThemeLoadStatic(Sing.StaticP2M, 'SingP2MStatic'); - ThemeLoadText(Sing.TextP2M, 'SingP2MText'); - ThemeLoadStatic(Sing.StaticP2MScoreBG, 'SingP2MStatic2'); - ThemeLoadText(Sing.TextP2MScore, 'SingP2MTextScore'); - - ThemeLoadStatic(Sing.StaticP3R, 'SingP3RStatic'); - ThemeLoadText(Sing.TextP3R, 'SingP3RText'); - ThemeLoadStatic(Sing.StaticP3RScoreBG, 'SingP3RStatic2'); - ThemeLoadText(Sing.TextP3RScore, 'SingP3RTextScore'); - - //Line Bonus Texts - Sing.LineBonusText[0] := Language.Translate('POPUP_AWFUL'); - Sing.LineBonusText[1] := Sing.LineBonusText[0]; - Sing.LineBonusText[2] := Language.Translate('POPUP_POOR'); - Sing.LineBonusText[3] := Language.Translate('POPUP_BAD'); - Sing.LineBonusText[4] := Language.Translate('POPUP_NOTBAD'); - Sing.LineBonusText[5] := Language.Translate('POPUP_GOOD'); - Sing.LineBonusText[6] := Language.Translate('POPUP_GREAT'); - Sing.LineBonusText[7] := Language.Translate('POPUP_AWESOME'); - Sing.LineBonusText[8] := Language.Translate('POPUP_PERFECT'); - - //PausePopup - ThemeLoadStatic(Sing.PausePopUp, 'PausePopUpStatic'); - - // Score - ThemeLoadBasic(Score, 'Score'); - - ThemeLoadText(Score.TextArtist, 'ScoreTextArtist'); - ThemeLoadText(Score.TextTitle, 'ScoreTextTitle'); - ThemeLoadText(Score.TextArtistTitle, 'ScoreTextArtistTitle'); - - for I := 1 to 6 do - begin - ThemeLoadStatics(Score.PlayerStatic[I], 'ScorePlayer' + IntToStr(I) + 'Static'); - ThemeLoadTexts(Score.PlayerTexts[I], 'ScorePlayer' + IntToStr(I) + 'Text'); - - ThemeLoadText(Score.TextName[I], 'ScoreTextName' + IntToStr(I)); - ThemeLoadText(Score.TextScore[I], 'ScoreTextScore' + IntToStr(I)); - ThemeLoadText(Score.TextNotes[I], 'ScoreTextNotes' + IntToStr(I)); - ThemeLoadText(Score.TextNotesScore[I], 'ScoreTextNotesScore' + IntToStr(I)); - ThemeLoadText(Score.TextLineBonus[I], 'ScoreTextLineBonus' + IntToStr(I)); - ThemeLoadText(Score.TextLineBonusScore[I], 'ScoreTextLineBonusScore' + IntToStr(I)); - ThemeLoadText(Score.TextGoldenNotes[I], 'ScoreTextGoldenNotes' + IntToStr(I)); - ThemeLoadText(Score.TextGoldenNotesScore[I], 'ScoreTextGoldenNotesScore' + IntToStr(I)); - ThemeLoadText(Score.TextTotal[I], 'ScoreTextTotal' + IntToStr(I)); - ThemeLoadText(Score.TextTotalScore[I], 'ScoreTextTotalScore' + IntToStr(I)); - - ThemeLoadStatic(Score.StaticBoxLightest[I], 'ScoreStaticBoxLightest' + IntToStr(I)); - ThemeLoadStatic(Score.StaticBoxLight[I], 'ScoreStaticBoxLight' + IntToStr(I)); - ThemeLoadStatic(Score.StaticBoxDark[I], 'ScoreStaticBoxDark' + IntToStr(I)); - - ThemeLoadStatic(Score.StaticBackLevel[I], 'ScoreStaticBackLevel' + IntToStr(I)); - ThemeLoadStatic(Score.StaticBackLevelRound[I], 'ScoreStaticBackLevelRound' + IntToStr(I)); - ThemeLoadStatic(Score.StaticLevel[I], 'ScoreStaticLevel' + IntToStr(I)); - ThemeLoadStatic(Score.StaticLevelRound[I], 'ScoreStaticLevelRound' + IntToStr(I)); - - ThemeLoadStatic(Score.StaticRatings[I], 'ScoreStaticRatingPicture' + IntToStr(I)); - end; - - // Top5 - ThemeLoadBasic(Top5, 'Top5'); - - ThemeLoadText(Top5.TextLevel, 'Top5TextLevel'); - ThemeLoadText(Top5.TextArtistTitle, 'Top5TextArtistTitle'); - ThemeLoadStatics(Top5.StaticNumber, 'Top5StaticNumber'); - ThemeLoadTexts(Top5.TextNumber, 'Top5TextNumber'); - ThemeLoadTexts(Top5.TextName, 'Top5TextName'); - ThemeLoadTexts(Top5.TextScore, 'Top5TextScore'); - ThemeLoadTexts(Top5.TextDate, 'Top5TextDate'); - - // Options - ThemeLoadBasic(Options, 'Options'); - - ThemeLoadButton(Options.ButtonGame, 'OptionsButtonGame'); - ThemeLoadButton(Options.ButtonGraphics, 'OptionsButtonGraphics'); - ThemeLoadButton(Options.ButtonSound, 'OptionsButtonSound'); - ThemeLoadButton(Options.ButtonLyrics, 'OptionsButtonLyrics'); - ThemeLoadButton(Options.ButtonThemes, 'OptionsButtonThemes'); - ThemeLoadButton(Options.ButtonRecord, 'OptionsButtonRecord'); - ThemeLoadButton(Options.ButtonAdvanced, 'OptionsButtonAdvanced'); - ThemeLoadButton(Options.ButtonExit, 'OptionsButtonExit'); - - Options.Description[0] := Language.Translate('SING_OPTIONS_GAME_DESC'); - Options.Description[1] := Language.Translate('SING_OPTIONS_GRAPHICS_DESC'); - Options.Description[2] := Language.Translate('SING_OPTIONS_SOUND_DESC'); - Options.Description[3] := Language.Translate('SING_OPTIONS_LYRICS_DESC'); - Options.Description[4] := Language.Translate('SING_OPTIONS_THEMES_DESC'); - Options.Description[5] := Language.Translate('SING_OPTIONS_RECORD_DESC'); - Options.Description[6] := Language.Translate('SING_OPTIONS_ADVANCED_DESC'); - Options.Description[7] := Language.Translate('SING_OPTIONS_EXIT'); - - ThemeLoadText(Options.TextDescription, 'OptionsTextDescription'); - Options.TextDescription.Text := Options.Description[0]; - - // Options Game - ThemeLoadBasic(OptionsGame, 'OptionsGame'); - - ThemeLoadSelectSlide(OptionsGame.SelectPlayers, 'OptionsGameSelectPlayers'); - ThemeLoadSelectSlide(OptionsGame.SelectDifficulty, 'OptionsGameSelectDifficulty'); - ThemeLoadSelectSlide(OptionsGame.SelectLanguage, 'OptionsGameSelectSlideLanguage'); - ThemeLoadSelectSlide(OptionsGame.SelectTabs, 'OptionsGameSelectTabs'); - ThemeLoadSelectSlide(OptionsGame.SelectSorting, 'OptionsGameSelectSlideSorting'); - ThemeLoadSelectSlide(OptionsGame.SelectDebug, 'OptionsGameSelectDebug'); - ThemeLoadButton(OptionsGame.ButtonExit, 'OptionsGameButtonExit'); - - // Options Graphics - ThemeLoadBasic(OptionsGraphics, 'OptionsGraphics'); - - ThemeLoadSelectSlide(OptionsGraphics.SelectFullscreen, 'OptionsGraphicsSelectFullscreen'); - ThemeLoadSelectSlide(OptionsGraphics.SelectResolution, 'OptionsGraphicsSelectSlideResolution'); - ThemeLoadSelectSlide(OptionsGraphics.SelectDepth, 'OptionsGraphicsSelectDepth'); - ThemeLoadSelectSlide(OptionsGraphics.SelectVisualizer, 'OptionsGraphicsSelectVisualizer'); - ThemeLoadSelectSlide(OptionsGraphics.SelectOscilloscope, 'OptionsGraphicsSelectOscilloscope'); - ThemeLoadSelectSlide(OptionsGraphics.SelectLineBonus, 'OptionsGraphicsSelectLineBonus'); - ThemeLoadSelectSlide(OptionsGraphics.SelectMovieSize, 'OptionsGraphicsSelectMovieSize'); - ThemeLoadButton(OptionsGraphics.ButtonExit, 'OptionsGraphicsButtonExit'); - - // Options Sound - ThemeLoadBasic(OptionsSound, 'OptionsSound'); - - ThemeLoadSelectSlide(OptionsSound.SelectBackgroundMusic, 'OptionsSoundSelectBackgroundMusic'); - ThemeLoadSelectSlide(OptionsSound.SelectMicBoost, 'OptionsSoundSelectMicBoost'); - ThemeLoadSelectSlide(OptionsSound.SelectClickAssist, 'OptionsSoundSelectClickAssist'); - ThemeLoadSelectSlide(OptionsSound.SelectBeatClick, 'OptionsSoundSelectBeatClick'); - ThemeLoadSelectSlide(OptionsSound.SelectThreshold, 'OptionsSoundSelectThreshold'); - //Song Preview - ThemeLoadSelectSlide(OptionsSound.SelectSlidePreviewVolume, 'OptionsSoundSelectSlidePreviewVolume'); - ThemeLoadSelectSlide(OptionsSound.SelectSlidePreviewFading, 'OptionsSoundSelectSlidePreviewFading'); - ThemeLoadSelectSlide(OptionsSound.SelectSlideVoicePassthrough, 'OptionsSoundSelectVoicePassthrough'); - - ThemeLoadButton(OptionsSound.ButtonExit, 'OptionsSoundButtonExit'); - - // Options Lyrics - ThemeLoadBasic(OptionsLyrics, 'OptionsLyrics'); - - ThemeLoadSelectSlide(OptionsLyrics.SelectLyricsFont, 'OptionsLyricsSelectLyricsFont'); - ThemeLoadSelectSlide(OptionsLyrics.SelectLyricsEffect, 'OptionsLyricsSelectLyricsEffect'); - //ThemeLoadSelectSlide(OptionsLyrics.SelectSolmization, 'OptionsLyricsSelectSolmization'); - ThemeLoadSelectSlide(OptionsLyrics.SelectNoteLines, 'OptionsLyricsSelectNoteLines'); - ThemeLoadButton(OptionsLyrics.ButtonExit, 'OptionsLyricsButtonExit'); - - // Options Themes - ThemeLoadBasic(OptionsThemes, 'OptionsThemes'); - - ThemeLoadSelectSlide(OptionsThemes.SelectTheme, 'OptionsThemesSelectTheme'); - ThemeLoadSelectSlide(OptionsThemes.SelectSkin, 'OptionsThemesSelectSkin'); - ThemeLoadSelectSlide(OptionsThemes.SelectColor, 'OptionsThemesSelectColor'); - ThemeLoadButton(OptionsThemes.ButtonExit, 'OptionsThemesButtonExit'); - - // Options Record - ThemeLoadBasic(OptionsRecord, 'OptionsRecord'); - - ThemeLoadSelectSlide(OptionsRecord.SelectSlideCard, 'OptionsRecordSelectSlideCard'); - ThemeLoadSelectSlide(OptionsRecord.SelectSlideInput, 'OptionsRecordSelectSlideInput'); - ThemeLoadSelectSlide(OptionsRecord.SelectSlideChannel, 'OptionsRecordSelectSlideChannel'); - ThemeLoadButton(OptionsRecord.ButtonExit, 'OptionsRecordButtonExit'); - - //Options Advanced - ThemeLoadBasic(OptionsAdvanced, 'OptionsAdvanced'); - - ThemeLoadSelectSlide(OptionsAdvanced.SelectLoadAnimation, 'OptionsAdvancedSelectLoadAnimation'); - ThemeLoadSelectSlide(OptionsAdvanced.SelectScreenFade, 'OptionsAdvancedSelectScreenFade'); - ThemeLoadSelectSlide(OptionsAdvanced.SelectEffectSing, 'OptionsAdvancedSelectEffectSing'); - ThemeLoadSelectSlide(OptionsAdvanced.SelectLineBonus, 'OptionsAdvancedSelectLineBonus'); - ThemeLoadSelectSlide(OptionsAdvanced.SelectOnSongClick, 'OptionsAdvancedSelectSlideOnSongClick'); - ThemeLoadSelectSlide(OptionsAdvanced.SelectAskbeforeDel, 'OptionsAdvancedSelectAskbeforeDel'); - ThemeLoadSelectSlide(OptionsAdvanced.SelectPartyPopup, 'OptionsAdvancedSelectPartyPopup'); - ThemeLoadButton (OptionsAdvanced.ButtonExit, 'OptionsAdvancedButtonExit'); - - //Edit Menu - ThemeLoadBasic (Edit, 'Edit'); - - ThemeLoadButton(Edit.ButtonConvert, 'EditButtonConvert'); - ThemeLoadButton(Edit.ButtonExit, 'EditButtonExit'); - - Edit.Description[0] := Language.Translate('SING_EDIT_BUTTON_DESCRIPTION_CONVERT'); - Edit.Description[1] := Language.Translate('SING_EDIT_BUTTON_DESCRIPTION_EXIT'); - - ThemeLoadText(Edit.TextDescription, 'EditTextDescription'); - Edit.TextDescription.Text := Edit.Description[0]; - - //error and check popup - ThemeLoadBasic (ErrorPopup, 'ErrorPopup'); - ThemeLoadButton(ErrorPopup.Button1, 'ErrorPopupButton1'); - ThemeLoadText (ErrorPopup.TextError,'ErrorPopupText'); - ThemeLoadBasic (CheckPopup, 'CheckPopup'); - ThemeLoadButton(CheckPopup.Button1, 'CheckPopupButton1'); - ThemeLoadButton(CheckPopup.Button2, 'CheckPopupButton2'); - ThemeLoadText(CheckPopup.TextCheck , 'CheckPopupText'); - - //Song Menu - ThemeLoadBasic (SongMenu, 'SongMenu'); - ThemeLoadButton(SongMenu.Button1, 'SongMenuButton1'); - ThemeLoadButton(SongMenu.Button2, 'SongMenuButton2'); - ThemeLoadButton(SongMenu.Button3, 'SongMenuButton3'); - ThemeLoadButton(SongMenu.Button4, 'SongMenuButton4'); - ThemeLoadSelectSlide(SongMenu.SelectSlide3, 'SongMenuSelectSlide3'); - - ThemeLoadText(SongMenu.TextMenu, 'SongMenuTextMenu'); - - //Song Jumpto - ThemeLoadBasic (SongJumpto, 'SongJumpto'); - ThemeLoadButton(SongJumpto.ButtonSearchText, 'SongJumptoButtonSearchText'); - ThemeLoadSelectSlide(SongJumpto.SelectSlideType, 'SongJumptoSelectSlideType'); - ThemeLoadText(SongJumpto.TextFound, 'SongJumptoTextFound'); - //Translations - SongJumpto.IType[0] := Language.Translate('SONG_JUMPTO_TYPE1'); - SongJumpto.IType[1] := Language.Translate('SONG_JUMPTO_TYPE2'); - SongJumpto.IType[2] := Language.Translate('SONG_JUMPTO_TYPE3'); - SongJumpto.SongsFound := Language.Translate('SONG_JUMPTO_SONGSFOUND'); - SongJumpto.NoSongsFound := Language.Translate('SONG_JUMPTO_NOSONGSFOUND'); - SongJumpto.CatText := Language.Translate('SONG_JUMPTO_CATTEXT'); - - //Party Screens: - //Party NewRound - ThemeLoadBasic(PartyNewRound, 'PartyNewRound'); - - ThemeLoadText (PartyNewRound.TextRound1, 'PartyNewRoundTextRound1'); - ThemeLoadText (PartyNewRound.TextRound2, 'PartyNewRoundTextRound2'); - ThemeLoadText (PartyNewRound.TextRound3, 'PartyNewRoundTextRound3'); - ThemeLoadText (PartyNewRound.TextRound4, 'PartyNewRoundTextRound4'); - ThemeLoadText (PartyNewRound.TextRound5, 'PartyNewRoundTextRound5'); - ThemeLoadText (PartyNewRound.TextRound6, 'PartyNewRoundTextRound6'); - ThemeLoadText (PartyNewRound.TextRound7, 'PartyNewRoundTextRound7'); - ThemeLoadText (PartyNewRound.TextWinner1, 'PartyNewRoundTextWinner1'); - ThemeLoadText (PartyNewRound.TextWinner2, 'PartyNewRoundTextWinner2'); - ThemeLoadText (PartyNewRound.TextWinner3, 'PartyNewRoundTextWinner3'); - ThemeLoadText (PartyNewRound.TextWinner4, 'PartyNewRoundTextWinner4'); - ThemeLoadText (PartyNewRound.TextWinner5, 'PartyNewRoundTextWinner5'); - ThemeLoadText (PartyNewRound.TextWinner6, 'PartyNewRoundTextWinner6'); - ThemeLoadText (PartyNewRound.TextWinner7, 'PartyNewRoundTextWinner7'); - ThemeLoadText (PartyNewRound.TextNextRound, 'PartyNewRoundTextNextRound'); - ThemeLoadText (PartyNewRound.TextNextRoundNo, 'PartyNewRoundTextNextRoundNo'); - ThemeLoadText (PartyNewRound.TextNextPlayer1, 'PartyNewRoundTextNextPlayer1'); - ThemeLoadText (PartyNewRound.TextNextPlayer2, 'PartyNewRoundTextNextPlayer2'); - ThemeLoadText (PartyNewRound.TextNextPlayer3, 'PartyNewRoundTextNextPlayer3'); - - ThemeLoadStatic (PartyNewRound.StaticRound1, 'PartyNewRoundStaticRound1'); - ThemeLoadStatic (PartyNewRound.StaticRound2, 'PartyNewRoundStaticRound2'); - ThemeLoadStatic (PartyNewRound.StaticRound3, 'PartyNewRoundStaticRound3'); - ThemeLoadStatic (PartyNewRound.StaticRound4, 'PartyNewRoundStaticRound4'); - ThemeLoadStatic (PartyNewRound.StaticRound5, 'PartyNewRoundStaticRound5'); - ThemeLoadStatic (PartyNewRound.StaticRound6, 'PartyNewRoundStaticRound6'); - ThemeLoadStatic (PartyNewRound.StaticRound7, 'PartyNewRoundStaticRound7'); - - ThemeLoadText (PartyNewRound.TextScoreTeam1, 'PartyNewRoundTextScoreTeam1'); - ThemeLoadText (PartyNewRound.TextScoreTeam2, 'PartyNewRoundTextScoreTeam2'); - ThemeLoadText (PartyNewRound.TextScoreTeam3, 'PartyNewRoundTextScoreTeam3'); - ThemeLoadText (PartyNewRound.TextNameTeam1, 'PartyNewRoundTextNameTeam1'); - ThemeLoadText (PartyNewRound.TextNameTeam2, 'PartyNewRoundTextNameTeam2'); - ThemeLoadText (PartyNewRound.TextNameTeam3, 'PartyNewRoundTextNameTeam3'); - - ThemeLoadText (PartyNewRound.TextTeam1Players, 'PartyNewRoundTextTeam1Players'); - ThemeLoadText (PartyNewRound.TextTeam2Players, 'PartyNewRoundTextTeam2Players'); - ThemeLoadText (PartyNewRound.TextTeam3Players, 'PartyNewRoundTextTeam3Players'); - - ThemeLoadStatic (PartyNewRound.StaticTeam1, 'PartyNewRoundStaticTeam1'); - ThemeLoadStatic (PartyNewRound.StaticTeam2, 'PartyNewRoundStaticTeam2'); - ThemeLoadStatic (PartyNewRound.StaticTeam3, 'PartyNewRoundStaticTeam3'); - ThemeLoadStatic (PartyNewRound.StaticNextPlayer1, 'PartyNewRoundStaticNextPlayer1'); - ThemeLoadStatic (PartyNewRound.StaticNextPlayer2, 'PartyNewRoundStaticNextPlayer2'); - ThemeLoadStatic (PartyNewRound.StaticNextPlayer3, 'PartyNewRoundStaticNextPlayer3'); - - //Party Score - ThemeLoadBasic(PartyScore, 'PartyScore'); - - ThemeLoadText (PartyScore.TextScoreTeam1, 'PartyScoreTextScoreTeam1'); - ThemeLoadText (PartyScore.TextScoreTeam2, 'PartyScoreTextScoreTeam2'); - ThemeLoadText (PartyScore.TextScoreTeam3, 'PartyScoreTextScoreTeam3'); - ThemeLoadText (PartyScore.TextNameTeam1, 'PartyScoreTextNameTeam1'); - ThemeLoadText (PartyScore.TextNameTeam2, 'PartyScoreTextNameTeam2'); - ThemeLoadText (PartyScore.TextNameTeam3, 'PartyScoreTextNameTeam3'); - - ThemeLoadStatic (PartyScore.StaticTeam1, 'PartyScoreStaticTeam1'); - ThemeLoadStatic (PartyScore.StaticTeam1BG, 'PartyScoreStaticTeam1BG'); - ThemeLoadStatic (PartyScore.StaticTeam1Deco, 'PartyScoreStaticTeam1Deco'); - ThemeLoadStatic (PartyScore.StaticTeam2, 'PartyScoreStaticTeam2'); - ThemeLoadStatic (PartyScore.StaticTeam2BG, 'PartyScoreStaticTeam2BG'); - ThemeLoadStatic (PartyScore.StaticTeam2Deco, 'PartyScoreStaticTeam2Deco'); - ThemeLoadStatic (PartyScore.StaticTeam3, 'PartyScoreStaticTeam3'); - ThemeLoadStatic (PartyScore.StaticTeam3BG, 'PartyScoreStaticTeam3BG'); - ThemeLoadStatic (PartyScore.StaticTeam3Deco, 'PartyScoreStaticTeam3Deco'); - - //Load Party Score DecoTextures Object - PartyScore.DecoTextures.ChangeTextures := (ThemeIni.ReadInteger('PartyScoreDecoTextures', 'ChangeTextures', 0) = 1); - PartyScore.DecoTextures.FirstTexture := ThemeIni.ReadString('PartyScoreDecoTextures', 'FirstTexture', ''); - PartyScore.DecoTextures.FirstTyp := ParseTextureType(ThemeIni.ReadString('PartyScoreDecoTextures', 'FirstTyp', ''), TEXTURE_TYPE_COLORIZED); - PartyScore.DecoTextures.FirstColor := ThemeIni.ReadString('PartyScoreDecoTextures', 'FirstColor', 'Black'); - - PartyScore.DecoTextures.SecondTexture := ThemeIni.ReadString('PartyScoreDecoTextures', 'SecondTexture', ''); - PartyScore.DecoTextures.SecondTyp := ParseTextureType(ThemeIni.ReadString('PartyScoreDecoTextures', 'SecondTyp', ''), TEXTURE_TYPE_COLORIZED); - PartyScore.DecoTextures.SecondColor := ThemeIni.ReadString('PartyScoreDecoTextures', 'SecondColor', 'Black'); - - PartyScore.DecoTextures.ThirdTexture := ThemeIni.ReadString('PartyScoreDecoTextures', 'ThirdTexture', ''); - PartyScore.DecoTextures.ThirdTyp := ParseTextureType(ThemeIni.ReadString('PartyScoreDecoTextures', 'ThirdTyp', ''), TEXTURE_TYPE_COLORIZED); - PartyScore.DecoTextures.ThirdColor := ThemeIni.ReadString('PartyScoreDecoTextures', 'ThirdColor', 'Black'); - - ThemeLoadText (PartyScore.TextWinner, 'PartyScoreTextWinner'); - - //Party Win - ThemeLoadBasic(PartyWin, 'PartyWin'); - - ThemeLoadText (PartyWin.TextScoreTeam1, 'PartyWinTextScoreTeam1'); - ThemeLoadText (PartyWin.TextScoreTeam2, 'PartyWinTextScoreTeam2'); - ThemeLoadText (PartyWin.TextScoreTeam3, 'PartyWinTextScoreTeam3'); - ThemeLoadText (PartyWin.TextNameTeam1, 'PartyWinTextNameTeam1'); - ThemeLoadText (PartyWin.TextNameTeam2, 'PartyWinTextNameTeam2'); - ThemeLoadText (PartyWin.TextNameTeam3, 'PartyWinTextNameTeam3'); - - ThemeLoadStatic (PartyWin.StaticTeam1, 'PartyWinStaticTeam1'); - ThemeLoadStatic (PartyWin.StaticTeam1BG, 'PartyWinStaticTeam1BG'); - ThemeLoadStatic (PartyWin.StaticTeam1Deco, 'PartyWinStaticTeam1Deco'); - ThemeLoadStatic (PartyWin.StaticTeam2, 'PartyWinStaticTeam2'); - ThemeLoadStatic (PartyWin.StaticTeam2BG, 'PartyWinStaticTeam2BG'); - ThemeLoadStatic (PartyWin.StaticTeam2Deco, 'PartyWinStaticTeam2Deco'); - ThemeLoadStatic (PartyWin.StaticTeam3, 'PartyWinStaticTeam3'); - ThemeLoadStatic (PartyWin.StaticTeam3BG, 'PartyWinStaticTeam3BG'); - ThemeLoadStatic (PartyWin.StaticTeam3Deco, 'PartyWinStaticTeam3Deco'); - - ThemeLoadText (PartyWin.TextWinner, 'PartyWinTextWinner'); - - //Party Options - ThemeLoadBasic(PartyOptions, 'PartyOptions'); - ThemeLoadSelectSlide(PartyOptions.SelectLevel, 'PartyOptionsSelectLevel'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayList, 'PartyOptionsSelectPlayList'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayList2, 'PartyOptionsSelectPlayList2'); - ThemeLoadSelectSlide(PartyOptions.SelectRounds, 'PartyOptionsSelectRounds'); - ThemeLoadSelectSlide(PartyOptions.SelectTeams, 'PartyOptionsSelectTeams'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayers1, 'PartyOptionsSelectPlayers1'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayers2, 'PartyOptionsSelectPlayers2'); - ThemeLoadSelectSlide(PartyOptions.SelectPlayers3, 'PartyOptionsSelectPlayers3'); - - {ThemeLoadButton (ButtonNext, 'ButtonNext'); - ThemeLoadButton (ButtonPrev, 'ButtonPrev');} - - //Party Player - ThemeLoadBasic(PartyPlayer, 'PartyPlayer'); - ThemeLoadButton(PartyPlayer.Team1Name, 'PartyPlayerTeam1Name'); - ThemeLoadButton(PartyPlayer.Player1Name, 'PartyPlayerPlayer1Name'); - ThemeLoadButton(PartyPlayer.Player2Name, 'PartyPlayerPlayer2Name'); - ThemeLoadButton(PartyPlayer.Player3Name, 'PartyPlayerPlayer3Name'); - ThemeLoadButton(PartyPlayer.Player4Name, 'PartyPlayerPlayer4Name'); - - ThemeLoadButton(PartyPlayer.Team2Name, 'PartyPlayerTeam2Name'); - ThemeLoadButton(PartyPlayer.Player5Name, 'PartyPlayerPlayer5Name'); - ThemeLoadButton(PartyPlayer.Player6Name, 'PartyPlayerPlayer6Name'); - ThemeLoadButton(PartyPlayer.Player7Name, 'PartyPlayerPlayer7Name'); - ThemeLoadButton(PartyPlayer.Player8Name, 'PartyPlayerPlayer8Name'); - - ThemeLoadButton(PartyPlayer.Team3Name, 'PartyPlayerTeam3Name'); - ThemeLoadButton(PartyPlayer.Player9Name, 'PartyPlayerPlayer9Name'); - ThemeLoadButton(PartyPlayer.Player10Name, 'PartyPlayerPlayer10Name'); - ThemeLoadButton(PartyPlayer.Player11Name, 'PartyPlayerPlayer11Name'); - ThemeLoadButton(PartyPlayer.Player12Name, 'PartyPlayerPlayer12Name'); - - {ThemeLoadButton(ButtonNext, 'PartyPlayerButtonNext'); - ThemeLoadButton(ButtonPrev, 'PartyPlayerButtonPrev');} - - ThemeLoadBasic(StatMain, 'StatMain'); - - ThemeLoadButton(StatMain.ButtonScores, 'StatMainButtonScores'); - ThemeLoadButton(StatMain.ButtonSingers, 'StatMainButtonSingers'); - ThemeLoadButton(StatMain.ButtonSongs, 'StatMainButtonSongs'); - ThemeLoadButton(StatMain.ButtonBands, 'StatMainButtonBands'); - ThemeLoadButton(StatMain.ButtonExit, 'StatMainButtonExit'); - - ThemeLoadText (StatMain.TextOverview, 'StatMainTextOverview'); - - - ThemeLoadBasic(StatDetail, 'StatDetail'); - - ThemeLoadButton(StatDetail.ButtonNext, 'StatDetailButtonNext'); - ThemeLoadButton(StatDetail.ButtonPrev, 'StatDetailButtonPrev'); - ThemeLoadButton(StatDetail.ButtonReverse, 'StatDetailButtonReverse'); - ThemeLoadButton(StatDetail.ButtonExit, 'StatDetailButtonExit'); - - ThemeLoadText (StatDetail.TextDescription, 'StatDetailTextDescription'); - ThemeLoadText (StatDetail.TextPage, 'StatDetailTextPage'); - ThemeLoadTexts(StatDetail.TextList, 'StatDetailTextList'); - - //Translate Texts - StatDetail.Description[0] := Language.Translate('STAT_DESC_SCORES'); - StatDetail.Description[1] := Language.Translate('STAT_DESC_SINGERS'); - StatDetail.Description[2] := Language.Translate('STAT_DESC_SONGS'); - StatDetail.Description[3] := Language.Translate('STAT_DESC_BANDS'); - - StatDetail.DescriptionR[0] := Language.Translate('STAT_DESC_SCORES_REVERSED'); - StatDetail.DescriptionR[1] := Language.Translate('STAT_DESC_SINGERS_REVERSED'); - StatDetail.DescriptionR[2] := Language.Translate('STAT_DESC_SONGS_REVERSED'); - StatDetail.DescriptionR[3] := Language.Translate('STAT_DESC_BANDS_REVERSED'); - - StatDetail.FormatStr[0] := Language.Translate('STAT_FORMAT_SCORES'); - StatDetail.FormatStr[1] := Language.Translate('STAT_FORMAT_SINGERS'); - StatDetail.FormatStr[2] := Language.Translate('STAT_FORMAT_SONGS'); - StatDetail.FormatStr[3] := Language.Translate('STAT_FORMAT_BANDS'); - - StatDetail.PageStr := Language.Translate('STAT_PAGE'); - - //Playlist Translations - Playlist.CatText := Language.Translate('PLAYLIST_CATTEXT'); - - //Level Translations - //Fill ILevel - ILevel[0] := Language.Translate('SING_EASY'); - ILevel[1] := Language.Translate('SING_MEDIUM'); - ILevel[2] := Language.Translate('SING_HARD'); - end; - - ThemeIni.Free; - end; -end; - -procedure TTheme.ThemeLoadBasic(Theme: TThemeBasic; const Name: string); -begin - ThemeLoadBackground(Theme.Background, Name); - ThemeLoadTexts(Theme.Text, Name + 'Text'); - ThemeLoadStatics(Theme.Static, Name + 'Static'); - ThemeLoadButtonCollections(Theme.ButtonCollection, Name + 'ButtonCollection'); - - LastThemeBasic := Theme; -end; - -procedure TTheme.ThemeLoadBackground(var ThemeBackground: TThemeBackground; const Name: string); -var - BGType: string; - I: TBackgroundType; -begin - BGType := LowerCase(ThemeIni.ReadString(Name + 'Background', 'Type', 'auto')); - - ThemeBackground.BGType := bgtAuto; - for I := Low(BGT_Names) to High(BGT_Names) do - begin - if (BGT_Names[I] = BGType) then - begin - ThemeBackground.BGType := I; - Break; - end; - end; - - ThemeBackground.Tex := ThemeIni.ReadString(Name + 'Background', 'Tex', ''); - ThemeBackground.Color.R := ThemeIni.ReadFloat(Name + 'Background', 'ColR', 1); - ThemeBackground.Color.G := ThemeIni.ReadFloat(Name + 'Background', 'ColG', 1); - ThemeBackground.Color.B := ThemeIni.ReadFloat(Name + 'Background', 'ColB', 1); - ThemeBackground.Alpha := ThemeIni.ReadFloat(Name + 'Background', 'Alpha', 1); -end; - -procedure TTheme.ThemeLoadText(var ThemeText: TThemeText; const Name: string); -var - C: integer; -begin - ThemeText.X := ThemeIni.ReadInteger(Name, 'X', 0); - ThemeText.Y := ThemeIni.ReadInteger(Name, 'Y', 0); - ThemeText.W := ThemeIni.ReadInteger(Name, 'W', 0); - - ThemeText.Z := ThemeIni.ReadFloat(Name, 'Z', 0); - - ThemeText.ColR := ThemeIni.ReadFloat(Name, 'ColR', 0); - ThemeText.ColG := ThemeIni.ReadFloat(Name, 'ColG', 0); - ThemeText.ColB := ThemeIni.ReadFloat(Name, 'ColB', 0); - - ThemeText.Font := ThemeIni.ReadInteger(Name, 'Font', 0); - ThemeText.Size := ThemeIni.ReadInteger(Name, 'Size', 0); - ThemeText.Align := ThemeIni.ReadInteger(Name, 'Align', 0); - - ThemeText.Text := Language.Translate(ThemeIni.ReadString(Name, 'Text', '')); - ThemeText.Color := ThemeIni.ReadString(Name, 'Color', ''); - - //Reflection - ThemeText.Reflection := (ThemeIni.ReadInteger(Name, 'Reflection', 0)) = 1; - ThemeText.Reflectionspacing := ThemeIni.ReadFloat(Name, 'ReflectionSpacing', 15); - - C := ColorExists(ThemeText.Color); - if C >= 0 then - begin - ThemeText.ColR := Color[C].RGB.R; - ThemeText.ColG := Color[C].RGB.G; - ThemeText.ColB := Color[C].RGB.B; - end; -end; - -procedure TTheme.ThemeLoadTexts(var ThemeText: AThemeText; const Name: string); -var - T: integer; -begin - T := 1; - while ThemeIni.SectionExists(Name + IntToStr(T)) do - begin - SetLength(ThemeText, T); - ThemeLoadText(ThemeText[T-1], Name + IntToStr(T)); - Inc(T); - end; -end; - -procedure TTheme.ThemeLoadStatic(var ThemeStatic: TThemeStatic; const Name: string); -var - C: integer; -begin - ThemeStatic.Tex := ThemeIni.ReadString(Name, 'Tex', ''); - - ThemeStatic.X := ThemeIni.ReadInteger(Name, 'X', 0); - ThemeStatic.Y := ThemeIni.ReadInteger(Name, 'Y', 0); - ThemeStatic.Z := ThemeIni.ReadFloat (Name, 'Z', 0); - ThemeStatic.W := ThemeIni.ReadInteger(Name, 'W', 0); - ThemeStatic.H := ThemeIni.ReadInteger(Name, 'H', 0); - - ThemeStatic.Typ := ParseTextureType(ThemeIni.ReadString(Name, 'Type', ''), TEXTURE_TYPE_PLAIN); - ThemeStatic.Color := ThemeIni.ReadString(Name, 'Color', ''); - - C := ColorExists(ThemeStatic.Color); - if C >= 0 then - begin - ThemeStatic.ColR := Color[C].RGB.R; - ThemeStatic.ColG := Color[C].RGB.G; - ThemeStatic.ColB := Color[C].RGB.B; - end; - - ThemeStatic.TexX1 := ThemeIni.ReadFloat(Name, 'TexX1', 0); - ThemeStatic.TexY1 := ThemeIni.ReadFloat(Name, 'TexY1', 0); - ThemeStatic.TexX2 := ThemeIni.ReadFloat(Name, 'TexX2', 1); - ThemeStatic.TexY2 := ThemeIni.ReadFloat(Name, 'TexY2', 1); - - //Reflection Mod - ThemeStatic.Reflection := (ThemeIni.ReadInteger(Name, 'Reflection', 0) = 1); - ThemeStatic.ReflectionSpacing := ThemeIni.ReadFloat(Name, 'ReflectionSpacing', 15); -end; - -procedure TTheme.ThemeLoadStatics(var ThemeStatic: AThemeStatic; const Name: string); -var - S: integer; -begin - S := 1; - while ThemeIni.SectionExists(Name + IntToStr(S)) do - begin - SetLength(ThemeStatic, S); - ThemeLoadStatic(ThemeStatic[S-1], Name + IntToStr(S)); - Inc(S); - end; -end; - -//Button Collection Mod -procedure TTheme.ThemeLoadButtonCollection(var Collection: TThemeButtonCollection; const Name: string); -var T: integer; -begin - //Load Collection Style - ThemeLoadButton(Collection.Style, Name); - - //Load Other Attributes - T := ThemeIni.ReadInteger (Name, 'FirstChild', 0); - if (T > 0) And (T < 256) then - Collection.FirstChild := T - else - Collection.FirstChild := 0; -end; - -procedure TTheme.ThemeLoadButtonCollections(var Collections: AThemeButtonCollection; const Name: string); -var - I: integer; -begin - I := 1; - while ThemeIni.SectionExists(Name + IntToStr(I)) do - begin - SetLength(Collections, I); - ThemeLoadButtonCollection(Collections[I-1], Name + IntToStr(I)); - Inc(I); - end; -end; -//End Button Collection Mod - -procedure TTheme.ThemeLoadButton(var ThemeButton: TThemeButton; const Name: string; Collections: PAThemeButtonCollection); -var - C: integer; - TLen: integer; - T: integer; - Collections2: PAThemeButtonCollection; -begin - if not ThemeIni.SectionExists(Name) then - begin - ThemeButton.Visible := False; - exit; - end; - ThemeButton.Tex := ThemeIni.ReadString(Name, 'Tex', ''); - ThemeButton.X := ThemeIni.ReadInteger (Name, 'X', 0); - ThemeButton.Y := ThemeIni.ReadInteger (Name, 'Y', 0); - ThemeButton.Z := ThemeIni.ReadFloat (Name, 'Z', 0); - ThemeButton.W := ThemeIni.ReadInteger (Name, 'W', 0); - ThemeButton.H := ThemeIni.ReadInteger (Name, 'H', 0); - ThemeButton.Typ := ParseTextureType(ThemeIni.ReadString(Name, 'Type', ''), TEXTURE_TYPE_PLAIN); - - //Reflection Mod - ThemeButton.Reflection := (ThemeIni.ReadInteger(Name, 'Reflection', 0) = 1); - ThemeButton.ReflectionSpacing := ThemeIni.ReadFloat(Name, 'ReflectionSpacing', 15); - - ThemeButton.ColR := ThemeIni.ReadFloat(Name, 'ColR', 1); - ThemeButton.ColG := ThemeIni.ReadFloat(Name, 'ColG', 1); - ThemeButton.ColB := ThemeIni.ReadFloat(Name, 'ColB', 1); - ThemeButton.Int := ThemeIni.ReadFloat(Name, 'Int', 1); - ThemeButton.DColR := ThemeIni.ReadFloat(Name, 'DColR', 1); - ThemeButton.DColG := ThemeIni.ReadFloat(Name, 'DColG', 1); - ThemeButton.DColB := ThemeIni.ReadFloat(Name, 'DColB', 1); - ThemeButton.DInt := ThemeIni.ReadFloat(Name, 'DInt', 1); - - ThemeButton.Color := ThemeIni.ReadString(Name, 'Color', ''); - C := ColorExists(ThemeButton.Color); - if C >= 0 then - begin - ThemeButton.ColR := Color[C].RGB.R; - ThemeButton.ColG := Color[C].RGB.G; - ThemeButton.ColB := Color[C].RGB.B; - end; - - ThemeButton.DColor := ThemeIni.ReadString(Name, 'DColor', ''); - C := ColorExists(ThemeButton.DColor); - if C >= 0 then - begin - ThemeButton.DColR := Color[C].RGB.R; - ThemeButton.DColG := Color[C].RGB.G; - ThemeButton.DColB := Color[C].RGB.B; - end; - - ThemeButton.Visible := (ThemeIni.ReadInteger(Name, 'Visible', 1) = 1); - - //Fade Mod - ThemeButton.SelectH := ThemeIni.ReadInteger (Name, 'SelectH', ThemeButton.H); - ThemeButton.SelectW := ThemeIni.ReadInteger (Name, 'SelectW', ThemeButton.W); - - ThemeButton.DeSelectReflectionspacing := ThemeIni.ReadFloat(Name, 'DeSelectReflectionSpacing', ThemeButton.Reflectionspacing); - - ThemeButton.Fade := (ThemeIni.ReadInteger(Name, 'Fade', 0) = 1); - ThemeButton.FadeText := (ThemeIni.ReadInteger(Name, 'FadeText', 0) = 1); - - - ThemeButton.FadeTex := ThemeIni.ReadString(Name, 'FadeTex', ''); - ThemeButton.FadeTexPos:= ThemeIni.ReadInteger(Name, 'FadeTexPos', 0); - if (ThemeButton.FadeTexPos > 4) Or (ThemeButton.FadeTexPos < 0) then - ThemeButton.FadeTexPos := 0; - - //Button Collection Mod - T := ThemeIni.ReadInteger(Name, 'Parent', 0); - - //Set Collections to Last Basic Collections if no valid Value - if (Collections = nil) then - Collections2 := @LastThemeBasic.ButtonCollection - else - Collections2 := Collections; - //Test for valid Value - if (Collections2 <> nil) AND (T > 0) AND (T <= Length(Collections2^)) then - begin - Inc(Collections2^[T-1].ChildCount); - ThemeButton.Parent := T; - end - else - ThemeButton.Parent := 0; - - //Read ButtonTexts - TLen := ThemeIni.ReadInteger(Name, 'Texts', 0); - SetLength(ThemeButton.Text, TLen); - for T := 1 to TLen do - ThemeLoadText(ThemeButton.Text[T-1], Name + 'Text' + IntToStr(T)); -end; - -procedure TTheme.ThemeLoadSelectSlide(var ThemeSelectS: TThemeSelectSlide; const Name: string); -begin - ThemeSelectS.Text := Language.Translate(ThemeIni.ReadString(Name, 'Text', '')); - - ThemeSelectS.Tex := {Skin.SkinPath + }ThemeIni.ReadString(Name, 'Tex', ''); - ThemeSelectS.TexSBG := {Skin.SkinPath + }ThemeIni.ReadString(Name, 'TexSBG', ''); - - ThemeSelectS.X := ThemeIni.ReadInteger(Name, 'X', 0); - ThemeSelectS.Y := ThemeIni.ReadInteger(Name, 'Y', 0); - ThemeSelectS.W := ThemeIni.ReadInteger(Name, 'W', 0); - ThemeSelectS.H := ThemeIni.ReadInteger(Name, 'H', 0); - - ThemeSelectS.Z := ThemeIni.ReadFloat(Name, 'Z', 0); - - ThemeSelectS.TextSize := ThemeIni.ReadInteger(Name, 'TextSize', 30); - - ThemeSelectS.SkipX := ThemeIni.ReadInteger(Name, 'SkipX', 0); - - ThemeSelectS.SBGW := ThemeIni.ReadInteger(Name, 'SBGW', 400); - - LoadColor(ThemeSelectS.ColR, ThemeSelectS.ColG, ThemeSelectS.ColB, ThemeIni.ReadString(Name, 'Color', '')); - ThemeSelectS.Int := ThemeIni.ReadFloat(Name, 'Int', 1); - LoadColor(ThemeSelectS.DColR, ThemeSelectS.DColG, ThemeSelectS.DColB, ThemeIni.ReadString(Name, 'DColor', '')); - ThemeSelectS.DInt := ThemeIni.ReadFloat(Name, 'DInt', 1); - - LoadColor(ThemeSelectS.TColR, ThemeSelectS.TColG, ThemeSelectS.TColB, ThemeIni.ReadString(Name, 'TColor', '')); - ThemeSelectS.TInt := ThemeIni.ReadFloat(Name, 'TInt', 1); - LoadColor(ThemeSelectS.TDColR, ThemeSelectS.TDColG, ThemeSelectS.TDColB, ThemeIni.ReadString(Name, 'TDColor', '')); - ThemeSelectS.TDInt := ThemeIni.ReadFloat(Name, 'TDInt', 1); - - LoadColor(ThemeSelectS.SBGColR, ThemeSelectS.SBGColG, ThemeSelectS.SBGColB, ThemeIni.ReadString(Name, 'SBGColor', '')); - ThemeSelectS.SBGInt := ThemeIni.ReadFloat(Name, 'SBGInt', 1); - LoadColor(ThemeSelectS.SBGDColR, ThemeSelectS.SBGDColG, ThemeSelectS.SBGDColB, ThemeIni.ReadString(Name, 'SBGDColor', '')); - ThemeSelectS.SBGDInt := ThemeIni.ReadFloat(Name, 'SBGDInt', 1); - - LoadColor(ThemeSelectS.STColR, ThemeSelectS.STColG, ThemeSelectS.STColB, ThemeIni.ReadString(Name, 'STColor', '')); - ThemeSelectS.STInt := ThemeIni.ReadFloat(Name, 'STInt', 1); - LoadColor(ThemeSelectS.STDColR, ThemeSelectS.STDColG, ThemeSelectS.STDColB, ThemeIni.ReadString(Name, 'STDColor', '')); - ThemeSelectS.STDInt := ThemeIni.ReadFloat(Name, 'STDInt', 1); -end; - -procedure TTheme.ThemeLoadEqualizer(var ThemeEqualizer: TThemeEqualizer; const Name: string); -var I: integer; -begin - ThemeEqualizer.Visible := (ThemeIni.ReadInteger(Name, 'Visible', 0) = 1); - ThemeEqualizer.Direction := (ThemeIni.ReadInteger(Name, 'Direction', 0) = 1); - ThemeEqualizer.Alpha := ThemeIni.ReadInteger(Name, 'Alpha', 1); - ThemeEqualizer.Space := ThemeIni.ReadInteger(Name, 'Space', 1); - ThemeEqualizer.X := ThemeIni.ReadInteger(Name, 'X', 0); - ThemeEqualizer.Y := ThemeIni.ReadInteger(Name, 'Y', 0); - ThemeEqualizer.Z := ThemeIni.ReadInteger(Name, 'Z', 1); - ThemeEqualizer.W := ThemeIni.ReadInteger(Name, 'PieceW', 8); - ThemeEqualizer.H := ThemeIni.ReadInteger(Name, 'PieceH', 8); - ThemeEqualizer.Bands := ThemeIni.ReadInteger(Name, 'Bands', 5); - ThemeEqualizer.Length := ThemeIni.ReadInteger(Name, 'Length', 12); - ThemeEqualizer.Reflection := (ThemeIni.ReadInteger(Name, 'Reflection', 0) = 1); - ThemeEqualizer.ReflectionSpacing := ThemeIni.ReadFloat(Name, 'ReflectionSpacing', 15); - - //Color - I := ColorExists(ThemeIni.ReadString(Name, 'Color', 'Black')); - if I >= 0 then - begin - ThemeEqualizer.ColR := Color[I].RGB.R; - ThemeEqualizer.ColG := Color[I].RGB.G; - ThemeEqualizer.ColB := Color[I].RGB.B; - end - else - begin - ThemeEqualizer.ColR := 0; - ThemeEqualizer.ColG := 0; - ThemeEqualizer.ColB := 0; - end; -end; - -procedure TTheme.LoadColors; -var - SL: TStringList; - C: integer; - S: string; -begin - SL := TStringList.Create; - ThemeIni.ReadSection('Colors', SL); - - // normal colors - SetLength(Color, SL.Count); - for C := 0 to SL.Count-1 do - begin - Color[C].Name := SL.Strings[C]; - - S := ThemeIni.ReadString('Colors', SL.Strings[C], ''); - - Color[C].RGB.R := StrToInt(Copy(S, 1, Pos(' ' , S)-1))/255; - Delete(S, 1, Pos(' ', S)); - - Color[C].RGB.G := StrToInt(Copy(S, 1, Pos(' ' , S)-1))/255; - Delete(S, 1, Pos(' ', S)); - - Color[C].RGB.B := StrToInt(S)/255; - end; - - // skin color - SetLength(Color, SL.Count + 3); - C := SL.Count; - Color[C].Name := 'ColorDark'; - Color[C].RGB := GetSystemColor(Skin.Color); //Ini.Color); - - C := C+1; - Color[C].Name := 'ColorLight'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'ColorLightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - // players colors - SetLength(Color, Length(Color)+18); - - // P1 - C := C+1; - Color[C].Name := 'P1Dark'; - Color[C].RGB := GetSystemColor(0); // 0 - blue - - C := C+1; - Color[C].Name := 'P1Light'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'P1Lightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - // P2 - C := C+1; - Color[C].Name := 'P2Dark'; - Color[C].RGB := GetSystemColor(3); // 3 - red - - C := C+1; - Color[C].Name := 'P2Light'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'P2Lightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - // P3 - C := C+1; - Color[C].Name := 'P3Dark'; - Color[C].RGB := GetSystemColor(1); // 1 - green - - C := C+1; - Color[C].Name := 'P3Light'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'P3Lightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - // P4 - C := C+1; - Color[C].Name := 'P4Dark'; - Color[C].RGB := GetSystemColor(4); // 4 - brown - - C := C+1; - Color[C].Name := 'P4Light'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'P4Lightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - // P5 - C := C+1; - Color[C].Name := 'P5Dark'; - Color[C].RGB := GetSystemColor(5); // 5 - yellow - - C := C+1; - Color[C].Name := 'P5Light'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'P5Lightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - // P6 - C := C+1; - Color[C].Name := 'P6Dark'; - Color[C].RGB := GetSystemColor(6); // 6 - violet - - C := C+1; - Color[C].Name := 'P6Light'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - C := C+1; - Color[C].Name := 'P6Lightest'; - Color[C].RGB := ColorSqrt(Color[C-1].RGB); - - - SL.Free; -end; - -function ColorExists(Name: string): integer; -var - C: integer; -begin - Result := -1; - for C := 0 to High(Color) do - if Color[C].Name = Name then - Result := C; -end; - -procedure LoadColor(var R, G, B: real; ColorName: string); -var - C: integer; -begin - C := ColorExists(ColorName); - if C >= 0 then - begin - R := Color[C].RGB.R; - G := Color[C].RGB.G; - B := Color[C].RGB.B; - end; -end; - -function GetSystemColor(Color: integer): TRGB; -begin - case Color of - 0: begin - // blue - Result.R := 71/255; - Result.G := 175/255; - Result.B := 247/255; - end; - 1: begin - // green - Result.R := 63/255; - Result.G := 191/255; - Result.B := 63/255; - end; - 2: begin - // pink - Result.R := 255/255; -{ Result.G := 63/255; - Result.B := 192/255;} - Result.G := 175/255; - Result.B := 247/255; - end; - 3: begin - // red - Result.R := 247/255; - Result.G := 71/255; - Result.B := 71/255; - end; - //'Violet', 'Orange', 'Yellow', 'Brown', 'Black' - //New Theme-Color Patch - 4: begin - // violet - Result.R := 230/255; - Result.G := 63/255; - Result.B := 230/255; - end; - 5: begin - // orange - Result.R := 255/255; - Result.G := 144/255; - Result.B := 0; - end; - 6: begin - // yellow - Result.R := 230/255; - Result.G := 230/255; - Result.B := 95/255; - end; - 7: begin - // brown - Result.R := 192/255; - Result.G := 127/255; - Result.B := 31/255; - end; - 8: begin - // black - Result.R := 0; - Result.G := 0; - Result.B := 0; - end; - //New Theme-Color Patch End - - end; -end; - -function ColorSqrt(RGB: TRGB): TRGB; -begin - Result.R := sqrt(RGB.R); - Result.G := sqrt(RGB.G); - Result.B := sqrt(RGB.B); -end; - -procedure TTheme.ThemeSave(const FileName: string); -var - I: integer; -begin - {$IFDEF THEMESAVE} - ThemeIni := TIniFile.Create(FileName); - {$ELSE} - ThemeIni := TMemIniFile.Create(FileName); - {$ENDIF} - - ThemeSaveBasic(Loading, 'Loading'); - - ThemeSaveBasic(Main, 'Main'); - ThemeSaveText(Main.TextDescription, 'MainTextDescription'); - ThemeSaveText(Main.TextDescriptionLong, 'MainTextDescriptionLong'); - ThemeSaveButton(Main.ButtonSolo, 'MainButtonSolo'); - ThemeSaveButton(Main.ButtonEditor, 'MainButtonEditor'); - ThemeSaveButton(Main.ButtonOptions, 'MainButtonOptions'); - ThemeSaveButton(Main.ButtonExit, 'MainButtonExit'); - - ThemeSaveBasic(Name, 'Name'); - for I := 1 to 6 do - ThemeSaveButton(Name.ButtonPlayer[I], 'NameButtonPlayer' + IntToStr(I)); - - ThemeSaveBasic(Level, 'Level'); - ThemeSaveButton(Level.ButtonEasy, 'LevelButtonEasy'); - ThemeSaveButton(Level.ButtonMedium, 'LevelButtonMedium'); - ThemeSaveButton(Level.ButtonHard, 'LevelButtonHard'); - - ThemeSaveBasic(Song, 'Song'); - ThemeSaveText(Song.TextArtist, 'SongTextArtist'); - ThemeSaveText(Song.TextTitle, 'SongTextTitle'); - ThemeSaveText(Song.TextNumber, 'SongTextNumber'); - - //Show CAt in Top Left Mod - ThemeSaveText(Song.TextCat, 'SongTextCat'); - ThemeSaveStatic(Song.StaticCat, 'SongStaticCat'); - - ThemeSaveBasic(Sing, 'Sing'); - - //TimeBar mod - ThemeSaveStatic(Sing.StaticTimeProgress, 'SingTimeProgress'); - ThemeSaveText(Sing.TextTimeText, 'SingTimeText'); - //eoa TimeBar mod - - ThemeSaveStatic(Sing.StaticP1, 'SingP1Static'); - ThemeSaveText(Sing.TextP1, 'SingP1Text'); - ThemeSaveStatic(Sing.StaticP1ScoreBG, 'SingP1Static2'); - ThemeSaveText(Sing.TextP1Score, 'SingP1TextScore'); - - //moveable singbar mod - ThemeSaveStatic(Sing.StaticP1SingBar, 'SingP1SingBar'); - ThemeSaveStatic(Sing.StaticP1TwoPSingBar, 'SingP1TwoPSingBar'); - ThemeSaveStatic(Sing.StaticP1ThreePSingBar, 'SingP1ThreePSingBar'); - ThemeSaveStatic(Sing.StaticP2RSingBar, 'SingP2RSingBar'); - ThemeSaveStatic(Sing.StaticP2MSingBar, 'SingP2MSingBar'); - ThemeSaveStatic(Sing.StaticP3SingBar, 'SingP3SingBar'); - //eoa moveable singbar - - //Added for ps3 skin - //This one is shown in 2/4P mode - ThemeSaveStatic(Sing.StaticP1TwoP, 'SingP1TwoPStatic'); - ThemeSaveText(Sing.TextP1TwoP, 'SingP1TwoPText'); - ThemeSaveStatic(Sing.StaticP1TwoPScoreBG, 'SingP1TwoPStatic2'); - ThemeSaveText(Sing.TextP1TwoPScore, 'SingP1TwoPTextScore'); - - //This one is shown in 3/6P mode - ThemeSaveStatic(Sing.StaticP1ThreeP, 'SingP1ThreePStatic'); - ThemeSaveText(Sing.TextP1ThreeP, 'SingP1ThreePText'); - ThemeSaveStatic(Sing.StaticP1ThreePScoreBG, 'SingP1ThreePStatic2'); - ThemeSaveText(Sing.TextP1ThreePScore, 'SingP1ThreePTextScore'); - //eoa - - ThemeSaveStatic(Sing.StaticP2R, 'SingP2RStatic'); - ThemeSaveText(Sing.TextP2R, 'SingP2RText'); - ThemeSaveStatic(Sing.StaticP2RScoreBG, 'SingP2RStatic2'); - ThemeSaveText(Sing.TextP2RScore, 'SingP2RTextScore'); - - ThemeSaveStatic(Sing.StaticP2M, 'SingP2MStatic'); - ThemeSaveText(Sing.TextP2M, 'SingP2MText'); - ThemeSaveStatic(Sing.StaticP2MScoreBG, 'SingP2MStatic2'); - ThemeSaveText(Sing.TextP2MScore, 'SingP2MTextScore'); - - ThemeSaveStatic(Sing.StaticP3R, 'SingP3RStatic'); - ThemeSaveText(Sing.TextP3R, 'SingP3RText'); - ThemeSaveStatic(Sing.StaticP3RScoreBG, 'SingP3RStatic2'); - ThemeSaveText(Sing.TextP3RScore, 'SingP3RTextScore'); - - ThemeSaveBasic(Score, 'Score'); - ThemeSaveText(Score.TextArtist, 'ScoreTextArtist'); - ThemeSaveText(Score.TextTitle, 'ScoreTextTitle'); - - for I := 1 to 6 do - begin - ThemeSaveStatics(Score.PlayerStatic[I], 'ScorePlayer' + IntToStr(I) + 'Static'); - - ThemeSaveText(Score.TextName[I], 'ScoreTextName' + IntToStr(I)); - ThemeSaveText(Score.TextScore[I], 'ScoreTextScore' + IntToStr(I)); - ThemeSaveText(Score.TextNotes[I], 'ScoreTextNotes' + IntToStr(I)); - ThemeSaveText(Score.TextNotesScore[I], 'ScoreTextNotesScore' + IntToStr(I)); - ThemeSaveText(Score.TextLineBonus[I], 'ScoreTextLineBonus' + IntToStr(I)); - ThemeSaveText(Score.TextLineBonusScore[I], 'ScoreTextLineBonusScore' + IntToStr(I)); - ThemeSaveText(Score.TextGoldenNotes[I], 'ScoreTextGoldenNotes' + IntToStr(I)); - ThemeSaveText(Score.TextGoldenNotesScore[I], 'ScoreTextGoldenNotesScore' + IntToStr(I)); - ThemeSaveText(Score.TextTotal[I], 'ScoreTextTotal' + IntToStr(I)); - ThemeSaveText(Score.TextTotalScore[I], 'ScoreTextTotalScore' + IntToStr(I)); - - ThemeSaveStatic(Score.StaticBackLevel[I], 'ScoreStaticBackLevel' + IntToStr(I)); - ThemeSaveStatic(Score.StaticBackLevelRound[I], 'ScoreStaticBackLevelRound' + IntToStr(I)); - ThemeSaveStatic(Score.StaticLevel[I], 'ScoreStaticLevel' + IntToStr(I)); - ThemeSaveStatic(Score.StaticLevelRound[I], 'ScoreStaticLevelRound' + IntToStr(I)); - end; - - ThemeSaveBasic(Top5, 'Top5'); - ThemeSaveText(Top5.TextLevel, 'Top5TextLevel'); - ThemeSaveText(Top5.TextArtistTitle, 'Top5TextArtistTitle'); - ThemeSaveStatics(Top5.StaticNumber, 'Top5StaticNumber'); - ThemeSaveTexts(Top5.TextNumber, 'Top5TextNumber'); - ThemeSaveTexts(Top5.TextName, 'Top5TextName'); - ThemeSaveTexts(Top5.TextScore, 'Top5TextScore'); - - - ThemeIni.Free; -end; - -procedure TTheme.ThemeSaveBasic(Theme: TThemeBasic; const Name: string); -begin - ThemeIni.WriteInteger(Name, 'Texts', Length(Theme.Text)); - - ThemeSaveBackground(Theme.Background, Name + 'Background'); - ThemeSaveStatics(Theme.Static, Name + 'Static'); - ThemeSaveTexts(Theme.Text, Name + 'Text'); -end; - -procedure TTheme.ThemeSaveBackground(ThemeBackground: TThemeBackground; const Name: string); -begin - if ThemeBackground.Tex <> '' then - ThemeIni.WriteString(Name, 'Tex', ThemeBackground.Tex) - else - begin - ThemeIni.EraseSection(Name); - end; -end; - -procedure TTheme.ThemeSaveStatic(ThemeStatic: TThemeStatic; const Name: string); -begin - ThemeIni.WriteInteger(Name, 'X', ThemeStatic.X); - ThemeIni.WriteInteger(Name, 'Y', ThemeStatic.Y); - ThemeIni.WriteInteger(Name, 'W', ThemeStatic.W); - ThemeIni.WriteInteger(Name, 'H', ThemeStatic.H); - - ThemeIni.WriteString(Name, 'Tex', ThemeStatic.Tex); - ThemeIni.WriteString(Name, 'Type', TextureTypeToStr(ThemeStatic.Typ)); - ThemeIni.WriteString(Name, 'Color', ThemeStatic.Color); - - ThemeIni.WriteFloat(Name, 'TexX1', ThemeStatic.TexX1); - ThemeIni.WriteFloat(Name, 'TexY1', ThemeStatic.TexY1); - ThemeIni.WriteFloat(Name, 'TexX2', ThemeStatic.TexX2); - ThemeIni.WriteFloat(Name, 'TexY2', ThemeStatic.TexY2); -end; - -procedure TTheme.ThemeSaveStatics(ThemeStatic: AThemeStatic; const Name: string); -var - S: integer; -begin - for S := 0 to Length(ThemeStatic)-1 do - ThemeSaveStatic(ThemeStatic[S], Name + {'Static' +} IntToStr(S+1)); - - ThemeIni.EraseSection(Name + {'Static' + }IntToStr(S+1)); -end; - -procedure TTheme.ThemeSaveText(ThemeText: TThemeText; const Name: string); -begin - ThemeIni.WriteInteger(Name, 'X', ThemeText.X); - ThemeIni.WriteInteger(Name, 'Y', ThemeText.Y); - - ThemeIni.WriteInteger(Name, 'Font', ThemeText.Font); - ThemeIni.WriteInteger(Name, 'Size', ThemeText.Size); - ThemeIni.WriteInteger(Name, 'Align', ThemeText.Align); - - ThemeIni.WriteString(Name, 'Text', ThemeText.Text); - ThemeIni.WriteString(Name, 'Color', ThemeText.Color); - - ThemeIni.WriteBool(Name, 'Reflection', ThemeText.Reflection); - ThemeIni.WriteFloat(Name, 'ReflectionSpacing', ThemeText.ReflectionSpacing); -end; - -procedure TTheme.ThemeSaveTexts(ThemeText: AThemeText; const Name: string); -var - T: integer; -begin - for T := 0 to Length(ThemeText)-1 do - ThemeSaveText(ThemeText[T], Name + {'Text' + }IntToStr(T+1)); - - ThemeIni.EraseSection(Name + {'Text' + }IntToStr(T+1)); -end; - -procedure TTheme.ThemeSaveButton(ThemeButton: TThemeButton; const Name: string); -var - T: integer; -begin - ThemeIni.WriteString(Name, 'Tex', ThemeButton.Tex); - ThemeIni.WriteInteger(Name, 'X', ThemeButton.X); - ThemeIni.WriteInteger(Name, 'Y', ThemeButton.Y); - ThemeIni.WriteInteger(Name, 'W', ThemeButton.W); - ThemeIni.WriteInteger(Name, 'H', ThemeButton.H); - ThemeIni.WriteString(Name, 'Type', TextureTypeToStr(ThemeButton.Typ)); - ThemeIni.WriteInteger(Name, 'Texts', Length(ThemeButton.Text)); - - ThemeIni.WriteString(Name, 'Color', ThemeButton.Color); - -{ ThemeButton.ColR := ThemeIni.ReadFloat(Name, 'ColR', 1); - ThemeButton.ColG := ThemeIni.ReadFloat(Name, 'ColG', 1); - ThemeButton.ColB := ThemeIni.ReadFloat(Name, 'ColB', 1); - ThemeButton.Int := ThemeIni.ReadFloat(Name, 'Int', 1); - ThemeButton.DColR := ThemeIni.ReadFloat(Name, 'DColR', 1); - ThemeButton.DColG := ThemeIni.ReadFloat(Name, 'DColG', 1); - ThemeButton.DColB := ThemeIni.ReadFloat(Name, 'DColB', 1); - ThemeButton.DInt := ThemeIni.ReadFloat(Name, 'DInt', 1);} - -{ C := ColorExists(ThemeIni.ReadString(Name, 'Color', '')); - if C >= 0 then - begin - ThemeButton.ColR := Color[C].RGB.R; - ThemeButton.ColG := Color[C].RGB.G; - ThemeButton.ColB := Color[C].RGB.B; - end; - - C := ColorExists(ThemeIni.ReadString(Name, 'DColor', '')); - if C >= 0 then - begin - ThemeButton.DColR := Color[C].RGB.R; - ThemeButton.DColG := Color[C].RGB.G; - ThemeButton.DColB := Color[C].RGB.B; - end;} - - for T := 0 to High(ThemeButton.Text) do - ThemeSaveText(ThemeButton.Text[T], Name + 'Text' + IntToStr(T+1)); -end; - -procedure TTheme.CreateThemeObjects(); -begin - freeandnil(Loading); - Loading := TThemeLoading.Create; - - freeandnil(Main); - Main := TThemeMain.Create; - - freeandnil(Name); - Name := TThemeName.Create; - - freeandnil(Level); - Level := TThemeLevel.Create; - - freeandnil(Song); - Song := TThemeSong.Create; - - freeandnil(Sing); - Sing := TThemeSing.Create; - - freeandnil(Score); - Score := TThemeScore.Create; - - freeandnil(Top5); - Top5 := TThemeTop5.Create; - - freeandnil(Options); - Options := TThemeOptions.Create; - - freeandnil(OptionsGame); - OptionsGame := TThemeOptionsGame.Create; - - freeandnil(OptionsGraphics); - OptionsGraphics := TThemeOptionsGraphics.Create; - - freeandnil(OptionsSound); - OptionsSound := TThemeOptionsSound.Create; - - freeandnil(OptionsLyrics); - OptionsLyrics := TThemeOptionsLyrics.Create; - - freeandnil(OptionsThemes); - OptionsThemes := TThemeOptionsThemes.Create; - - freeandnil(OptionsRecord); - OptionsRecord := TThemeOptionsRecord.Create; - - freeandnil(OptionsAdvanced); - OptionsAdvanced := TThemeOptionsAdvanced.Create; - - freeandnil(Edit); - Edit := TThemeEdit.Create; - - freeandnil(ErrorPopup); - ErrorPopup := TThemeError.Create; - - freeandnil(CheckPopup); - CheckPopup := TThemeCheck.Create; - - freeandnil(SongMenu); - SongMenu := TThemeSongMenu.Create; - - freeandnil(SongJumpto); - SongJumpto := TThemeSongJumpto.Create; - - //Party Screens - freeandnil(PartyNewRound); - PartyNewRound := TThemePartyNewRound.Create; - - freeandnil(PartyWin); - PartyWin := TThemePartyWin.Create; - - freeandnil(PartyScore); - PartyScore := TThemePartyScore.Create; - - freeandnil(PartyOptions); - PartyOptions := TThemePartyOptions.Create; - - freeandnil(PartyPlayer); - PartyPlayer := TThemePartyPlayer.Create; - - //Stats Screens: - freeandnil(StatMain); - StatMain := TThemeStatMain.Create; - - freeandnil(StatDetail); - StatDetail := TThemeStatDetail.Create; - - end; - -end. diff --git a/src/base/UUnicodeUtils.pas b/src/base/UUnicodeUtils.pas deleted file mode 100644 index 37b53a67..00000000 --- a/src/base/UUnicodeUtils.pas +++ /dev/null @@ -1,670 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UUnicodeUtils; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -uses -{$IFDEF MSWINDOWS} - Windows, -{$ENDIF} - StrUtils, - SysUtils; - -type - // String with unknown encoding. Introduced with Delphi 2009 and maybe soon - // with FPC. - RawByteString = AnsiString; - -{** - * Returns true if the system uses UTF-8 as default string type - * (filesystem or API calls). - * This is always true on Mac OS X and always false on Win32. On Unix it depends - * on the LC_CTYPE setting. - * Do not use AnsiToUTF8() or UTF8ToAnsi() if this function returns true. - *} -function IsNativeUTF8(): boolean; - -(* - * Character classes - *) - -function IsAlphaChar(ch: WideChar): boolean; overload; -function IsAlphaChar(ch: UCS4Char): boolean; overload; - -function IsNumericChar(ch: WideChar): boolean; overload; -function IsNumericChar(ch: UCS4Char): boolean; overload; - -function IsAlphaNumericChar(ch: WideChar): boolean; overload; -function IsAlphaNumericChar(ch: UCS4Char): boolean; overload; - -function IsPunctuationChar(ch: WideChar): boolean; overload; -function IsPunctuationChar(ch: UCS4Char): boolean; overload; - -function IsControlChar(ch: WideChar): boolean; overload; -function IsControlChar(ch: UCS4Char): boolean; overload; - -function IsPrintableChar(ch: WideChar): boolean; overload; -function IsPrintableChar(ch: UCS4Char): boolean; overload; - -{** - * Checks if the given string is a valid UTF-8 string. - * If an ANSI encoded string (with char codes >= 128) is passed, the - * function will most probably return false, as most ANSI strings sequences - * are illegal in UTF-8. - *} -function IsUTF8String(const str: RawByteString): boolean; - -{** - * Iterates over an UTF-8 encoded string. - * StrPtr will be increased to the beginning of the next character on each - * call. - * Results true if the given string starts with an UTF-8 encoded char. - *} -function NextCharUTF8(var StrPtr: PAnsiChar; out Ch: UCS4Char): boolean; - -{** - * Deletes Count chars (not bytes) beginning at char- (not byte-) position Index. - * Index values start with 1. - *} -procedure UTF8Delete(var Str: UTF8String; Index: Integer; Count: Integer); -procedure UCS4Delete(var Str: UCS4String; Index: Integer; Count: Integer); - -{** - * Checks if the string is composed of ASCII characters. - *} -function IsASCIIString(const str: RawByteString): boolean; - -{* - * String format conversion - *} - -function UTF8ToUCS4String(const str: UTF8String): UCS4String; -function UCS4ToUTF8String(const str: UCS4String): UTF8String; overload; -function UCS4ToUTF8String(ch: UCS4Char): UTF8String; overload; - -{** - * Returns the number of characters (not bytes) in string str. - *} -function LengthUTF8(const str: UTF8String): integer; - -{** - * Returns the length of an UCS4String. Note that Length(UCS4String) returns - * the length+1 as UCS4Strings are zero-terminated. - *} -function LengthUCS4(const str: UCS4String): integer; - -{** @seealso WideCompareStr *} -function UTF8CompareStr(const S1, S2: UTF8String): integer; -{** @seealso WideCompareText *} -function UTF8CompareText(const S1, S2: UTF8String): integer; - -function UTF8StartsText(const SubText, Text: UTF8String): boolean; - -function UTF8ContainsStr(const Text, SubText: UTF8String): boolean; -function UTF8ContainsText(const Text, SubText: UTF8String): boolean; - -{** @seealso WideUpperCase *} -function UTF8UpperCase(const str: UTF8String): UTF8String; -{** @seealso WideCompareText *} -function UTF8LowerCase(const str: UTF8String): UTF8String; - -{** - * Converts a UCS-4 char ch to its upper-case representation. - *} -function UCS4UpperCase(ch: UCS4Char): UCS4Char; overload; - -{** - * Converts a UCS-4 string str to its upper-case representation. - *} -function UCS4UpperCase(const str: UCS4String): UCS4String; overload; - -{** - * Converts a UCS4Char to an UCS4String. - * Note that UCS4Strings are zero-terminated dynamic arrays. - *} -function UCS4CharToString(ch: UCS4Char): UCS4String; - -{** - * @seealso System.Pos() - *} -function UTF8Pos(const substr: UTF8String; const str: UTF8String): Integer; - -{** - * Copies a segment of str starting with Index (1-based) with Count characters (not bytes). - *} -function UTF8Copy(const str: UTF8String; Index: Integer = 1; Count: Integer = -1): UTF8String; - -{** - * Copies a segment of str starting with Index (0-based) with Count characters. - * Note: Do not use Copy() to copy UCS4Strings as the result will not contain - * a trailing #0 character and hence is invalid. - *} -function UCS4Copy(const str: UCS4String; Index: Integer = 0; Count: Integer = -1): UCS4String; - -(* - * Converts a WideString to its upper- or lower-case representation. - * Wrapper for WideUpper/LowerCase. Needed because some plattforms have - * problems with unicode support. - * - * Note that characters in UTF-16 might consist of one or two WideChar valus - * (see surrogates). So instead of using WideStringUpperCase(ch)[1] for single - * character access, convert to UCS-4 where each character is represented by - * one UCS4Char. - *) -function WideStringUpperCase(const str: WideString) : WideString; overload; -function WideStringUpperCase(ch: WideChar): WideString; overload; -function WideStringLowerCase(const str: WideString): WideString; overload; -function WideStringLowerCase(ch: WideChar): WideString; overload; - -function WideStringReplaceChar(const text: WideString; search, rep: WideChar): WideString; - -implementation - -{$IFDEF UNIX} -{$IFNDEF DARWIN} -const - LC_CTYPE = 0; - -function setlocale(category: integer; locale: PChar): PChar; cdecl; external 'c'; -{$ENDIF} -{$ENDIF} - -var - NativeUTF8: boolean; - -procedure InitUnicodeUtils(); -{$IFDEF UNIX} -{$IFNDEF DARWIN} -var - localeName: PChar; -{$ENDIF} -{$ENDIF} -begin - {$IF Defined(DARWIN)} - NativeUTF8 := true; - {$ELSEIF Defined(MSWindows)} - NativeUTF8 := false; - {$ELSEIF Defined(UNIX)} - // check if locale name contains UTF8 or UTF-8 - localeName := setlocale(LC_CTYPE, nil); - NativeUTF8 := Pos('UTF8', UpperCase(AnsiReplaceStr(localeName, '-', ''))) > 0; - {$ELSE} - raise Exception.Create('Unknown system'); - {$IFEND} -end; - -function IsNativeUTF8(): boolean; -begin - Result := NativeUTF8; -end; - -function IsAlphaChar(ch: WideChar): boolean; -begin - {$IFDEF MSWINDOWS} - Result := IsCharAlphaW(ch); - {$ELSE} - // TODO: add chars > 255 (or replace with libxml2 functions?) - case ch of - 'A'..'Z', // A-Z - 'a'..'z', // a-z - #170,#181,#186, - #192..#214, - #216..#246, - #248..#255: - Result := true; - else - Result := false; - end; - {$ENDIF} -end; - -function IsAlphaChar(ch: UCS4Char): boolean; -begin - Result := IsAlphaChar(WideChar(Ord(ch))); -end; - -function IsNumericChar(ch: WideChar): boolean; -begin - // TODO: replace with libxml2 functions? - // ignore non-arabic numerals as we do not want to handle them - case ch of - '0'..'9': - Result := true; - else - Result := false; - end; -end; - -function IsNumericChar(ch: UCS4Char): boolean; -begin - Result := IsNumericChar(WideChar(Ord(ch))); -end; - -function IsAlphaNumericChar(ch: WideChar): boolean; -begin - Result := (IsAlphaChar(ch) or IsNumericChar(ch)); -end; - -function IsAlphaNumericChar(ch: UCS4Char): boolean; -begin - Result := (IsAlphaChar(ch) or IsNumericChar(ch)); -end; - -function IsPunctuationChar(ch: WideChar): boolean; -begin - // TODO: add chars > 255 (or replace with libxml2 functions?) - case ch of - ' '..'/',':'..'@','['..'`','{'..'~', - #160..#191,#215,#247: - Result := true; - else - Result := false; - end; -end; - -function IsPunctuationChar(ch: UCS4Char): boolean; -begin - Result := IsPunctuationChar(WideChar(Ord(ch))); -end; - -function IsControlChar(ch: WideChar): boolean; -begin - case ch of - #0..#31, - #127..#159: - Result := true; - else - Result := false; - end; -end; - -function IsControlChar(ch: UCS4Char): boolean; -begin - Result := IsControlChar(WideChar(Ord(ch))); -end; - -function IsPrintableChar(ch: WideChar): boolean; -begin - Result := not IsControlChar(ch); -end; - -function IsPrintableChar(ch: UCS4Char): boolean; -begin - Result := IsPrintableChar(WideChar(Ord(ch))); -end; - - -function NextCharUTF8(var StrPtr: PAnsiChar; out Ch: UCS4Char): boolean; - - // find the most significant zero bit (Result: [7..-1]) - function FindZeroMSB(b: byte): integer; - var - Mask: byte; - begin - Mask := $80; - Result := 7; - while (b and Mask <> 0) do - begin - Mask := Mask shr 1; - Dec(Result); - end; - end; - -var - ZeroBit: integer; - SeqCount: integer; // number of trailing bytes to follow -const - Mask: array[1..3] of byte = ($1F, $0F, $07); -begin - Result := false; - SeqCount := 0; - Ch := 0; - - while (StrPtr^ <> #0) do - begin - if (StrPtr^ < #128) then - begin - // check that no more trailing bytes are expected - if (SeqCount = 0) then - begin - Ch := Ord(StrPtr^); - Inc(StrPtr); - Result := true; - end; - Break; - end - else - begin - ZeroBit := FindZeroMSB(Ord(StrPtr^)); - // trailing byte expected - if (SeqCount > 0) then - begin - // check if trailing byte has pattern 10xxxxxx - if (ZeroBit <> 6) then - begin - Inc(StrPtr); - Break; - end; - - Dec(SeqCount); - Ch := (Ch shl 6) or (Ord(StrPtr^) and $3F); - - // check if char is finished - if (SeqCount = 0) then - begin - Inc(StrPtr); - Result := true; - Break; - end; - end - else // leading byte expected - begin - // check if pattern is one of 110xxxxx/1110xxxx/11110xxx - if (ZeroBit > 5) or (ZeroBit < 3) then - begin - Inc(StrPtr); - Break; - end; - // calculate number of trailing bytes (1, 2 or 3) - SeqCount := 6 - ZeroBit; - // extract first part of char - Ch := Ord(StrPtr^) and Mask[SeqCount]; - end; - end; - - Inc(StrPtr); - end; - - if (not Result) then - Ch := Ord('?'); -end; - -function IsUTF8String(const str: RawByteString): boolean; -var - Ch: UCS4Char; - StrPtr: PAnsiChar; -begin - Result := true; - StrPtr := PChar(str); - while (StrPtr^ <> #0) do - begin - if (not NextCharUTF8(StrPtr, Ch)) then - begin - Result := false; - Exit; - end; - end; -end; - -function IsASCIIString(const str: RawByteString): boolean; -var - I: integer; -begin - for I := 1 to Length(str) do - begin - if (str[I] >= #128) then - begin - Result := false; - Exit; - end; - end; - Result := true; -end; - - -function UTF8ToUCS4String(const str: UTF8String): UCS4String; -begin - Result := WideStringToUCS4String(UTF8Decode(str)); -end; - -function UCS4ToUTF8String(const str: UCS4String): UTF8String; -begin - Result := UTF8Encode(UCS4StringToWideString(str)); -end; - -function UCS4ToUTF8String(ch: UCS4Char): UTF8String; -begin - Result := UCS4ToUTF8String(UCS4CharToString(ch)); -end; - -function LengthUTF8(const str: UTF8String): integer; -begin - Result := LengthUCS4(UTF8ToUCS4String(str)); -end; - -function LengthUCS4(const str: UCS4String): integer; -begin - Result := High(str); - if (Result = -1) then - Result := 0; -end; - -function UTF8CompareStr(const S1, S2: UTF8String): integer; -begin - Result := WideCompareStr(UTF8Decode(S1), UTF8Decode(S2)); -end; - -function UTF8CompareText(const S1, S2: UTF8String): integer; -begin - Result := WideCompareText(UTF8Decode(S1), UTF8Decode(S2)); -end; - -function UTF8StartsStr(const SubText, Text: UTF8String): boolean; -begin - // TODO: use WideSameStr (slower but handles different representations of the same char)? - Result := (Pos(SubText, Text) = 1); -end; - -function UTF8StartsText(const SubText, Text: UTF8String): boolean; -begin - // TODO: use WideSameText (slower but handles different representations of the same char)? - Result := (Pos(UTF8UpperCase(SubText), UTF8UpperCase(Text)) = 1); -end; - -function UTF8ContainsStr(const Text, SubText: UTF8String): boolean; -begin - Result := Pos(SubText, Text) > 0; -end; - -function UTF8ContainsText(const Text, SubText: UTF8String): boolean; -begin - Result := Pos(UTF8UpperCase(SubText), UTF8UpperCase(Text)) > 0; -end; - -function UTF8UpperCase(const str: UTF8String): UTF8String; -begin - Result := UTF8Encode(WideStringUpperCase(UTF8Decode(str))); -end; - -function UTF8LowerCase(const str: UTF8String): UTF8String; -begin - Result := UTF8Encode(WideStringLowerCase(UTF8Decode(str))); -end; - -function UCS4UpperCase(ch: UCS4Char): UCS4Char; -begin - Result := UCS4UpperCase(UCS4CharToString(ch))[0]; -end; - -function UCS4UpperCase(const str: UCS4String): UCS4String; -begin - // convert to upper-case as WideString and convert result back to UCS-4 - Result := WideStringToUCS4String( - WideStringUpperCase( - UCS4StringToWideString(str))); -end; - -function UCS4CharToString(ch: UCS4Char): UCS4String; -begin - SetLength(Result, 2); - Result[0] := ch; - Result[1] := 0; -end; - -function UTF8Pos(const substr: UTF8String; const str: UTF8String): Integer; -begin - Result := Pos(substr, str); -end; - -function UTF8Copy(const str: UTF8String; Index: Integer; Count: Integer): UTF8String; -begin - Result := UCS4ToUTF8String(UCS4Copy(UTF8ToUCS4String(str), Index-1, Count)); -end; - -function UCS4Copy(const str: UCS4String; Index: Integer; Count: Integer): UCS4String; -var - I: integer; - MaxCount: integer; -begin - // calculate max. copy count - MaxCount := LengthUCS4(str)-Index; - if (MaxCount < 0) then - MaxCount := 0; - // adjust copy count - if (Count > MaxCount) or (Count < 0) then - Count := MaxCount; - - // copy (and add zero terminator) - SetLength(Result, Count + 1); - for I := 0 to Count-1 do - Result[I] := str[Index+I]; - Result[Count] := 0; -end; - -procedure UTF8Delete(var Str: UTF8String; Index: Integer; Count: Integer); -var - StrUCS4: UCS4String; -begin - StrUCS4 := UTF8ToUCS4String(str); - UCS4Delete(StrUCS4, Index-1, Count); - Str := UCS4ToUTF8String(StrUCS4); -end; - -procedure UCS4Delete(var Str: UCS4String; Index: Integer; Count: Integer); -var - Len: integer; - OldStr: UCS4String; - I: integer; -begin - Len := LengthUCS4(Str); - if (Count <= 0) or (Index < 0) or (Index >= Len) then - Exit; - if (Index + Count > Len) then - Count := Len-Index; - - OldStr := Str; - SetLength(Str, Len-Count+1); - for I := 0 to Index-1 do - Str[I] := OldStr[I]; - for I := Index+Count to Len-1 do - Str[I-Count] := OldStr[I]; - Str[High(Str)] := 0; -end; - -function WideStringUpperCase(ch: WideChar): WideString; -begin - // If WideChar #0 is converted to a WideString in Delphi, a string with - // length 1 and a single char #0 is returned. In FPC an empty (length=0) - // string will be returned. This will crash, if a non printable key was - // pressed, its char code (#0) is translated to upper-case and the the first - // character is accessed with Result[1]. - // We cannot catch this error in the WideString parameter variant as the string - // has length 0 already. - - // Force min. string length of 1 - if (ch = #0) then - Result := #0 - else - Result := WideStringUpperCase(WideString(ch)); -end; - -function WideStringUpperCase(const str: WideString): WideString; -begin - // On Linux and MacOSX the cwstring unit is necessary for Unicode function-calls. - // Otherwise you will get an EIntOverflow exception (thrown by unimplementedwidestring()). - // The Unicode manager cwstring does not work with MacOSX at the moment because - // of missing references to iconv. - // Note: Should be fixed now - - {.$IFNDEF DARWIN} - {.$IFDEF NOIGNORE} - Result := WideUpperCase(str) - {.$ELSE} - //Result := UTF8Decode(UpperCase(UTF8Encode(str))); - {.$ENDIF} -end; - -function WideStringLowerCase(ch: WideChar): WideString; -begin - // see WideStringUpperCase - if (ch = #0) then - Result := #0 - else - Result := WideStringLowerCase(WideString(ch)); -end; - -function WideStringLowerCase(const str: WideString): WideString; -begin - // see WideStringUpperCase - Result := WideLowerCase(str) -end; - -function WideStringReplaceChar(const text: WideString; search, rep: WideChar): WideString; -var - iPos : integer; -// sTemp : WideString; -begin -(* - result := text; - iPos := Pos(search, result); - while (iPos > 0) do - begin - sTemp := copy(result, iPos + length(search), length(result)); - result := copy(result, 1, iPos - 1) + rep + sTEmp; - iPos := Pos(search, result); - end; -*) - result := text; - - if search = rep then - exit; - - for iPos := 1 to length(result) do - begin - if result[iPos] = search then - result[iPos] := rep; - end; -end; - -initialization - InitUnicodeUtils; - -end. diff --git a/src/base/UXMLSong.pas b/src/base/UXMLSong.pas deleted file mode 100644 index e9751eba..00000000 --- a/src/base/UXMLSong.pas +++ /dev/null @@ -1,623 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UXMLSong; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - UPath, - UUnicodeUtils; - -type - TNote = record - Start: Cardinal; - Duration: Cardinal; - Tone: Integer; - NoteTyp: Byte; - Lyric: UTF8String; - end; - ANote = array of TNote; - - TSentence = record - Singer: Byte; - Duration: Cardinal; - Notes: ANote; - end; - ASentence = array of TSentence; - - TSongInfo = record - ID: Cardinal; - DualChannel: Boolean; - Header: record - Artist: UTF8String; - Title: UTF8String; - Gap: Cardinal; - BPM: Real; - Resolution: Byte; - Edition: UTF8String; - Genre: UTF8String; - Year: UTF8String; - Language: UTF8String; - end; - CountSentences: Cardinal; - Sentences: ASentence; - end; - - TParser = class - private - SSFile: TStringList; - - ParserState: Byte; - CurPosinSong: Cardinal; //Cur Beat Pos in the Song - CurDuettSinger: Byte; //Who sings this Part? - BindLyrics: Boolean; //Should the Lyrics be bind to the last Word (no Space) - FirstNote: Boolean; //Is this the First Note found? For Gap calculating - - function ParseLine(Line: RawByteString): Boolean; - public - SongInfo: TSongInfo; - ErrorMessage: string; - Edition: UTF8String; - SingstarVersion: string; - - Settings: record - DashReplacement: Char; - end; - - constructor Create; - - function ParseConfigForEdition(const Filename: IPath): String; - - function ParseSongHeader(const Filename: IPath): Boolean; //Parse Song Header only - function ParseSong (const Filename: IPath): Boolean; //Parse whole Song - end; - -const - PS_None = 0; - PS_Melody = 1; - PS_Sentence = 2; - - NT_Normal = 1; - NT_Freestyle = 0; - NT_Golden = 2; - - DS_Player1 = 1; - DS_Player2 = 2; - DS_Both = 3; - -implementation - -uses - SysUtils, - StrUtils; - -constructor TParser.Create; -begin - inherited Create; - ErrorMessage := ''; - - DecimalSeparator := '.'; -end; - -function TParser.ParseSong(const Filename: IPath): Boolean; -var - I: Integer; - FileStream: TBinaryFileStream; -begin - Result := False; - if Filename.IsFile() then - begin - ErrorMessage := 'Can''t open melody.xml file'; - - SSFile := TStringList.Create; - FileStream := TBinaryFileStream.Create(Filename, fmOpenRead); - try - SSFile.LoadFromStream(FileStream); - - ErrorMessage := ''; - Result := True; - - I := 0; - - SongInfo.CountSentences := 0; - CurDuettSinger := DS_Both; //Both is Singstar Standard - CurPosinSong := 0; //Start at Pos 0 - BindLyrics := True; //Dont start with Space - FirstNote := True; //First Note found should be the First Note ;) - - SongInfo.Header.Language := ''; - SongInfo.Header.Edition := Edition; - SongInfo.DualChannel := False; - - ParserState := PS_None; - - SetLength(SongInfo.Sentences, 0); - - while Result and (I < SSFile.Count) do - begin - Result := ParseLine(SSFile.Strings[I]); - - Inc(I); - end; - - finally - SSFile.Free; - FileStream.Free; - end; - end; -end; - -function TParser.ParseSongHeader (const Filename: IPath): Boolean; -var - I: Integer; - Stream: TBinaryFileStream; -begin - Result := False; - - if Filename.IsFile() then - begin - SSFile := TStringList.Create; - Stream := TBinaryFileStream.Create(Filename, fmOpenRead); - try - SSFile.LoadFromStream(Stream); - - If (SSFile.Count > 0) then - begin - Result := True; - I := 0; - - SongInfo.CountSentences := 0; - CurDuettSinger := DS_Both; //Both is Singstar Standard - CurPosinSong := 0; //Start at Pos 0 - BindLyrics := True; //Dont start with Space - FirstNote := True; //First Note found should be the First Note ;) - - SongInfo.ID := 0; - SongInfo.Header.Language := ''; - SongInfo.Header.Edition := Edition; - SongInfo.DualChannel := False; - ParserState := PS_None; - - While (SongInfo.ID < 4) AND Result And (I < SSFile.Count) do - begin - Result := ParseLine(SSFile.Strings[I]); - - Inc(I); - end; - end - else - ErrorMessage := 'Can''t open melody.xml file'; - - finally - SSFile.Free; - Stream.Free; - end; - end - else - ErrorMessage := 'Can''t find melody.xml file'; -end; - -Function TParser.ParseLine(Line: String): Boolean; -var - Tag: String; - Values: String; - AValues: Array of Record - Name: String; - Value: String; - end; - I, J, K: Integer; - Duration, Tone: Integer; - Lyric: String; - NoteType: Byte; - - Procedure MakeValuesArray; - var Len, Pos, State, StateChange: Integer; - begin - Len := -1; - SetLength(AValues, Len + 1); - - Pos := 1; - State := 0; - While (Pos <= Length(Values)) AND (Pos <> 0) do - begin - Case State of - - 0: begin //Search for ValueName - If (Values[Pos] <> ' ') AND (Values[Pos] <> '=') then - begin - //Found Something - State := 1; //State search for '=' - StateChange := Pos; //Save Pos of Change - Pos := PosEx('=', Values, Pos + 1); - end - else Inc(Pos); //When nothing found then go to next char - end; - - 1: begin //Search for Equal Mark - //Add New Value - Inc(Len); - SetLength(AValues, Len + 1); - - AValues[Len].Name := UpperCase(Copy(Values, StateChange, Pos - StateChange)); - - - State := 2; //Now Search for starting '"' - StateChange := Pos; //Save Pos of Change - Pos := PosEx('"', Values, Pos + 1); - end; - - 2: begin //Search for starting '"' or ' ' <- End if there was no " - If (Values[Pos] = '"') then - begin //Found starting '"' - State := 3; //Now Search for ending '"' - StateChange := Pos; //Save Pos of Change - Pos := PosEx('"', Values, Pos + 1); - end - else If (Values[Pos] = ' ') then //Found ending Space - begin - //Save Value to Array - AValues[Len].Value := Copy(Values, StateChange + 1, Pos - StateChange - 1); - - //Search for next Valuename - State := 0; - StateChange := Pos; - Inc(Pos); - end; - end; - - 3: begin //Search for ending '"' - //Save Value to Array - AValues[Len].Value := Copy(Values, StateChange + 1, Pos - StateChange - 1); - - //Search for next Valuename - State := 0; - StateChange := Pos; - Inc(Pos); - end; - end; - - If (State >= 2) then - begin //Save Last Value - AValues[Len].Value := Copy(Values, StateChange + 1, Length(Values) - StateChange); - end; - end; - end; -begin - Result := True; - - Line := Trim(Line); - If (Length(Line) > 0) then - begin - I := Pos('<', Line); - J := PosEx(' ', Line, I+1); - K := PosEx('>', Line, I+1); - - If (J = 0) then J := K - Else If (K < J) AND (K <> 0) then J := K; //Use nearest Tagname End indicator - Tag := UpperCase(copy(Line, I + 1, J - I - 1)); - Values := copy(Line, J + 1, K - J - 1); - - Case ParserState of - PS_None: begin//Search for Melody Tag - If (Tag = 'MELODY') then - begin - Inc(SongInfo.ID); //Inc SongID when header Information is added - MakeValuesArray; - For I := 0 to High(AValues) do - begin - If (AValues[I].Name = 'TEMPO') then - begin - SongInfo.Header.BPM := StrtoFloatDef(AValues[I].Value, 0); - If (SongInfo.Header.BPM <= 0) then - begin - Result := False; - ErrorMessage := 'Can''t read BPM from Song'; - end; - end - - Else If (AValues[I].Name = 'RESOLUTION') then - begin - AValues[I].Value := Uppercase(AValues[I].Value); - //Ultrastar Resolution is "how often a Beat is split / 4" - If (AValues[I].Value = 'HEMIDEMISEMIQUAVER') then - SongInfo.Header.Resolution := 64 div 4 - Else If (AValues[I].Value = 'DEMISEMIQUAVER') then - SongInfo.Header.Resolution := 32 div 4 - Else If (AValues[I].Value = 'SEMIQUAVER') then - SongInfo.Header.Resolution := 16 div 4 - Else If (AValues[I].Value = 'QUAVER') then - SongInfo.Header.Resolution := 8 div 4 - Else If (AValues[I].Value = 'CROTCHET') then - SongInfo.Header.Resolution := 4 div 4 - Else - begin //Can't understand teh Resolution :/ - Result := False; - ErrorMessage := 'Can''t read Resolution from Song'; - end; - end - - Else If (AValues[I].Name = 'GENRE') then - begin - SongInfo.Header.Genre := AValues[I].Value; - end - - Else If (AValues[I].Name = 'YEAR') then - begin - SongInfo.Header.Year := AValues[I].Value; - end - - Else If (AValues[I].Name = 'VERSION') then - begin - SingstarVersion := AValues[I].Value; - end; - end; - - ParserState := PS_Melody; //In Melody Tag - end; - end; - - - PS_Melody: begin //Search for Sentence, Artist/Title Info or eo Melody - If (Tag = 'SENTENCE') then - begin - ParserState := PS_Sentence; //Parse in a Sentence Tag now - - //Increase SentenceCount - Inc(SongInfo.CountSentences); - - BindLyrics := True; //Don't let Txts Begin w/ Space - - //Search for Duett Singer Info - MakeValuesArray; - For I := 0 to High(AValues) do - If (AValues[I].Name = 'SINGER') then - begin - AValues[I].Value := Uppercase(AValues[I].Value); - If (AValues[I].Value = 'SOLO 1') then - CurDuettSinger := DS_Player1 - Else If (AValues[I].Value = 'SOLO 2') then - CurDuettSinger := DS_Player2 - Else - CurDuettSinger := DS_Both; //In case of "Group" or anything that is not identified use Both - end; - end - - Else If (Tag = '!--') then - begin //Comment, this may be Artist or Title Info - I := Pos(':', Values); //Search for Delimiter - - If (I <> 0) then //If Found check for Title or Artist - begin - //Copy Title or Artist Tag to Tag String - Tag := Uppercase(Trim(Copy(Values, 1, I - 1))); - - If (Tag = 'ARTIST') then - begin - SongInfo.Header.Artist := Trim(Copy(Values, I + 1, Length(Values) - I - 2)); - Inc(SongInfo.ID); //Inc SongID when header Information is added - end - Else If (Tag = 'TITLE') then - begin - SongInfo.Header.Title := Trim(Copy(Values, I + 1, Length(Values) - I - 2)); - Inc(SongInfo.ID); //Inc SongID when header Information is added - end; - end; - end - - //Parsing for weird "Die toten Hosen" Tags - Else If (Tag = '!--ARTIST:') OR (Tag = '!--ARTIST') then - begin //Comment, with Artist Info - I := Pos(':', Values); //Search for Delimiter - - Inc(SongInfo.ID); //Inc SongID when header Information is added - - SongInfo.Header.Artist := Trim(Copy(Values, I + 1, Length(Values) - I - 2)); - end - - Else If (Tag = '!--TITLE:') OR (Tag = '!--TITLE') then - begin //Comment, with Artist Info - I := Pos(':', Values); //Search for Delimiter - - Inc(SongInfo.ID); //Inc SongID when header Information is added - - SongInfo.Header.Title := Trim(Copy(Values, I + 1, Length(Values) - I - 2)); - end - - Else If (Tag = '/MELODY') then - begin - ParserState := PS_None; - Exit; //Stop Parsing, Melody iTag ended - end - end; - - - PS_Sentence: begin //Search for Notes or eo Sentence - If (Tag = 'NOTE') then - begin //Found Note - //Get Values - MakeValuesArray; - - NoteType := NT_Normal; - For I := 0 to High(AValues) do - begin - If (AValues[I].Name = 'DURATION') then - begin - Duration := StrtoIntDef(AValues[I].Value, -1); - If (Duration < 0) then - begin - Result := False; - ErrorMessage := 'Can''t read duration from Note in Line: "' + Line + '"'; - Exit; - end; - end - Else If (AValues[I].Name = 'MIDINOTE') then - begin - Tone := StrtoIntDef(AValues[I].Value, 0); - end - Else If (AValues[I].Name = 'BONUS') AND (Uppercase(AValues[I].Value) = 'YES') then - begin - NoteType := NT_Golden; - end - Else If (AValues[I].Name = 'FREESTYLE') AND (Uppercase(AValues[I].Value) = 'YES') then - begin - NoteType := NT_Freestyle; - end - Else If (AValues[I].Name = 'LYRIC') then - begin - Lyric := AValues[I].Value; - - If (Length(Lyric) > 0) then - begin - If (Lyric = '-') then - Lyric[1] := Settings.DashReplacement; - - If (not BindLyrics) then - Lyric := ' ' + Lyric; - - - If (Length(Lyric) > 2) AND (Lyric[Length(Lyric)-1] = ' ') AND (Lyric[Length(Lyric)] = '-') then - begin //Between this and the next Lyric should be no space - BindLyrics := True; - SetLength(Lyric, Length(Lyric) - 2); - end - else - BindLyrics := False; //There should be a Space - end; - end; - end; - - //Add Note - I := SongInfo.CountSentences - 1; - - If (Length(Lyric) > 0) then - begin //Real note, no rest - //First Note of Sentence - If (Length(SongInfo.Sentences) < SongInfo.CountSentences) then - begin - SetLength(SongInfo.Sentences, SongInfo.CountSentences); - SetLength(SongInfo.Sentences[I].Notes, 0); - end; - - //First Note of Song -> Generate Gap - If (FirstNote) then - begin - //Calculate Gap - If (SongInfo.Header.Resolution <> 0) AND (SongInfo.Header.BPM <> 0) then - SongInfo.Header.Gap := Round(CurPosinSong / (SongInfo.Header.BPM*SongInfo.Header.Resolution) * 60000) - Else - begin - Result := False; - ErrorMessage := 'Can''t calculate Gap, no Resolution or BPM present.'; - Exit; - end; - - CurPosinSong := 0; //Start at 0, because Gap goes until here - Inc(SongInfo.ID); //Add Header Value therefore Inc - FirstNote := False; - end; - - J := Length(SongInfo.Sentences[I].Notes); - SetLength(SongInfo.Sentences[I].Notes, J + 1); - SongInfo.Sentences[I].Notes[J].Start := CurPosinSong; - SongInfo.Sentences[I].Notes[J].Duration := Duration; - SongInfo.Sentences[I].Notes[J].Tone := Tone; - SongInfo.Sentences[I].Notes[J].NoteTyp := NoteType; - SongInfo.Sentences[I].Notes[J].Lyric := Lyric; - - //Inc Pos in Song - Inc(CurPosInSong, Duration); - end - else - begin - //just change pos in Song - Inc(CurPosInSong, Duration); - end; - - - end - Else If (Tag = '/SENTENCE') then - begin //End of Sentence Tag - ParserState := PS_Melody; - - //Delete Sentence if no Note is Added - If (Length(SongInfo.Sentences) <> SongInfo.CountSentences) then - begin - SongInfo.CountSentences := Length(SongInfo.Sentences); - end; - end; - end; - end; - - end - else //Empty Line -> parsed succesful ;) - Result := true; -end; - -Function TParser.ParseConfigForEdition(const Filename: IPath): String; -var - txt: TStringlist; - Stream: TBinaryFileStream; - I: Integer; - J, K: Integer; - S: String; -begin - Result := ''; - - Stream := TBinaryFileStream.Create(Filename, fmOpenRead); - try - txt := TStringlist.Create; - txt.LoadFromStream(Stream); - For I := 0 to txt.Count-1 do - begin - S := Trim(txt.Strings[I]); - J := Pos('', S); - - If (J <> 0) then - begin - Inc(J, 14); - K := Pos('', S); - If (K nil then - begin - Result := FreeImage_AdjustBrightness(FDib, Percentage); - Change; - end - else - Result := False -end; - -function TFreeBitmap.AdjustContrast(Percentage: Double): Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_AdjustContrast(FDib, Percentage); - Change; - end - else - Result := False -end; - -function TFreeBitmap.AdjustCurve(Lut: PByte; - Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_AdjustCurve(FDib, Lut, Channel); - Change; - end - else - Result := False -end; - -function TFreeBitmap.AdjustGamma(Gamma: Double): Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_AdjustGamma(FDib, Gamma); - Change; - end - else - Result := False -end; - -procedure TFreeBitmap.Assign(Source: TFreeBitmap); -var - SourceBmp: TFreeBitmap; - Clone: PFIBITMAP; -begin - if Source = nil then - begin - Clear; - Exit; - end; - - if Source is TFreeBitmap then - begin - SourceBmp := TFreeBitmap(Source); - if SourceBmp <> Self then - begin - if SourceBmp.IsValid then - begin - Clone := FreeImage_Clone(SourceBmp.FDib); - Replace(Clone); - end - else - Clear; - end; - end; -end; - -function TFreeBitmap.CanSave(fif: FREE_IMAGE_FORMAT): Boolean; -var - ImageType: FREE_IMAGE_TYPE; - Bpp: Word; -begin - Result := False; - if not IsValid then Exit; - - if fif <> FIF_UNKNOWN then - begin - // check that the dib can be saved in this format - ImageType := FreeImage_GetImageType(FDib); - if ImageType = FIT_BITMAP then - begin - // standard bitmap type - Bpp := FreeImage_GetBPP(FDib); - Result := FreeImage_FIFSupportsWriting(fif) - and FreeImage_FIFSupportsExportBPP(fif, Bpp); - end - else // special bitmap type - Result := FreeImage_FIFSupportsExportType(fif, ImageType); - end; -end; - -procedure TFreeBitmap.Change; -begin - if Assigned(FOnChange) then FOnChange(Self) -end; - -procedure TFreeBitmap.Clear; -begin - if FDib <> nil then - begin - FreeImage_Unload(FDib); - FDib := nil; - Change; - end; -end; - -function TFreeBitmap.ColorQuantize( - Algorithm: FREE_IMAGE_QUANTIZE): Boolean; -var - dib8: PFIBITMAP; -begin - if FDib <> nil then - begin - dib8 := FreeImage_ColorQuantize(FDib, Algorithm); - Result := Replace(dib8); - end - else - Result := False; -end; - -function TFreeBitmap.CombineChannels(Red, Green, - Blue: TFreeBitmap): Boolean; -var - Width, Height: Integer; -begin - if FDib = nil then - begin - Width := Red.GetWidth; - Height := Red.GetHeight; - FDib := FreeImage_Allocate(Width, Height, 24, FI_RGBA_RED_MASK, - FI_RGBA_GREEN_MASK, FI_RGBA_BLUE_MASK); - end; - - if FDib <> nil then - begin - Result := FreeImage_SetChannel(FDib, Red.FDib, FICC_RED) and - FreeImage_SetChannel(FDib, Green.FDib, FICC_GREEN) and - FreeImage_SetChannel(FDib, Blue.FDib, FICC_BLUE); - - Change - end - else - Result := False; -end; - -function TFreeBitmap.ConvertTo16Bits555: Boolean; -var - dib16_555: PFIBITMAP; -begin - if FDib <> nil then - begin - dib16_555 := FreeImage_ConvertTo16Bits555(FDib); - Result := Replace(dib16_555); - end - else - Result := False -end; - -function TFreeBitmap.ConvertTo16Bits565: Boolean; -var - dib16_565: PFIBITMAP; -begin - if FDib <> nil then - begin - dib16_565 := FreeImage_ConvertTo16Bits565(FDib); - Result := Replace(dib16_565); - end - else - Result := False -end; - -function TFreeBitmap.ConvertTo24Bits: Boolean; -var - dibRGB: PFIBITMAP; -begin - if FDib <> nil then - begin - dibRGB := FreeImage_ConvertTo24Bits(FDib); - Result := Replace(dibRGB); - end - else - Result := False -end; - -function TFreeBitmap.ConvertTo32Bits: Boolean; -var - dib32: PFIBITMAP; -begin - if FDib <> nil then - begin - dib32 := FreeImage_ConvertTo32Bits(FDib); - Result := Replace(dib32); - end - else - Result := False -end; - -function TFreeBitmap.ConvertTo4Bits: Boolean; -var - dib4: PFIBITMAP; -begin - Result := False; - if IsValid then - begin - dib4 := FreeImage_ConvertTo4Bits(FDib); - Result := Replace(dib4); - end; -end; - -function TFreeBitmap.ConvertTo8Bits: Boolean; -var - dib8: PFIBITMAP; -begin - if FDib <> nil then - begin - dib8 := FreeImage_ConvertTo8Bits(FDib); - Result := Replace(dib8); - end - else - Result := False -end; - -function TFreeBitmap.ConvertToGrayscale: Boolean; -var - dib8: PFIBITMAP; -begin - Result := False; - - if IsValid then - begin - dib8 := FreeImage_ConvertToGreyscale(FDib); - Result := Replace(dib8); - end -end; - -function TFreeBitmap.ConvertToRGBF: Boolean; -var - ImageType: FREE_IMAGE_TYPE; - NewDib: PFIBITMAP; -begin - Result := False; - if not IsValid then Exit; - - ImageType := GetImageType; - - if (ImageType = FIT_BITMAP) then - begin - if GetBitsPerPixel < 24 then - if not ConvertTo24Bits then - Exit - end; - NewDib := FreeImage_ConvertToRGBF(FDib); - Result := Replace(NewDib); -end; - -function TFreeBitmap.ConvertToStandardType(ScaleLinear: Boolean): Boolean; -var - dibStandard: PFIBITMAP; -begin - if IsValid then - begin - dibStandard := FreeImage_ConvertToStandardType(FDib, ScaleLinear); - Result := Replace(dibStandard); - end - else - Result := False; -end; - -function TFreeBitmap.ConvertToType(ImageType: FREE_IMAGE_TYPE; - ScaleLinear: Boolean): Boolean; -var - dib: PFIBITMAP; -begin - if FDib <> nil then - begin - dib := FreeImage_ConvertToType(FDib, ImageType, ScaleLinear); - Result := Replace(dib) - end - else - Result := False -end; - -function TFreeBitmap.CopySubImage(Left, Top, Right, Bottom: Integer; - Dest: TFreeBitmap): Boolean; -begin - if FDib <> nil then - begin - Dest.FDib := FreeImage_Copy(FDib, Left, Top, Right, Bottom); - Result := Dest.IsValid; - end else - Result := False; -end; - -constructor TFreeBitmap.Create(ImageType: FREE_IMAGE_TYPE; Width, Height, - Bpp: Integer); -begin - inherited Create; - - FDib := nil; - if (Width > 0) and (Height > 0) and (Bpp > 0) then - SetSize(ImageType, Width, Height, Bpp); -end; - -destructor TFreeBitmap.Destroy; -begin - if FDib <> nil then - FreeImage_Unload(FDib); - inherited; -end; - -function TFreeBitmap.Dither(Algorithm: FREE_IMAGE_DITHER): Boolean; -var - dib: PFIBITMAP; -begin - if FDib <> nil then - begin - dib := FreeImage_Dither(FDib, Algorithm); - Result := Replace(dib); - end - else - Result := False; -end; - -function TFreeBitmap.DoChanging(var OldDib, NewDib: PFIBITMAP): Boolean; -begin - Result := False; - if (OldDib <> NewDib) and Assigned(FOnChanging) then - FOnChanging(Self, OldDib, NewDib, Result); -end; - -procedure TFreeBitmap.FindCloseMetadata(MDHandle: PFIMETADATA); -begin - FreeImage_FindCloseMetadata(MDHandle); -end; - -function TFreeBitmap.FindFirstMetadata(Model: FREE_IMAGE_MDMODEL; - var Tag: TFreeTag): PFIMETADATA; -begin - Result := FreeImage_FindFirstMetadata(Model, FDib, Tag.FTag); -end; - -function TFreeBitmap.FindNextMetadata(MDHandle: PFIMETADATA; - var Tag: TFreeTag): Boolean; -begin - Result := FreeImage_FindNextMetadata(MDHandle, Tag.FTag); -end; - -function TFreeBitmap.FlipHorizontal: Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_FlipHorizontal(FDib); - Change; - end - else - Result := False -end; - -function TFreeBitmap.FlipVertical: Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_FlipVertical(FDib); - Change; - end - else - Result := False -end; - -function TFreeBitmap.GetBitsPerPixel: Integer; -begin - Result := FreeImage_GetBPP(FDib) -end; - -function TFreeBitmap.GetChannel(Bitmap: TFreeBitmap; - Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; -begin - if FDib <> nil then - begin - Bitmap.Dib := FreeImage_GetChannel(FDib, Channel); - Result := Bitmap.IsValid; - end - else - Result := False -end; - -function TFreeBitmap.GetColorsUsed: Integer; -begin - Result := FreeImage_GetColorsUsed(FDib) -end; - -function TFreeBitmap.GetColorType: FREE_IMAGE_COLOR_TYPE; -begin - Result := FreeImage_GetColorType(FDib); -end; - -function TFreeBitmap.GetFileBkColor(var BkColor: PRGBQuad): Boolean; -begin - Result := FreeImage_GetBackgroundColor(FDib, BkColor) -end; - -function TFreeBitmap.GetHeight: Integer; -begin - Result := FreeImage_GetHeight(FDib) -end; - -function TFreeBitmap.GetHistogram(Histo: PDWORD; - Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; -begin - if FDib <> nil then - Result := FreeImage_GetHistogram(FDib, Histo, Channel) - else - Result := False -end; - -function TFreeBitmap.GetHorizontalResolution: Double; -begin - Result := FreeImage_GetDotsPerMeterX(FDib) / 100 -end; - -function TFreeBitmap.GetImageSize: Cardinal; -begin - Result := FreeImage_GetDIBSize(FDib); -end; - -function TFreeBitmap.GetImageType: FREE_IMAGE_TYPE; -begin - Result := FreeImage_GetImageType(FDib); -end; - -function TFreeBitmap.GetInfo: PBitmapInfo; -begin - Result := FreeImage_GetInfo(FDib^) -end; - -function TFreeBitmap.GetInfoHeader: PBITMAPINFOHEADER; -begin - Result := FreeImage_GetInfoHeader(FDib) -end; - -function TFreeBitmap.GetLine: Integer; -begin - Result := FreeImage_GetLine(FDib) -end; - -function TFreeBitmap.GetMetadata(Model: FREE_IMAGE_MDMODEL; - const Key: string; var Tag: TFreeTag): Boolean; -begin - Result := FreeImage_GetMetaData(Model, FDib, PChar(Key), Tag.FTag); -end; - -function TFreeBitmap.GetMetadataCount(Model: FREE_IMAGE_MDMODEL): Cardinal; -begin - Result := FreeImage_GetMetadataCount(Model, FDib); -end; - -function TFreeBitmap.GetPalette: PRGBQUAD; -begin - Result := FreeImage_GetPalette(FDib) -end; - -function TFreeBitmap.GetPaletteSize: Integer; -begin - Result := FreeImage_GetColorsUsed(FDib) * SizeOf(RGBQUAD) -end; - -function TFreeBitmap.GetPixelColor(X, Y: Cardinal; Value: PRGBQUAD): Boolean; -begin - Result := FreeImage_GetPixelColor(FDib, X, Y, Value) -end; - -function TFreeBitmap.GetPixelIndex(X, Y: Cardinal; - var Value: PByte): Boolean; -begin - Result := FreeImage_GetPixelIndex(FDib, X, Y, Value) -end; - -function TFreeBitmap.GetScanLine(ScanLine: Integer): PByte; -var - H: Integer; -begin - H := FreeImage_GetHeight(FDib); - if ScanLine < H then - Result := FreeImage_GetScanLine(FDib, ScanLine) - else - Result := nil; -end; - -function TFreeBitmap.GetScanWidth: Integer; -begin - Result := FreeImage_GetPitch(FDib) -end; - -function TFreeBitmap.GetTransparencyCount: Cardinal; -begin - Result := FreeImage_GetTransparencyCount(FDib) -end; - -function TFreeBitmap.GetTransparencyTable: PByte; -begin - Result := FreeImage_GetTransparencyTable(FDib) -end; - -function TFreeBitmap.GetVerticalResolution: Double; -begin - Result := FreeImage_GetDotsPerMeterY(Fdib) / 100 -end; - -function TFreeBitmap.GetWidth: Integer; -begin - Result := FreeImage_GetWidth(FDib) -end; - -function TFreeBitmap.HasFileBkColor: Boolean; -begin - Result := FreeImage_HasBackgroundColor(FDib) -end; - -function TFreeBitmap.Invert: Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_Invert(FDib); - Change; - end - else - Result := False -end; - -function TFreeBitmap.IsGrayScale: Boolean; -begin - Result := (FreeImage_GetBPP(FDib) = 8) - and (FreeImage_GetColorType(FDib) = FIC_PALETTE); -end; - -function TFreeBitmap.IsTransparent: Boolean; -begin - Result := FreeImage_IsTransparent(FDib); -end; - -function TFreeBitmap.IsValid: Boolean; -begin - Result := FDib <> nil -end; - -function TFreeBitmap.Load(const FileName: string; Flag: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - - // check the file signature and get its format - fif := FreeImage_GetFileType(PChar(Filename), 0); - if fif = FIF_UNKNOWN then - // no signature? - // try to guess the file format from the file extention - fif := FreeImage_GetFIFFromFilename(PChar(FileName)); - - // check that the plugin has reading capabilities ... - if (fif <> FIF_UNKNOWN) and FreeImage_FIFSupportsReading(FIF) then - begin - // free the previous dib - if FDib <> nil then - FreeImage_Unload(dib); - - // load the file - FDib := FreeImage_Load(fif, PChar(FileName), Flag); - - Change; - Result := IsValid; - end else - Result := False; -end; - -function TFreeBitmap.LoadFromHandle(IO: PFreeImageIO; Handle: fi_handle; - Flag: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - // check the file signature and get its format - fif := FreeImage_GetFileTypeFromHandle(IO, Handle, 16); - if (fif <> FIF_UNKNOWN) and FreeImage_FIFSupportsReading(fif) then - begin - // free the previous dib - if FDib <> nil then - FreeImage_Unload(FDib); - - // load the file - FDib := FreeImage_LoadFromHandle(fif, IO, Handle, Flag); - - Change; - Result := IsValid; - end else - Result := False; -end; - -function TFreeBitmap.LoadFromMemory(MemIO: TFreeMemoryIO; - Flag: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - - // check the file signature and get its format - fif := MemIO.GetFileType; - if (fif <> FIF_UNKNOWN) and FreeImage_FIFSupportsReading(fif) then - begin - // free the previous dib - if FDib <> nil then - FreeImage_Unload(FDib); - - // load the file - FDib := MemIO.Read(fif, Flag); - - Result := IsValid; - Change; - end else - Result := False; -end; - -function TFreeBitmap.LoadFromStream(Stream: TStream; - Flag: Integer): Boolean; -var - MemIO: TFreeMemoryIO; - Data: PByte; - MemStream: TMemoryStream; - Size: Cardinal; -begin - Size := Stream.Size; - - MemStream := TMemoryStream.Create; - try - MemStream.CopyFrom(Stream, Size); - Data := MemStream.Memory; - - MemIO := TFreeMemoryIO.Create(Data, Size); - try - Result := LoadFromMemory(MemIO); - finally - MemIO.Free; - end; - finally - MemStream.Free; - end; -end; - -function TFreeBitmap.LoadU(const FileName: WideString; - Flag: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - - // check the file signature and get its format - fif := FreeImage_GetFileTypeU(PWideChar(Filename), 0); - if fif = FIF_UNKNOWN then - // no signature? - // try to guess the file format from the file extention - fif := FreeImage_GetFIFFromFilenameU(PWideChar(FileName)); - - // check that the plugin has reading capabilities ... - if (fif <> FIF_UNKNOWN) and FreeImage_FIFSupportsReading(FIF) then - begin - // free the previous dib - if FDib <> nil then - FreeImage_Unload(dib); - - // load the file - FDib := FreeImage_LoadU(fif, PWideChar(FileName), Flag); - - Change; - Result := IsValid; - end else - Result := False; -end; - -procedure TFreeBitmap.MakeThumbnail(const Width, Height: Integer; - DestBitmap: TFreeBitmap); -type - PRGB24 = ^TRGB24; - TRGB24 = packed record - B: Byte; - G: Byte; - R: Byte; - end; -var - x, y, ix, iy: integer; - x1, x2, x3: integer; - - xscale, yscale: single; - iRed, iGrn, iBlu, iRatio: Longword; - p, c1, c2, c3, c4, c5: TRGB24; - pt, pt1: PRGB24; - iSrc, iDst, s1: integer; - i, j, r, g, b, tmpY: integer; - - RowDest, RowSource, RowSourceStart: integer; - w, h: Integer; - dxmin, dymin: integer; - ny1, ny2, ny3: integer; - dx, dy: integer; - lutX, lutY: array of integer; - - SrcBmp, DestBmp: PFIBITMAP; -begin - if not IsValid then Exit; - - if (GetWidth <= ThumbSize) and (GetHeight <= ThumbSize) then - begin - DestBitmap.Assign(Self); - Exit; - end; - - w := Width; - h := Height; - - // prepare bitmaps - if GetBitsPerPixel <> 24 then - SrcBmp := FreeImage_ConvertTo24Bits(FDib) - else - SrcBmp := FDib; - DestBmp := FreeImage_Allocate(w, h, 24); - Assert(DestBmp <> nil, 'TFreeBitmap.MakeThumbnail error'); - -{ iDst := (w * 24 + 31) and not 31; - iDst := iDst div 8; //BytesPerScanline - iSrc := (GetWidth * 24 + 31) and not 31; - iSrc := iSrc div 8; -} - // BytesPerScanline - iDst := FreeImage_GetPitch(DestBmp); - iSrc := FreeImage_GetPitch(SrcBmp); - - xscale := 1 / (w / FreeImage_GetWidth(SrcBmp)); - yscale := 1 / (h / FreeImage_GetHeight(SrcBmp)); - - // X lookup table - SetLength(lutX, w); - x1 := 0; - x2 := trunc(xscale); - for x := 0 to w - 1 do - begin - lutX[x] := x2 - x1; - x1 := x2; - x2 := trunc((x + 2) * xscale); - end; - - // Y lookup table - SetLength(lutY, h); - x1 := 0; - x2 := trunc(yscale); - for x := 0 to h - 1 do - begin - lutY[x] := x2 - x1; - x1 := x2; - x2 := trunc((x + 2) * yscale); - end; - - Dec(w); - Dec(h); - RowDest := integer(FreeImage_GetScanLine(DestBmp, 0)); - RowSourceStart := integer(FreeImage_GetScanLine(SrcBmp, 0)); - RowSource := RowSourceStart; - - for y := 0 to h do - // resampling - begin - dy := lutY[y]; - x1 := 0; - x3 := 0; - for x := 0 to w do // loop through row - begin - dx:= lutX[x]; - iRed:= 0; - iGrn:= 0; - iBlu:= 0; - RowSource := RowSourceStart; - for iy := 1 to dy do - begin - pt := PRGB24(RowSource + x1); - for ix := 1 to dx do - begin - iRed := iRed + pt.R; - iGrn := iGrn + pt.G; - iBlu := iBlu + pt.B; - inc(pt); - end; - RowSource := RowSource + iSrc; - end; - iRatio := 65535 div (dx * dy); - pt1 := PRGB24(RowDest + x3); - pt1.R := (iRed * iRatio) shr 16; - pt1.G := (iGrn * iRatio) shr 16; - pt1.B := (iBlu * iRatio) shr 16; - x1 := x1 + 3 * dx; - inc(x3,3); - end; - RowDest := RowDest + iDst; - RowSourceStart := RowSource; - end; // resampling - - if FreeImage_GetHeight(DestBmp) >= 3 then - // Sharpening... - begin - s1 := integer(FreeImage_GetScanLine(DestBmp, 0)); - iDst := integer(FreeImage_GetScanLine(DestBmp, 1)) - s1; - ny1 := Integer(s1); - ny2 := ny1 + iDst; - ny3 := ny2 + iDst; - for y := 1 to FreeImage_GetHeight(DestBmp) - 2 do - begin - for x := 0 to FreeImage_GetWidth(DestBmp) - 3 do - begin - x1 := x * 3; - x2 := x1 + 3; - x3 := x1 + 6; - - c1 := pRGB24(ny1 + x1)^; - c2 := pRGB24(ny1 + x3)^; - c3 := pRGB24(ny2 + x2)^; - c4 := pRGB24(ny3 + x1)^; - c5 := pRGB24(ny3 + x3)^; - - r := (c1.R + c2.R + (c3.R * -12) + c4.R + c5.R) div -8; - g := (c1.G + c2.G + (c3.G * -12) + c4.G + c5.G) div -8; - b := (c1.B + c2.B + (c3.B * -12) + c4.B + c5.B) div -8; - - if r < 0 then r := 0 else if r > 255 then r := 255; - if g < 0 then g := 0 else if g > 255 then g := 255; - if b < 0 then b := 0 else if b > 255 then b := 255; - - pt1 := pRGB24(ny2 + x2); - pt1.R := r; - pt1.G := g; - pt1.B := b; - end; - inc(ny1, iDst); - inc(ny2, iDst); - inc(ny3, iDst); - end; - end; // sharpening - - if SrcBmp <> FDib then - FreeImage_Unload(SrcBmp); - DestBitmap.Replace(DestBmp); -end; - -function TFreeBitmap.PasteSubImage(Src: TFreeBitmap; Left, Top, - Alpha: Integer): Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_Paste(FDib, Src.Dib, Left, Top, Alpha); - Change; - end else - Result := False; -end; - -function TFreeBitmap.Replace(NewDib: PFIBITMAP): Boolean; -begin - Result := False; - if NewDib = nil then Exit; - - if not DoChanging(FDib, NewDib) and IsValid then - FreeImage_Unload(FDib); - - FDib := NewDib; - Result := True; - Change; -end; - -function TFreeBitmap.Rescale(NewWidth, NewHeight: Integer; - Filter: FREE_IMAGE_FILTER; Dest: TFreeBitmap): Boolean; -var - Bpp: Integer; - DstDib: PFIBITMAP; -begin - Result := False; - - if FDib <> nil then - begin - Bpp := FreeImage_GetBPP(FDib); - - if Bpp < 8 then - if not ConvertToGrayscale then Exit - else - if Bpp = 16 then - // convert to 24-bit - if not ConvertTo24Bits then Exit; - - // perform upsampling / downsampling - DstDib := FreeImage_Rescale(FDib, NewWidth, NewHeight, Filter); - if Dest = nil then - Result := Replace(DstDib) - else - Result := Dest.Replace(DstDib) - end -end; - -function TFreeBitmap.Rotate(Angle: Double): Boolean; -var - Bpp: Integer; - Rotated: PFIBITMAP; -begin - Result := False; - if IsValid then - begin - Bpp := FreeImage_GetBPP(FDib); - if Bpp in [1, 8, 24, 32] then - begin - Rotated := FreeImage_RotateClassic(FDib, Angle); - Result := Replace(Rotated); - end - end; -end; - -function TFreeBitmap.RotateEx(Angle, XShift, YShift, XOrigin, - YOrigin: Double; UseMask: Boolean): Boolean; -var - Rotated: PFIBITMAP; -begin - Result := False; - if FDib <> nil then - begin - if FreeImage_GetBPP(FDib) >= 8 then - begin - Rotated := FreeImage_RotateEx(FDib, Angle, XShift, YShift, XOrigin, YOrigin, UseMask); - Result := Replace(Rotated); - end - end; -end; - -function TFreeBitmap.Save(const FileName: string; Flag: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - Result := False; - - // try to guess the file format from the file extension - fif := FreeImage_GetFIFFromFilename(PChar(Filename)); - if CanSave(fif) then - Result := FreeImage_Save(fif, FDib, PChar(FileName), Flag); -end; - -function TFreeBitmap.SaveToHandle(fif: FREE_IMAGE_FORMAT; IO: PFreeImageIO; - Handle: fi_handle; Flag: Integer): Boolean; -begin - Result := False; - if CanSave(fif) then - Result := FreeImage_SaveToHandle(fif, FDib, IO, Handle, Flag) -end; - -function TFreeBitmap.SaveToMemory(fif: FREE_IMAGE_FORMAT; - MemIO: TFreeMemoryIO; Flag: Integer): Boolean; -begin - Result := False; - - if CanSave(fif) then - Result := MemIO.Write(fif, FDib, Flag) -end; - -function TFreeBitmap.SaveToStream(fif: FREE_IMAGE_FORMAT; Stream: TStream; - Flag: Integer): Boolean; -var - MemIO: TFreeMemoryIO; - Data: PByte; - Size: Cardinal; -begin - MemIO := TFreeMemoryIO.Create; - try - Result := SaveToMemory(fif, MemIO, Flag); - if Result then - begin - MemIO.Acquire(Data, Size); - Stream.WriteBuffer(Data^, Size); - end; - finally - MemIO.Free; - end; -end; - -function TFreeBitmap.SaveU(const FileName: WideString; - Flag: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - Result := False; - - // try to guess the file format from the file extension - fif := FreeImage_GetFIFFromFilenameU(PWideChar(Filename)); - if CanSave(fif) then - Result := FreeImage_SaveU(fif, FDib, PWideChar(FileName), Flag); -end; - -function TFreeBitmap.SetChannel(Bitmap: TFreeBitmap; - Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; -begin - if FDib <> nil then - begin - Result := FreeImage_SetChannel(FDib, Bitmap.FDib, Channel); - Change; - end - else - Result := False -end; - -procedure TFreeBitmap.SetDib(Value: PFIBITMAP); -begin - Replace(Value); -end; - -function TFreeBitmap.SetFileBkColor(BkColor: PRGBQuad): Boolean; -begin - Result := FreeImage_SetBackgroundColor(FDib, BkColor); - Change; -end; - -procedure TFreeBitmap.SetHorizontalResolution(Value: Double); -begin - if IsValid then - begin - FreeImage_SetDotsPerMeterX(FDib, Trunc(Value * 100 + 0.5)); - Change; - end; -end; - -function TFreeBitmap.SetMetadata(Model: FREE_IMAGE_MDMODEL; - const Key: string; Tag: TFreeTag): Boolean; -begin - Result := FreeImage_SetMetadata(Model, FDib, PChar(Key), Tag.Tag); -end; - -function TFreeBitmap.SetPixelColor(X, Y: Cardinal; - Value: PRGBQUAD): Boolean; -begin - Result := FreeImage_SetPixelColor(FDib, X, Y, Value); - Change; -end; - -function TFreeBitmap.SetPixelIndex(X, Y: Cardinal; Value: PByte): Boolean; -begin - Result := FreeImage_SetPixelIndex(FDib, X, Y, Value); - Change; -end; - -function TFreeBitmap.SetSize(ImageType: FREE_IMAGE_TYPE; Width, Height, - Bpp: Integer; RedMask, GreenMask, BlueMask: Cardinal): Boolean; -var - Pal: PRGBQuad; - I: Cardinal; -begin - Result := False; - - if FDib <> nil then - FreeImage_Unload(FDib); - - FDib := FreeImage_Allocate(Width, Height, Bpp, RedMask, GreenMask, BlueMask); - if FDib = nil then Exit; - - if ImageType = FIT_BITMAP then - case Bpp of - 1, 4, 8: - begin - Pal := FreeImage_GetPalette(FDib); - for I := 0 to FreeImage_GetColorsUsed(FDib) - 1 do - begin - Pal.rgbBlue := I; - Pal.rgbGreen := I; - Pal.rgbRed := I; - Inc(Pal, SizeOf(RGBQUAD)); - end; - end; - end; - - Result := True; - Change; -end; - -procedure TFreeBitmap.SetTransparencyTable(Table: PByte; Count: Integer); -begin - FreeImage_SetTransparencyTable(FDib, Table, Count); - Change; -end; - -procedure TFreeBitmap.SetVerticalResolution(Value: Double); -begin - if IsValid then - begin - FreeImage_SetDotsPerMeterY(FDib, Trunc(Value * 100 + 0.5)); - Change; - end; -end; - -function TFreeBitmap.SplitChannels(RedChannel, GreenChannel, - BlueChannel: TFreeBitmap): Boolean; -begin - if FDib <> nil then - begin - RedChannel.FDib := FreeImage_GetChannel(FDib, FICC_RED); - GreenChannel.FDib := FreeImage_GetChannel(FDib, FICC_GREEN); - BlueChannel.FDib := FreeImage_GetChannel(FDib, FICC_BLUE); - Result := RedChannel.IsValid and GreenChannel.IsValid and BlueChannel.IsValid; - end - else - Result := False -end; - -function TFreeBitmap.Threshold(T: Byte): Boolean; -var - dib1: PFIBITMAP; -begin - if FDib <> nil then - begin - dib1 := FreeImage_Threshold(FDib, T); - Result := Replace(dib1); - end - else - Result := False -end; - -function TFreeBitmap.ToneMapping(TMO: FREE_IMAGE_TMO; FirstParam, - SecondParam: Double): Boolean; -var - NewDib: PFIBITMAP; -begin - Result := False; - if not IsValid then Exit; - - NewDib := FreeImage_ToneMapping(Fdib, TMO, FirstParam, SecondParam); - Result := Replace(NewDib); -end; - - -{ TFreeMultiBitmap } - -procedure TFreeMultiBitmap.AppendPage(Bitmap: TFreeBitmap); -begin - if IsValid then - FreeImage_AppendPage(FMPage, Bitmap.FDib); -end; - -function TFreeMultiBitmap.Close(Flags: Integer): Boolean; -begin - Result := FreeImage_CloseMultiBitmap(FMPage, Flags); - FMPage := nil; -end; - -constructor TFreeMultiBitmap.Create(KeepCacheInMemory: Boolean); -begin - inherited Create; - FMemoryCache := KeepCacheInMemory; -end; - -procedure TFreeMultiBitmap.DeletePage(Page: Integer); -begin - if IsValid then - FreeImage_DeletePage(FMPage, Page); -end; - -destructor TFreeMultiBitmap.Destroy; -begin - if FMPage <> nil then Close; - inherited; -end; - -function TFreeMultiBitmap.GetLockedPageNumbers(var Pages, - Count: Integer): Boolean; -begin - Result := False; - if not IsValid then Exit; - Result := FreeImage_GetLockedPageNumbers(FMPage, Pages, Count) -end; - -function TFreeMultiBitmap.GetPageCount: Integer; -begin - Result := 0; - if IsValid then - Result := FreeImage_GetPageCount(FMPage) -end; - -procedure TFreeMultiBitmap.InsertPage(Page: Integer; Bitmap: TFreeBitmap); -begin - if IsValid then - FreeImage_InsertPage(FMPage, Page, Bitmap.FDib); -end; - -function TFreeMultiBitmap.IsValid: Boolean; -begin - Result := FMPage <> nil -end; - -procedure TFreeMultiBitmap.LockPage(Page: Integer; DestBitmap: TFreeBitmap); -begin - if not IsValid then Exit; - - if Assigned(DestBitmap) then - begin - DestBitmap.Replace(FreeImage_LockPage(FMPage, Page)); - end; -end; - -function TFreeMultiBitmap.MovePage(Target, Source: Integer): Boolean; -begin - Result := False; - if not IsValid then Exit; - Result := FreeImage_MovePage(FMPage, Target, Source); -end; - -function TFreeMultiBitmap.Open(const FileName: string; CreateNew, - ReadOnly: Boolean; Flags: Integer): Boolean; -var - fif: FREE_IMAGE_FORMAT; -begin - Result := False; - - // try to guess the file format from the filename - fif := FreeImage_GetFIFFromFilename(PChar(FileName)); - - // check for supported file types - if (fif <> FIF_UNKNOWN) and (not fif in [FIF_TIFF, FIF_ICO, FIF_GIF]) then - Exit; - - // open the stream - FMPage := FreeImage_OpenMultiBitmap(fif, PChar(FileName), CreateNew, ReadOnly, FMemoryCache, Flags); - - Result := FMPage <> nil; -end; - -procedure TFreeMultiBitmap.UnlockPage(Bitmap: TFreeBitmap; - Changed: Boolean); -begin - if IsValid then - begin - FreeImage_UnlockPage(FMPage, Bitmap.FDib, Changed); - // clear the image so that it becomes invalid. - // don't use Bitmap.Clear method because it calls FreeImage_Unload - // just clear the pointer - Bitmap.FDib := nil; - Bitmap.Change; - end; -end; - -{ TFreeMemoryIO } - -function TFreeMemoryIO.Acquire(var Data: PByte; - var SizeInBytes: DWORD): Boolean; -begin - Result := FreeImage_AcquireMemory(FHMem, Data, SizeInBytes); -end; - -constructor TFreeMemoryIO.Create(Data: PByte; SizeInBytes: DWORD); -begin - inherited Create; - FHMem := FreeImage_OpenMemory(Data, SizeInBytes); -end; - -destructor TFreeMemoryIO.Destroy; -begin - FreeImage_CloseMemory(FHMem); - inherited; -end; - -function TFreeMemoryIO.GetFileType: FREE_IMAGE_FORMAT; -begin - Result := FreeImage_GetFileTypeFromMemory(FHMem); -end; - -function TFreeMemoryIO.IsValid: Boolean; -begin - Result := FHMem <> nil -end; - -function TFreeMemoryIO.Read(fif: FREE_IMAGE_FORMAT; - Flag: Integer): PFIBITMAP; -begin - Result := FreeImage_LoadFromMemory(fif, FHMem, Flag) -end; - -function TFreeMemoryIO.Seek(Offset: Longint; Origin: Word): Boolean; -begin - Result := FreeImage_SeekMemory(FHMem, Offset, Origin) -end; - -function TFreeMemoryIO.Tell: Longint; -begin - Result := FreeImage_TellMemory(FHMem) -end; - -function TFreeMemoryIO.Write(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; - Flag: Integer): Boolean; -begin - Result := FreeImage_SaveToMemory(fif, dib, FHMem, Flag) -end; - -{ TFreeTag } - -function TFreeTag.Clone: TFreeTag; -var - CloneTag: PFITAG; -begin - Result := nil; - if not IsValid then Exit; - - CloneTag := FreeImage_CloneTag(FTag); - Result := TFreeTag.Create(CloneTag); -end; - -constructor TFreeTag.Create(ATag: PFITAG); -begin - inherited Create; - - if ATag <> nil then - FTag := ATag - else - FTag := FreeImage_CreateTag; -end; - -destructor TFreeTag.Destroy; -begin - if IsValid then - FreeImage_DeleteTag(FTag); - - inherited; -end; - -function TFreeTag.GetCount: Cardinal; -begin - Result := 0; - if not IsValid then Exit; - - Result := FreeImage_GetTagCount(FTag); -end; - -function TFreeTag.GetDescription: string; -begin - Result := ''; - if not IsValid then Exit; - - Result := FreeImage_GetTagDescription(FTag); -end; - -function TFreeTag.GetID: Word; -begin - Result := 0; - if not IsValid then Exit; - - Result := FreeImage_GetTagID(FTag); -end; - -function TFreeTag.GetKey: string; -begin - Result := ''; - if not IsValid then Exit; - - Result := FreeImage_GetTagKey(FTag); -end; - -function TFreeTag.GetLength: Cardinal; -begin - Result := 0; - if not IsValid then Exit; - - Result := FreeImage_GetTagLength(FTag); -end; - -function TFreeTag.GetTagType: FREE_IMAGE_MDTYPE; -begin - Result := FIDT_NOTYPE; - if not IsValid then Exit; - - Result := FreeImage_GetTagType(FTag); -end; - -function TFreeTag.GetValue: Pointer; -begin - Result := nil; - if not IsValid then Exit; - - Result := FreeImage_GetTagValue(FTag); -end; - -function TFreeTag.IsValid: Boolean; -begin - Result := FTag <> nil; -end; - -procedure TFreeTag.SetCount(const Value: Cardinal); -begin - if IsValid then - FreeImage_SetTagCount(FTag, Value); -end; - -procedure TFreeTag.SetDescription(const Value: string); -begin - if IsValid then - FreeImage_SetTagDescription(FTag, PChar(Value)); -end; - -procedure TFreeTag.SetID(const Value: Word); -begin - if IsValid then - FreeImage_SetTagID(FTag, Value); -end; - -procedure TFreeTag.SetKey(const Value: string); -begin - if IsValid then - FreeImage_SetTagKey(FTag, PChar(Value)); -end; - -procedure TFreeTag.SetLength(const Value: Cardinal); -begin - if IsValid then - FreeImage_SetTagLength(FTag, Value); -end; - -procedure TFreeTag.SetTagType(const Value: FREE_IMAGE_MDTYPE); -begin - if IsValid then - FreeImage_SetTagType(FTag, Value); -end; - -procedure TFreeTag.SetValue(const Value: Pointer); -begin - if IsValid then - FreeImage_SetTagValue(FTag, Value); -end; - -function TFreeTag.ToString(Model: FREE_IMAGE_MDMODEL; Make: PChar): string; -begin - Result := FreeImage_TagToString(Model, FTag, Make); -end; - -end. diff --git a/src/lib/FreeImage/FreeImage.pas b/src/lib/FreeImage/FreeImage.pas deleted file mode 100644 index 69c0a0d1..00000000 --- a/src/lib/FreeImage/FreeImage.pas +++ /dev/null @@ -1,771 +0,0 @@ -unit FreeImage; - -{$I switches.inc} - - -// ========================================================== -// Delphi wrapper for FreeImage 3 -// -// Design and implementation by -// - Simon Beavis -// - Peter Byström -// - Anatoliy Pulyaevskiy (xvel84@rambler.ru) -// -// This file is part of FreeImage 3 -// -// COVERED CODE IS PROVIDED UNDER THIS LICENSE ON AN "AS IS" BASIS, WITHOUT WARRANTY -// OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, WITHOUT LIMITATION, WARRANTIES -// THAT THE COVERED CODE IS FREE OF DEFECTS, MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE -// OR NON-INFRINGING. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE COVERED -// CODE IS WITH YOU. SHOULD ANY COVERED CODE PROVE DEFECTIVE IN ANY RESPECT, YOU (NOT -// THE INITIAL DEVELOPER OR ANY OTHER CONTRIBUTOR) ASSUME THE COST OF ANY NECESSARY -// SERVICING, REPAIR OR CORRECTION. THIS DISCLAIMER OF WARRANTY CONSTITUTES AN ESSENTIAL -// PART OF THIS LICENSE. NO USE OF ANY COVERED CODE IS AUTHORIZED HEREUNDER EXCEPT UNDER -// THIS DISCLAIMER. -// -// Use at your own risk! -// ========================================================== - -interface - -uses - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF} - ctypes; - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$IFDEF MSWINDOWS} - {$DEFINE DLL_STDCALL} -{$ELSE} - {$DEFINE DLL_CDECL} -{$ENDIF} - -const -{$IF Defined(MSWINDOWS)} - FIDLL = 'freeimage.dll'; -{$ELSEIF Defined(DARWIN)} - FIDLL = 'libfreeimage.dylib'; -{$ELSEIF Defined(UNIX)} - FIDLL = 'libfreeimage.so'; -{$IFEND} - -{$IFNDEF MSWINDOWS} -type - // define portable types for 32-bit / 64-bit OS - BOOL = cint32; - BYTE = cuint8; - WORD = cuint16; - DWORD = cuint32; - LONG = cint32; -{$ENDIF} - -// -------------------------------------------------------------------------- -// Bitmap types ------------------------------------------------------------- -// -------------------------------------------------------------------------- - -type - FIBITMAP = record - data : Pointer; - end; - PFIBITMAP = ^FIBITMAP; - - FIMULTIBITMAP = record - data : Pointer; - end; - PFIMULTIBITMAP = ^FIMULTIBITMAP; - -// -------------------------------------------------------------------------- -// Indexes for byte arrays, masks and shifts for treating pixels as words --- -// These coincide with the order of RGBQUAD and RGBTRIPLE ------------------- -// Little Endian (x86 / MS Windows, Linux) : BGR(A) order ------------------- -// -------------------------------------------------------------------------- - -const - FI_RGBA_RED = 2; - FI_RGBA_GREEN = 1; - FI_RGBA_BLUE = 0; - FI_RGBA_ALPHA = 3; - FI_RGBA_RED_MASK = $00FF0000; - FI_RGBA_GREEN_MASK = $0000FF00; - FI_RGBA_BLUE_MASK = $000000FF; - FI_RGBA_ALPHA_MASK = $FF000000; - FI_RGBA_RED_SHIFT = 16; - FI_RGBA_GREEN_SHIFT = 8; - FI_RGBA_BLUE_SHIFT = 0; - FI_RGBA_ALPHA_SHIFT = 24; - -// -------------------------------------------------------------------------- -// The 16bit macros only include masks and shifts, -------------------------- -// since each color element is not byte aligned ----------------------------- -// -------------------------------------------------------------------------- - -const - FI16_555_RED_MASK = $7C00; - FI16_555_GREEN_MASK = $03E0; - FI16_555_BLUE_MASK = $001F; - FI16_555_RED_SHIFT = 10; - FI16_555_GREEN_SHIFT = 5; - FI16_555_BLUE_SHIFT = 0; - FI16_565_RED_MASK = $F800; - FI16_565_GREEN_MASK = $07E0; - FI16_565_BLUE_MASK = $001F; - FI16_565_RED_SHIFT = 11; - FI16_565_GREEN_SHIFT = 5; - FI16_565_BLUE_SHIFT = 0; - -// -------------------------------------------------------------------------- -// ICC profile support ------------------------------------------------------ -// -------------------------------------------------------------------------- - -const - FIICC_DEFAULT = $0; - FIICC_COLOR_IS_CMYK = $1; - -type - FIICCPROFILE = record - flags : WORD; // info flag - size : DWORD; // profile's size measured in bytes - data : Pointer; // points to a block of contiguous memory containing the profile - end; - PFIICCPROFILE = ^FIICCPROFILE; - -// -------------------------------------------------------------------------- -// Important enums ---------------------------------------------------------- -// -------------------------------------------------------------------------- - -type - FREE_IMAGE_FORMAT = cint; - FREE_IMAGE_TYPE = cint; - FREE_IMAGE_COLOR_TYPE = cint; - FREE_IMAGE_QUANTIZE = cint; - FREE_IMAGE_DITHER = cint; - FREE_IMAGE_FILTER = cint; - FREE_IMAGE_COLOR_CHANNEL = cint; - FREE_IMAGE_MDTYPE = cint; - FREE_IMAGE_MDMODEL = cint; - FREE_IMAGE_JPEG_OPERATION = cint; - FREE_IMAGE_TMO = cint; - -const - // I/O image format identifiers. - FIF_UNKNOWN = FREE_IMAGE_FORMAT(-1); - FIF_BMP = FREE_IMAGE_FORMAT(0); - FIF_ICO = FREE_IMAGE_FORMAT(1); - FIF_JPEG = FREE_IMAGE_FORMAT(2); - FIF_JNG = FREE_IMAGE_FORMAT(3); - FIF_KOALA = FREE_IMAGE_FORMAT(4); - FIF_LBM = FREE_IMAGE_FORMAT(5); - FIF_IFF = FIF_LBM; - FIF_MNG = FREE_IMAGE_FORMAT(6); - FIF_PBM = FREE_IMAGE_FORMAT(7); - FIF_PBMRAW = FREE_IMAGE_FORMAT(8); - FIF_PCD = FREE_IMAGE_FORMAT(9); - FIF_PCX = FREE_IMAGE_FORMAT(10); - FIF_PGM = FREE_IMAGE_FORMAT(11); - FIF_PGMRAW = FREE_IMAGE_FORMAT(12); - FIF_PNG = FREE_IMAGE_FORMAT(13); - FIF_PPM = FREE_IMAGE_FORMAT(14); - FIF_PPMRAW = FREE_IMAGE_FORMAT(15); - FIF_RAS = FREE_IMAGE_FORMAT(16); - FIF_TARGA = FREE_IMAGE_FORMAT(17); - FIF_TIFF = FREE_IMAGE_FORMAT(18); - FIF_WBMP = FREE_IMAGE_FORMAT(19); - FIF_PSD = FREE_IMAGE_FORMAT(20); - FIF_CUT = FREE_IMAGE_FORMAT(21); - FIF_XBM = FREE_IMAGE_FORMAT(22); - FIF_XPM = FREE_IMAGE_FORMAT(23); - FIF_DDS = FREE_IMAGE_FORMAT(24); - FIF_GIF = FREE_IMAGE_FORMAT(25); - FIF_HDR = FREE_IMAGE_FORMAT(26); - FIF_FAXG3 = FREE_IMAGE_FORMAT(27); - FIF_SGI = FREE_IMAGE_FORMAT(28); - - // Image type used in FreeImage. - FIT_UNKNOWN = FREE_IMAGE_TYPE(0); // unknown type - FIT_BITMAP = FREE_IMAGE_TYPE(1); // standard image: 1-, 4-, 8-, 16-, 24-, 32-bit - FIT_UINT16 = FREE_IMAGE_TYPE(2); // array of unsigned short: unsigned 16-bit - FIT_INT16 = FREE_IMAGE_TYPE(3); // array of short: signed 16-bit - FIT_UINT32 = FREE_IMAGE_TYPE(4); // array of unsigned long: unsigned 32-bit - FIT_INT32 = FREE_IMAGE_TYPE(5); // array of long: signed 32-bit - FIT_FLOAT = FREE_IMAGE_TYPE(6); // array of float: 32-bit IEEE floating point - FIT_DOUBLE = FREE_IMAGE_TYPE(7); // array of double: 64-bit IEEE floating point - FIT_COMPLEX = FREE_IMAGE_TYPE(8); // array of FICOMPLEX: 2 x 64-bit IEEE floating point - FIT_RGB16 = FREE_IMAGE_TYPE(9); // 48-bit RGB image: 3 x 16-bit - FIT_RGBA16 = FREE_IMAGE_TYPE(10); // 64-bit RGBA image: 4 x 16-bit - FIT_RGBF = FREE_IMAGE_TYPE(11); // 96-bit RGB float image: 3 x 32-bit IEEE floating point - FIT_RGBAF = FREE_IMAGE_TYPE(12); // 128-bit RGBA float image: 4 x 32-bit IEEE floating point - - // Image color type used in FreeImage. - FIC_MINISWHITE = FREE_IMAGE_COLOR_TYPE(0); // min value is white - FIC_MINISBLACK = FREE_IMAGE_COLOR_TYPE(1); // min value is black - FIC_RGB = FREE_IMAGE_COLOR_TYPE(2); // RGB color model - FIC_PALETTE = FREE_IMAGE_COLOR_TYPE(3); // color map indexed - FIC_RGBALPHA = FREE_IMAGE_COLOR_TYPE(4); // RGB color model with alpha channel - FIC_CMYK = FREE_IMAGE_COLOR_TYPE(5); // CMYK color model - - // Color quantization algorithms. Constants used in FreeImage_ColorQuantize. - FIQ_WUQUANT = FREE_IMAGE_QUANTIZE(0); // Xiaolin Wu color quantization algorithm - FIQ_NNQUANT = FREE_IMAGE_QUANTIZE(1); // NeuQuant neural-net quantization algorithm by Anthony Dekker - - // Dithering algorithms. Constants used FreeImage_Dither. - FID_FS = FREE_IMAGE_DITHER(0); // Floyd & Steinberg error diffusion - FID_BAYER4x4 = FREE_IMAGE_DITHER(1); // Bayer ordered dispersed dot dithering (order 2 dithering matrix) - FID_BAYER8x8 = FREE_IMAGE_DITHER(2); // Bayer ordered dispersed dot dithering (order 3 dithering matrix) - FID_CLUSTER6x6 = FREE_IMAGE_DITHER(3); // Ordered clustered dot dithering (order 3 - 6x6 matrix) - FID_CLUSTER8x8 = FREE_IMAGE_DITHER(4); // Ordered clustered dot dithering (order 4 - 8x8 matrix) - FID_CLUSTER16x16 = FREE_IMAGE_DITHER(5); // Ordered clustered dot dithering (order 8 - 16x16 matrix) - - // Lossless JPEG transformations Constants used in FreeImage_JPEGTransform - FIJPEG_OP_NONE = FREE_IMAGE_JPEG_OPERATION(0); // no transformation - FIJPEG_OP_FLIP_H = FREE_IMAGE_JPEG_OPERATION(1); // horizontal flip - FIJPEG_OP_FLIP_V = FREE_IMAGE_JPEG_OPERATION(2); // vertical flip - FIJPEG_OP_TRANSPOSE = FREE_IMAGE_JPEG_OPERATION(3); // transpose across UL-to-LR axis - FIJPEG_OP_TRANSVERSE = FREE_IMAGE_JPEG_OPERATION(4); // transpose across UR-to-LL axis - FIJPEG_OP_ROTATE_90 = FREE_IMAGE_JPEG_OPERATION(5); // 90-degree clockwise rotation - FIJPEG_OP_ROTATE_180 = FREE_IMAGE_JPEG_OPERATION(6); // 180-degree rotation - FIJPEG_OP_ROTATE_270 = FREE_IMAGE_JPEG_OPERATION(7); // 270-degree clockwise (or 90 ccw) - - // Tone mapping operators. Constants used in FreeImage_ToneMapping. - FITMO_DRAGO03 = FREE_IMAGE_TMO(0); // Adaptive logarithmic mapping (F. Drago, 2003) - FITMO_REINHARD05 = FREE_IMAGE_TMO(1); // Dynamic range reduction inspired by photoreceptor physiology (E. Reinhard, 2005) - - // Upsampling / downsampling filters. Constants used in FreeImage_Rescale. - FILTER_BOX = FREE_IMAGE_FILTER(0); // Box, pulse, Fourier window, 1st order (constant) b-spline - FILTER_BICUBIC = FREE_IMAGE_FILTER(1); // Mitchell & Netravali's two-param cubic filter - FILTER_BILINEAR = FREE_IMAGE_FILTER(2); // Bilinear filter - FILTER_BSPLINE = FREE_IMAGE_FILTER(3); // 4th order (cubic) b-spline - FILTER_CATMULLROM = FREE_IMAGE_FILTER(4); // Catmull-Rom spline, Overhauser spline - FILTER_LANCZOS3 = FREE_IMAGE_FILTER(5); // Lanczos3 filter - - // Color channels. Constants used in color manipulation routines. - FICC_RGB = FREE_IMAGE_COLOR_CHANNEL(0); // Use red, green and blue channels - FICC_RED = FREE_IMAGE_COLOR_CHANNEL(1); // Use red channel - FICC_GREEN = FREE_IMAGE_COLOR_CHANNEL(2); // Use green channel - FICC_BLUE = FREE_IMAGE_COLOR_CHANNEL(3); // Use blue channel - FICC_ALPHA = FREE_IMAGE_COLOR_CHANNEL(4); // Use alpha channel - FICC_BLACK = FREE_IMAGE_COLOR_CHANNEL(5); // Use black channel - FICC_REAL = FREE_IMAGE_COLOR_CHANNEL(6); // Complex images: use real part - FICC_IMAG = FREE_IMAGE_COLOR_CHANNEL(7); // Complex images: use imaginary part - FICC_MAG = FREE_IMAGE_COLOR_CHANNEL(8); // Complex images: use magnitude - FICC_PHASE = FREE_IMAGE_COLOR_CHANNEL(9); // Complex images: use phase - - // Tag data type information (based on TIFF specifications) - FIDT_NOTYPE = FREE_IMAGE_MDTYPE(0); // placeholder - FIDT_BYTE = FREE_IMAGE_MDTYPE(1); // 8-bit unsigned integer - FIDT_ASCII = FREE_IMAGE_MDTYPE(2); // 8-bit bytes w/ last byte null - FIDT_SHORT = FREE_IMAGE_MDTYPE(3); // 16-bit unsigned integer - FIDT_LONG = FREE_IMAGE_MDTYPE(4); // 32-bit unsigned integer - FIDT_RATIONAL = FREE_IMAGE_MDTYPE(5); // 64-bit unsigned fraction - FIDT_SBYTE = FREE_IMAGE_MDTYPE(6); // 8-bit signed integer - FIDT_UNDEFINED = FREE_IMAGE_MDTYPE(7); // 8-bit untyped data - FIDT_SSHORT = FREE_IMAGE_MDTYPE(8); // 16-bit signed integer - FIDT_SLONG = FREE_IMAGE_MDTYPE(9); // 32-bit signed integer - FIDT_SRATIONAL = FREE_IMAGE_MDTYPE(10); // 64-bit signed fraction - FIDT_FLOAT = FREE_IMAGE_MDTYPE(11); // 32-bit IEEE floating point - FIDT_DOUBLE = FREE_IMAGE_MDTYPE(12); // 64-bit IEEE floating point - FIDT_IFD = FREE_IMAGE_MDTYPE(13); // 32-bit unsigned integer (offset) - FIDT_PALETTE = FREE_IMAGE_MDTYPE(14); // 32-bit RGBQUAD - - // Metadata models supported by FreeImage - FIMD_NODATA = FREE_IMAGE_MDMODEL(-1); - FIMD_COMMENTS = FREE_IMAGE_MDMODEL(0); // single comment or keywords - FIMD_EXIF_MAIN = FREE_IMAGE_MDMODEL(1); // Exif-TIFF metadata - FIMD_EXIF_EXIF = FREE_IMAGE_MDMODEL(2); // Exif-specific metadata - FIMD_EXIF_GPS = FREE_IMAGE_MDMODEL(3); // Exif GPS metadata - FIMD_EXIF_MAKERNOTE = FREE_IMAGE_MDMODEL(4); // Exif maker note metadata - FIMD_EXIF_INTEROP = FREE_IMAGE_MDMODEL(5); // Exif interoperability metadata - FIMD_IPTC = FREE_IMAGE_MDMODEL(6); // IPTC/NAA metadata - FIMD_XMP = FREE_IMAGE_MDMODEL(7); // Abobe XMP metadata - FIMD_GEOTIFF = FREE_IMAGE_MDMODEL(8); // GeoTIFF metadata (to be implemented) - FIMD_ANIMATION = FREE_IMAGE_MDMODEL(9); // Animation metadata - FIMD_CUSTOM = FREE_IMAGE_MDMODEL(10); // Used to attach other metadata types to a dib - -//{$endif} - -type - // Handle to a metadata model - FIMETADATA = record - data: Pointer; - end; - PFIMETADATA = ^FIMETADATA; - - // Handle to a metadata tag - FITAG = record - data: Pointer; - end; - PFITAG = ^FITAG; - -// -------------------------------------------------------------------------- -// File IO routines --------------------------------------------------------- -// -------------------------------------------------------------------------- - -type - FI_Handle = Pointer; - - FI_ReadProc = function(buffer : pointer; size : cuint; count : cuint; handle : fi_handle) : cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_WriteProc = function(buffer : pointer; size, count : cuint; handle : FI_Handle) : cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_SeekProc = function(handle : fi_handle; offset : clong; origin : cint) : cint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_TellProc = function(handle : fi_handle) : clong; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - - FreeImageIO = packed record - read_proc : FI_ReadProc; // pointer to the function used to read data - write_proc: FI_WriteProc; // pointer to the function used to write data - seek_proc : FI_SeekProc; // pointer to the function used to seek - tell_proc : FI_TellProc; // pointer to the function used to aquire the current position - end; - PFreeImageIO = ^FreeImageIO; - - // Handle to a memory I/O stream - FIMEMORY = record - data: Pointer; - end; - PFIMEMORY = ^FIMEMORY; - -const - // constants used in FreeImage_Seek for Origin parameter - SEEK_SET = 0; - SEEK_CUR = 1; - SEEK_END = 2; - -// -------------------------------------------------------------------------- -// Plugin routines ---------------------------------------------------------- -// -------------------------------------------------------------------------- - -type - PPluginStruct = ^PluginStruct; - - FI_InitProc = procedure(Plugin: PPluginStruct; Format_ID: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_FormatProc = function: PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_DescriptionProc = function: PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_ExtensionListProc = function: PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_RegExprProc = function: PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_OpenProc = function(IO: PFreeImageIO; Handle: FI_Handle; Read: BOOL): Pointer; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_CloseProc = procedure(IO: PFreeImageIO; Handle: FI_Handle; Data: Pointer); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_PageCountProc = function(IO: PFreeImageIO; Handle: FI_Handle; Data: Pointer): cint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_PageCapabilityProc = function(IO: PFreeImageIO; Handle: FI_Handle; Data: Pointer): cint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_LoadProc = function(IO: PFreeImageIO; Handle: FI_Handle; Page, Flags: cint; data: pointer): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_SaveProc = function(IO: PFreeImageIO; Dib: PFIBITMAP; Handle: FI_Handle; Page, Flags: cint; Data: Pointer): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_ValidateProc = function(IO: PFreeImageIO; Handle: FI_Handle): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_MimeProc = function: PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_SupportsExportBPPProc = function(Bpp: cint): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_SupportsExportTypeProc = function(AType: FREE_IMAGE_TYPE): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - FI_SupportsICCProfilesProc = function: BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} - - PluginStruct = record - format_proc: FI_FormatProc; - description_proc: FI_DescriptionProc; - extension_proc: FI_ExtensionListProc; - regexpr_proc: FI_RegExprProc; - open_proc: FI_OpenProc; - close_proc: FI_CloseProc; - pagecount_proc: FI_PageCountProc; - pagecapability_proc: FI_PageCapabilityProc; - load_proc: FI_LoadProc; - save_proc: FI_SaveProc; - validate_proc: FI_ValidateProc; - mime_proc: FI_MimeProc; - supports_export_bpp_proc: FI_SupportsExportBPPProc; - supports_export_type_proc: FI_SupportsExportTypeProc; - supports_icc_profiles_proc: FI_SupportsICCProfilesProc; - end; - -// -------------------------------------------------------------------------- -// Load/Save flag constants ------------------------------------------------- -// -------------------------------------------------------------------------- - -const - BMP_DEFAULT = 0; - BMP_SAVE_RLE = 1; - CUT_DEFAULT = 0; - DDS_DEFAULT = 0; - FAXG3_DEFAULT = 0; - GIF_DEFAULT = 0; - ICO_DEFAULT = 0; - ICO_MAKEALPHA = 0; // convert to 32bpp and create an alpha channel from the AND-mask when loading - IFF_DEFAULT = 0; - JPEG_DEFAULT = 0; - JPEG_FAST = 1; - JPEG_ACCURATE = 2; - JPEG_QUALITYSUPERB = $0080; - JPEG_QUALITYGOOD = $0100; - JPEG_QUALITYNORMAL = $0200; - JPEG_QUALITYAVERAGE = $0400; - JPEG_QUALITYBAD = $0800; - JPEG_CMYK = $1000; // load separated CMYK "as is" (use | to combine with other flags) - KOALA_DEFAULT = 0; - LBM_DEFAULT = 0; - MNG_DEFAULT = 0; - PCD_DEFAULT = 0; - PCD_BASE = 1; // load the bitmap sized 768 x 512 - PCD_BASEDIV4 = 2; // load the bitmap sized 384 x 256 - PCD_BASEDIV16 = 3; // load the bitmap sized 192 x 128 - PCX_DEFAULT = 0; - PNG_DEFAULT = 0; - PNG_IGNOREGAMMA = 1; // avoid gamma correction - PNM_DEFAULT = 0; - PNM_SAVE_RAW = 0; // If set the writer saves in RAW format (i.e. P4, P5 or P6) - PNM_SAVE_ASCII = 1; // If set the writer saves in ASCII format (i.e. P1, P2 or P3) - PSD_DEFAULT = 0; - RAS_DEFAULT = 0; - SGI_DEFAULT = 0; - TARGA_DEFAULT = 0; - TARGA_LOAD_RGB888 = 1; // If set the loader converts RGB555 and ARGB8888 -> RGB888. - TIFF_DEFAULT = 0; - TIFF_CMYK = $0001; // reads/stores tags for separated CMYK (use | to combine with compression flags) - TIFF_PACKBITS = $0100; // save using PACKBITS compression - TIFF_DEFLATE = $0200; // save using DEFLATE compression - TIFF_ADOBE_DEFLATE = $0400; // save using ADOBE DEFLATE compression - TIFF_NONE = $0800; // save without any compression - TIFF_CCITTFAX = $1000; // save using CCITT Group 3 fax encoding - TIFF_CCITTFAX4 = $2000; // save using CCITT Group 4 fax encoding - TIFF_LZW = $4000; // save using LZW compression - TIFF_JPEG = $8000; // save using JPEG compression - WBMP_DEFAULT = 0; - XBM_DEFAULT = 0; - XPM_DEFAULT = 0; - -// -------------------------------------------------------------------------- -// Init/Error routines ------------------------------------------------------ -// -------------------------------------------------------------------------- - -procedure FreeImage_Initialise(load_local_plugins_only : BOOL = False); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_DeInitialise; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Version routines --------------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_GetVersion : PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetCopyrightMessage : PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Message output functions ------------------------------------------------- -// -------------------------------------------------------------------------- - -procedure FreeImage_OutPutMessageProc(fif: cint; fmt: PChar); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -type FreeImage_OutputMessageFunction = function(fif: FREE_IMAGE_FORMAT; msg: PChar): pointer; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} -procedure FreeImage_SetOutputMessage(omf: FreeImage_OutputMessageFunction); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Allocate/Unload routines ------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_Allocate(width, height, bpp: cint; red_mask: cuint = 0; green_mask: cuint = 0; blue_mask: cuint = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_AllocateT(Atype: FREE_IMAGE_TYPE; Width, Height: cint; bpp: cint = 8; red_mask: cuint = 0; green_mask: cuint = 0; blue_mask: cuint = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Clone(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_Unload(dib: PFIBITMAP); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Load / Save routines ----------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_Load(fif: FREE_IMAGE_FORMAT; const filename: PChar; flags: cint = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_LoadU(fif: FREE_IMAGE_FORMAT; const filename: PWideChar; flags: cint = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_LoadFromHandle(fif: FREE_IMAGE_FORMAT; io: PFreeImageIO; handle: fi_handle; flags: cint = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Save(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; filename: PChar; flags: cint = 0): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SaveU(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; const filename: PWideChar; flags: cint = 0): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SaveToHandle(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; io : PFreeImageIO; handle : fi_handle; flags : cint = 0) : BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Memory I/O stream routines ----------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_OpenMemory(data: PByte = nil; size_in_bytes: DWORD = 0): PFIMEMORY; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_CloseMemory(stream: PFIMEMORY); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_LoadFromMemory(fif: FREE_IMAGE_FORMAT; stream: PFIMEMORY; flags: cint = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SaveToMemory(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; stream: PFIMEMORY; flags: cint = 0): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_TellMemory(stream: PFIMEMORY): clong; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SeekMemory(stream: PFIMEMORY; offset: clong; origin: cint): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_AcquireMemory(stream: PFIMEMORY; var data: PByte; var size_in_bytes: DWORD): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Plugin Interface --------------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_RegisterLocalPlugin(proc_address: FI_InitProc; format, description, extension, regexpr: PChar): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_RegisterExternalPlugin(path, format, description, extension, regexpr: PChar): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFCount: cint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_SetPluginEnabled(fif: FREE_IMAGE_FORMAT; enable: BOOL); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_IsPluginEnabled(fif: FREE_IMAGE_FORMAT): cint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFFromFormat(const format: PChar): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFFromMime(const format: PChar): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFormatFromFIF(fif: FREE_IMAGE_FORMAT): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFExtensionList(fif: FREE_IMAGE_FORMAT): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFDescription(fif: FREE_IMAGE_FORMAT): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFRegExpr(fif: FREE_IMAGE_FORMAT): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFFromFilename(const fname: PChar): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFIFFromFilenameU(const fname:PWideChar): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FIFSupportsReading(fif: FREE_IMAGE_FORMAT): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FIFSupportsWriting(fif: FREE_IMAGE_FORMAT): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FIFSupportsExportBPP(fif: FREE_IMAGE_FORMAT; bpp: cint): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FIFSupportsICCProfiles(fif: FREE_IMAGE_FORMAT): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FIFSupportsExportType(fif: FREE_IMAGE_FORMAT; image_type: FREE_IMAGE_TYPE): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Multipaging interface ---------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_OpenMultiBitmap(fif: FREE_IMAGE_FORMAT; filename: PChar; create_new, read_only, keep_cache_in_memory: BOOL; flags: cint = 0): PFIMULTIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_CloseMultiBitmap(bitmap: PFIMULTIBITMAP; flags: cint = 0): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetPageCount(bitmap: PFIMULTIBITMAP): cint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_AppendPage(bitmap: PFIMULTIBITMAP; data: PFIBITMAP); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_InsertPage(bitmap: PFIMULTIBITMAP; page: cint; data: PFIBITMAP); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_DeletePage(bitmap: PFIMULTIBITMAP; page: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_LockPage(bitmap: PFIMULTIBITMAP; page: cint): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_UnlockPage(bitmap: PFIMULTIBITMAP; page: PFIBITMAP; changed: BOOL); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_MovePage(bitmap: PFIMULTIBITMAP; target, source: cint): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetLockedPageNumbers(bitmap: PFIMULTIBITMAP; var pages: cint; var count : cint): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Filetype request routines ------------------------------------------------ -// -------------------------------------------------------------------------- - -function FreeImage_GetFileType(const filename: PChar; size: cint): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFileTypeU(const filename: PWideChar; size: cint): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFileTypeFromHandle(io: PFreeImageIO; handle: FI_Handle; size: cint = 0): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetFileTypeFromMemory(stream: PFIMEMORY; size: cint = 0): FREE_IMAGE_FORMAT; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// ImageType request routine ------------------------------------------------ -// -------------------------------------------------------------------------- - -function FreeImage_GetImageType(dib: PFIBITMAP): FREE_IMAGE_TYPE; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// FreeImage helper routines ------------------------------------------------ -// -------------------------------------------------------------------------- - -function FreeImage_IsLittleEndian: BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_LookupX11Color(const szColor: PChar; var nRed, nGreen, nBlue: PByte): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_LookupSVGColor(const szColor: PChar; var nRed, nGreen, nBlue: PByte): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Pixels access routines --------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_GetBits(dib: PFIBITMAP): PByte; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetScanLine(dib: PFIBITMAP; scanline: cint): PByte; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_GetPixelIndex(dib: PFIBITMAP; X, Y: cuint; Value: PByte): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetPixelColor(dib: PFIBITMAP; X, Y: cuint; Value: PRGBQuad): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetPixelIndex(dib: PFIBITMAP; X, Y: cuint; Value: PByte): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetPixelColor(dib: PFIBITMAP; X, Y: cuint; Value: PRGBQuad): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// DIB info routines -------------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_GetColorsUsed(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetBPP(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetWidth(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetHeight(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetLine(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetPitch(dib : PFIBITMAP) : cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetDIBSize(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetPalette(dib: PFIBITMAP): PRGBQUAD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_GetDotsPerMeterX(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetDotsPerMeterY(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_SetDotsPerMeterX(dib: PFIBITMAP; res: cuint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_SetDotsPerMeterY(dib: PFIBITMAP; res: cuint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_GetInfoHeader(dib: PFIBITMAP): PBITMAPINFOHEADER; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetInfo(var dib: FIBITMAP): PBITMAPINFO; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetColorType(dib: PFIBITMAP): FREE_IMAGE_COLOR_TYPE; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_GetRedMask(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetGreenMask(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetBlueMask(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_GetTransparencyCount(dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTransparencyTable(dib: PFIBITMAP): PByte; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_SetTransparent(dib: PFIBITMAP; enabled: BOOL); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_SetTransparencyTable(dib: PFIBITMAP; table: PByte; count: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_IsTransparent(dib: PFIBITMAP): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_HasBackgroundColor(dib: PFIBITMAP): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetBackgroundColor(dib: PFIBITMAP; var bkcolor: PRGBQUAD): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetBackgroundColor(dib: PFIBITMAP; bkcolor: PRGBQUAD): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// ICC profile routines ----------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_GetICCProfile(var dib: FIBITMAP): PFIICCPROFILE; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_CreateICCProfile(var dib: FIBITMAP; data: Pointer; size: clong): PFIICCPROFILE; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_DestroyICCProfile(var dib : FIBITMAP); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Line conversion routines ------------------------------------------------- -// -------------------------------------------------------------------------- - -procedure FreeImage_ConvertLine1To4(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine8To4(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQuad); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To4_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To4_565(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine24To4(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine32To4(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -procedure FreeImage_ConvertLine1To8(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine4To8(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To8_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To8_565(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine24To8(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine32To8(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -procedure FreeImage_ConvertLine1To16_555(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine4To16_555(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine8To16_555(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16_565_To16_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine24To16_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine32To16_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -procedure FreeImage_ConvertLine1To16_565(target, source : PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine4To16_565(target, source : PBYTE; width_in_pixels : cint; palette : PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine8To16_565(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16_555_To16_565(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine24To16_565(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine32To16_565(target, source : PBYTE; width_in_pixels : cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -procedure FreeImage_ConvertLine1To24(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine4To24(target, source : PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine8To24(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To24_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To24_565(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine32To24(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -procedure FreeImage_ConvertLine1To32(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine4To32(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine8To32(target, source: PBYTE; width_in_pixels: cint; palette: PRGBQUAD); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To32_555(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine16To32_565(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertLine24To32(target, source: PBYTE; width_in_pixels: cint); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Smart conversion routines ------------------------------------------------ -// -------------------------------------------------------------------------- - -function FreeImage_ConvertTo4Bits(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertTo8Bits(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertToGreyscale(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertTo16Bits555(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertTo16Bits565(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertTo24Bits(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertTo32Bits(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ColorQuantize(dib: PFIBITMAP; quantize: FREE_IMAGE_QUANTIZE): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ColorQuantizeEx(dib: PFIBITMAP; quantize: FREE_IMAGE_QUANTIZE = FIQ_WUQUANT; PaletteSize: cint = 256; ReserveSize: cint = 0; ReservePalette: PRGBQuad = nil): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Threshold(dib: PFIBITMAP; T: Byte): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Dither(dib: PFIBITMAP; algorithm: FREE_IMAGE_DITHER): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_ConvertFromRawBits(bits: PBYTE; width, height, pitch: cint; bpp, red_mask, green_mask, blue_mask: cuint; topdown: BOOL): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_ConvertToRawBits(bits: PBYTE; dib: PFIBITMAP; pitch: cint; bpp, red_mask, green_mask, blue_mask: cuint; topdown: BOOL); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_ConvertToRGBF(dib: PFIBITMAP): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_ConvertToStandardType(src: PFIBITMAP; scale_linear: BOOL = True): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ConvertToType(src: PFIBITMAP; dst_type: FREE_IMAGE_TYPE; scale_linear: BOOL = True): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// tone mapping operators -function FreeImage_ToneMapping(dib: PFIBITMAP; tmo: FREE_IMAGE_TMO; first_param: cdouble = 0; second_param: cdouble = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_TmoDrago03(src: PFIBITMAP; gamma: cdouble = 2.2; exposure: cdouble = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_TmoReinhard05(src: PFIBITMAP; intensity: cdouble = 0; contrast: cdouble = 0): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// ZLib interface ----------------------------------------------------------- -// -------------------------------------------------------------------------- - -function FreeImage_ZLibCompress(target: PBYTE; target_size: DWORD; source: PBYTE; source_size: DWORD): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ZLibUncompress(target: PBYTE; target_size: DWORD; source: PBYTE; source_size: DWORD): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_ZLibGZip(target: PBYTE; target_size: DWORD; source: PBYTE; source_size: DWORD): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ZLibGUnzip(target: PBYTE; target_size: DWORD; source: PBYTE; source_size: DWORD): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_ZLibCRC32(crc: DWORD; source: PByte; source_size: DWORD): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Metadata routines -------------------------------------------------------- -// -------------------------------------------------------------------------- - -// tag creation / destruction -function FreeImage_CreateTag: PFITAG; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_DeleteTag(tag: PFITAG); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_CloneTag(tag: PFITAG): PFITAG; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// tag getters and setters -function FreeImage_GetTagKey(tag: PFITAG): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTagDescription(tag: PFITAG): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTagID(tag: PFITAG): Word; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTagType(tag: PFITAG): FREE_IMAGE_MDTYPE; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTagCount(tag: PFITAG): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTagLength(tag: PFITAG): DWORD; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetTagValue(tag: PFITAG): Pointer; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -function FreeImage_SetTagKey(tag: PFITAG; const key: PChar): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetTagDescription(tag: PFITAG; const description: PChar): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetTagID(tag: PFITAG; id: Word): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetTagType(tag: PFITAG; atype: FREE_IMAGE_MDTYPE): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetTagCount(tag: PFITAG; count: DWORD): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetTagLength(tag: PFITAG; length: DWORD): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetTagValue(tag: PFITAG; const value: Pointer): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// iterator -function FreeImage_FindFirstMetadata(model: FREE_IMAGE_MDMODEL; dib: PFIBITMAP; var tag: PFITAG): PFIMETADATA; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FindNextMetadata(mdhandle: PFIMETADATA; var tag: PFITAG): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -procedure FreeImage_FindCloseMetadata(mdhandle: PFIMETADATA); {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// metadata setter and getter -function FreeImage_SetMetadata(model: FREE_IMAGE_MDMODEL; dib: PFIBITMAP; const key: PChar; tag: PFITAG): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetMetadata(model: FREE_IMAGE_MDMODEL; dib: PFIBITMAP; const key: PChar; var tag: PFITAG): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// helpers -function FreeImage_GetMetadataCount(model: FREE_IMAGE_MDMODEL; dib: PFIBITMAP): cuint; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// tag to C string conversion -function FreeImage_TagToString(model: FREE_IMAGE_MDMODEL; tag: PFITAG; Make: PChar = nil): PChar; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// -------------------------------------------------------------------------- -// Image manipulation toolkit ----------------------------------------------- -// -------------------------------------------------------------------------- - -// rotation and flipping -function FreeImage_RotateClassic(dib: PFIBITMAP; angle: cdouble): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_RotateEx(dib: PFIBITMAP; angle, x_shift, y_shift, x_origin, y_origin: cdouble; use_mask: BOOL): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FlipHorizontal(dib: PFIBITMAP): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_FlipVertical(dib: PFIBITMAP): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_JPEGTransform(const src_file: PChar; const dst_file: PChar; operation: FREE_IMAGE_JPEG_OPERATION; perfect: BOOL = False): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// upsampling / downsampling -function FreeImage_Rescale(dib: PFIBITMAP; dst_width, dst_height: cint; filter: FREE_IMAGE_FILTER): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_MakeThumbnail(dib: PFIBITMAP; max_pixel_size: cint; convert:BOOL = TRUE): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// color manipulation routines (point operations) -function FreeImage_AdjustCurve(dib: PFIBITMAP; LUT: PBYTE; channel: FREE_IMAGE_COLOR_CHANNEL): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_AdjustGamma(dib: PFIBITMAP; gamma: cdouble): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_AdjustBrightness(dib: PFIBITMAP; percentage: cdouble): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_AdjustContrast(dib: PFIBITMAP; percentage: cdouble): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Invert(dib: PFIBITMAP): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetHistogram(dib: PFIBITMAP; histo: PDWORD; channel: FREE_IMAGE_COLOR_CHANNEL = FICC_BLACK): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// channel processing routines -function FreeImage_GetChannel(dib: PFIBITMAP; channel: FREE_IMAGE_COLOR_CHANNEL): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetChannel(dib, dib8: PFIBITMAP; channel: FREE_IMAGE_COLOR_CHANNEL): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_GetComplexChannel(src: PFIBITMAP; channel: FREE_IMAGE_COLOR_CHANNEL): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_SetComplexChannel(src: PFIBITMAP; channel: FREE_IMAGE_COLOR_CHANNEL): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -// copy / paste / composite routines - -function FreeImage_Copy(dib: PFIBITMAP; left, top, right, bottom: cint): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Paste(dst, src: PFIBITMAP; left, top, alpha: cint): BOOL; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; -function FreeImage_Composite(fg: PFIBITMAP; useFileBkg: BOOL = False; appBkColor: PRGBQUAD = nil; bg: PFIBITMAP = nil): PFIBITMAP; {$IFDEF DLL_STDCALL} stdcall; {$ENDIF} {$IFDEF DLL_CDECL} cdecl; {$ENDIF} external FIDLL; - -{$MINENUMSIZE 1} -implementation - -end. diff --git a/src/lib/JEDI-SDL/OpenGL/Pas/geometry.pas b/src/lib/JEDI-SDL/OpenGL/Pas/geometry.pas deleted file mode 100644 index 166ec811..00000000 --- a/src/lib/JEDI-SDL/OpenGL/Pas/geometry.pas +++ /dev/null @@ -1,1994 +0,0 @@ -unit geometry; -{ - $Id: geometry.pas,v 1.1 2004/03/30 21:53:54 savage Exp $ - -} - -// This unit contains many needed types, functions and procedures for -// quaternion, vector and matrix arithmetics. It is specifically designed -// for geometric calculations within R3 (affine vector space) -// and R4 (homogeneous vector space). -// -// Note: The terms 'affine' or 'affine coordinates' are not really correct here -// because an 'affine transformation' describes generally a transformation which leads -// to a uniquely solvable system of equations and has nothing to do with the dimensionality -// of a vector. One could use 'projective coordinates' but this is also not really correct -// and since I haven't found a better name (or even any correct one), 'affine' is as good -// as any other one. -// -// Identifiers containing no dimensionality (like affine or homogeneous) -// and no datatype (integer..extended) are supposed as R4 representation -// with 'single' floating point type (examples are TVector, TMatrix, -// and TQuaternion). The default data type is 'single' ('GLFloat' for OpenGL) -// and used in all routines (except conversions and trigonometric functions). -// -// Routines with an open array as argument can either take Func([1,2,3,4,..]) or Func(Vect). -// The latter is prefered, since no extra stack operations is required. -// Note: Be careful while passing open array elements! If you pass more elements -// than there's room in the result the behaviour will be unpredictable. -// -// If not otherwise stated, all angles are given in radians -// (instead of degrees). Use RadToDeg or DegToRad to convert between them. -// -// Geometry.pas was assembled from different sources (like GraphicGems) -// and relevant books or based on self written code, respectivly. -// -// Note: Some aspects need to be considered when using Delphi and pure -// assembler code. Delphi ensures that the direction flag is always -// cleared while entering a function and expects it cleared on return. -// This is in particular important in routines with (CPU) string commands (MOVSD etc.) -// The registers EDI, ESI and EBX (as well as the stack management -// registers EBP and ESP) must not be changed! EAX, ECX and EDX are -// freely available and mostly used for parameter. -// -// Version 2.5 -// last change : 04. January 2000 -// -// (c) Copyright 1999, Dipl. Ing. Mike Lischke (public@lischke-online.de) -{ - $Log: geometry.pas,v $ - Revision 1.1 2004/03/30 21:53:54 savage - Moved to it's own folder. - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - -} - -interface - -{$I jedi-sdl.inc} - -type - // data types needed for 3D graphics calculation, - // included are 'C like' aliases for each type (to be - // conformal with OpenGL types) - - PByte = ^Byte; - PWord = ^Word; - PInteger = ^Integer; - PFloat = ^Single; - PDouble = ^Double; - PExtended = ^Extended; - PPointer = ^Pointer; - - // types to specify continous streams of a specific type - // switch off range checking to access values beyond the limits - PByteVector = ^TByteVector; - PByteArray = PByteVector; - TByteVector = array[0..0] of Byte; - - PWordVector = ^TWordVector; - PWordArray = PWordVector; // note: there's a same named type in SysUtils - TWordVector = array[0..0] of Word; - - PIntegerVector = ^TIntegerVector; - PIntegerArray = PIntegerVector; - TIntegerVector = array[0..0] of Integer; - - PFloatVector = ^TFloatVector; - PFloatArray = PFloatVector; - TFloatVector = array[0..0] of Single; - - PDoubleVector = ^TDoubleVector; - PDoubleArray = PDoubleVector; - TDoubleVector = array[0..0] of Double; - - PExtendedVector = ^TExtendedVector; - PExtendedArray = PExtendedVector; - TExtendedVector = array[0..0] of Extended; - - PPointerVector = ^TPointerVector; - PPointerArray = PPointerVector; - TPointerVector = array[0..0] of Pointer; - - PCardinalVector = ^TCardinalVector; - PCardinalArray = PCardinalVector; - TCardinalVector = array[0..0] of Cardinal; - - // common vector and matrix types with predefined limits - // indices correspond like: x -> 0 - // y -> 1 - // z -> 2 - // w -> 3 - - PHomogeneousByteVector = ^THomogeneousByteVector; - THomogeneousByteVector = array[0..3] of Byte; - TVector4b = THomogeneousByteVector; - - PHomogeneousWordVector = ^THomogeneousWordVector; - THomogeneousWordVector = array[0..3] of Word; - TVector4w = THomogeneousWordVector; - - PHomogeneousIntVector = ^THomogeneousIntVector; - THomogeneousIntVector = array[0..3] of Integer; - TVector4i = THomogeneousIntVector; - - PHomogeneousFltVector = ^THomogeneousFltVector; - THomogeneousFltVector = array[0..3] of Single; - TVector4f = THomogeneousFltVector; - - PHomogeneousDblVector = ^THomogeneousDblVector; - THomogeneousDblVector = array[0..3] of Double; - TVector4d = THomogeneousDblVector; - - PHomogeneousExtVector = ^THomogeneousExtVector; - THomogeneousExtVector = array[0..3] of Extended; - TVector4e = THomogeneousExtVector; - - PHomogeneousPtrVector = ^THomogeneousPtrVector; - THomogeneousPtrVector = array[0..3] of Pointer; - TVector4p = THomogeneousPtrVector; - - PAffineByteVector = ^TAffineByteVector; - TAffineByteVector = array[0..2] of Byte; - TVector3b = TAffineByteVector; - - PAffineWordVector = ^TAffineWordVector; - TAffineWordVector = array[0..2] of Word; - TVector3w = TAffineWordVector; - - PAffineIntVector = ^TAffineIntVector; - TAffineIntVector = array[0..2] of Integer; - TVector3i = TAffineIntVector; - - PAffineFltVector = ^TAffineFltVector; - TAffineFltVector = array[0..2] of Single; - TVector3f = TAffineFltVector; - - PAffineDblVector = ^TAffineDblVector; - TAffineDblVector = array[0..2] of Double; - TVector3d = TAffineDblVector; - - PAffineExtVector = ^TAffineExtVector; - TAffineExtVector = array[0..2] of Extended; - TVector3e = TAffineExtVector; - - PAffinePtrVector = ^TAffinePtrVector; - TAffinePtrVector = array[0..2] of Pointer; - TVector3p = TAffinePtrVector; - - // some simplified names - PVector = ^TVector; - TVector = THomogeneousFltVector; - - PHomogeneousVector = ^THomogeneousVector; - THomogeneousVector = THomogeneousFltVector; - - PAffineVector = ^TAffineVector; - TAffineVector = TAffineFltVector; - - // arrays of vectors - PVectorArray = ^TVectorArray; - TVectorArray = array[0..0] of TAffineVector; - - // matrices - THomogeneousByteMatrix = array[0..3] of THomogeneousByteVector; - TMatrix4b = THomogeneousByteMatrix; - - THomogeneousWordMatrix = array[0..3] of THomogeneousWordVector; - TMatrix4w = THomogeneousWordMatrix; - - THomogeneousIntMatrix = array[0..3] of THomogeneousIntVector; - TMatrix4i = THomogeneousIntMatrix; - - THomogeneousFltMatrix = array[0..3] of THomogeneousFltVector; - TMatrix4f = THomogeneousFltMatrix; - - THomogeneousDblMatrix = array[0..3] of THomogeneousDblVector; - TMatrix4d = THomogeneousDblMatrix; - - THomogeneousExtMatrix = array[0..3] of THomogeneousExtVector; - TMatrix4e = THomogeneousExtMatrix; - - TAffineByteMatrix = array[0..2] of TAffineByteVector; - TMatrix3b = TAffineByteMatrix; - - TAffineWordMatrix = array[0..2] of TAffineWordVector; - TMatrix3w = TAffineWordMatrix; - - TAffineIntMatrix = array[0..2] of TAffineIntVector; - TMatrix3i = TAffineIntMatrix; - - TAffineFltMatrix = array[0..2] of TAffineFltVector; - TMatrix3f = TAffineFltMatrix; - - TAffineDblMatrix = array[0..2] of TAffineDblVector; - TMatrix3d = TAffineDblMatrix; - - TAffineExtMatrix = array[0..2] of TAffineExtVector; - TMatrix3e = TAffineExtMatrix; - - // some simplified names - PMatrix = ^TMatrix; - TMatrix = THomogeneousFltMatrix; - - PHomogeneousMatrix = ^THomogeneousMatrix; - THomogeneousMatrix = THomogeneousFltMatrix; - - PAffineMatrix = ^TAffineMatrix; - TAffineMatrix = TAffineFltMatrix; - - // q = ([x, y, z], w) - TQuaternion = record - case Integer of - 0: - (ImagPart: TAffineVector; - RealPart: Single); - 1: - (Vector: TVector4f); - end; - - TRectangle = record - Left, - Top, - Width, - Height: Integer; - end; - - TTransType = (ttScaleX, ttScaleY, ttScaleZ, - ttShearXY, ttShearXZ, ttShearYZ, - ttRotateX, ttRotateY, ttRotateZ, - ttTranslateX, ttTranslateY, ttTranslateZ, - ttPerspectiveX, ttPerspectiveY, ttPerspectiveZ, ttPerspectiveW); - - // used to describe a sequence of transformations in following order: - // [Sx][Sy][Sz][ShearXY][ShearXZ][ShearZY][Rx][Ry][Rz][Tx][Ty][Tz][P(x,y,z,w)] - // constants are declared for easier access (see MatrixDecompose below) - TTransformations = array[TTransType] of Single; - - -const - // useful constants - - // standard vectors - XVector: TAffineVector = (1, 0, 0); - YVector: TAffineVector = (0, 1, 0); - ZVector: TAffineVector = (0, 0, 1); - NullVector: TAffineVector = (0, 0, 0); - - IdentityMatrix: TMatrix = ((1, 0, 0, 0), - (0, 1, 0, 0), - (0, 0, 1, 0), - (0, 0, 0, 1)); - EmptyMatrix: TMatrix = ((0, 0, 0, 0), - (0, 0, 0, 0), - (0, 0, 0, 0), - (0, 0, 0, 0)); - // some very small numbers - EPSILON = 1e-100; - EPSILON2 = 1e-50; - -//---------------------------------------------------------------------------------------------------------------------- - -// vector functions -function VectorAdd(V1, V2: TVector): TVector; -function VectorAffineAdd(V1, V2: TAffineVector): TAffineVector; -function VectorAffineCombine(V1, V2: TAffineVector; F1, F2: Single): TAffineVector; -function VectorAffineDotProduct(V1, V2: TAffineVector): Single; -function VectorAffineLerp(V1, V2: TAffineVector; t: Single): TAffineVector; -function VectorAffineSubtract(V1, V2: TAffineVector): TAffineVector; -function VectorAngle(V1, V2: TAffineVector): Single; -function VectorCombine(V1, V2: TVector; F1, F2: Single): TVector; -function VectorCrossProduct(V1, V2: TAffineVector): TAffineVector; -function VectorDotProduct(V1, V2: TVector): Single; -function VectorLength(V: array of Single): Single; -function VectorLerp(V1, V2: TVector; t: Single): TVector; -procedure VectorNegate(V: array of Single); -function VectorNorm(V: array of Single): Single; -function VectorNormalize(V: array of Single): Single; -function VectorPerpendicular(V, N: TAffineVector): TAffineVector; -function VectorReflect(V, N: TAffineVector): TAffineVector; -procedure VectorRotate(var Vector: TVector4f; Axis: TVector3f; Angle: Single); -procedure VectorScale(V: array of Single; Factor: Single); -function VectorSubtract(V1, V2: TVector): TVector; - -// matrix functions -function CreateRotationMatrixX(Sine, Cosine: Single): TMatrix; -function CreateRotationMatrixY(Sine, Cosine: Single): TMatrix; -function CreateRotationMatrixZ(Sine, Cosine: Single): TMatrix; -function CreateScaleMatrix(V: TAffineVector): TMatrix; -function CreateTranslationMatrix(V: TVector): TMatrix; -procedure MatrixAdjoint(var M: TMatrix); -function MatrixAffineDeterminant(M: TAffineMatrix): Single; -procedure MatrixAffineTranspose(var M: TAffineMatrix); -function MatrixDeterminant(M: TMatrix): Single; -procedure MatrixInvert(var M: TMatrix); -function MatrixMultiply(M1, M2: TMatrix): TMatrix; -procedure MatrixScale(var M: TMatrix; Factor: Single); -procedure MatrixTranspose(var M: TMatrix); - -// quaternion functions -function QuaternionConjugate(Q: TQuaternion): TQuaternion; -function QuaternionFromPoints(V1, V2: TAffineVector): TQuaternion; -function QuaternionMultiply(qL, qR: TQuaternion): TQuaternion; -function QuaternionSlerp(QStart, QEnd: TQuaternion; Spin: Integer; t: Single): TQuaternion; -function QuaternionToMatrix(Q: TQuaternion): TMatrix; -procedure QuaternionToPoints(Q: TQuaternion; var ArcFrom, ArcTo: TAffineVector); - -// mixed functions -function ConvertRotation(Angles: TAffineVector): TVector; -function CreateRotationMatrix(Axis: TVector3f; Angle: Single): TMatrix; -function MatrixDecompose(M: TMatrix; var Tran: TTransformations): Boolean; -function VectorAffineTransform(V: TAffineVector; M: TAffineMatrix): TAffineVector; -function VectorTransform(V: TVector4f; M: TMatrix): TVector4f; overload; -function VectorTransform(V: TVector3f; M: TMatrix): TVector3f; overload; - -// miscellaneous functions -function MakeAffineDblVector(V: array of Double): TAffineDblVector; -function MakeDblVector(V: array of Double): THomogeneousDblVector; -function MakeAffineVector(V: array of Single): TAffineVector; -function MakeQuaternion(Imag: array of Single; Real: Single): TQuaternion; -function MakeVector(V: array of Single): TVector; -function PointInPolygon(xp, yp : array of Single; x, y: Single): Boolean; -function VectorAffineDblToFlt(V: TAffineDblVector): TAffineVector; -function VectorDblToFlt(V: THomogeneousDblVector): THomogeneousVector; -function VectorAffineFltToDbl(V: TAffineVector): TAffineDblVector; -function VectorFltToDbl(V: TVector): THomogeneousDblVector; - -// trigonometric functions -function ArcCos(X: Extended): Extended; -function ArcSin(X: Extended): Extended; -function ArcTan2(Y, X: Extended): Extended; -function CoTan(X: Extended): Extended; -function DegToRad(Degrees: Extended): Extended; -function RadToDeg(Radians: Extended): Extended; -procedure SinCos(Theta: Extended; var Sin, Cos: Extended); -function Tan(X: Extended): Extended; - -// coordinate system manipulation functions -function Turn(Matrix: TMatrix; Angle: Single): TMatrix; overload; -function Turn(Matrix: TMatrix; MasterUp: TAffineVector; Angle: Single): TMatrix; overload; -function Pitch(Matrix: TMatrix; Angle: Single): TMatrix; overload; -function Pitch(Matrix: TMatrix; MasterRight: TAffineVector; Angle: Single): TMatrix; overload; -function Roll(Matrix: TMatrix; Angle: Single): TMatrix; overload; -function Roll(Matrix: TMatrix; MasterDirection: TAffineVector; Angle: Single): TMatrix; overload; - -//---------------------------------------------------------------------------------------------------------------------- - -implementation - -const - // FPU status flags (high order byte) - C0 = 1; - C1 = 2; - C2 = 4; - C3 = $40; - - // to be used as descriptive indices - X = 0; - Y = 1; - Z = 2; - W = 3; - -//----------------- trigonometric helper functions --------------------------------------------------------------------- - -function DegToRad(Degrees: Extended): Extended; - -begin - Result := Degrees * (PI / 180); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function RadToDeg(Radians: Extended): Extended; - -begin - Result := Radians * (180 / PI); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure SinCos(Theta: Extended; var Sin, Cos: Extended); assembler; register; - -// calculates sine and cosine from the given angle Theta -// EAX contains address of Sin -// EDX contains address of Cos -// Theta is passed over the stack - -asm - FLD Theta - FSINCOS - FSTP TBYTE PTR [EDX] // cosine - FSTP TBYTE PTR [EAX] // sine - FWAIT -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function ArcCos(X: Extended): Extended; - -begin - Result := ArcTan2(Sqrt(1 - X * X), X); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function ArcSin(X: Extended): Extended; - -begin - Result := ArcTan2(X, Sqrt(1 - X * X)) -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function ArcTan2(Y, X: Extended): Extended; - -asm - FLD Y - FLD X - FPATAN - FWAIT -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Tan(X: Extended): Extended; - -asm - FLD X - FPTAN - FSTP ST(0) // FPTAN pushes 1.0 after result - FWAIT -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CoTan(X: Extended): Extended; - -asm - FLD X - FPTAN - FDIVRP - FWAIT -end; - -//----------------- miscellaneous vector functions --------------------------------------------------------------------- - -function MakeAffineDblVector(V: array of Double): TAffineDblVector; assembler; - -// creates a vector from given values -// EAX contains address of V -// ECX contains address to result vector -// EDX contains highest index of V - -asm - PUSH EDI - PUSH ESI - MOV EDI, ECX - MOV ESI, EAX - MOV ECX, EDX - ADD ECX, 2 - REP MOVSD - POP ESI - POP EDI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MakeDblVector(V: array of Double): THomogeneousDblVector; assembler; - -// creates a vector from given values -// EAX contains address of V -// ECX contains address to result vector -// EDX contains highest index of V - -asm - PUSH EDI - PUSH ESI - MOV EDI, ECX - MOV ESI, EAX - MOV ECX, EDX - ADD ECX, 2 - REP MOVSD - POP ESI - POP EDI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MakeAffineVector(V: array of Single): TAffineVector; assembler; - -// creates a vector from given values -// EAX contains address of V -// ECX contains address to result vector -// EDX contains highest index of V - -asm - PUSH EDI - PUSH ESI - MOV EDI, ECX - MOV ESI, EAX - MOV ECX, EDX - INC ECX - CMP ECX, 3 - JB @@1 - MOV ECX, 3 -@@1: REP MOVSD // copy given values - MOV ECX, 2 - SUB ECX, EDX // determine missing entries - JS @@Finish - XOR EAX, EAX - REP STOSD // set remaining fields to 0 -@@Finish: POP ESI - POP EDI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MakeQuaternion(Imag: array of Single; Real: Single): TQuaternion; assembler; - -// creates a quaternion from the given values -// EAX contains address of Imag -// ECX contains address to result vector -// EDX contains highest index of Imag -// Real part is passed on the stack - -asm - PUSH EDI - PUSH ESI - MOV EDI, ECX - MOV ESI, EAX - MOV ECX, EDX - INC ECX - REP MOVSD - MOV EAX, [Real] - MOV [EDI], EAX - POP ESI - POP EDI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MakeVector(V: array of Single): TVector; assembler; - -// creates a vector from given values -// EAX contains address of V -// ECX contains address to result vector -// EDX contains highest index of V - -asm - PUSH EDI - PUSH ESI - MOV EDI, ECX - MOV ESI, EAX - MOV ECX, EDX - INC ECX - CMP ECX, 4 - JB @@1 - MOV ECX, 4 -@@1: REP MOVSD // copy given values - MOV ECX, 3 - SUB ECX, EDX // determine missing entries - JS @@Finish - XOR EAX, EAX - REP STOSD // set remaining fields to 0 -@@Finish: POP ESI - POP EDI -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorLength(V: array of Single): Single; assembler; - -// calculates the length of a vector following the equation: sqrt(x * x + y * y + ...) -// Note: The parameter of this function is declared as open array. Thus -// there's no restriction about the number of the components of the vector. -// -// EAX contains address of V -// EDX contains the highest index of V -// the result is returned in ST(0) - -asm - FLDZ // initialize sum -@@Loop: FLD DWORD PTR [EAX + 4 * EDX] // load a component - FMUL ST, ST - FADDP - SUB EDX, 1 - JNL @@Loop - FSQRT -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAngle(V1, V2: TAffineVector): Single; assembler; - -// calculates the cosine of the angle between Vector1 and Vector2 -// Result = DotProduct(V1, V2) / (Length(V1) * Length(V2)) -// -// EAX contains address of Vector1 -// EDX contains address of Vector2 - -asm - FLD DWORD PTR [EAX] // V1[0] - FLD ST // double V1[0] - FMUL ST, ST // V1[0]^2 (prep. for divisor) - FLD DWORD PTR [EDX] // V2[0] - FMUL ST(2), ST // ST(2) := V1[0] * V2[0] - FMUL ST, ST // V2[0]^2 (prep. for divisor) - FLD DWORD PTR [EAX + 4] // V1[1] - FLD ST // double V1[1] - FMUL ST, ST // ST(0) := V1[1]^2 - FADDP ST(3), ST // ST(2) := V1[0]^2 + V1[1] * * 2 - FLD DWORD PTR [EDX + 4] // V2[1] - FMUL ST(1), ST // ST(1) := V1[1] * V2[1] - FMUL ST, ST // ST(0) := V2[1]^2 - FADDP ST(2), ST // ST(1) := V2[0]^2 + V2[1]^2 - FADDP ST(3), ST // ST(2) := V1[0] * V2[0] + V1[1] * V2[1] - FLD DWORD PTR [EAX + 8] // load V2[1] - FLD ST // same calcs go here - FMUL ST, ST // (compare above) - FADDP ST(3), ST - FLD DWORD PTR [EDX + 8] - FMUL ST(1), ST - FMUL ST, ST - FADDP ST(2), ST - FADDP ST(3), ST - FMULP // ST(0) := (V1[0]^2 + V1[1]^2 + V1[2]) * - // (V2[0]^2 + V2[1]^2 + V2[2]) - FSQRT // sqrt(ST(0)) - FDIVP // ST(0) := Result := ST(1) / ST(0) - // the result is expected in ST(0), if it's invalid, an error is raised -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorNorm(V: array of Single): Single; assembler; register; - -// calculates norm of a vector which is defined as norm = x * x + y * y + ... -// EAX contains address of V -// EDX contains highest index in V -// result is passed in ST(0) - -asm - FLDZ // initialize sum -@@Loop: FLD DWORD PTR [EAX + 4 * EDX] // load a component - FMUL ST, ST // make square - FADDP // add previous calculated sum - SUB EDX, 1 - JNL @@Loop -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorNormalize(V: array of Single): Single; assembler; register; - -// transforms a vector to unit length and return length -// EAX contains address of V -// EDX contains the highest index in V -// return former length of V in ST - -asm - PUSH EBX - MOV ECX, EDX // save size of V - CALL VectorLength // calculate length of vector - FTST // test if length = 0 - MOV EBX, EAX // save parameter address - FSTSW AX // get test result - TEST AH, C3 // check the test result - JNZ @@Finish - SUB EBX, 4 // simplyfied address calculation - INC ECX - FLD1 // calculate reciprocal of length - FDIV ST, ST(1) -@@1: FLD ST // double reciprocal - FMUL DWORD PTR [EBX + 4 * ECX] // scale component - WAIT - FSTP DWORD PTR [EBX + 4 * ECX] // store result - LOOP @@1 - FSTP ST // remove reciprocal from FPU stack -@@Finish: POP EBX -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineSubtract(V1, V2: TAffineVector): TAffineVector; assembler; register; - -// returns v1 minus v2 -// EAX contains address of V1 -// EDX contains address of V2 -// ECX contains address of the result - -asm - {Result[X] := V1[X]-V2[X]; - Result[Y] := V1[Y]-V2[Y]; - Result[Z] := V1[Z]-V2[Z];} - - FLD DWORD PTR [EAX] - FSUB DWORD PTR [EDX] - FSTP DWORD PTR [ECX] - FLD DWORD PTR [EAX + 4] - FSUB DWORD PTR [EDX + 4] - FSTP DWORD PTR [ECX + 4] - FLD DWORD PTR [EAX + 8] - FSUB DWORD PTR [EDX + 8] - FSTP DWORD PTR [ECX + 8] -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorReflect(V, N: TAffineVector): TAffineVector; assembler; register; - -// reflects vector V against N (assumes N is normalized) -// EAX contains address of V -// EDX contains address of N -// ECX contains address of the result - -//var Dot : Single; - -asm - {Dot := VectorAffineDotProduct(V, N); - Result[X] := V[X]-2 * Dot * N[X]; - Result[Y] := V[Y]-2 * Dot * N[Y]; - Result[Z] := V[Z]-2 * Dot * N[Z];} - - CALL VectorAffineDotProduct // dot is now in ST(0) - FCHS // -dot - FADD ST, ST // -dot * 2 - FLD DWORD PTR [EDX] // ST := N[X] - FMUL ST, ST(1) // ST := -2 * dot * N[X] - FADD DWORD PTR[EAX] // ST := V[X] - 2 * dot * N[X] - FSTP DWORD PTR [ECX] // store result - FLD DWORD PTR [EDX + 4] // etc. - FMUL ST, ST(1) - FADD DWORD PTR[EAX + 4] - FSTP DWORD PTR [ECX + 4] - FLD DWORD PTR [EDX + 8] - FMUL ST, ST(1) - FADD DWORD PTR[EAX + 8] - FSTP DWORD PTR [ECX + 8] - FSTP ST // clean FPU stack -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure VectorRotate(var Vector: TVector4f; Axis: TVector3f; Angle: Single); - -// rotates Vector about Axis with Angle radiants - -var RotMatrix : TMatrix4f; - -begin - RotMatrix := CreateRotationMatrix(Axis, Angle); - Vector := VectorTransform(Vector, RotMatrix); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure VectorScale(V: array of Single; Factor: Single); assembler; register; - -// returns a vector scaled by a factor -// EAX contains address of V -// EDX contains highest index in V -// Factor is located on the stack - -asm - {for I := Low(V) to High(V) do V[I] := V[I] * Factor;} - - FLD DWORD PTR [Factor] // load factor -@@Loop: FLD DWORD PTR [EAX + 4 * EDX] // load a component - FMUL ST, ST(1) // multiply it with the factor - WAIT - FSTP DWORD PTR [EAX + 4 * EDX] // store the result - DEC EDX // do the entire array - JNS @@Loop - FSTP ST(0) // clean the FPU stack -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure VectorNegate(V: array of Single); assembler; register; - -// returns a negated vector -// EAX contains address of V -// EDX contains highest index in V - -asm - {V[X] := -V[X]; - V[Y] := -V[Y]; - V[Z] := -V[Z];} - -@@Loop: FLD DWORD PTR [EAX + 4 * EDX] - FCHS - WAIT - FSTP DWORD PTR [EAX + 4 * EDX] - DEC EDX - JNS @@Loop -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAdd(V1, V2: TVector): TVector; register; - -// returns the sum of two vectors - -begin - Result[X] := V1[X] + V2[X]; - Result[Y] := V1[Y] + V2[Y]; - Result[Z] := V1[Z] + V2[Z]; - Result[W] := V1[W] + V2[W]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineAdd(V1, V2: TAffineVector): TAffineVector; register; - -// returns the sum of two vectors - -begin - Result[X] := V1[X] + V2[X]; - Result[Y] := V1[Y] + V2[Y]; - Result[Z] := V1[Z] + V2[Z]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorSubtract(V1, V2: TVector): TVector; register; - -// returns the difference of two vectors - -begin - Result[X] := V1[X] - V2[X]; - Result[Y] := V1[Y] - V2[Y]; - Result[Z] := V1[Z] - V2[Z]; - Result[W] := V1[W] - V2[W]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorDotProduct(V1, V2: TVector): Single; register; - -begin - Result := V1[X] * V2[X] + V1[Y] * V2[Y] + V1[Z] * V2[Z] + V1[W] * V2[W]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineDotProduct(V1, V2: TAffineVector): Single; assembler; register; - -// calculates the dot product between V1 and V2 -// EAX contains address of V1 -// EDX contains address of V2 -// result is stored in ST(0) - -asm - //Result := V1[X] * V2[X] + V1[Y] * V2[Y] + V1[Z] * V2[Z]; - - FLD DWORD PTR [EAX] - FMUL DWORD PTR [EDX] - FLD DWORD PTR [EAX + 4] - FMUL DWORD PTR [EDX + 4] - FADDP - FLD DWORD PTR [EAX + 8] - FMUL DWORD PTR [EDX + 8] - FADDP -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorCrossProduct(V1, V2: TAffineVector): TAffineVector; - -// calculates the cross product between vector 1 and 2, Temp is necessary because -// either V1 or V2 could also be the result vector -// -// EAX contains address of V1 -// EDX contains address of V2 -// ECX contains address of result - -var Temp: TAffineVector; - -asm - {Temp[X] := V1[Y] * V2[Z]-V1[Z] * V2[Y]; - Temp[Y] := V1[Z] * V2[X]-V1[X] * V2[Z]; - Temp[Z] := V1[X] * V2[Y]-V1[Y] * V2[X]; - Result := Temp;} - - PUSH EBX // save EBX, must be restored to original value - LEA EBX, [Temp] - FLD DWORD PTR [EDX + 8] // first load both vectors onto FPU register stack - FLD DWORD PTR [EDX + 4] - FLD DWORD PTR [EDX + 0] - FLD DWORD PTR [EAX + 8] - FLD DWORD PTR [EAX + 4] - FLD DWORD PTR [EAX + 0] - - FLD ST(1) // ST(0) := V1[Y] - FMUL ST, ST(6) // ST(0) := V1[Y] * V2[Z] - FLD ST(3) // ST(0) := V1[Z] - FMUL ST, ST(6) // ST(0) := V1[Z] * V2[Y] - FSUBP ST(1), ST // ST(0) := ST(1)-ST(0) - FSTP DWORD [EBX] // Temp[X] := ST(0) - FLD ST(2) // ST(0) := V1[Z] - FMUL ST, ST(4) // ST(0) := V1[Z] * V2[X] - FLD ST(1) // ST(0) := V1[X] - FMUL ST, ST(7) // ST(0) := V1[X] * V2[Z] - FSUBP ST(1), ST // ST(0) := ST(1)-ST(0) - FSTP DWORD [EBX + 4] // Temp[Y] := ST(0) - FLD ST // ST(0) := V1[X] - FMUL ST, ST(5) // ST(0) := V1[X] * V2[Y] - FLD ST(2) // ST(0) := V1[Y] - FMUL ST, ST(5) // ST(0) := V1[Y] * V2[X] - FSUBP ST(1), ST // ST(0) := ST(1)-ST(0) - FSTP DWORD [EBX + 8] // Temp[Z] := ST(0) - FSTP ST(0) // clear FPU register stack - FSTP ST(0) - FSTP ST(0) - FSTP ST(0) - FSTP ST(0) - FSTP ST(0) - MOV EAX, [EBX] // copy Temp to Result - MOV [ECX], EAX - MOV EAX, [EBX + 4] - MOV [ECX + 4], EAX - MOV EAX, [EBX + 8] - MOV [ECX + 8], EAX - POP EBX -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorPerpendicular(V, N: TAffineVector): TAffineVector; - -// calculates a vector perpendicular to N (N is assumed to be of unit length) -// subtract out any component parallel to N - -var Dot: Single; - -begin - Dot := VectorAffineDotProduct(V, N); - Result[X] := V[X]-Dot * N[X]; - Result[Y] := V[Y]-Dot * N[Y]; - Result[Z] := V[Z]-Dot * N[Z]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorTransform(V: TVector4f; M: TMatrix): TVector4f; register; - -// transforms a homogeneous vector by multiplying it with a matrix - -var TV: TVector4f; - -begin - TV[X] := V[X] * M[X, X] + V[Y] * M[Y, X] + V[Z] * M[Z, X] + V[W] * M[W, X]; - TV[Y] := V[X] * M[X, Y] + V[Y] * M[Y, Y] + V[Z] * M[Z, Y] + V[W] * M[W, Y]; - TV[Z] := V[X] * M[X, Z] + V[Y] * M[Y, Z] + V[Z] * M[Z, Z] + V[W] * M[W, Z]; - TV[W] := V[X] * M[X, W] + V[Y] * M[Y, W] + V[Z] * M[Z, W] + V[W] * M[W, W]; - Result := TV -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorTransform(V: TVector3f; M: TMatrix): TVector3f; - -// transforms an affine vector by multiplying it with a (homogeneous) matrix - -var TV: TVector3f; - -begin - TV[X] := V[X] * M[X, X] + V[Y] * M[Y, X] + V[Z] * M[Z, X] + M[W, X]; - TV[Y] := V[X] * M[X, Y] + V[Y] * M[Y, Y] + V[Z] * M[Z, Y] + M[W, Y]; - TV[Z] := V[X] * M[X, Z] + V[Y] * M[Y, Z] + V[Z] * M[Z, Z] + M[W, Z]; - Result := TV; -end; - - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineTransform(V: TAffineVector; M: TAffineMatrix): TAffineVector; register; - -// transforms an affine vector by multiplying it with a matrix - -var TV: TAffineVector; - -begin - TV[X] := V[X] * M[X, X] + V[Y] * M[Y, X] + V[Z] * M[Z, X]; - TV[Y] := V[X] * M[X, Y] + V[Y] * M[Y, Y] + V[Z] * M[Z, Y]; - TV[Z] := V[X] * M[X, Z] + V[Y] * M[Y, Z] + V[Z] * M[Z, Z]; - Result := TV; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function PointInPolygon(xp, yp : array of Single; x, y: Single): Boolean; - -// The code below is from Wm. Randolph Franklin -// with some minor modifications for speed. It returns 1 for strictly -// interior points, 0 for strictly exterior, and 0 or 1 for points on -// the boundary. -// This code is not yet tested! - -var I, J: Integer; - -begin - Result := False; - if High(XP) <> High(YP) then Exit; - J := High(XP); - for I := 0 to High(XP) do - begin - if ((((yp[I] <= y) and (y < yp[J])) or ((yp[J] <= y) and (y < yp[I]))) and - (x < (xp[J] - xp[I]) * (y - yp[I]) / (yp[J] - yp[I]) + xp[I])) - then Result := not Result; - J := I + 1; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function QuaternionConjugate(Q: TQuaternion): TQuaternion; assembler; - -// returns the conjugate of a quaternion -// EAX contains address of Q -// EDX contains address of result - -asm - FLD DWORD PTR [EAX] - FCHS - WAIT - FSTP DWORD PTR [EDX] - FLD DWORD PTR [EAX + 4] - FCHS - WAIT - FSTP DWORD PTR [EDX + 4] - FLD DWORD PTR [EAX + 8] - FCHS - WAIT - FSTP DWORD PTR [EDX + 8] - MOV EAX, [EAX + 12] - MOV [EDX + 12], EAX -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function QuaternionFromPoints(V1, V2: TAffineVector): TQuaternion; assembler; - -// constructs a unit quaternion from two points on unit sphere -// EAX contains address of V1 -// ECX contains address to result -// EDX contains address of V2 - -asm - {Result.ImagPart := VectorCrossProduct(V1, V2); - Result.RealPart := Sqrt((VectorAffineDotProduct(V1, V2) + 1)/2);} - - PUSH EAX - CALL VectorCrossProduct // determine axis to rotate about - POP EAX - FLD1 // prepare next calculation - Call VectorAffineDotProduct // calculate cos(angle between V1 and V2) - FADD ST, ST(1) // transform angle to angle/2 by: cos(a/2)=sqrt((1 + cos(a))/2) - FXCH ST(1) - FADD ST, ST - FDIVP ST(1), ST - FSQRT - FSTP DWORD PTR [ECX + 12] // Result.RealPart := ST(0) -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function QuaternionMultiply(qL, qR: TQuaternion): TQuaternion; - -// Returns quaternion product qL * qR. Note: order is important! -// To combine rotations, use the product QuaternionMuliply(qSecond, qFirst), -// which gives the effect of rotating by qFirst then qSecond. - -var Temp : TQuaternion; - -begin - Temp.RealPart := qL.RealPart * qR.RealPart - qL.ImagPart[X] * qR.ImagPart[X] - - qL.ImagPart[Y] * qR.ImagPart[Y] - qL.ImagPart[Z] * qR.ImagPart[Z]; - Temp.ImagPart[X] := qL.RealPart * qR.ImagPart[X] + qL.ImagPart[X] * qR.RealPart + - qL.ImagPart[Y] * qR.ImagPart[Z] - qL.ImagPart[Z] * qR.ImagPart[Y]; - Temp.ImagPart[Y] := qL.RealPart * qR.ImagPart[Y] + qL.ImagPart[Y] * qR.RealPart + - qL.ImagPart[Z] * qR.ImagPart[X] - qL.ImagPart[X] * qR.ImagPart[Z]; - Temp.ImagPart[Z] := qL.RealPart * qR.ImagPart[Z] + qL.ImagPart[Z] * qR.RealPart + - qL.ImagPart[X] * qR.ImagPart[Y] - qL.ImagPart[Y] * qR.ImagPart[X]; - Result := Temp; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function QuaternionToMatrix(Q: TQuaternion): TMatrix; - -// Constructs rotation matrix from (possibly non-unit) quaternion. -// Assumes matrix is used to multiply column vector on the left: -// vnew = mat vold. Works correctly for right-handed coordinate system -// and right-handed rotations. - -// Essentially, this function is the same as CreateRotationMatrix and you can consider it as -// being for reference here. - -{var Norm, S, - XS, YS, ZS, - WX, WY, WZ, - XX, XY, XZ, - YY, YZ, ZZ : Single; - -begin - Norm := Q.Vector[X] * Q.Vector[X] + Q.Vector[Y] * Q.Vector[Y] + Q.Vector[Z] * Q.Vector[Z] + Q.RealPart * Q.RealPart; - if Norm > 0 then S := 2 / Norm - else S := 0; - - XS := Q.Vector[X] * S; YS := Q.Vector[Y] * S; ZS := Q.Vector[Z] * S; - WX := Q.RealPart * XS; WY := Q.RealPart * YS; WZ := Q.RealPart * ZS; - XX := Q.Vector[X] * XS; XY := Q.Vector[X] * YS; XZ := Q.Vector[X] * ZS; - YY := Q.Vector[Y] * YS; YZ := Q.Vector[Y] * ZS; ZZ := Q.Vector[Z] * ZS; - - Result[X, X] := 1 - (YY + ZZ); Result[Y, X] := XY + WZ; Result[Z, X] := XZ - WY; Result[W, X] := 0; - Result[X, Y] := XY - WZ; Result[Y, Y] := 1 - (XX + ZZ); Result[Z, Y] := YZ + WX; Result[W, Y] := 0; - Result[X, Z] := XZ + WY; Result[Y, Z] := YZ - WX; Result[Z, Z] := 1 - (XX + YY); Result[W, Z] := 0; - Result[X, W] := 0; Result[Y, W] := 0; Result[Z, W] := 0; Result[W, W] := 1;} - -var - V: TAffineVector; - SinA, CosA, - A, B, C: Extended; - -begin - V := Q.ImagPart; - VectorNormalize(V); - SinCos(Q.RealPart / 2, SinA, CosA); - A := V[X] * SinA; - B := V[Y] * SinA; - C := V[Z] * SinA; - - Result := IdentityMatrix; - Result[X, X] := 1 - 2 * B * B - 2 * C * C; - Result[X, Y] := 2 * A * B - 2 * CosA * C; - Result[X, Z] := 2 * A * C + 2 * CosA * B; - - Result[Y, X] := 2 * A * B + 2 * CosA * C; - Result[Y, Y] := 1 - 2 * A * A - 2 * C * C; - Result[Y, Z] := 2 * B * C - 2 * CosA * A; - - Result[Z, X] := 2 * A * C - 2 * CosA * B; - Result[Z, Y] := 2 * B * C + 2 * CosA * A; - Result[Z, Z] := 1 - 2 * A * A - 2 * B * B; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure QuaternionToPoints(Q: TQuaternion; var ArcFrom, ArcTo: TAffineVector); register; - -// converts a unit quaternion into two points on a unit sphere - -var S: Single; - -begin - S := Sqrt(Q.ImagPart[X] * Q.ImagPart[X] + Q.ImagPart[Y] * Q.ImagPart[Y]); - if S = 0 then ArcFrom := MakeAffineVector([0, 1, 0]) - else ArcFrom := MakeAffineVector([-Q.ImagPart[Y] / S, Q.ImagPart[X] / S, 0]); - ArcTo[X] := Q.RealPart * ArcFrom[X] - Q.ImagPart[Z] * ArcFrom[Y]; - ArcTo[Y] := Q.RealPart * ArcFrom[Y] + Q.ImagPart[Z] * ArcFrom[X]; - ArcTo[Z] := Q.ImagPart[X] * ArcFrom[Y] - Q.ImagPart[Y] * ArcFrom[X]; - if Q.RealPart < 0 then ArcFrom := MakeAffineVector([-ArcFrom[X], -ArcFrom[Y], 0]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MatrixAffineDeterminant(M: TAffineMatrix): Single; register; - -// determinant of a 3x3 matrix - -begin - Result := M[X, X] * (M[Y, Y] * M[Z, Z] - M[Z, Y] * M[Y, Z]) - - M[X, Y] * (M[Y, X] * M[Z, Z] - M[Z, X] * M[Y, Z]) + - M[X, Z] * (M[Y, X] * M[Z, Y] - M[Z, X] * M[Y, Y]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MatrixDetInternal(a1, a2, a3, b1, b2, b3, c1, c2, c3: Single): Single; - -// internal version for the determinant of a 3x3 matrix - -begin - Result := a1 * (b2 * c3 - b3 * c2) - - b1 * (a2 * c3 - a3 * c2) + - c1 * (a2 * b3 - a3 * b2); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure MatrixAdjoint(var M: TMatrix); register; - -// Adjoint of a 4x4 matrix - used in the computation of the inverse -// of a 4x4 matrix - -var a1, a2, a3, a4, - b1, b2, b3, b4, - c1, c2, c3, c4, - d1, d2, d3, d4: Single; - - -begin - a1 := M[X, X]; b1 := M[X, Y]; - c1 := M[X, Z]; d1 := M[X, W]; - a2 := M[Y, X]; b2 := M[Y, Y]; - c2 := M[Y, Z]; d2 := M[Y, W]; - a3 := M[Z, X]; b3 := M[Z, Y]; - c3 := M[Z, Z]; d3 := M[Z, W]; - a4 := M[W, X]; b4 := M[W, Y]; - c4 := M[W, Z]; d4 := M[W, W]; - - // row column labeling reversed since we transpose rows & columns - M[X, X] := MatrixDetInternal(b2, b3, b4, c2, c3, c4, d2, d3, d4); - M[Y, X] := -MatrixDetInternal(a2, a3, a4, c2, c3, c4, d2, d3, d4); - M[Z, X] := MatrixDetInternal(a2, a3, a4, b2, b3, b4, d2, d3, d4); - M[W, X] := -MatrixDetInternal(a2, a3, a4, b2, b3, b4, c2, c3, c4); - - M[X, Y] := -MatrixDetInternal(b1, b3, b4, c1, c3, c4, d1, d3, d4); - M[Y, Y] := MatrixDetInternal(a1, a3, a4, c1, c3, c4, d1, d3, d4); - M[Z, Y] := -MatrixDetInternal(a1, a3, a4, b1, b3, b4, d1, d3, d4); - M[W, Y] := MatrixDetInternal(a1, a3, a4, b1, b3, b4, c1, c3, c4); - - M[X, Z] := MatrixDetInternal(b1, b2, b4, c1, c2, c4, d1, d2, d4); - M[Y, Z] := -MatrixDetInternal(a1, a2, a4, c1, c2, c4, d1, d2, d4); - M[Z, Z] := MatrixDetInternal(a1, a2, a4, b1, b2, b4, d1, d2, d4); - M[W, Z] := -MatrixDetInternal(a1, a2, a4, b1, b2, b4, c1, c2, c4); - - M[X, W] := -MatrixDetInternal(b1, b2, b3, c1, c2, c3, d1, d2, d3); - M[Y, W] := MatrixDetInternal(a1, a2, a3, c1, c2, c3, d1, d2, d3); - M[Z, W] := -MatrixDetInternal(a1, a2, a3, b1, b2, b3, d1, d2, d3); - M[W, W] := MatrixDetInternal(a1, a2, a3, b1, b2, b3, c1, c2, c3); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MatrixDeterminant(M: TMatrix): Single; register; - -// Determinant of a 4x4 matrix - -var a1, a2, a3, a4, - b1, b2, b3, b4, - c1, c2, c3, c4, - d1, d2, d3, d4 : Single; - -begin - a1 := M[X, X]; b1 := M[X, Y]; c1 := M[X, Z]; d1 := M[X, W]; - a2 := M[Y, X]; b2 := M[Y, Y]; c2 := M[Y, Z]; d2 := M[Y, W]; - a3 := M[Z, X]; b3 := M[Z, Y]; c3 := M[Z, Z]; d3 := M[Z, W]; - a4 := M[W, X]; b4 := M[W, Y]; c4 := M[W, Z]; d4 := M[W, W]; - - Result := a1 * MatrixDetInternal(b2, b3, b4, c2, c3, c4, d2, d3, d4) - - b1 * MatrixDetInternal(a2, a3, a4, c2, c3, c4, d2, d3, d4) + - c1 * MatrixDetInternal(a2, a3, a4, b2, b3, b4, d2, d3, d4) - - d1 * MatrixDetInternal(a2, a3, a4, b2, b3, b4, c2, c3, c4); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure MatrixScale(var M: TMatrix; Factor: Single); register; - -// multiplies all elements of a 4x4 matrix with a factor - -var I, J: Integer; - -begin - for I := 0 to 3 do - for J := 0 to 3 do M[I, J] := M[I, J] * Factor; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure MatrixInvert(var M: TMatrix); register; - -// finds the inverse of a 4x4 matrix - -var Det: Single; - -begin - Det := MatrixDeterminant(M); - if Abs(Det) < EPSILON then M := IdentityMatrix - else - begin - MatrixAdjoint(M); - MatrixScale(M, 1 / Det); - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure MatrixTranspose(var M: TMatrix); register; - -// computes transpose of 4x4 matrix - -var I, J: Integer; - TM: TMatrix; - -begin - for I := 0 to 3 do - for J := 0 to 3 do TM[J, I] := M[I, J]; - M := TM; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -procedure MatrixAffineTranspose(var M: TAffineMatrix); register; - -// computes transpose of 3x3 matrix - -var I, J: Integer; - TM: TAffineMatrix; - -begin - for I := 0 to 2 do - for J := 0 to 2 do TM[J, I] := M[I, J]; - M := TM; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MatrixMultiply(M1, M2: TMatrix): TMatrix; register; - -// multiplies two 4x4 matrices - -var I, J: Integer; - TM: TMatrix; - -begin - for I := 0 to 3 do - for J := 0 to 3 do - TM[I, J] := M1[I, X] * M2[X, J] + - M1[I, Y] * M2[Y, J] + - M1[I, Z] * M2[Z, J] + - M1[I, W] * M2[W, J]; - Result := TM; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateRotationMatrix(Axis: TVector3f; Angle: Single): TMatrix; register; - -// Creates a rotation matrix along the given Axis by the given Angle in radians. - -var cosine, - sine, - Len, - one_minus_cosine: Extended; - -begin - SinCos(Angle, Sine, Cosine); - one_minus_cosine := 1 - cosine; - Len := VectorNormalize(Axis); - - if Len = 0 then Result := IdentityMatrix - else - begin - Result[X, X] := (one_minus_cosine * Sqr(Axis[0])) + Cosine; - Result[X, Y] := (one_minus_cosine * Axis[0] * Axis[1]) - (Axis[2] * Sine); - Result[X, Z] := (one_minus_cosine * Axis[2] * Axis[0]) + (Axis[1] * Sine); - Result[X, W] := 0; - - Result[Y, X] := (one_minus_cosine * Axis[0] * Axis[1]) + (Axis[2] * Sine); - Result[Y, Y] := (one_minus_cosine * Sqr(Axis[1])) + Cosine; - Result[Y, Z] := (one_minus_cosine * Axis[1] * Axis[2]) - (Axis[0] * Sine); - Result[Y, W] := 0; - - Result[Z, X] := (one_minus_cosine * Axis[2] * Axis[0]) - (Axis[1] * Sine); - Result[Z, Y] := (one_minus_cosine * Axis[1] * Axis[2]) + (Axis[0] * Sine); - Result[Z, Z] := (one_minus_cosine * Sqr(Axis[2])) + Cosine; - Result[Z, W] := 0; - - Result[W, X] := 0; - Result[W, Y] := 0; - Result[W, Z] := 0; - Result[W, W] := 1; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function ConvertRotation(Angles: TAffineVector): TVector; register; - -{ Turn a triplet of rotations about x, y, and z (in that order) into an - equivalent rotation around a single axis (all in radians). - - Rotation of the Angle t about the axis (X, Y, Z) is given by: - - | X^2 + (1-X^2) Cos(t), XY(1-Cos(t)) + Z Sin(t), XZ(1-Cos(t))-Y Sin(t) | - M = | XY(1-Cos(t))-Z Sin(t), Y^2 + (1-Y^2) Cos(t), YZ(1-Cos(t)) + X Sin(t) | - | XZ(1-Cos(t)) + Y Sin(t), YZ(1-Cos(t))-X Sin(t), Z^2 + (1-Z^2) Cos(t) | - - Rotation about the three axes (Angles a1, a2, a3) can be represented as - the product of the individual rotation matrices: - - | 1 0 0 | | Cos(a2) 0 -Sin(a2) | | Cos(a3) Sin(a3) 0 | - | 0 Cos(a1) Sin(a1) | * | 0 1 0 | * | -Sin(a3) Cos(a3) 0 | - | 0 -Sin(a1) Cos(a1) | | Sin(a2) 0 Cos(a2) | | 0 0 1 | - Mx My Mz - - We now want to solve for X, Y, Z, and t given 9 equations in 4 unknowns. - Using the diagonal elements of the two matrices, we get: - - X^2 + (1-X^2) Cos(t) = M[0][0] - Y^2 + (1-Y^2) Cos(t) = M[1][1] - Z^2 + (1-Z^2) Cos(t) = M[2][2] - - Adding the three equations, we get: - - X^2 + Y^2 + Z^2 - (M[0][0] + M[1][1] + M[2][2]) = - - (3 - X^2 - Y^2 - Z^2) Cos(t) - - Since (X^2 + Y^2 + Z^2) = 1, we can rewrite as: - - Cos(t) = (1 - (M[0][0] + M[1][1] + M[2][2])) / 2 - - Solving for t, we get: - - t = Acos(((M[0][0] + M[1][1] + M[2][2]) - 1) / 2) - - We can substitute t into the equations for X^2, Y^2, and Z^2 above - to get the values for X, Y, and Z. To find the proper signs we note - that: - - 2 X Sin(t) = M[1][2] - M[2][1] - 2 Y Sin(t) = M[2][0] - M[0][2] - 2 Z Sin(t) = M[0][1] - M[1][0] -} - -var Axis1, Axis2: TVector3f; - M, M1, M2: TMatrix; - cost, cost1, - sint, - s1, s2, s3: Single; - I: Integer; - - -begin - // see if we are only rotating about a single Axis - if Abs(Angles[X]) < EPSILON then - begin - if Abs(Angles[Y]) < EPSILON then - begin - Result := MakeVector([0, 0, 1, Angles[Z]]); - Exit; - end - else - if Abs(Angles[Z]) < EPSILON then - begin - Result := MakeVector([0, 1, 0, Angles[Y]]); - Exit; - end - end - else - if (Abs(Angles[Y]) < EPSILON) and - (Abs(Angles[Z]) < EPSILON) then - begin - Result := MakeVector([1, 0, 0, Angles[X]]); - Exit; - end; - - // make the rotation matrix - Axis1 := MakeAffineVector([1, 0, 0]); - M := CreateRotationMatrix(Axis1, Angles[X]); - - Axis2 := MakeAffineVector([0, 1, 0]); - M2 := CreateRotationMatrix(Axis2, Angles[Y]); - M1 := MatrixMultiply(M, M2); - - Axis2 := MakeAffineVector([0, 0, 1]); - M2 := CreateRotationMatrix(Axis2, Angles[Z]); - M := MatrixMultiply(M1, M2); - - cost := ((M[X, X] + M[Y, Y] + M[Z, Z])-1) / 2; - if cost < -1 then cost := -1 - else - if cost > 1 - EPSILON then - begin - // Bad Angle - this would cause a crash - Result := MakeVector([1, 0, 0, 0]); - Exit; - end; - - cost1 := 1 - cost; - Result := Makevector([Sqrt((M[X, X]-cost) / cost1), - Sqrt((M[Y, Y]-cost) / cost1), - sqrt((M[Z, Z]-cost) / cost1), - arccos(cost)]); - - sint := 2 * Sqrt(1 - cost * cost); // This is actually 2 Sin(t) - - // Determine the proper signs - for I := 0 to 7 do - begin - if (I and 1) > 1 then s1 := -1 else s1 := 1; - if (I and 2) > 1 then s2 := -1 else s2 := 1; - if (I and 4) > 1 then s3 := -1 else s3 := 1; - if (Abs(s1 * Result[X] * sint-M[Y, Z] + M[Z, Y]) < EPSILON2) and - (Abs(s2 * Result[Y] * sint-M[Z, X] + M[X, Z]) < EPSILON2) and - (Abs(s3 * Result[Z] * sint-M[X, Y] + M[Y, X]) < EPSILON2) then - begin - // We found the right combination of signs - Result[X] := Result[X] * s1; - Result[Y] := Result[Y] * s2; - Result[Z] := Result[Z] * s3; - Exit; - end; - end; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateRotationMatrixX(Sine, Cosine: Single): TMatrix; register; - -// creates matrix for rotation about x-axis - -begin - Result := EmptyMatrix; - Result[X, X] := 1; - Result[Y, Y] := Cosine; - Result[Y, Z] := Sine; - Result[Z, Y] := -Sine; - Result[Z, Z] := Cosine; - Result[W, W] := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateRotationMatrixY(Sine, Cosine: Single): TMatrix; register; - -// creates matrix for rotation about y-axis - -begin - Result := EmptyMatrix; - Result[X, X] := Cosine; - Result[X, Z] := -Sine; - Result[Y, Y] := 1; - Result[Z, X] := Sine; - Result[Z, Z] := Cosine; - Result[W, W] := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateRotationMatrixZ(Sine, Cosine: Single): TMatrix; register; - -// creates matrix for rotation about z-axis - -begin - Result := EmptyMatrix; - Result[X, X] := Cosine; - Result[X, Y] := Sine; - Result[Y, X] := -Sine; - Result[Y, Y] := Cosine; - Result[Z, Z] := 1; - Result[W, W] := 1; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateScaleMatrix(V: TAffineVector): TMatrix; register; - -// creates scaling matrix - -begin - Result := IdentityMatrix; - Result[X, X] := V[X]; - Result[Y, Y] := V[Y]; - Result[Z, Z] := V[Z]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function CreateTranslationMatrix(V: TVector): TMatrix; register; - -// creates translation matrix - -begin - Result := IdentityMatrix; - Result[W, X] := V[X]; - Result[W, Y] := V[Y]; - Result[W, Z] := V[Z]; - Result[W, W] := V[W]; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Lerp(Start, Stop, t: Single): Single; - -// calculates linear interpolation between start and stop at point t - -begin - Result := Start + (Stop - Start) * t; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineLerp(V1, V2: TAffineVector; t: Single): TAffineVector; - -// calculates linear interpolation between vector1 and vector2 at point t - -begin - Result[X] := Lerp(V1[X], V2[X], t); - Result[Y] := Lerp(V1[Y], V2[Y], t); - Result[Z] := Lerp(V1[Z], V2[Z], t); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorLerp(V1, V2: TVector; t: Single): TVector; - -// calculates linear interpolation between vector1 and vector2 at point t - -begin - Result[X] := Lerp(V1[X], V2[X], t); - Result[Y] := Lerp(V1[Y], V2[Y], t); - Result[Z] := Lerp(V1[Z], V2[Z], t); - Result[W] := Lerp(V1[W], V2[W], t); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function QuaternionSlerp(QStart, QEnd: TQuaternion; Spin: Integer; t: Single): TQuaternion; - -// spherical linear interpolation of unit quaternions with spins -// QStart, QEnd - start and end unit quaternions -// t - interpolation parameter (0 to 1) -// Spin - number of extra spin rotations to involve - -var beta, // complementary interp parameter - theta, // Angle between A and B - sint, cost, // sine, cosine of theta - phi: Single; // theta plus spins - bflip: Boolean; // use negativ t? - - -begin - // cosine theta - cost := VectorAngle(QStart.ImagPart, QEnd.ImagPart); - - // if QEnd is on opposite hemisphere from QStart, use -QEnd instead - if cost < 0 then - begin - cost := -cost; - bflip := True; - end - else bflip := False; - - // if QEnd is (within precision limits) the same as QStart, - // just linear interpolate between QStart and QEnd. - // Can't do spins, since we don't know what direction to spin. - - if (1 - cost) < EPSILON then beta := 1 - t - else - begin - // normal case - theta := arccos(cost); - phi := theta + Spin * Pi; - sint := sin(theta); - beta := sin(theta - t * phi) / sint; - t := sin(t * phi) / sint; - end; - - if bflip then t := -t; - - // interpolate - Result.ImagPart[X] := beta * QStart.ImagPart[X] + t * QEnd.ImagPart[X]; - Result.ImagPart[Y] := beta * QStart.ImagPart[Y] + t * QEnd.ImagPart[Y]; - Result.ImagPart[Z] := beta * QStart.ImagPart[Z] + t * QEnd.ImagPart[Z]; - Result.RealPart := beta * QStart.RealPart + t * QEnd.RealPart; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineCombine(V1, V2: TAffineVector; F1, F2: Single): TAffineVector; - -// makes a linear combination of two vectors and return the result - -begin - Result[X] := (F1 * V1[X]) + (F2 * V2[X]); - Result[Y] := (F1 * V1[Y]) + (F2 * V2[Y]); - Result[Z] := (F1 * V1[Z]) + (F2 * V2[Z]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorCombine(V1, V2: TVector; F1, F2: Single): TVector; - -// makes a linear combination of two vectors and return the result - -begin - Result[X] := (F1 * V1[X]) + (F2 * V2[X]); - Result[Y] := (F1 * V1[Y]) + (F2 * V2[Y]); - Result[Z] := (F1 * V1[Z]) + (F2 * V2[Z]); - Result[W] := (F1 * V1[W]) + (F2 * V2[W]); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function MatrixDecompose(M: TMatrix; var Tran: TTransformations): Boolean; register; - -// Author: Spencer W. Thomas, University of Michigan -// -// MatrixDecompose - Decompose a non-degenerated 4x4 transformation matrix into -// the sequence of transformations that produced it. -// -// The coefficient of each transformation is returned in the corresponding -// element of the vector Tran. -// -// Returns true upon success, false if the matrix is singular. - -var I, J: Integer; - LocMat, - pmat, - invpmat, - tinvpmat: TMatrix; - prhs, - psol: TVector; - Row: array[0..2] of TAffineVector; - -begin - Result := False; - locmat := M; - // normalize the matrix - if locmat[W, W] = 0 then Exit; - for I := 0 to 3 do - for J := 0 to 3 do - locmat[I, J] := locmat[I, J] / locmat[W, W]; - - // pmat is used to solve for perspective, but it also provides - // an easy way to test for singularity of the upper 3x3 component. - - pmat := locmat; - for I := 0 to 2 do pmat[I, W] := 0; - pmat[W, W] := 1; - - if MatrixDeterminant(pmat) = 0 then Exit; - - // First, isolate perspective. This is the messiest. - if (locmat[X, W] <> 0) or - (locmat[Y, W] <> 0) or - (locmat[Z, W] <> 0) then - begin - // prhs is the right hand side of the equation. - prhs[X] := locmat[X, W]; - prhs[Y] := locmat[Y, W]; - prhs[Z] := locmat[Z, W]; - prhs[W] := locmat[W, W]; - - // Solve the equation by inverting pmat and multiplying - // prhs by the inverse. (This is the easiest way, not - // necessarily the best.) - - invpmat := pmat; - MatrixInvert(invpmat); - MatrixTranspose(invpmat); - psol := VectorTransform(prhs, tinvpmat); - - // stuff the answer away - Tran[ttPerspectiveX] := psol[X]; - Tran[ttPerspectiveY] := psol[Y]; - Tran[ttPerspectiveZ] := psol[Z]; - Tran[ttPerspectiveW] := psol[W]; - - // clear the perspective partition - locmat[X, W] := 0; - locmat[Y, W] := 0; - locmat[Z, W] := 0; - locmat[W, W] := 1; - end - else - begin - // no perspective - Tran[ttPerspectiveX] := 0; - Tran[ttPerspectiveY] := 0; - Tran[ttPerspectiveZ] := 0; - Tran[ttPerspectiveW] := 0; - end; - - // next take care of translation (easy) - for I := 0 to 2 do - begin - Tran[TTransType(Ord(ttTranslateX) + I)] := locmat[W, I]; - locmat[W, I] := 0; - end; - - // now get scale and shear - for I := 0 to 2 do - begin - row[I, X] := locmat[I, X]; - row[I, Y] := locmat[I, Y]; - row[I, Z] := locmat[I, Z]; - end; - - // compute X scale factor and normalize first row - Tran[ttScaleX] := Sqr(VectorNormalize(row[0])); // ml: calculation optimized - - // compute XY shear factor and make 2nd row orthogonal to 1st - Tran[ttShearXY] := VectorAffineDotProduct(row[0], row[1]); - row[1] := VectorAffineCombine(row[1], row[0], 1, -Tran[ttShearXY]); - - // now, compute Y scale and normalize 2nd row - Tran[ttScaleY] := Sqr(VectorNormalize(row[1])); // ml: calculation optimized - Tran[ttShearXY] := Tran[ttShearXY]/Tran[ttScaleY]; - - // compute XZ and YZ shears, orthogonalize 3rd row - Tran[ttShearXZ] := VectorAffineDotProduct(row[0], row[2]); - row[2] := VectorAffineCombine(row[2], row[0], 1, -Tran[ttShearXZ]); - Tran[ttShearYZ] := VectorAffineDotProduct(row[1], row[2]); - row[2] := VectorAffineCombine(row[2], row[1], 1, -Tran[ttShearYZ]); - - // next, get Z scale and normalize 3rd row - Tran[ttScaleZ] := Sqr(VectorNormalize(row[1])); // (ML) calc. optimized - Tran[ttShearXZ] := Tran[ttShearXZ] / tran[ttScaleZ]; - Tran[ttShearYZ] := Tran[ttShearYZ] / Tran[ttScaleZ]; - - // At this point, the matrix (in rows[]) is orthonormal. - // Check for a coordinate system flip. If the determinant - // is -1, then negate the matrix and the scaling factors. - if VectorAffineDotProduct(row[0], VectorCrossProduct(row[1], row[2])) < 0 then - for I := 0 to 2 do - begin - Tran[TTransType(Ord(ttScaleX) + I)] := -Tran[TTransType(Ord(ttScaleX) + I)]; - row[I, X] := -row[I, X]; - row[I, Y] := -row[I, Y]; - row[I, Z] := -row[I, Z]; - end; - - // now, get the rotations out, as described in the gem - Tran[ttRotateY] := arcsin(-row[0, Z]); - if cos(Tran[ttRotateY]) <> 0 then - begin - Tran[ttRotateX] := arctan2(row[1, Z], row[2, Z]); - Tran[ttRotateZ] := arctan2(row[0, Y], row[0, X]); - end - else - begin - tran[ttRotateX] := arctan2(row[1, X], row[1, Y]); - tran[ttRotateZ] := 0; - end; - // All done! - Result := True; -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorDblToFlt(V: THomogeneousDblVector): THomogeneousVector; assembler; - -// converts a vector containing double sized values into a vector with single sized values - -asm - FLD QWORD PTR [EAX] - FSTP DWORD PTR [EDX] - FLD QWORD PTR [EAX + 8] - FSTP DWORD PTR [EDX + 4] - FLD QWORD PTR [EAX + 16] - FSTP DWORD PTR [EDX + 8] - FLD QWORD PTR [EAX + 24] - FSTP DWORD PTR [EDX + 12] -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineDblToFlt(V: TAffineDblVector): TAffineVector; assembler; - -// converts a vector containing double sized values into a vector with single sized values - -asm - FLD QWORD PTR [EAX] - FSTP DWORD PTR [EDX] - FLD QWORD PTR [EAX + 8] - FSTP DWORD PTR [EDX + 4] - FLD QWORD PTR [EAX + 16] - FSTP DWORD PTR [EDX + 8] -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorAffineFltToDbl(V: TAffineVector): TAffineDblVector; assembler; - -// converts a vector containing single sized values into a vector with double sized values - -asm - FLD DWORD PTR [EAX] - FSTP QWORD PTR [EDX] - FLD DWORD PTR [EAX + 8] - FSTP QWORD PTR [EDX + 4] - FLD DWORD PTR [EAX + 16] - FSTP QWORD PTR [EDX + 8] -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function VectorFltToDbl(V: TVector): THomogeneousDblVector; assembler; - -// converts a vector containing single sized values into a vector with double sized values - -asm - FLD DWORD PTR [EAX] - FSTP QWORD PTR [EDX] - FLD DWORD PTR [EAX + 8] - FSTP QWORD PTR [EDX + 4] - FLD DWORD PTR [EAX + 16] - FSTP QWORD PTR [EDX + 8] - FLD DWORD PTR [EAX + 24] - FSTP QWORD PTR [EDX + 12] -end; - -//----------------- coordinate system manipulation functions ----------------------------------------------------------- - -function Turn(Matrix: TMatrix; Angle: Single): TMatrix; - -// rotates the given coordinate system (represented by the matrix) around its Y-axis - -begin - Result := MatrixMultiply(Matrix, CreateRotationMatrix(MakeAffineVector(Matrix[1]), Angle)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Turn(Matrix: TMatrix; MasterUp: TAffineVector; Angle: Single): TMatrix; - -// rotates the given coordinate system (represented by the matrix) around MasterUp - -begin - Result := MatrixMultiply(Matrix, CreateRotationMatrix(MasterUp, Angle)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Pitch(Matrix: TMatrix; Angle: Single): TMatrix; - -// rotates the given coordinate system (represented by the matrix) around its X-axis - -begin - Result := MatrixMultiply(Matrix, CreateRotationMatrix(MakeAffineVector(Matrix[0]), Angle)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Pitch(Matrix: TMatrix; MasterRight: TAffineVector; Angle: Single): TMatrix; overload; - -// rotates the given coordinate system (represented by the matrix) around MasterRight - -begin - Result := MatrixMultiply(Matrix, CreateRotationMatrix(MasterRight, Angle)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Roll(Matrix: TMatrix; Angle: Single): TMatrix; - -// rotates the given coordinate system (represented by the matrix) around its Z-axis - -begin - Result := MatrixMultiply(Matrix, CreateRotationMatrix(MakeAffineVector(Matrix[2]), Angle)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -function Roll(Matrix: TMatrix; MasterDirection: TAffineVector; Angle: Single): TMatrix; overload; - -// rotates the given coordinate system (represented by the matrix) around MasterDirection - -begin - Result := MatrixMultiply(Matrix, CreateRotationMatrix(MasterDirection, Angle)); -end; - -//---------------------------------------------------------------------------------------------------------------------- - -end. - - diff --git a/src/lib/JEDI-SDL/OpenGL/Pas/gl.pas b/src/lib/JEDI-SDL/OpenGL/Pas/gl.pas deleted file mode 100644 index d1231cdd..00000000 --- a/src/lib/JEDI-SDL/OpenGL/Pas/gl.pas +++ /dev/null @@ -1,2301 +0,0 @@ -unit gl; -{ - $Id: gl.pas,v 1.5 2007/05/20 20:28:31 savage Exp $ - - Adaption of the delphi3d.net OpenGL units to FreePascal - Sebastian Guenther (sg@freepascal.org) in 2002 - These units are free to use -} - -(*++ BUILD Version: 0004 // Increment this if a change has global effects - -Copyright (c) 1985-96, Microsoft Corporation - -Module Name: - - gl.h - -Abstract: - - Procedure declarations, constant definitions and macros for the OpenGL - component. - ---*) - -(* -** Copyright 1996 Silicon Graphics, Inc. -** All Rights Reserved. -** -** This is UNPUBLISHED PROPRIETARY SOURCE CODE of Silicon Graphics, Inc.; -** the contents of this file may not be disclosed to third parties, copied or -** duplicated in any form, in whole or in part, without the prior written -** permission of Silicon Graphics, Inc. -** -** RESTRICTED RIGHTS LEGEND: -** Use, duplication or disclosure by the Government is subject to restrictions -** as set forth in subdivision (c)(1)(ii) of the Rights in Technical Data -** and Computer Software clause at DFARS 252.227-7013, and/or in similar or -** successor clauses in the FAR, DOD or NASA FAR Supplement. Unpublished - -** rights reserved under the Copyright Laws of the United States. -*) - -{******************************************************************************} -{ } -{ Converted to Delphi by Tom Nuydens (tom@delphi3d.net) } -{ For the latest updates, visit Delphi3D: http://www.delphi3d.net } -{ } -{ Modified for Delphi/Kylix and FreePascal } -{ by Dominique Louis ( Dominique@Savagesoftware.com.au) } -{ For the latest updates, visit JEDI-SDL : http://www.sf.net/projects/jedi-sdl } -{ } -{******************************************************************************} - -{ - $Log: gl.pas,v $ - Revision 1.5 2007/05/20 20:28:31 savage - Initial Changes to Handle 64 Bits - - Revision 1.4 2006/11/20 21:20:59 savage - Updated to work in MacOS X - - Revision 1.3 2005/05/22 18:52:09 savage - Changes as suggested by Michalis Kamburelis. Thanks again. - - Revision 1.2 2004/08/14 22:54:30 savage - Updated so that Library name defines are correctly defined for MacOS X. - - Revision 1.1 2004/03/30 21:53:54 savage - Moved to it's own folder. - - Revision 1.4 2004/02/20 17:09:55 savage - Code tidied up in gl, glu and glut, while extensions in glext.pas are now loaded using SDL_GL_GetProcAddress, thus making it more cross-platform compatible, but now more tied to SDL. - - Revision 1.3 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.2 2004/02/14 00:09:18 savage - Changed uses to now make use of moduleloader.pas rather than dllfuncs.pas - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - Revision 1.6 2003/06/02 12:32:12 savage - Modified Sources to avoid warnings with Delphi by moving CVS Logging to the top of the header files. Hopefully CVS Logging still works. - -} - -interface - -{$I jedi-sdl.inc} - -uses -{$IFDEF __GPC__} - system, - gpc, -{$ENDIF} - -{$IFDEF WINDOWS} - Windows, -{$ENDIF} - moduleloader; - - -var - LibGL: TModuleHandle; - -type - GLenum = Cardinal; PGLenum = ^GLenum; - GLboolean = Byte; PGLboolean = ^GLboolean; - GLbitfield = Cardinal; PGLbitfield = ^GLbitfield; - GLbyte = ShortInt; PGLbyte = ^GLbyte; - GLshort = SmallInt; PGLshort = ^GLshort; - GLint = Integer; PGLint = ^GLint; - GLsizei = Integer; PGLsizei = ^GLsizei; - GLubyte = Byte; PGLubyte = ^GLubyte; - GLushort = Word; PGLushort = ^GLushort; - GLuint = Cardinal; PGLuint = ^GLuint; - GLfloat = Single; PGLfloat = ^GLfloat; - GLclampf = Single; PGLclampf = ^GLclampf; - GLdouble = Double; PGLdouble = ^GLdouble; - GLclampd = Double; PGLclampd = ^GLclampd; -{ GLvoid = void; } PGLvoid = Pointer; - -{******************************************************************************} - -const -{$IFDEF WINDOWS} - GLLibName = 'OpenGL32.dll'; -{$ENDIF} - -{$IFDEF UNIX} -{$IFDEF DARWIN} - GLLibName = '/System/Library/Frameworks/OpenGL.framework/Libraries/libGL.dylib'; -{$ELSE} - GLLibName = 'libGL.so.1'; -{$ENDIF} -{$ENDIF} - - // Version - GL_VERSION_1_1 = 1; - - // AccumOp - GL_ACCUM = $0100; - GL_LOAD = $0101; - GL_RETURN = $0102; - GL_MULT = $0103; - GL_ADD = $0104; - - // AlphaFunction - GL_NEVER = $0200; - GL_LESS = $0201; - GL_EQUAL = $0202; - GL_LEQUAL = $0203; - GL_GREATER = $0204; - GL_NOTEQUAL = $0205; - GL_GEQUAL = $0206; - GL_ALWAYS = $0207; - - // AttribMask - GL_CURRENT_BIT = $00000001; - GL_POINT_BIT = $00000002; - GL_LINE_BIT = $00000004; - GL_POLYGON_BIT = $00000008; - GL_POLYGON_STIPPLE_BIT = $00000010; - GL_PIXEL_MODE_BIT = $00000020; - GL_LIGHTING_BIT = $00000040; - GL_FOG_BIT = $00000080; - GL_DEPTH_BUFFER_BIT = $00000100; - GL_ACCUM_BUFFER_BIT = $00000200; - GL_STENCIL_BUFFER_BIT = $00000400; - GL_VIEWPORT_BIT = $00000800; - GL_TRANSFORM_BIT = $00001000; - GL_ENABLE_BIT = $00002000; - GL_COLOR_BUFFER_BIT = $00004000; - GL_HINT_BIT = $00008000; - GL_EVAL_BIT = $00010000; - GL_LIST_BIT = $00020000; - GL_TEXTURE_BIT = $00040000; - GL_SCISSOR_BIT = $00080000; - GL_ALL_ATTRIB_BITS = $000FFFFF; - - // BeginMode - GL_POINTS = $0000; - GL_LINES = $0001; - GL_LINE_LOOP = $0002; - GL_LINE_STRIP = $0003; - GL_TRIANGLES = $0004; - GL_TRIANGLE_STRIP = $0005; - GL_TRIANGLE_FAN = $0006; - GL_QUADS = $0007; - GL_QUAD_STRIP = $0008; - GL_POLYGON = $0009; - - // BlendingFactorDest - GL_ZERO = 0; - GL_ONE = 1; - GL_SRC_COLOR = $0300; - GL_ONE_MINUS_SRC_COLOR = $0301; - GL_SRC_ALPHA = $0302; - GL_ONE_MINUS_SRC_ALPHA = $0303; - GL_DST_ALPHA = $0304; - GL_ONE_MINUS_DST_ALPHA = $0305; - - // BlendingFactorSrc - // GL_ZERO - // GL_ONE - GL_DST_COLOR = $0306; - GL_ONE_MINUS_DST_COLOR = $0307; - GL_SRC_ALPHA_SATURATE = $0308; - // GL_SRC_ALPHA - // GL_ONE_MINUS_SRC_ALPHA - // GL_DST_ALPHA - // GL_ONE_MINUS_DST_ALPHA - - // Boolean - GL_TRUE = 1; - GL_FALSE = 0; - - // ClearBufferMask - // GL_COLOR_BUFFER_BIT - // GL_ACCUM_BUFFER_BIT - // GL_STENCIL_BUFFER_BIT - // GL_DEPTH_BUFFER_BIT - - // ClientArrayType - // GL_VERTEX_ARRAY - // GL_NORMAL_ARRAY - // GL_COLOR_ARRAY - // GL_INDEX_ARRAY - // GL_TEXTURE_COORD_ARRAY - // GL_EDGE_FLAG_ARRAY - - // ClipPlaneName - GL_CLIP_PLANE0 = $3000; - GL_CLIP_PLANE1 = $3001; - GL_CLIP_PLANE2 = $3002; - GL_CLIP_PLANE3 = $3003; - GL_CLIP_PLANE4 = $3004; - GL_CLIP_PLANE5 = $3005; - - // ColorMaterialFace - // GL_FRONT - // GL_BACK - // GL_FRONT_AND_BACK - - // ColorMaterialParameter - // GL_AMBIENT - // GL_DIFFUSE - // GL_SPECULAR - // GL_EMISSION - // GL_AMBIENT_AND_DIFFUSE - - // ColorPointerType - // GL_BYTE - // GL_UNSIGNED_BYTE - // GL_SHORT - // GL_UNSIGNED_SHORT - // GL_INT - // GL_UNSIGNED_INT - // GL_FLOAT - // GL_DOUBLE - - // CullFaceMode - // GL_FRONT - // GL_BACK - // GL_FRONT_AND_BACK - - // DataType - GL_BYTE = $1400; - GL_UNSIGNED_BYTE = $1401; - GL_SHORT = $1402; - GL_UNSIGNED_SHORT = $1403; - GL_INT = $1404; - GL_UNSIGNED_INT = $1405; - GL_FLOAT = $1406; - GL_2_BYTES = $1407; - GL_3_BYTES = $1408; - GL_4_BYTES = $1409; - GL_DOUBLE = $140A; - - // DepthFunction - // GL_NEVER - // GL_LESS - // GL_EQUAL - // GL_LEQUAL - // GL_GREATER - // GL_NOTEQUAL - // GL_GEQUAL - // GL_ALWAYS - - // DrawBufferMode - GL_NONE = 0; - GL_FRONT_LEFT = $0400; - GL_FRONT_RIGHT = $0401; - GL_BACK_LEFT = $0402; - GL_BACK_RIGHT = $0403; - GL_FRONT = $0404; - GL_BACK = $0405; - GL_LEFT = $0406; - GL_RIGHT = $0407; - GL_FRONT_AND_BACK = $0408; - GL_AUX0 = $0409; - GL_AUX1 = $040A; - GL_AUX2 = $040B; - GL_AUX3 = $040C; - - // Enable - // GL_FOG - // GL_LIGHTING - // GL_TEXTURE_1D - // GL_TEXTURE_2D - // GL_LINE_STIPPLE - // GL_POLYGON_STIPPLE - // GL_CULL_FACE - // GL_ALPHA_TEST - // GL_BLEND - // GL_INDEX_LOGIC_OP - // GL_COLOR_LOGIC_OP - // GL_DITHER - // GL_STENCIL_TEST - // GL_DEPTH_TEST - // GL_CLIP_PLANE0 - // GL_CLIP_PLANE1 - // GL_CLIP_PLANE2 - // GL_CLIP_PLANE3 - // GL_CLIP_PLANE4 - // GL_CLIP_PLANE5 - // GL_LIGHT0 - // GL_LIGHT1 - // GL_LIGHT2 - // GL_LIGHT3 - // GL_LIGHT4 - // GL_LIGHT5 - // GL_LIGHT6 - // GL_LIGHT7 - // GL_TEXTURE_GEN_S - // GL_TEXTURE_GEN_T - // GL_TEXTURE_GEN_R - // GL_TEXTURE_GEN_Q - // GL_MAP1_VERTEX_3 - // GL_MAP1_VERTEX_4 - // GL_MAP1_COLOR_4 - // GL_MAP1_INDEX - // GL_MAP1_NORMAL - // GL_MAP1_TEXTURE_COORD_1 - // GL_MAP1_TEXTURE_COORD_2 - // GL_MAP1_TEXTURE_COORD_3 - // GL_MAP1_TEXTURE_COORD_4 - // GL_MAP2_VERTEX_3 - // GL_MAP2_VERTEX_4 - // GL_MAP2_COLOR_4 - // GL_MAP2_INDEX - // GL_MAP2_NORMAL - // GL_MAP2_TEXTURE_COORD_1 - // GL_MAP2_TEXTURE_COORD_2 - // GL_MAP2_TEXTURE_COORD_3 - // GL_MAP2_TEXTURE_COORD_4 - // GL_POINT_SMOOTH - // GL_LINE_SMOOTH - // GL_POLYGON_SMOOTH - // GL_SCISSOR_TEST - // GL_COLOR_MATERIAL - // GL_NORMALIZE - // GL_AUTO_NORMAL - // GL_VERTEX_ARRAY - // GL_NORMAL_ARRAY - // GL_COLOR_ARRAY - // GL_INDEX_ARRAY - // GL_TEXTURE_COORD_ARRAY - // GL_EDGE_FLAG_ARRAY - // GL_POLYGON_OFFSET_POINT - // GL_POLYGON_OFFSET_LINE - // GL_POLYGON_OFFSET_FILL - - // ErrorCode - GL_NO_ERROR = 0; - GL_INVALID_ENUM = $0500; - GL_INVALID_VALUE = $0501; - GL_INVALID_OPERATION = $0502; - GL_STACK_OVERFLOW = $0503; - GL_STACK_UNDERFLOW = $0504; - GL_OUT_OF_MEMORY = $0505; - - // FeedBackMode - GL_2D = $0600; - GL_3D = $0601; - GL_3D_COLOR = $0602; - GL_3D_COLOR_TEXTURE = $0603; - GL_4D_COLOR_TEXTURE = $0604; - - // FeedBackToken - GL_PASS_THROUGH_TOKEN = $0700; - GL_POINT_TOKEN = $0701; - GL_LINE_TOKEN = $0702; - GL_POLYGON_TOKEN = $0703; - GL_BITMAP_TOKEN = $0704; - GL_DRAW_PIXEL_TOKEN = $0705; - GL_COPY_PIXEL_TOKEN = $0706; - GL_LINE_RESET_TOKEN = $0707; - - // FogMode - // GL_LINEAR - GL_EXP = $0800; - GL_EXP2 = $0801; - - // FogParameter - // GL_FOG_COLOR - // GL_FOG_DENSITY - // GL_FOG_END - // GL_FOG_INDEX - // GL_FOG_MODE - // GL_FOG_START - - // FrontFaceDirection - GL_CW = $0900; - GL_CCW = $0901; - - // GetMapTarget - GL_COEFF = $0A00; - GL_ORDER = $0A01; - GL_DOMAIN = $0A02; - - // GetPixelMap - // GL_PIXEL_MAP_I_TO_I - // GL_PIXEL_MAP_S_TO_S - // GL_PIXEL_MAP_I_TO_R - // GL_PIXEL_MAP_I_TO_G - // GL_PIXEL_MAP_I_TO_B - // GL_PIXEL_MAP_I_TO_A - // GL_PIXEL_MAP_R_TO_R - // GL_PIXEL_MAP_G_TO_G - // GL_PIXEL_MAP_B_TO_B - // GL_PIXEL_MAP_A_TO_A - - // GetPointerTarget - // GL_VERTEX_ARRAY_POINTER - // GL_NORMAL_ARRAY_POINTER - // GL_COLOR_ARRAY_POINTER - // GL_INDEX_ARRAY_POINTER - // GL_TEXTURE_COORD_ARRAY_POINTER - // GL_EDGE_FLAG_ARRAY_POINTER - - // GetTarget - GL_CURRENT_COLOR = $0B00; - GL_CURRENT_INDEX = $0B01; - GL_CURRENT_NORMAL = $0B02; - GL_CURRENT_TEXTURE_COORDS = $0B03; - GL_CURRENT_RASTER_COLOR = $0B04; - GL_CURRENT_RASTER_INDEX = $0B05; - GL_CURRENT_RASTER_TEXTURE_COORDS = $0B06; - GL_CURRENT_RASTER_POSITION = $0B07; - GL_CURRENT_RASTER_POSITION_VALID = $0B08; - GL_CURRENT_RASTER_DISTANCE = $0B09; - GL_POINT_SMOOTH = $0B10; - GL_POINT_SIZE = $0B11; - GL_POINT_SIZE_RANGE = $0B12; - GL_POINT_SIZE_GRANULARITY = $0B13; - GL_LINE_SMOOTH = $0B20; - GL_LINE_WIDTH = $0B21; - GL_LINE_WIDTH_RANGE = $0B22; - GL_LINE_WIDTH_GRANULARITY = $0B23; - GL_LINE_STIPPLE = $0B24; - GL_LINE_STIPPLE_PATTERN = $0B25; - GL_LINE_STIPPLE_REPEAT = $0B26; - GL_LIST_MODE = $0B30; - GL_MAX_LIST_NESTING = $0B31; - GL_LIST_BASE = $0B32; - GL_LIST_INDEX = $0B33; - GL_POLYGON_MODE = $0B40; - GL_POLYGON_SMOOTH = $0B41; - GL_POLYGON_STIPPLE = $0B42; - GL_EDGE_FLAG = $0B43; - GL_CULL_FACE = $0B44; - GL_CULL_FACE_MODE = $0B45; - GL_FRONT_FACE = $0B46; - GL_LIGHTING = $0B50; - GL_LIGHT_MODEL_LOCAL_VIEWER = $0B51; - GL_LIGHT_MODEL_TWO_SIDE = $0B52; - GL_LIGHT_MODEL_AMBIENT = $0B53; - GL_SHADE_MODEL = $0B54; - GL_COLOR_MATERIAL_FACE = $0B55; - GL_COLOR_MATERIAL_PARAMETER = $0B56; - GL_COLOR_MATERIAL = $0B57; - GL_FOG = $0B60; - GL_FOG_INDEX = $0B61; - GL_FOG_DENSITY = $0B62; - GL_FOG_START = $0B63; - GL_FOG_END = $0B64; - GL_FOG_MODE = $0B65; - GL_FOG_COLOR = $0B66; - GL_DEPTH_RANGE = $0B70; - GL_DEPTH_TEST = $0B71; - GL_DEPTH_WRITEMASK = $0B72; - GL_DEPTH_CLEAR_VALUE = $0B73; - GL_DEPTH_FUNC = $0B74; - GL_ACCUM_CLEAR_VALUE = $0B80; - GL_STENCIL_TEST = $0B90; - GL_STENCIL_CLEAR_VALUE = $0B91; - GL_STENCIL_FUNC = $0B92; - GL_STENCIL_VALUE_MASK = $0B93; - GL_STENCIL_FAIL = $0B94; - GL_STENCIL_PASS_DEPTH_FAIL = $0B95; - GL_STENCIL_PASS_DEPTH_PASS = $0B96; - GL_STENCIL_REF = $0B97; - GL_STENCIL_WRITEMASK = $0B98; - GL_MATRIX_MODE = $0BA0; - GL_NORMALIZE = $0BA1; - GL_VIEWPORT = $0BA2; - GL_MODELVIEW_STACK_DEPTH = $0BA3; - GL_PROJECTION_STACK_DEPTH = $0BA4; - GL_TEXTURE_STACK_DEPTH = $0BA5; - GL_MODELVIEW_MATRIX = $0BA6; - GL_PROJECTION_MATRIX = $0BA7; - GL_TEXTURE_MATRIX = $0BA8; - GL_ATTRIB_STACK_DEPTH = $0BB0; - GL_CLIENT_ATTRIB_STACK_DEPTH = $0BB1; - GL_ALPHA_TEST = $0BC0; - GL_ALPHA_TEST_FUNC = $0BC1; - GL_ALPHA_TEST_REF = $0BC2; - GL_DITHER = $0BD0; - GL_BLEND_DST = $0BE0; - GL_BLEND_SRC = $0BE1; - GL_BLEND = $0BE2; - GL_LOGIC_OP_MODE = $0BF0; - GL_INDEX_LOGIC_OP = $0BF1; - GL_COLOR_LOGIC_OP = $0BF2; - GL_AUX_BUFFERS = $0C00; - GL_DRAW_BUFFER = $0C01; - GL_READ_BUFFER = $0C02; - GL_SCISSOR_BOX = $0C10; - GL_SCISSOR_TEST = $0C11; - GL_INDEX_CLEAR_VALUE = $0C20; - GL_INDEX_WRITEMASK = $0C21; - GL_COLOR_CLEAR_VALUE = $0C22; - GL_COLOR_WRITEMASK = $0C23; - GL_INDEX_MODE = $0C30; - GL_RGBA_MODE = $0C31; - GL_DOUBLEBUFFER = $0C32; - GL_STEREO = $0C33; - GL_RENDER_MODE = $0C40; - GL_PERSPECTIVE_CORRECTION_HINT = $0C50; - GL_POINT_SMOOTH_HINT = $0C51; - GL_LINE_SMOOTH_HINT = $0C52; - GL_POLYGON_SMOOTH_HINT = $0C53; - GL_FOG_HINT = $0C54; - GL_TEXTURE_GEN_S = $0C60; - GL_TEXTURE_GEN_T = $0C61; - GL_TEXTURE_GEN_R = $0C62; - GL_TEXTURE_GEN_Q = $0C63; - GL_PIXEL_MAP_I_TO_I = $0C70; - GL_PIXEL_MAP_S_TO_S = $0C71; - GL_PIXEL_MAP_I_TO_R = $0C72; - GL_PIXEL_MAP_I_TO_G = $0C73; - GL_PIXEL_MAP_I_TO_B = $0C74; - GL_PIXEL_MAP_I_TO_A = $0C75; - GL_PIXEL_MAP_R_TO_R = $0C76; - GL_PIXEL_MAP_G_TO_G = $0C77; - GL_PIXEL_MAP_B_TO_B = $0C78; - GL_PIXEL_MAP_A_TO_A = $0C79; - GL_PIXEL_MAP_I_TO_I_SIZE = $0CB0; - GL_PIXEL_MAP_S_TO_S_SIZE = $0CB1; - GL_PIXEL_MAP_I_TO_R_SIZE = $0CB2; - GL_PIXEL_MAP_I_TO_G_SIZE = $0CB3; - GL_PIXEL_MAP_I_TO_B_SIZE = $0CB4; - GL_PIXEL_MAP_I_TO_A_SIZE = $0CB5; - GL_PIXEL_MAP_R_TO_R_SIZE = $0CB6; - GL_PIXEL_MAP_G_TO_G_SIZE = $0CB7; - GL_PIXEL_MAP_B_TO_B_SIZE = $0CB8; - GL_PIXEL_MAP_A_TO_A_SIZE = $0CB9; - GL_UNPACK_SWAP_BYTES = $0CF0; - GL_UNPACK_LSB_FIRST = $0CF1; - GL_UNPACK_ROW_LENGTH = $0CF2; - GL_UNPACK_SKIP_ROWS = $0CF3; - GL_UNPACK_SKIP_PIXELS = $0CF4; - GL_UNPACK_ALIGNMENT = $0CF5; - GL_PACK_SWAP_BYTES = $0D00; - GL_PACK_LSB_FIRST = $0D01; - GL_PACK_ROW_LENGTH = $0D02; - GL_PACK_SKIP_ROWS = $0D03; - GL_PACK_SKIP_PIXELS = $0D04; - GL_PACK_ALIGNMENT = $0D05; - GL_MAP_COLOR = $0D10; - GL_MAP_STENCIL = $0D11; - GL_INDEX_SHIFT = $0D12; - GL_INDEX_OFFSET = $0D13; - GL_RED_SCALE = $0D14; - GL_RED_BIAS = $0D15; - GL_ZOOM_X = $0D16; - GL_ZOOM_Y = $0D17; - GL_GREEN_SCALE = $0D18; - GL_GREEN_BIAS = $0D19; - GL_BLUE_SCALE = $0D1A; - GL_BLUE_BIAS = $0D1B; - GL_ALPHA_SCALE = $0D1C; - GL_ALPHA_BIAS = $0D1D; - GL_DEPTH_SCALE = $0D1E; - GL_DEPTH_BIAS = $0D1F; - GL_MAX_EVAL_ORDER = $0D30; - GL_MAX_LIGHTS = $0D31; - GL_MAX_CLIP_PLANES = $0D32; - GL_MAX_TEXTURE_SIZE = $0D33; - GL_MAX_PIXEL_MAP_TABLE = $0D34; - GL_MAX_ATTRIB_STACK_DEPTH = $0D35; - GL_MAX_MODELVIEW_STACK_DEPTH = $0D36; - GL_MAX_NAME_STACK_DEPTH = $0D37; - GL_MAX_PROJECTION_STACK_DEPTH = $0D38; - GL_MAX_TEXTURE_STACK_DEPTH = $0D39; - GL_MAX_VIEWPORT_DIMS = $0D3A; - GL_MAX_CLIENT_ATTRIB_STACK_DEPTH = $0D3B; - GL_SUBPIXEL_BITS = $0D50; - GL_INDEX_BITS = $0D51; - GL_RED_BITS = $0D52; - GL_GREEN_BITS = $0D53; - GL_BLUE_BITS = $0D54; - GL_ALPHA_BITS = $0D55; - GL_DEPTH_BITS = $0D56; - GL_STENCIL_BITS = $0D57; - GL_ACCUM_RED_BITS = $0D58; - GL_ACCUM_GREEN_BITS = $0D59; - GL_ACCUM_BLUE_BITS = $0D5A; - GL_ACCUM_ALPHA_BITS = $0D5B; - GL_NAME_STACK_DEPTH = $0D70; - GL_AUTO_NORMAL = $0D80; - GL_MAP1_COLOR_4 = $0D90; - GL_MAP1_INDEX = $0D91; - GL_MAP1_NORMAL = $0D92; - GL_MAP1_TEXTURE_COORD_1 = $0D93; - GL_MAP1_TEXTURE_COORD_2 = $0D94; - GL_MAP1_TEXTURE_COORD_3 = $0D95; - GL_MAP1_TEXTURE_COORD_4 = $0D96; - GL_MAP1_VERTEX_3 = $0D97; - GL_MAP1_VERTEX_4 = $0D98; - GL_MAP2_COLOR_4 = $0DB0; - GL_MAP2_INDEX = $0DB1; - GL_MAP2_NORMAL = $0DB2; - GL_MAP2_TEXTURE_COORD_1 = $0DB3; - GL_MAP2_TEXTURE_COORD_2 = $0DB4; - GL_MAP2_TEXTURE_COORD_3 = $0DB5; - GL_MAP2_TEXTURE_COORD_4 = $0DB6; - GL_MAP2_VERTEX_3 = $0DB7; - GL_MAP2_VERTEX_4 = $0DB8; - GL_MAP1_GRID_DOMAIN = $0DD0; - GL_MAP1_GRID_SEGMENTS = $0DD1; - GL_MAP2_GRID_DOMAIN = $0DD2; - GL_MAP2_GRID_SEGMENTS = $0DD3; - GL_TEXTURE_1D = $0DE0; - GL_TEXTURE_2D = $0DE1; - GL_FEEDBACK_BUFFER_POINTER = $0DF0; - GL_FEEDBACK_BUFFER_SIZE = $0DF1; - GL_FEEDBACK_BUFFER_TYPE = $0DF2; - GL_SELECTION_BUFFER_POINTER = $0DF3; - GL_SELECTION_BUFFER_SIZE = $0DF4; - // GL_TEXTURE_BINDING_1D - // GL_TEXTURE_BINDING_2D - // GL_VERTEX_ARRAY - // GL_NORMAL_ARRAY - // GL_COLOR_ARRAY - // GL_INDEX_ARRAY - // GL_TEXTURE_COORD_ARRAY - // GL_EDGE_FLAG_ARRAY - // GL_VERTEX_ARRAY_SIZE - // GL_VERTEX_ARRAY_TYPE - // GL_VERTEX_ARRAY_STRIDE - // GL_NORMAL_ARRAY_TYPE - // GL_NORMAL_ARRAY_STRIDE - // GL_COLOR_ARRAY_SIZE - // GL_COLOR_ARRAY_TYPE - // GL_COLOR_ARRAY_STRIDE - // GL_INDEX_ARRAY_TYPE - // GL_INDEX_ARRAY_STRIDE - // GL_TEXTURE_COORD_ARRAY_SIZE - // GL_TEXTURE_COORD_ARRAY_TYPE - // GL_TEXTURE_COORD_ARRAY_STRIDE - // GL_EDGE_FLAG_ARRAY_STRIDE - // GL_POLYGON_OFFSET_FACTOR - // GL_POLYGON_OFFSET_UNITS - - // GetTextureParameter - // GL_TEXTURE_MAG_FILTER - // GL_TEXTURE_MIN_FILTER - // GL_TEXTURE_WRAP_S - // GL_TEXTURE_WRAP_T - GL_TEXTURE_WIDTH = $1000; - GL_TEXTURE_HEIGHT = $1001; - GL_TEXTURE_INTERNAL_FORMAT = $1003; - GL_TEXTURE_BORDER_COLOR = $1004; - GL_TEXTURE_BORDER = $1005; - // GL_TEXTURE_RED_SIZE - // GL_TEXTURE_GREEN_SIZE - // GL_TEXTURE_BLUE_SIZE - // GL_TEXTURE_ALPHA_SIZE - // GL_TEXTURE_LUMINANCE_SIZE - // GL_TEXTURE_INTENSITY_SIZE - // GL_TEXTURE_PRIORITY - // GL_TEXTURE_RESIDENT - - // HintMode - GL_DONT_CARE = $1100; - GL_FASTEST = $1101; - GL_NICEST = $1102; - - // HintTarget - // GL_PERSPECTIVE_CORRECTION_HINT - // GL_POINT_SMOOTH_HINT - // GL_LINE_SMOOTH_HINT - // GL_POLYGON_SMOOTH_HINT - // GL_FOG_HINT - - // IndexPointerType - // GL_SHORT - // GL_INT - // GL_FLOAT - // GL_DOUBLE - - // LightModelParameter - // GL_LIGHT_MODEL_AMBIENT - // GL_LIGHT_MODEL_LOCAL_VIEWER - // GL_LIGHT_MODEL_TWO_SIDE - - // LightName - GL_LIGHT0 = $4000; - GL_LIGHT1 = $4001; - GL_LIGHT2 = $4002; - GL_LIGHT3 = $4003; - GL_LIGHT4 = $4004; - GL_LIGHT5 = $4005; - GL_LIGHT6 = $4006; - GL_LIGHT7 = $4007; - - // LightParameter - GL_AMBIENT = $1200; - GL_DIFFUSE = $1201; - GL_SPECULAR = $1202; - GL_POSITION = $1203; - GL_SPOT_DIRECTION = $1204; - GL_SPOT_EXPONENT = $1205; - GL_SPOT_CUTOFF = $1206; - GL_CONSTANT_ATTENUATION = $1207; - GL_LINEAR_ATTENUATION = $1208; - GL_QUADRATIC_ATTENUATION = $1209; - - // InterleavedArrays - // GL_V2F - // GL_V3F - // GL_C4UB_V2F - // GL_C4UB_V3F - // GL_C3F_V3F - // GL_N3F_V3F - // GL_C4F_N3F_V3F - // GL_T2F_V3F - // GL_T4F_V4F - // GL_T2F_C4UB_V3F - // GL_T2F_C3F_V3F - // GL_T2F_N3F_V3F - // GL_T2F_C4F_N3F_V3F - // GL_T4F_C4F_N3F_V4F - - // ListMode - GL_COMPILE = $1300; - GL_COMPILE_AND_EXECUTE = $1301; - - // ListNameType - // GL_BYTE - // GL_UNSIGNED_BYTE - // GL_SHORT - // GL_UNSIGNED_SHORT - // GL_INT - // GL_UNSIGNED_INT - // GL_FLOAT - // GL_2_BYTES - // GL_3_BYTES - // GL_4_BYTES - - // LogicOp - GL_CLEAR = $1500; - GL_AND = $1501; - GL_AND_REVERSE = $1502; - GL_COPY = $1503; - GL_AND_INVERTED = $1504; - GL_NOOP = $1505; - GL_XOR = $1506; - GL_OR = $1507; - GL_NOR = $1508; - GL_EQUIV = $1509; - GL_INVERT = $150A; - GL_OR_REVERSE = $150B; - GL_COPY_INVERTED = $150C; - GL_OR_INVERTED = $150D; - GL_NAND = $150E; - GL_SET = $150F; - - // MapTarget - // GL_MAP1_COLOR_4 - // GL_MAP1_INDEX - // GL_MAP1_NORMAL - // GL_MAP1_TEXTURE_COORD_1 - // GL_MAP1_TEXTURE_COORD_2 - // GL_MAP1_TEXTURE_COORD_3 - // GL_MAP1_TEXTURE_COORD_4 - // GL_MAP1_VERTEX_3 - // GL_MAP1_VERTEX_4 - // GL_MAP2_COLOR_4 - // GL_MAP2_INDEX - // GL_MAP2_NORMAL - // GL_MAP2_TEXTURE_COORD_1 - // GL_MAP2_TEXTURE_COORD_2 - // GL_MAP2_TEXTURE_COORD_3 - // GL_MAP2_TEXTURE_COORD_4 - // GL_MAP2_VERTEX_3 - // GL_MAP2_VERTEX_4 - - // MaterialFace - // GL_FRONT - // GL_BACK - // GL_FRONT_AND_BACK - - // MaterialParameter - GL_EMISSION = $1600; - GL_SHININESS = $1601; - GL_AMBIENT_AND_DIFFUSE = $1602; - GL_COLOR_INDEXES = $1603; - // GL_AMBIENT - // GL_DIFFUSE - // GL_SPECULAR - - // MatrixMode - GL_MODELVIEW = $1700; - GL_PROJECTION = $1701; - GL_TEXTURE = $1702; - - // MeshMode1 - // GL_POINT - // GL_LINE - - // MeshMode2 - // GL_POINT - // GL_LINE - // GL_FILL - - // NormalPointerType - // GL_BYTE - // GL_SHORT - // GL_INT - // GL_FLOAT - // GL_DOUBLE - - // PixelCopyType - GL_COLOR = $1800; - GL_DEPTH = $1801; - GL_STENCIL = $1802; - - // PixelFormat - GL_COLOR_INDEX = $1900; - GL_STENCIL_INDEX = $1901; - GL_DEPTH_COMPONENT = $1902; - GL_RED = $1903; - GL_GREEN = $1904; - GL_BLUE = $1905; - GL_ALPHA = $1906; - GL_RGB = $1907; - GL_RGBA = $1908; - GL_LUMINANCE = $1909; - GL_LUMINANCE_ALPHA = $190A; - - // PixelMap - // GL_PIXEL_MAP_I_TO_I - // GL_PIXEL_MAP_S_TO_S - // GL_PIXEL_MAP_I_TO_R - // GL_PIXEL_MAP_I_TO_G - // GL_PIXEL_MAP_I_TO_B - // GL_PIXEL_MAP_I_TO_A - // GL_PIXEL_MAP_R_TO_R - // GL_PIXEL_MAP_G_TO_G - // GL_PIXEL_MAP_B_TO_B - // GL_PIXEL_MAP_A_TO_A - - // PixelStore - // GL_UNPACK_SWAP_BYTES - // GL_UNPACK_LSB_FIRST - // GL_UNPACK_ROW_LENGTH - // GL_UNPACK_SKIP_ROWS - // GL_UNPACK_SKIP_PIXELS - // GL_UNPACK_ALIGNMENT - // GL_PACK_SWAP_BYTES - // GL_PACK_LSB_FIRST - // GL_PACK_ROW_LENGTH - // GL_PACK_SKIP_ROWS - // GL_PACK_SKIP_PIXELS - // GL_PACK_ALIGNMENT - - // PixelTransfer - // GL_MAP_COLOR - // GL_MAP_STENCIL - // GL_INDEX_SHIFT - // GL_INDEX_OFFSET - // GL_RED_SCALE - // GL_RED_BIAS - // GL_GREEN_SCALE - // GL_GREEN_BIAS - // GL_BLUE_SCALE - // GL_BLUE_BIAS - // GL_ALPHA_SCALE - // GL_ALPHA_BIAS - // GL_DEPTH_SCALE - // GL_DEPTH_BIAS - - // PixelType - GL_BITMAP = $1A00; - // GL_BYTE - // GL_UNSIGNED_BYTE - // GL_SHORT - // GL_UNSIGNED_SHORT - // GL_INT - // GL_UNSIGNED_INT - // GL_FLOAT - - // PolygonMode - GL_POINT = $1B00; - GL_LINE = $1B01; - GL_FILL = $1B02; - - // ReadBufferMode - // GL_FRONT_LEFT - // GL_FRONT_RIGHT - // GL_BACK_LEFT - // GL_BACK_RIGHT - // GL_FRONT - // GL_BACK - // GL_LEFT - // GL_RIGHT - // GL_AUX0 - // GL_AUX1 - // GL_AUX2 - // GL_AUX3 - - // RenderingMode - GL_RENDER = $1C00; - GL_FEEDBACK = $1C01; - GL_SELECT = $1C02; - - // ShadingModel - GL_FLAT = $1D00; - GL_SMOOTH = $1D01; - - // StencilFunction - // GL_NEVER - // GL_LESS - // GL_EQUAL - // GL_LEQUAL - // GL_GREATER - // GL_NOTEQUAL - // GL_GEQUAL - // GL_ALWAYS - - // StencilOp - // GL_ZERO - GL_KEEP = $1E00; - GL_REPLACE = $1E01; - GL_INCR = $1E02; - GL_DECR = $1E03; - // GL_INVERT - - // StringName - GL_VENDOR = $1F00; - GL_RENDERER = $1F01; - GL_VERSION = $1F02; - GL_EXTENSIONS = $1F03; - - // TextureCoordName - GL_S = $2000; - GL_T = $2001; - GL_R = $2002; - GL_Q = $2003; - - // TexCoordPointerType - // GL_SHORT - // GL_INT - // GL_FLOAT - // GL_DOUBLE - - // TextureEnvMode - GL_MODULATE = $2100; - GL_DECAL = $2101; - // GL_BLEND - // GL_REPLACE - - // TextureEnvParameter - GL_TEXTURE_ENV_MODE = $2200; - GL_TEXTURE_ENV_COLOR = $2201; - - // TextureEnvTarget - GL_TEXTURE_ENV = $2300; - - // TextureGenMode - GL_EYE_LINEAR = $2400; - GL_OBJECT_LINEAR = $2401; - GL_SPHERE_MAP = $2402; - - // TextureGenParameter - GL_TEXTURE_GEN_MODE = $2500; - GL_OBJECT_PLANE = $2501; - GL_EYE_PLANE = $2502; - - // TextureMagFilter - GL_NEAREST = $2600; - GL_LINEAR = $2601; - - // TextureMinFilter - // GL_NEAREST - // GL_LINEAR - GL_NEAREST_MIPMAP_NEAREST = $2700; - GL_LINEAR_MIPMAP_NEAREST = $2701; - GL_NEAREST_MIPMAP_LINEAR = $2702; - GL_LINEAR_MIPMAP_LINEAR = $2703; - - // TextureParameterName - GL_TEXTURE_MAG_FILTER = $2800; - GL_TEXTURE_MIN_FILTER = $2801; - GL_TEXTURE_WRAP_S = $2802; - GL_TEXTURE_WRAP_T = $2803; - // GL_TEXTURE_BORDER_COLOR - // GL_TEXTURE_PRIORITY - - // TextureTarget - // GL_TEXTURE_1D - // GL_TEXTURE_2D - // GL_PROXY_TEXTURE_1D - // GL_PROXY_TEXTURE_2D - - // TextureWrapMode - GL_CLAMP = $2900; - GL_REPEAT = $2901; - - // VertexPointerType - // GL_SHORT - // GL_INT - // GL_FLOAT - // GL_DOUBLE - - // ClientAttribMask - GL_CLIENT_PIXEL_STORE_BIT = $00000001; - GL_CLIENT_VERTEX_ARRAY_BIT = $00000002; - GL_CLIENT_ALL_ATTRIB_BITS = $FFFFFFFF; - - // polygon_offset - GL_POLYGON_OFFSET_FACTOR = $8038; - GL_POLYGON_OFFSET_UNITS = $2A00; - GL_POLYGON_OFFSET_POINT = $2A01; - GL_POLYGON_OFFSET_LINE = $2A02; - GL_POLYGON_OFFSET_FILL = $8037; - - // texture - GL_ALPHA4 = $803B; - GL_ALPHA8 = $803C; - GL_ALPHA12 = $803D; - GL_ALPHA16 = $803E; - GL_LUMINANCE4 = $803F; - GL_LUMINANCE8 = $8040; - GL_LUMINANCE12 = $8041; - GL_LUMINANCE16 = $8042; - GL_LUMINANCE4_ALPHA4 = $8043; - GL_LUMINANCE6_ALPHA2 = $8044; - GL_LUMINANCE8_ALPHA8 = $8045; - GL_LUMINANCE12_ALPHA4 = $8046; - GL_LUMINANCE12_ALPHA12 = $8047; - GL_LUMINANCE16_ALPHA16 = $8048; - GL_INTENSITY = $8049; - GL_INTENSITY4 = $804A; - GL_INTENSITY8 = $804B; - GL_INTENSITY12 = $804C; - GL_INTENSITY16 = $804D; - GL_R3_G3_B2 = $2A10; - GL_RGB4 = $804F; - GL_RGB5 = $8050; - GL_RGB8 = $8051; - GL_RGB10 = $8052; - GL_RGB12 = $8053; - GL_RGB16 = $8054; - GL_RGBA2 = $8055; - GL_RGBA4 = $8056; - GL_RGB5_A1 = $8057; - GL_RGBA8 = $8058; - GL_RGB10_A2 = $8059; - GL_RGBA12 = $805A; - GL_RGBA16 = $805B; - GL_TEXTURE_RED_SIZE = $805C; - GL_TEXTURE_GREEN_SIZE = $805D; - GL_TEXTURE_BLUE_SIZE = $805E; - GL_TEXTURE_ALPHA_SIZE = $805F; - GL_TEXTURE_LUMINANCE_SIZE = $8060; - GL_TEXTURE_INTENSITY_SIZE = $8061; - GL_PROXY_TEXTURE_1D = $8063; - GL_PROXY_TEXTURE_2D = $8064; - - // texture_object - GL_TEXTURE_PRIORITY = $8066; - GL_TEXTURE_RESIDENT = $8067; - GL_TEXTURE_BINDING_1D = $8068; - GL_TEXTURE_BINDING_2D = $8069; - - // vertex_array - GL_VERTEX_ARRAY = $8074; - GL_NORMAL_ARRAY = $8075; - GL_COLOR_ARRAY = $8076; - GL_INDEX_ARRAY = $8077; - GL_TEXTURE_COORD_ARRAY = $8078; - GL_EDGE_FLAG_ARRAY = $8079; - GL_VERTEX_ARRAY_SIZE = $807A; - GL_VERTEX_ARRAY_TYPE = $807B; - GL_VERTEX_ARRAY_STRIDE = $807C; - GL_NORMAL_ARRAY_TYPE = $807E; - GL_NORMAL_ARRAY_STRIDE = $807F; - GL_COLOR_ARRAY_SIZE = $8081; - GL_COLOR_ARRAY_TYPE = $8082; - GL_COLOR_ARRAY_STRIDE = $8083; - GL_INDEX_ARRAY_TYPE = $8085; - GL_INDEX_ARRAY_STRIDE = $8086; - GL_TEXTURE_COORD_ARRAY_SIZE = $8088; - GL_TEXTURE_COORD_ARRAY_TYPE = $8089; - GL_TEXTURE_COORD_ARRAY_STRIDE = $808A; - GL_EDGE_FLAG_ARRAY_STRIDE = $808C; - GL_VERTEX_ARRAY_POINTER = $808E; - GL_NORMAL_ARRAY_POINTER = $808F; - GL_COLOR_ARRAY_POINTER = $8090; - GL_INDEX_ARRAY_POINTER = $8091; - GL_TEXTURE_COORD_ARRAY_POINTER = $8092; - GL_EDGE_FLAG_ARRAY_POINTER = $8093; - GL_V2F = $2A20; - GL_V3F = $2A21; - GL_C4UB_V2F = $2A22; - GL_C4UB_V3F = $2A23; - GL_C3F_V3F = $2A24; - GL_N3F_V3F = $2A25; - GL_C4F_N3F_V3F = $2A26; - GL_T2F_V3F = $2A27; - GL_T4F_V4F = $2A28; - GL_T2F_C4UB_V3F = $2A29; - GL_T2F_C3F_V3F = $2A2A; - GL_T2F_N3F_V3F = $2A2B; - GL_T2F_C4F_N3F_V3F = $2A2C; - GL_T4F_C4F_N3F_V4F = $2A2D; - - // Extensions - GL_EXT_vertex_array = 1; - GL_WIN_swap_hint = 1; - GL_EXT_bgra = 1; - GL_EXT_paletted_texture = 1; - - // EXT_vertex_array - GL_VERTEX_ARRAY_EXT = $8074; - GL_NORMAL_ARRAY_EXT = $8075; - GL_COLOR_ARRAY_EXT = $8076; - GL_INDEX_ARRAY_EXT = $8077; - GL_TEXTURE_COORD_ARRAY_EXT = $8078; - GL_EDGE_FLAG_ARRAY_EXT = $8079; - GL_VERTEX_ARRAY_SIZE_EXT = $807A; - GL_VERTEX_ARRAY_TYPE_EXT = $807B; - GL_VERTEX_ARRAY_STRIDE_EXT = $807C; - GL_VERTEX_ARRAY_COUNT_EXT = $807D; - GL_NORMAL_ARRAY_TYPE_EXT = $807E; - GL_NORMAL_ARRAY_STRIDE_EXT = $807F; - GL_NORMAL_ARRAY_COUNT_EXT = $8080; - GL_COLOR_ARRAY_SIZE_EXT = $8081; - GL_COLOR_ARRAY_TYPE_EXT = $8082; - GL_COLOR_ARRAY_STRIDE_EXT = $8083; - GL_COLOR_ARRAY_COUNT_EXT = $8084; - GL_INDEX_ARRAY_TYPE_EXT = $8085; - GL_INDEX_ARRAY_STRIDE_EXT = $8086; - GL_INDEX_ARRAY_COUNT_EXT = $8087; - GL_TEXTURE_COORD_ARRAY_SIZE_EXT = $8088; - GL_TEXTURE_COORD_ARRAY_TYPE_EXT = $8089; - GL_TEXTURE_COORD_ARRAY_STRIDE_EXT = $808A; - GL_TEXTURE_COORD_ARRAY_COUNT_EXT = $808B; - GL_EDGE_FLAG_ARRAY_STRIDE_EXT = $808C; - GL_EDGE_FLAG_ARRAY_COUNT_EXT = $808D; - GL_VERTEX_ARRAY_POINTER_EXT = $808E; - GL_NORMAL_ARRAY_POINTER_EXT = $808F; - GL_COLOR_ARRAY_POINTER_EXT = $8090; - GL_INDEX_ARRAY_POINTER_EXT = $8091; - GL_TEXTURE_COORD_ARRAY_POINTER_EXT = $8092; - GL_EDGE_FLAG_ARRAY_POINTER_EXT = $8093; - GL_DOUBLE_EXT = GL_DOUBLE; - - // EXT_bgra - GL_BGR_EXT = $80E0; - GL_BGRA_EXT = $80E1; - - // EXT_paletted_texture - - // These must match the GL_COLOR_TABLE_*_SGI enumerants - GL_COLOR_TABLE_FORMAT_EXT = $80D8; - GL_COLOR_TABLE_WIDTH_EXT = $80D9; - GL_COLOR_TABLE_RED_SIZE_EXT = $80DA; - GL_COLOR_TABLE_GREEN_SIZE_EXT = $80DB; - GL_COLOR_TABLE_BLUE_SIZE_EXT = $80DC; - GL_COLOR_TABLE_ALPHA_SIZE_EXT = $80DD; - GL_COLOR_TABLE_LUMINANCE_SIZE_EXT = $80DE; - GL_COLOR_TABLE_INTENSITY_SIZE_EXT = $80DF; - - GL_COLOR_INDEX1_EXT = $80E2; - GL_COLOR_INDEX2_EXT = $80E3; - GL_COLOR_INDEX4_EXT = $80E4; - GL_COLOR_INDEX8_EXT = $80E5; - GL_COLOR_INDEX12_EXT = $80E6; - GL_COLOR_INDEX16_EXT = $80E7; - - // For compatibility with OpenGL v1.0 - GL_LOGIC_OP = GL_INDEX_LOGIC_OP; - GL_TEXTURE_COMPONENTS = GL_TEXTURE_INTERNAL_FORMAT; - -{******************************************************************************} - -var - glAccum: procedure(op: GLenum; value: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAlphaFunc: procedure(func: GLenum; ref: GLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAreTexturesResident: function (n: GLsizei; const textures: PGLuint; residences: PGLboolean): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glArrayElement: procedure(i: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBegin: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindTexture: procedure(target: GLenum; texture: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBitmap: procedure (width, height: GLsizei; xorig, yorig: GLfloat; xmove, ymove: GLfloat; const bitmap: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBlendFunc: procedure(sfactor, dfactor: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCallList: procedure(list: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCallLists: procedure(n: GLsizei; atype: GLenum; const lists: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClear: procedure(mask: GLbitfield); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClearAccum: procedure(red, green, blue, alpha: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClearColor: procedure(red, green, blue, alpha: GLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClearDepth: procedure(depth: GLclampd); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClearIndex: procedure(c: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClearStencil: procedure(s: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClipPlane: procedure(plane: GLenum; const equation: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3b: procedure(red, green, blue: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3bv: procedure(const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3d: procedure(red, green, blue: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3f: procedure(red, green, blue: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3i: procedure(red, green, blue: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3s: procedure(red, green, blue: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3ub: procedure(red, green, blue: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3ubv: procedure(const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3ui: procedure(red, green, blue: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3uiv: procedure(const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3us: procedure(red, green, blue: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3usv: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4b: procedure(red, green, blue, alpha: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4bv: procedure(const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4d: procedure(red, green, blue, alpha: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4f: procedure(red, green, blue, alpha: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4i: procedure(red, green, blue, alpha: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4s: procedure(red, green, blue, alpha: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4ub: procedure(red, green, blue, alpha: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4ubv: procedure(const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4ui: procedure(red, green, blue, alpha: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4uiv: procedure(const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4us: procedure(red, green, blue, alpha: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4usv: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorMask: procedure(red, green, blue, alpha: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorMaterial: procedure(face, mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorPointer: procedure(size: GLint; atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyPixels: procedure(x, y: GLint; width, height: GLsizei; atype: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyTexImage1D: procedure (target: GLenum; level: GLint; internalFormat: GLenum; x, y: GLint; width: GLsizei; border: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyTexImage2D: procedure(target: GLenum; level: GLint; internalFormat: GLenum; x, y: GLint; width, height: GLsizei; border: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyTexSubImage1D: procedure(target: GLenum; level, xoffset, x, y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyTexSubImage2D: procedure(target: GLenum; level, xoffset, yoffset, x, y: GLint; width, height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCullFace: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteLists: procedure(list: GLuint; range: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteTextures: procedure(n: GLsizei; const textures: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDepthFunc: procedure(func: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDepthMask: procedure(flag: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDepthRange: procedure(zNear, zFar: GLclampd); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDisable: procedure(cap: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDisableClientState: procedure(aarray: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawArrays: procedure(mode: GLenum; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawBuffer: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawElements: procedure(mode: GLenum; count: GLsizei; atype: GLenum; const indices: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawPixels: procedure(width, height: GLsizei; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEdgeFlag: procedure(flag: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEdgeFlagPointer: procedure(stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEdgeFlagv: procedure(const flag: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEnable: procedure(cap: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEnableClientState: procedure(aarray: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEnd: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEndList: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord1d: procedure(u: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord1dv: procedure(const u: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord1f: procedure(u: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord1fv: procedure(const u: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord2d: procedure(u, v: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord2dv: procedure(const u: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord2f: procedure(u, v: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalCoord2fv: procedure(const u: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalMesh1: procedure(mode: GLenum; i1, i2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalMesh2: procedure(mode: GLenum; i1, i2, j1, j2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalPoint1: procedure(i: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalPoint2: procedure(i, j: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFeedbackBuffer: procedure(size: GLsizei; atype: GLenum; buffer: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFinish: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFlush: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogfv: procedure(pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogi: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogiv: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFrontFace: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFrustum: procedure(left, right, bottom, top, zNear, zFar: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenLists: function(range: GLsizei): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenTextures: procedure(n: GLsizei; textures: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBooleanv: procedure(pname: GLenum; params: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetClipPlane: procedure(plane: GLenum; equation: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetDoublev: procedure(pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetError: function: GLenum; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetFloatv: procedure(pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetIntegerv: procedure(pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetLightfv: procedure(light, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetLightiv: procedure(light, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapdv: procedure(target, query: GLenum; v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapfv: procedure(target, query: GLenum; v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapiv: procedure(target, query: GLenum; v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMaterialfv: procedure(face, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMaterialiv: procedure(face, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPixelMapfv: procedure(map: GLenum; values: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPixelMapuiv: procedure(map: GLenum; values: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPixelMapusv: procedure(map: GLenum; values: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPointerv: procedure(pname: GLenum; params: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPolygonStipple: procedure(mask: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetString: function(name: GLenum): PChar; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexEnvfv: procedure(target, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexEnviv: procedure(target, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexGendv: procedure(coord, pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexGenfv: procedure(coord, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexGeniv: procedure(coord, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexImage: procedure(target: GLenum; level: GLint; format: GLenum; atype: GLenum; pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexLevelParameterfv: procedure(target: GLenum; level: GLint; pname: GLenum; params: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexLevelParameteriv: procedure(target: GLenum; level: GLint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexParameterfv: procedure(target, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexParameteriv: procedure(target, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glHint: procedure(target, mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexMask: procedure(mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexPointer: procedure(atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexd: procedure(c: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexdv: procedure(const c: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexf: procedure(c: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexfv: procedure(const c: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexi: procedure(c: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexiv: procedure(const c: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexs: procedure(c: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexsv: procedure(const c: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexub: procedure(c: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexubv: procedure(const c: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glInitNames: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glInterleavedArrays: procedure(format: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsEnabled: function(cap: GLenum): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsList: function(list: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsTexture: function(texture: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightModelf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightModelfv: procedure(pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightModeli: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightModeliv: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightf: procedure(light, pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightfv: procedure(light, pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLighti: procedure(light, pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLightiv: procedure(light, pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLineStipple: procedure(factor: GLint; pattern: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLineWidth: procedure(width: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glListBase: procedure(base: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadIdentity: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadMatrixd: procedure(const m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadMatrixf: procedure(const m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadName: procedure(name: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLogicOp: procedure(opcode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMap1d: procedure(target: GLenum; u1, u2: GLdouble; stride, order: GLint; const points: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMap1f: procedure(target: GLenum; u1, u2: GLfloat; stride, order: GLint; const points: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMap2d: procedure(target: GLenum; u1, u2: GLdouble; ustride, uorder: GLint; v1, v2: GLdouble; vstride, vorder: GLint; const points: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMap2f: procedure(target: GLenum; u1, u2: GLfloat; ustride, uorder: GLint; v1, v2: GLfloat; vstride, vorder: GLint; const points: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapGrid1d: procedure(un: GLint; u1, u2: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapGrid1f: procedure(un: GLint; u1, u2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapGrid2d: procedure(un: GLint; u1, u2: GLdouble; vn: GLint; v1, v2: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapGrid2f: procedure(un: GLint; u1, u2: GLfloat; vn: GLint; v1, v2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMaterialf: procedure(face, pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMaterialfv: procedure(face, pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMateriali: procedure(face, pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMaterialiv: procedure(face, pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMatrixMode: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultMatrixd: procedure(const m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultMatrixf: procedure(const m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNewList: procedure(list: GLuint; mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3b: procedure(nx, ny, nz: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3bv: procedure(const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3d: procedure(nx, ny, nz: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3f: procedure(nx, ny, nz: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3i: procedure(nx, ny, nz: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3s: procedure(nx, ny, nz: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalPointer: procedure(atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glOrtho: procedure(left, right, bottom, top, zNear, zFar: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPassThrough: procedure(token: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelMapfv: procedure(map: GLenum; mapsize: GLsizei; const values: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelMapuiv: procedure(map: GLenum; mapsize: GLsizei; const values: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelMapusv: procedure(map: GLenum; mapsize: GLsizei; const values: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelStoref: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelStorei: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelTransferf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelTransferi: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelZoom: procedure(xfactor, yfactor: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointSize: procedure(size: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPolygonMode: procedure(face, mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPolygonOffset: procedure(factor, units: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPolygonStipple: procedure(const mask: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPopAttrib: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPopClientAttrib: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPopMatrix: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPopName: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPrioritizeTextures: procedure(n: GLsizei; const textures: PGLuint; const priorities: PGLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPushAttrib: procedure(mask: GLbitfield); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPushClientAttrib: procedure(mask: GLbitfield); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPushMatrix: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPushName: procedure(name: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2d: procedure(x, y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2f: procedure(x, y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2i: procedure(x, y: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2s: procedure(x, y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos2sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3d: procedure(x, y, z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3f: procedure(x, y, z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3i: procedure(x, y, z: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3s: procedure(x, y, z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4d: procedure(x, y, z, w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4f: procedure(x, y, z, w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4i: procedure(x, y, z, w: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4s: procedure(x, y, z, w: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRasterPos4sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReadBuffer: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReadPixels: procedure(x, y: GLint; width, height: GLsizei; format, atype: GLenum; pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRectd: procedure(x1, y1, x2, y2: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRectdv: procedure(const v1: PGLdouble; const v2: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRectf: procedure(x1, y1, x2, y2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRectfv: procedure(const v1: PGLfloat; const v2: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRecti: procedure(x1, y1, x2, y2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRectiv: procedure(const v1: PGLint; const v2: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRects: procedure(x1, y1, x2, y2: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRectsv: procedure(const v1: PGLshort; const v2: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRenderMode: function(mode: GLint): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRotated: procedure(angle, x, y, z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRotatef: procedure(angle, x, y, z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glScaled: procedure(x, y, z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glScalef: procedure(x, y, z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glScissor: procedure(x, y: GLint; width, height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSelectBuffer: procedure(size: GLsizei; buffer: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glShadeModel: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilFunc: procedure(func: GLenum; ref: GLint; mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilMask: procedure(mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilOp: procedure(fail, zfail, zpass: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1d: procedure(s: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1f: procedure(s: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1i: procedure(s: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1s: procedure(s: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2d: procedure(s, t: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2f: procedure(s, t: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2i: procedure(s, t: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2s: procedure(s, t: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3d: procedure(s, t, r: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3f: procedure(s, t, r: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3i: procedure(s, t, r: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3s: procedure(s, t, r: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4d: procedure(s, t, r, q: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4f: procedure(s, t, r, q: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4i: procedure(s, t, r, q: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4s: procedure(s, t, r, q: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoordPointer: procedure(size: GLint; atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexEnvf: procedure(target: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexEnvfv: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexEnvi: procedure(target: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexEnviv: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexGend: procedure(coord: GLenum; pname: GLenum; param: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexGendv: procedure(coord: GLenum; pname: GLenum; const params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexGenf: procedure(coord: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexGenfv: procedure(coord: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexGeni: procedure(coord: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexGeniv: procedure(coord: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexImage1D: procedure(target: GLenum; level, internalformat: GLint; width: GLsizei; border: GLint; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexImage2D: procedure(target: GLenum; level, internalformat: GLint; width, height: GLsizei; border: GLint; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexParameterf: procedure(target: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexParameterfv: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexParameteri: procedure(target: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexParameteriv: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexSubImage1D: procedure(target: GLenum; level, xoffset: GLint; width: GLsizei; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexSubImage2D: procedure(target: GLenum; level, xoffset, yoffset: GLint; width, height: GLsizei; format, atype: GLenum; const pixels: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTranslated: procedure(x, y, z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTranslatef: procedure(x, y, z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2d: procedure(x, y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2f: procedure(x, y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2i: procedure(x, y: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2s: procedure(x, y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3d: procedure(x, y, z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3f: procedure(x, y, z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3i: procedure(x, y, z: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3s: procedure(x, y, z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4d: procedure(x, y, z, w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4f: procedure(x, y, z, w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4i: procedure(x, y, z, w: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4s: procedure(x, y, z, w: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexPointer: procedure(size: GLint; atype: GLenum; stride: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glViewport: procedure(x, y: GLint; width, height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - {$IFDEF WINDOWS} - ChoosePixelFormat: function(DC: HDC; p2: PPixelFormatDescriptor): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - {$ENDIF} - -type - // EXT_vertex_array - PFNGLARRAYELEMENTEXTPROC = procedure(i: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLDRAWARRAYSEXTPROC = procedure(mode: GLenum; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLVERTEXPOINTEREXTPROC = procedure(size: GLint; atype: GLenum; - stride, count: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLNORMALPOINTEREXTPROC = procedure(atype: GLenum; stride, count: GLsizei; - const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLCOLORPOINTEREXTPROC = procedure(size: GLint; atype: GLenum; stride, count: GLsizei; - const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLINDEXPOINTEREXTPROC = procedure(atype: GLenum; stride, count: GLsizei; - const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLTEXCOORDPOINTEREXTPROC = procedure(size: GLint; atype: GLenum; - stride, count: GLsizei; const pointer: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLEDGEFLAGPOINTEREXTPROC = procedure(stride, count: GLsizei; - const pointer: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLGETPOINTERVEXTPROC = procedure(pname: GLenum; params: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLARRAYELEMENTARRAYEXTPROC = procedure(mode: GLenum; count: GLsizei; - const pi: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - - // WIN_swap_hint - PFNGLADDSWAPHINTRECTWINPROC = procedure(x, y: GLint; width, height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - - // EXT_paletted_texture - PFNGLCOLORTABLEEXTPROC = procedure(target, internalFormat: GLenum; width: GLsizei; - format, atype: GLenum; const data: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLCOLORSUBTABLEEXTPROC = procedure(target: GLenum; start, count: GLsizei; - format, atype: GLenum; const data: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLGETCOLORTABLEEXTPROC = procedure(target, format, atype: GLenum; data: Pointer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLGETCOLORTABLEPARAMETERIVEXTPROC = procedure(target, pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - PFNGLGETCOLORTABLEPARAMETERFVEXTPROC = procedure(target, pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -procedure LoadOpenGL( const dll: PChar ); -procedure FreeOpenGL; - -implementation - -procedure FreeOpenGL; -begin - - @glAccum := nil; - @glAlphaFunc := nil; - @glAreTexturesResident := nil; - @glArrayElement := nil; - @glBegin := nil; - @glBindTexture := nil; - @glBitmap := nil; - @glBlendFunc := nil; - @glCallList := nil; - @glCallLists := nil; - @glClear := nil; - @glClearAccum := nil; - @glClearColor := nil; - @glClearDepth := nil; - @glClearIndex := nil; - @glClearStencil := nil; - @glClipPlane := nil; - @glColor3b := nil; - @glColor3bv := nil; - @glColor3d := nil; - @glColor3dv := nil; - @glColor3f := nil; - @glColor3fv := nil; - @glColor3i := nil; - @glColor3iv := nil; - @glColor3s := nil; - @glColor3sv := nil; - @glColor3ub := nil; - @glColor3ubv := nil; - @glColor3ui := nil; - @glColor3uiv := nil; - @glColor3us := nil; - @glColor3usv := nil; - @glColor4b := nil; - @glColor4bv := nil; - @glColor4d := nil; - @glColor4dv := nil; - @glColor4f := nil; - @glColor4fv := nil; - @glColor4i := nil; - @glColor4iv := nil; - @glColor4s := nil; - @glColor4sv := nil; - @glColor4ub := nil; - @glColor4ubv := nil; - @glColor4ui := nil; - @glColor4uiv := nil; - @glColor4us := nil; - @glColor4usv := nil; - @glColorMask := nil; - @glColorMaterial := nil; - @glColorPointer := nil; - @glCopyPixels := nil; - @glCopyTexImage1D := nil; - @glCopyTexImage2D := nil; - @glCopyTexSubImage1D := nil; - @glCopyTexSubImage2D := nil; - @glCullFace := nil; - @glDeleteLists := nil; - @glDeleteTextures := nil; - @glDepthFunc := nil; - @glDepthMask := nil; - @glDepthRange := nil; - @glDisable := nil; - @glDisableClientState := nil; - @glDrawArrays := nil; - @glDrawBuffer := nil; - @glDrawElements := nil; - @glDrawPixels := nil; - @glEdgeFlag := nil; - @glEdgeFlagPointer := nil; - @glEdgeFlagv := nil; - @glEnable := nil; - @glEnableClientState := nil; - @glEnd := nil; - @glEndList := nil; - @glEvalCoord1d := nil; - @glEvalCoord1dv := nil; - @glEvalCoord1f := nil; - @glEvalCoord1fv := nil; - @glEvalCoord2d := nil; - @glEvalCoord2dv := nil; - @glEvalCoord2f := nil; - @glEvalCoord2fv := nil; - @glEvalMesh1 := nil; - @glEvalMesh2 := nil; - @glEvalPoint1 := nil; - @glEvalPoint2 := nil; - @glFeedbackBuffer := nil; - @glFinish := nil; - @glFlush := nil; - @glFogf := nil; - @glFogfv := nil; - @glFogi := nil; - @glFogiv := nil; - @glFrontFace := nil; - @glFrustum := nil; - @glGenLists := nil; - @glGenTextures := nil; - @glGetBooleanv := nil; - @glGetClipPlane := nil; - @glGetDoublev := nil; - @glGetError := nil; - @glGetFloatv := nil; - @glGetIntegerv := nil; - @glGetLightfv := nil; - @glGetLightiv := nil; - @glGetMapdv := nil; - @glGetMapfv := nil; - @glGetMapiv := nil; - @glGetMaterialfv := nil; - @glGetMaterialiv := nil; - @glGetPixelMapfv := nil; - @glGetPixelMapuiv := nil; - @glGetPixelMapusv := nil; - @glGetPointerv := nil; - @glGetPolygonStipple := nil; - @glGetString := nil; - @glGetTexEnvfv := nil; - @glGetTexEnviv := nil; - @glGetTexGendv := nil; - @glGetTexGenfv := nil; - @glGetTexGeniv := nil; - @glGetTexImage := nil; - @glGetTexLevelParameterfv := nil; - @glGetTexLevelParameteriv := nil; - @glGetTexParameterfv := nil; - @glGetTexParameteriv := nil; - @glHint := nil; - @glIndexMask := nil; - @glIndexPointer := nil; - @glIndexd := nil; - @glIndexdv := nil; - @glIndexf := nil; - @glIndexfv := nil; - @glIndexi := nil; - @glIndexiv := nil; - @glIndexs := nil; - @glIndexsv := nil; - @glIndexub := nil; - @glIndexubv := nil; - @glInitNames := nil; - @glInterleavedArrays := nil; - @glIsEnabled := nil; - @glIsList := nil; - @glIsTexture := nil; - @glLightModelf := nil; - @glLightModelfv := nil; - @glLightModeli := nil; - @glLightModeliv := nil; - @glLightf := nil; - @glLightfv := nil; - @glLighti := nil; - @glLightiv := nil; - @glLineStipple := nil; - @glLineWidth := nil; - @glListBase := nil; - @glLoadIdentity := nil; - @glLoadMatrixd := nil; - @glLoadMatrixf := nil; - @glLoadName := nil; - @glLogicOp := nil; - @glMap1d := nil; - @glMap1f := nil; - @glMap2d := nil; - @glMap2f := nil; - @glMapGrid1d := nil; - @glMapGrid1f := nil; - @glMapGrid2d := nil; - @glMapGrid2f := nil; - @glMaterialf := nil; - @glMaterialfv := nil; - @glMateriali := nil; - @glMaterialiv := nil; - @glMatrixMode := nil; - @glMultMatrixd := nil; - @glMultMatrixf := nil; - @glNewList := nil; - @glNormal3b := nil; - @glNormal3bv := nil; - @glNormal3d := nil; - @glNormal3dv := nil; - @glNormal3f := nil; - @glNormal3fv := nil; - @glNormal3i := nil; - @glNormal3iv := nil; - @glNormal3s := nil; - @glNormal3sv := nil; - @glNormalPointer := nil; - @glOrtho := nil; - @glPassThrough := nil; - @glPixelMapfv := nil; - @glPixelMapuiv := nil; - @glPixelMapusv := nil; - @glPixelStoref := nil; - @glPixelStorei := nil; - @glPixelTransferf := nil; - @glPixelTransferi := nil; - @glPixelZoom := nil; - @glPointSize := nil; - @glPolygonMode := nil; - @glPolygonOffset := nil; - @glPolygonStipple := nil; - @glPopAttrib := nil; - @glPopClientAttrib := nil; - @glPopMatrix := nil; - @glPopName := nil; - @glPrioritizeTextures := nil; - @glPushAttrib := nil; - @glPushClientAttrib := nil; - @glPushMatrix := nil; - @glPushName := nil; - @glRasterPos2d := nil; - @glRasterPos2dv := nil; - @glRasterPos2f := nil; - @glRasterPos2fv := nil; - @glRasterPos2i := nil; - @glRasterPos2iv := nil; - @glRasterPos2s := nil; - @glRasterPos2sv := nil; - @glRasterPos3d := nil; - @glRasterPos3dv := nil; - @glRasterPos3f := nil; - @glRasterPos3fv := nil; - @glRasterPos3i := nil; - @glRasterPos3iv := nil; - @glRasterPos3s := nil; - @glRasterPos3sv := nil; - @glRasterPos4d := nil; - @glRasterPos4dv := nil; - @glRasterPos4f := nil; - @glRasterPos4fv := nil; - @glRasterPos4i := nil; - @glRasterPos4iv := nil; - @glRasterPos4s := nil; - @glRasterPos4sv := nil; - @glReadBuffer := nil; - @glReadPixels := nil; - @glRectd := nil; - @glRectdv := nil; - @glRectf := nil; - @glRectfv := nil; - @glRecti := nil; - @glRectiv := nil; - @glRects := nil; - @glRectsv := nil; - @glRenderMode := nil; - @glRotated := nil; - @glRotatef := nil; - @glScaled := nil; - @glScalef := nil; - @glScissor := nil; - @glSelectBuffer := nil; - @glShadeModel := nil; - @glStencilFunc := nil; - @glStencilMask := nil; - @glStencilOp := nil; - @glTexCoord1d := nil; - @glTexCoord1dv := nil; - @glTexCoord1f := nil; - @glTexCoord1fv := nil; - @glTexCoord1i := nil; - @glTexCoord1iv := nil; - @glTexCoord1s := nil; - @glTexCoord1sv := nil; - @glTexCoord2d := nil; - @glTexCoord2dv := nil; - @glTexCoord2f := nil; - @glTexCoord2fv := nil; - @glTexCoord2i := nil; - @glTexCoord2iv := nil; - @glTexCoord2s := nil; - @glTexCoord2sv := nil; - @glTexCoord3d := nil; - @glTexCoord3dv := nil; - @glTexCoord3f := nil; - @glTexCoord3fv := nil; - @glTexCoord3i := nil; - @glTexCoord3iv := nil; - @glTexCoord3s := nil; - @glTexCoord3sv := nil; - @glTexCoord4d := nil; - @glTexCoord4dv := nil; - @glTexCoord4f := nil; - @glTexCoord4fv := nil; - @glTexCoord4i := nil; - @glTexCoord4iv := nil; - @glTexCoord4s := nil; - @glTexCoord4sv := nil; - @glTexCoordPointer := nil; - @glTexEnvf := nil; - @glTexEnvfv := nil; - @glTexEnvi := nil; - @glTexEnviv := nil; - @glTexGend := nil; - @glTexGendv := nil; - @glTexGenf := nil; - @glTexGenfv := nil; - @glTexGeni := nil; - @glTexGeniv := nil; - @glTexImage1D := nil; - @glTexImage2D := nil; - @glTexParameterf := nil; - @glTexParameterfv := nil; - @glTexParameteri := nil; - @glTexParameteriv := nil; - @glTexSubImage1D := nil; - @glTexSubImage2D := nil; - @glTranslated := nil; - @glTranslatef := nil; - @glVertex2d := nil; - @glVertex2dv := nil; - @glVertex2f := nil; - @glVertex2fv := nil; - @glVertex2i := nil; - @glVertex2iv := nil; - @glVertex2s := nil; - @glVertex2sv := nil; - @glVertex3d := nil; - @glVertex3dv := nil; - @glVertex3f := nil; - @glVertex3fv := nil; - @glVertex3i := nil; - @glVertex3iv := nil; - @glVertex3s := nil; - @glVertex3sv := nil; - @glVertex4d := nil; - @glVertex4dv := nil; - @glVertex4f := nil; - @glVertex4fv := nil; - @glVertex4i := nil; - @glVertex4iv := nil; - @glVertex4s := nil; - @glVertex4sv := nil; - @glVertexPointer := nil; - @glViewport := nil; - {$IFDEF WINDOWS} - @ChoosePixelFormat := nil; - {$ENDIF} - - UnLoadModule(LibGL); - -end; - -procedure LoadOpenGL(const dll: PChar); -begin - - FreeOpenGL; - - if LoadModule( LibGL, dll ) then - begin - @glAccum := GetModuleSymbol(LibGL, 'glAccum'); - @glAlphaFunc := GetModuleSymbol(LibGL, 'glAlphaFunc'); - @glAreTexturesResident := GetModuleSymbol(LibGL, 'glAreTexturesResident'); - @glArrayElement := GetModuleSymbol(LibGL, 'glArrayElement'); - @glBegin := GetModuleSymbol(LibGL, 'glBegin'); - @glBindTexture := GetModuleSymbol(LibGL, 'glBindTexture'); - @glBitmap := GetModuleSymbol(LibGL, 'glBitmap'); - @glBlendFunc := GetModuleSymbol(LibGL, 'glBlendFunc'); - @glCallList := GetModuleSymbol(LibGL, 'glCallList'); - @glCallLists := GetModuleSymbol(LibGL, 'glCallLists'); - @glClear := GetModuleSymbol(LibGL, 'glClear'); - @glClearAccum := GetModuleSymbol(LibGL, 'glClearAccum'); - @glClearColor := GetModuleSymbol(LibGL, 'glClearColor'); - @glClearDepth := GetModuleSymbol(LibGL, 'glClearDepth'); - @glClearIndex := GetModuleSymbol(LibGL, 'glClearIndex'); - @glClearStencil := GetModuleSymbol(LibGL, 'glClearStencil'); - @glClipPlane := GetModuleSymbol(LibGL, 'glClipPlane'); - @glColor3b := GetModuleSymbol(LibGL, 'glColor3b'); - @glColor3bv := GetModuleSymbol(LibGL, 'glColor3bv'); - @glColor3d := GetModuleSymbol(LibGL, 'glColor3d'); - @glColor3dv := GetModuleSymbol(LibGL, 'glColor3dv'); - @glColor3f := GetModuleSymbol(LibGL, 'glColor3f'); - @glColor3fv := GetModuleSymbol(LibGL, 'glColor3fv'); - @glColor3i := GetModuleSymbol(LibGL, 'glColor3i'); - @glColor3iv := GetModuleSymbol(LibGL, 'glColor3iv'); - @glColor3s := GetModuleSymbol(LibGL, 'glColor3s'); - @glColor3sv := GetModuleSymbol(LibGL, 'glColor3sv'); - @glColor3ub := GetModuleSymbol(LibGL, 'glColor3ub'); - @glColor3ubv := GetModuleSymbol(LibGL, 'glColor3ubv'); - @glColor3ui := GetModuleSymbol(LibGL, 'glColor3ui'); - @glColor3uiv := GetModuleSymbol(LibGL, 'glColor3uiv'); - @glColor3us := GetModuleSymbol(LibGL, 'glColor3us'); - @glColor3usv := GetModuleSymbol(LibGL, 'glColor3usv'); - @glColor4b := GetModuleSymbol(LibGL, 'glColor4b'); - @glColor4bv := GetModuleSymbol(LibGL, 'glColor4bv'); - @glColor4d := GetModuleSymbol(LibGL, 'glColor4d'); - @glColor4dv := GetModuleSymbol(LibGL, 'glColor4dv'); - @glColor4f := GetModuleSymbol(LibGL, 'glColor4f'); - @glColor4fv := GetModuleSymbol(LibGL, 'glColor4fv'); - @glColor4i := GetModuleSymbol(LibGL, 'glColor4i'); - @glColor4iv := GetModuleSymbol(LibGL, 'glColor4iv'); - @glColor4s := GetModuleSymbol(LibGL, 'glColor4s'); - @glColor4sv := GetModuleSymbol(LibGL, 'glColor4sv'); - @glColor4ub := GetModuleSymbol(LibGL, 'glColor4ub'); - @glColor4ubv := GetModuleSymbol(LibGL, 'glColor4ubv'); - @glColor4ui := GetModuleSymbol(LibGL, 'glColor4ui'); - @glColor4uiv := GetModuleSymbol(LibGL, 'glColor4uiv'); - @glColor4us := GetModuleSymbol(LibGL, 'glColor4us'); - @glColor4usv := GetModuleSymbol(LibGL, 'glColor4usv'); - @glColorMask := GetModuleSymbol(LibGL, 'glColorMask'); - @glColorMaterial := GetModuleSymbol(LibGL, 'glColorMaterial'); - @glColorPointer := GetModuleSymbol(LibGL, 'glColorPointer'); - @glCopyPixels := GetModuleSymbol(LibGL, 'glCopyPixels'); - @glCopyTexImage1D := GetModuleSymbol(LibGL, 'glCopyTexImage1D'); - @glCopyTexImage2D := GetModuleSymbol(LibGL, 'glCopyTexImage2D'); - @glCopyTexSubImage1D := GetModuleSymbol(LibGL, 'glCopyTexSubImage1D'); - @glCopyTexSubImage2D := GetModuleSymbol(LibGL, 'glCopyTexSubImage2D'); - @glCullFace := GetModuleSymbol(LibGL, 'glCullFace'); - @glDeleteLists := GetModuleSymbol(LibGL, 'glDeleteLists'); - @glDeleteTextures := GetModuleSymbol(LibGL, 'glDeleteTextures'); - @glDepthFunc := GetModuleSymbol(LibGL, 'glDepthFunc'); - @glDepthMask := GetModuleSymbol(LibGL, 'glDepthMask'); - @glDepthRange := GetModuleSymbol(LibGL, 'glDepthRange'); - @glDisable := GetModuleSymbol(LibGL, 'glDisable'); - @glDisableClientState := GetModuleSymbol(LibGL, 'glDisableClientState'); - @glDrawArrays := GetModuleSymbol(LibGL, 'glDrawArrays'); - @glDrawBuffer := GetModuleSymbol(LibGL, 'glDrawBuffer'); - @glDrawElements := GetModuleSymbol(LibGL, 'glDrawElements'); - @glDrawPixels := GetModuleSymbol(LibGL, 'glDrawPixels'); - @glEdgeFlag := GetModuleSymbol(LibGL, 'glEdgeFlag'); - @glEdgeFlagPointer := GetModuleSymbol(LibGL, 'glEdgeFlagPointer'); - @glEdgeFlagv := GetModuleSymbol(LibGL, 'glEdgeFlagv'); - @glEnable := GetModuleSymbol(LibGL, 'glEnable'); - @glEnableClientState := GetModuleSymbol(LibGL, 'glEnableClientState'); - @glEnd := GetModuleSymbol(LibGL, 'glEnd'); - @glEndList := GetModuleSymbol(LibGL, 'glEndList'); - @glEvalCoord1d := GetModuleSymbol(LibGL, 'glEvalCoord1d'); - @glEvalCoord1dv := GetModuleSymbol(LibGL, 'glEvalCoord1dv'); - @glEvalCoord1f := GetModuleSymbol(LibGL, 'glEvalCoord1f'); - @glEvalCoord1fv := GetModuleSymbol(LibGL, 'glEvalCoord1fv'); - @glEvalCoord2d := GetModuleSymbol(LibGL, 'glEvalCoord2d'); - @glEvalCoord2dv := GetModuleSymbol(LibGL, 'glEvalCoord2dv'); - @glEvalCoord2f := GetModuleSymbol(LibGL, 'glEvalCoord2f'); - @glEvalCoord2fv := GetModuleSymbol(LibGL, 'glEvalCoord2fv'); - @glEvalMesh1 := GetModuleSymbol(LibGL, 'glEvalMesh1'); - @glEvalMesh2 := GetModuleSymbol(LibGL, 'glEvalMesh2'); - @glEvalPoint1 := GetModuleSymbol(LibGL, 'glEvalPoint1'); - @glEvalPoint2 := GetModuleSymbol(LibGL, 'glEvalPoint2'); - @glFeedbackBuffer := GetModuleSymbol(LibGL, 'glFeedbackBuffer'); - @glFinish := GetModuleSymbol(LibGL, 'glFinish'); - @glFlush := GetModuleSymbol(LibGL, 'glFlush'); - @glFogf := GetModuleSymbol(LibGL, 'glFogf'); - @glFogfv := GetModuleSymbol(LibGL, 'glFogfv'); - @glFogi := GetModuleSymbol(LibGL, 'glFogi'); - @glFogiv := GetModuleSymbol(LibGL, 'glFogiv'); - @glFrontFace := GetModuleSymbol(LibGL, 'glFrontFace'); - @glFrustum := GetModuleSymbol(LibGL, 'glFrustum'); - @glGenLists := GetModuleSymbol(LibGL, 'glGenLists'); - @glGenTextures := GetModuleSymbol(LibGL, 'glGenTextures'); - @glGetBooleanv := GetModuleSymbol(LibGL, 'glGetBooleanv'); - @glGetClipPlane := GetModuleSymbol(LibGL, 'glGetClipPlane'); - @glGetDoublev := GetModuleSymbol(LibGL, 'glGetDoublev'); - @glGetError := GetModuleSymbol(LibGL, 'glGetError'); - @glGetFloatv := GetModuleSymbol(LibGL, 'glGetFloatv'); - @glGetIntegerv := GetModuleSymbol(LibGL, 'glGetIntegerv'); - @glGetLightfv := GetModuleSymbol(LibGL, 'glGetLightfv'); - @glGetLightiv := GetModuleSymbol(LibGL, 'glGetLightiv'); - @glGetMapdv := GetModuleSymbol(LibGL, 'glGetMapdv'); - @glGetMapfv := GetModuleSymbol(LibGL, 'glGetMapfv'); - @glGetMapiv := GetModuleSymbol(LibGL, 'glGetMapiv'); - @glGetMaterialfv := GetModuleSymbol(LibGL, 'glGetMaterialfv'); - @glGetMaterialiv := GetModuleSymbol(LibGL, 'glGetMaterialiv'); - @glGetPixelMapfv := GetModuleSymbol(LibGL, 'glGetPixelMapfv'); - @glGetPixelMapuiv := GetModuleSymbol(LibGL, 'glGetPixelMapuiv'); - @glGetPixelMapusv := GetModuleSymbol(LibGL, 'glGetPixelMapusv'); - @glGetPointerv := GetModuleSymbol(LibGL, 'glGetPointerv'); - @glGetPolygonStipple := GetModuleSymbol(LibGL, 'glGetPolygonStipple'); - @glGetString := GetModuleSymbol(LibGL, 'glGetString'); - @glGetTexEnvfv := GetModuleSymbol(LibGL, 'glGetTexEnvfv'); - @glGetTexEnviv := GetModuleSymbol(LibGL, 'glGetTexEnviv'); - @glGetTexGendv := GetModuleSymbol(LibGL, 'glGetTexGendv'); - @glGetTexGenfv := GetModuleSymbol(LibGL, 'glGetTexGenfv'); - @glGetTexGeniv := GetModuleSymbol(LibGL, 'glGetTexGeniv'); - @glGetTexImage := GetModuleSymbol(LibGL, 'glGetTexImage'); - @glGetTexLevelParameterfv := GetModuleSymbol(LibGL, 'glGetTexLevelParameterfv'); - @glGetTexLevelParameteriv := GetModuleSymbol(LibGL, 'glGetTexLevelParameteriv'); - @glGetTexParameterfv := GetModuleSymbol(LibGL, 'glGetTexParameterfv'); - @glGetTexParameteriv := GetModuleSymbol(LibGL, 'glGetTexParameteriv'); - @glHint := GetModuleSymbol(LibGL, 'glHint'); - @glIndexMask := GetModuleSymbol(LibGL, 'glIndexMask'); - @glIndexPointer := GetModuleSymbol(LibGL, 'glIndexPointer'); - @glIndexd := GetModuleSymbol(LibGL, 'glIndexd'); - @glIndexdv := GetModuleSymbol(LibGL, 'glIndexdv'); - @glIndexf := GetModuleSymbol(LibGL, 'glIndexf'); - @glIndexfv := GetModuleSymbol(LibGL, 'glIndexfv'); - @glIndexi := GetModuleSymbol(LibGL, 'glIndexi'); - @glIndexiv := GetModuleSymbol(LibGL, 'glIndexiv'); - @glIndexs := GetModuleSymbol(LibGL, 'glIndexs'); - @glIndexsv := GetModuleSymbol(LibGL, 'glIndexsv'); - @glIndexub := GetModuleSymbol(LibGL, 'glIndexub'); - @glIndexubv := GetModuleSymbol(LibGL, 'glIndexubv'); - @glInitNames := GetModuleSymbol(LibGL, 'glInitNames'); - @glInterleavedArrays := GetModuleSymbol(LibGL, 'glInterleavedArrays'); - @glIsEnabled := GetModuleSymbol(LibGL, 'glIsEnabled'); - @glIsList := GetModuleSymbol(LibGL, 'glIsList'); - @glIsTexture := GetModuleSymbol(LibGL, 'glIsTexture'); - @glLightModelf := GetModuleSymbol(LibGL, 'glLightModelf'); - @glLightModelfv := GetModuleSymbol(LibGL, 'glLightModelfv'); - @glLightModeli := GetModuleSymbol(LibGL, 'glLightModeli'); - @glLightModeliv := GetModuleSymbol(LibGL, 'glLightModeliv'); - @glLightf := GetModuleSymbol(LibGL, 'glLightf'); - @glLightfv := GetModuleSymbol(LibGL, 'glLightfv'); - @glLighti := GetModuleSymbol(LibGL, 'glLighti'); - @glLightiv := GetModuleSymbol(LibGL, 'glLightiv'); - @glLineStipple := GetModuleSymbol(LibGL, 'glLineStipple'); - @glLineWidth := GetModuleSymbol(LibGL, 'glLineWidth'); - @glListBase := GetModuleSymbol(LibGL, 'glListBase'); - @glLoadIdentity := GetModuleSymbol(LibGL, 'glLoadIdentity'); - @glLoadMatrixd := GetModuleSymbol(LibGL, 'glLoadMatrixd'); - @glLoadMatrixf := GetModuleSymbol(LibGL, 'glLoadMatrixf'); - @glLoadName := GetModuleSymbol(LibGL, 'glLoadName'); - @glLogicOp := GetModuleSymbol(LibGL, 'glLogicOp'); - @glMap1d := GetModuleSymbol(LibGL, 'glMap1d'); - @glMap1f := GetModuleSymbol(LibGL, 'glMap1f'); - @glMap2d := GetModuleSymbol(LibGL, 'glMap2d'); - @glMap2f := GetModuleSymbol(LibGL, 'glMap2f'); - @glMapGrid1d := GetModuleSymbol(LibGL, 'glMapGrid1d'); - @glMapGrid1f := GetModuleSymbol(LibGL, 'glMapGrid1f'); - @glMapGrid2d := GetModuleSymbol(LibGL, 'glMapGrid2d'); - @glMapGrid2f := GetModuleSymbol(LibGL, 'glMapGrid2f'); - @glMaterialf := GetModuleSymbol(LibGL, 'glMaterialf'); - @glMaterialfv := GetModuleSymbol(LibGL, 'glMaterialfv'); - @glMateriali := GetModuleSymbol(LibGL, 'glMateriali'); - @glMaterialiv := GetModuleSymbol(LibGL, 'glMaterialiv'); - @glMatrixMode := GetModuleSymbol(LibGL, 'glMatrixMode'); - @glMultMatrixd := GetModuleSymbol(LibGL, 'glMultMatrixd'); - @glMultMatrixf := GetModuleSymbol(LibGL, 'glMultMatrixf'); - @glNewList := GetModuleSymbol(LibGL, 'glNewList'); - @glNormal3b := GetModuleSymbol(LibGL, 'glNormal3b'); - @glNormal3bv := GetModuleSymbol(LibGL, 'glNormal3bv'); - @glNormal3d := GetModuleSymbol(LibGL, 'glNormal3d'); - @glNormal3dv := GetModuleSymbol(LibGL, 'glNormal3dv'); - @glNormal3f := GetModuleSymbol(LibGL, 'glNormal3f'); - @glNormal3fv := GetModuleSymbol(LibGL, 'glNormal3fv'); - @glNormal3i := GetModuleSymbol(LibGL, 'glNormal3i'); - @glNormal3iv := GetModuleSymbol(LibGL, 'glNormal3iv'); - @glNormal3s := GetModuleSymbol(LibGL, 'glNormal3s'); - @glNormal3sv := GetModuleSymbol(LibGL, 'glNormal3sv'); - @glNormalPointer := GetModuleSymbol(LibGL, 'glNormalPointer'); - @glOrtho := GetModuleSymbol(LibGL, 'glOrtho'); - @glPassThrough := GetModuleSymbol(LibGL, 'glPassThrough'); - @glPixelMapfv := GetModuleSymbol(LibGL, 'glPixelMapfv'); - @glPixelMapuiv := GetModuleSymbol(LibGL, 'glPixelMapuiv'); - @glPixelMapusv := GetModuleSymbol(LibGL, 'glPixelMapusv'); - @glPixelStoref := GetModuleSymbol(LibGL, 'glPixelStoref'); - @glPixelStorei := GetModuleSymbol(LibGL, 'glPixelStorei'); - @glPixelTransferf := GetModuleSymbol(LibGL, 'glPixelTransferf'); - @glPixelTransferi := GetModuleSymbol(LibGL, 'glPixelTransferi'); - @glPixelZoom := GetModuleSymbol(LibGL, 'glPixelZoom'); - @glPointSize := GetModuleSymbol(LibGL, 'glPointSize'); - @glPolygonMode := GetModuleSymbol(LibGL, 'glPolygonMode'); - @glPolygonOffset := GetModuleSymbol(LibGL, 'glPolygonOffset'); - @glPolygonStipple := GetModuleSymbol(LibGL, 'glPolygonStipple'); - @glPopAttrib := GetModuleSymbol(LibGL, 'glPopAttrib'); - @glPopClientAttrib := GetModuleSymbol(LibGL, 'glPopClientAttrib'); - @glPopMatrix := GetModuleSymbol(LibGL, 'glPopMatrix'); - @glPopName := GetModuleSymbol(LibGL, 'glPopName'); - @glPrioritizeTextures := GetModuleSymbol(LibGL, 'glPrioritizeTextures'); - @glPushAttrib := GetModuleSymbol(LibGL, 'glPushAttrib'); - @glPushClientAttrib := GetModuleSymbol(LibGL, 'glPushClientAttrib'); - @glPushMatrix := GetModuleSymbol(LibGL, 'glPushMatrix'); - @glPushName := GetModuleSymbol(LibGL, 'glPushName'); - @glRasterPos2d := GetModuleSymbol(LibGL, 'glRasterPos2d'); - @glRasterPos2dv := GetModuleSymbol(LibGL, 'glRasterPos2dv'); - @glRasterPos2f := GetModuleSymbol(LibGL, 'glRasterPos2f'); - @glRasterPos2fv := GetModuleSymbol(LibGL, 'glRasterPos2fv'); - @glRasterPos2i := GetModuleSymbol(LibGL, 'glRasterPos2i'); - @glRasterPos2iv := GetModuleSymbol(LibGL, 'glRasterPos2iv'); - @glRasterPos2s := GetModuleSymbol(LibGL, 'glRasterPos2s'); - @glRasterPos2sv := GetModuleSymbol(LibGL, 'glRasterPos2sv'); - @glRasterPos3d := GetModuleSymbol(LibGL, 'glRasterPos3d'); - @glRasterPos3dv := GetModuleSymbol(LibGL, 'glRasterPos3dv'); - @glRasterPos3f := GetModuleSymbol(LibGL, 'glRasterPos3f'); - @glRasterPos3fv := GetModuleSymbol(LibGL, 'glRasterPos3fv'); - @glRasterPos3i := GetModuleSymbol(LibGL, 'glRasterPos3i'); - @glRasterPos3iv := GetModuleSymbol(LibGL, 'glRasterPos3iv'); - @glRasterPos3s := GetModuleSymbol(LibGL, 'glRasterPos3s'); - @glRasterPos3sv := GetModuleSymbol(LibGL, 'glRasterPos3sv'); - @glRasterPos4d := GetModuleSymbol(LibGL, 'glRasterPos4d'); - @glRasterPos4dv := GetModuleSymbol(LibGL, 'glRasterPos4dv'); - @glRasterPos4f := GetModuleSymbol(LibGL, 'glRasterPos4f'); - @glRasterPos4fv := GetModuleSymbol(LibGL, 'glRasterPos4fv'); - @glRasterPos4i := GetModuleSymbol(LibGL, 'glRasterPos4i'); - @glRasterPos4iv := GetModuleSymbol(LibGL, 'glRasterPos4iv'); - @glRasterPos4s := GetModuleSymbol(LibGL, 'glRasterPos4s'); - @glRasterPos4sv := GetModuleSymbol(LibGL, 'glRasterPos4sv'); - @glReadBuffer := GetModuleSymbol(LibGL, 'glReadBuffer'); - @glReadPixels := GetModuleSymbol(LibGL, 'glReadPixels'); - @glRectd := GetModuleSymbol(LibGL, 'glRectd'); - @glRectdv := GetModuleSymbol(LibGL, 'glRectdv'); - @glRectf := GetModuleSymbol(LibGL, 'glRectf'); - @glRectfv := GetModuleSymbol(LibGL, 'glRectfv'); - @glRecti := GetModuleSymbol(LibGL, 'glRecti'); - @glRectiv := GetModuleSymbol(LibGL, 'glRectiv'); - @glRects := GetModuleSymbol(LibGL, 'glRects'); - @glRectsv := GetModuleSymbol(LibGL, 'glRectsv'); - @glRenderMode := GetModuleSymbol(LibGL, 'glRenderMode'); - @glRotated := GetModuleSymbol(LibGL, 'glRotated'); - @glRotatef := GetModuleSymbol(LibGL, 'glRotatef'); - @glScaled := GetModuleSymbol(LibGL, 'glScaled'); - @glScalef := GetModuleSymbol(LibGL, 'glScalef'); - @glScissor := GetModuleSymbol(LibGL, 'glScissor'); - @glSelectBuffer := GetModuleSymbol(LibGL, 'glSelectBuffer'); - @glShadeModel := GetModuleSymbol(LibGL, 'glShadeModel'); - @glStencilFunc := GetModuleSymbol(LibGL, 'glStencilFunc'); - @glStencilMask := GetModuleSymbol(LibGL, 'glStencilMask'); - @glStencilOp := GetModuleSymbol(LibGL, 'glStencilOp'); - @glTexCoord1d := GetModuleSymbol(LibGL, 'glTexCoord1d'); - @glTexCoord1dv := GetModuleSymbol(LibGL, 'glTexCoord1dv'); - @glTexCoord1f := GetModuleSymbol(LibGL, 'glTexCoord1f'); - @glTexCoord1fv := GetModuleSymbol(LibGL, 'glTexCoord1fv'); - @glTexCoord1i := GetModuleSymbol(LibGL, 'glTexCoord1i'); - @glTexCoord1iv := GetModuleSymbol(LibGL, 'glTexCoord1iv'); - @glTexCoord1s := GetModuleSymbol(LibGL, 'glTexCoord1s'); - @glTexCoord1sv := GetModuleSymbol(LibGL, 'glTexCoord1sv'); - @glTexCoord2d := GetModuleSymbol(LibGL, 'glTexCoord2d'); - @glTexCoord2dv := GetModuleSymbol(LibGL, 'glTexCoord2dv'); - @glTexCoord2f := GetModuleSymbol(LibGL, 'glTexCoord2f'); - @glTexCoord2fv := GetModuleSymbol(LibGL, 'glTexCoord2fv'); - @glTexCoord2i := GetModuleSymbol(LibGL, 'glTexCoord2i'); - @glTexCoord2iv := GetModuleSymbol(LibGL, 'glTexCoord2iv'); - @glTexCoord2s := GetModuleSymbol(LibGL, 'glTexCoord2s'); - @glTexCoord2sv := GetModuleSymbol(LibGL, 'glTexCoord2sv'); - @glTexCoord3d := GetModuleSymbol(LibGL, 'glTexCoord3d'); - @glTexCoord3dv := GetModuleSymbol(LibGL, 'glTexCoord3dv'); - @glTexCoord3f := GetModuleSymbol(LibGL, 'glTexCoord3f'); - @glTexCoord3fv := GetModuleSymbol(LibGL, 'glTexCoord3fv'); - @glTexCoord3i := GetModuleSymbol(LibGL, 'glTexCoord3i'); - @glTexCoord3iv := GetModuleSymbol(LibGL, 'glTexCoord3iv'); - @glTexCoord3s := GetModuleSymbol(LibGL, 'glTexCoord3s'); - @glTexCoord3sv := GetModuleSymbol(LibGL, 'glTexCoord3sv'); - @glTexCoord4d := GetModuleSymbol(LibGL, 'glTexCoord4d'); - @glTexCoord4dv := GetModuleSymbol(LibGL, 'glTexCoord4dv'); - @glTexCoord4f := GetModuleSymbol(LibGL, 'glTexCoord4f'); - @glTexCoord4fv := GetModuleSymbol(LibGL, 'glTexCoord4fv'); - @glTexCoord4i := GetModuleSymbol(LibGL, 'glTexCoord4i'); - @glTexCoord4iv := GetModuleSymbol(LibGL, 'glTexCoord4iv'); - @glTexCoord4s := GetModuleSymbol(LibGL, 'glTexCoord4s'); - @glTexCoord4sv := GetModuleSymbol(LibGL, 'glTexCoord4sv'); - @glTexCoordPointer := GetModuleSymbol(LibGL, 'glTexCoordPointer'); - @glTexEnvf := GetModuleSymbol(LibGL, 'glTexEnvf'); - @glTexEnvfv := GetModuleSymbol(LibGL, 'glTexEnvfv'); - @glTexEnvi := GetModuleSymbol(LibGL, 'glTexEnvi'); - @glTexEnviv := GetModuleSymbol(LibGL, 'glTexEnviv'); - @glTexGend := GetModuleSymbol(LibGL, 'glTexGend'); - @glTexGendv := GetModuleSymbol(LibGL, 'glTexGendv'); - @glTexGenf := GetModuleSymbol(LibGL, 'glTexGenf'); - @glTexGenfv := GetModuleSymbol(LibGL, 'glTexGenfv'); - @glTexGeni := GetModuleSymbol(LibGL, 'glTexGeni'); - @glTexGeniv := GetModuleSymbol(LibGL, 'glTexGeniv'); - @glTexImage1D := GetModuleSymbol(LibGL, 'glTexImage1D'); - @glTexImage2D := GetModuleSymbol(LibGL, 'glTexImage2D'); - @glTexParameterf := GetModuleSymbol(LibGL, 'glTexParameterf'); - @glTexParameterfv := GetModuleSymbol(LibGL, 'glTexParameterfv'); - @glTexParameteri := GetModuleSymbol(LibGL, 'glTexParameteri'); - @glTexParameteriv := GetModuleSymbol(LibGL, 'glTexParameteriv'); - @glTexSubImage1D := GetModuleSymbol(LibGL, 'glTexSubImage1D'); - @glTexSubImage2D := GetModuleSymbol(LibGL, 'glTexSubImage2D'); - @glTranslated := GetModuleSymbol(LibGL, 'glTranslated'); - @glTranslatef := GetModuleSymbol(LibGL, 'glTranslatef'); - @glVertex2d := GetModuleSymbol(LibGL, 'glVertex2d'); - @glVertex2dv := GetModuleSymbol(LibGL, 'glVertex2dv'); - @glVertex2f := GetModuleSymbol(LibGL, 'glVertex2f'); - @glVertex2fv := GetModuleSymbol(LibGL, 'glVertex2fv'); - @glVertex2i := GetModuleSymbol(LibGL, 'glVertex2i'); - @glVertex2iv := GetModuleSymbol(LibGL, 'glVertex2iv'); - @glVertex2s := GetModuleSymbol(LibGL, 'glVertex2s'); - @glVertex2sv := GetModuleSymbol(LibGL, 'glVertex2sv'); - @glVertex3d := GetModuleSymbol(LibGL, 'glVertex3d'); - @glVertex3dv := GetModuleSymbol(LibGL, 'glVertex3dv'); - @glVertex3f := GetModuleSymbol(LibGL, 'glVertex3f'); - @glVertex3fv := GetModuleSymbol(LibGL, 'glVertex3fv'); - @glVertex3i := GetModuleSymbol(LibGL, 'glVertex3i'); - @glVertex3iv := GetModuleSymbol(LibGL, 'glVertex3iv'); - @glVertex3s := GetModuleSymbol(LibGL, 'glVertex3s'); - @glVertex3sv := GetModuleSymbol(LibGL, 'glVertex3sv'); - @glVertex4d := GetModuleSymbol(LibGL, 'glVertex4d'); - @glVertex4dv := GetModuleSymbol(LibGL, 'glVertex4dv'); - @glVertex4f := GetModuleSymbol(LibGL, 'glVertex4f'); - @glVertex4fv := GetModuleSymbol(LibGL, 'glVertex4fv'); - @glVertex4i := GetModuleSymbol(LibGL, 'glVertex4i'); - @glVertex4iv := GetModuleSymbol(LibGL, 'glVertex4iv'); - @glVertex4s := GetModuleSymbol(LibGL, 'glVertex4s'); - @glVertex4sv := GetModuleSymbol(LibGL, 'glVertex4sv'); - @glVertexPointer := GetModuleSymbol(LibGL, 'glVertexPointer'); - @glViewport := GetModuleSymbol(LibGL, 'glViewport'); - - {$IFDEF WINDOWS} - @ChoosePixelFormat := GetModuleSymbol(LibGL, 'ChoosePixelFormat'); - if not Assigned(ChoosePixelFormat) then - {$IFNDEF FPC}@{$ENDIF}ChoosePixelFormat := @Windows.ChoosePixelFormat; - {$ENDIF} - end; -end; - -initialization - {$IF Defined(CPU386) or Defined(CPUI386) or Defined(CPUX86_64)} - Set8087CW($133F); - {$IFEND} - - LoadOpenGL( GLLibName ); - -finalization - - FreeOpenGL; - -end. - diff --git a/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas b/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas deleted file mode 100644 index 871247a9..00000000 --- a/src/lib/JEDI-SDL/OpenGL/Pas/glext.pas +++ /dev/null @@ -1,9579 +0,0 @@ -unit glext; -{ - $Id: glext.pas,v 1.6 2007/05/20 20:28:31 savage Exp $ - -} -(************************************************** - * OpenGL extension loading library * - * Generated by MetaGLext, written by Tom Nuydens * - * (tom@delphi3d.net -- http://www.delphi3d.net * - **************************************************) - -{ - $Log: glext.pas,v $ - Revision 1.6 2007/05/20 20:28:31 savage - Initial Changes to Handle 64 Bits - - Revision 1.5 2006/01/11 22:39:02 drellis - Updated to Support Up to OpenGL 2.0 - - Revision 1.4 2005/01/05 00:28:40 savage - Forgot to wrap a couple of Load_WGL function calls with an IFDEF WIN32. Fixed so now compiles under Linux as well. - - Revision 1.3 2004/08/24 19:33:06 savage - Removed declarations of SDL_GL_GetProcAddress as the correct ones are in sdl.pas. - - Revision 1.2 2004/08/09 00:38:01 savage - Updated to Tom's latest version. May contains bugs, but I hope not. - - Revision 1.1 2004/03/30 21:53:54 savage - Moved to it's own folder. - - Revision 1.6 2004/03/28 00:28:43 savage - Fixed some glSecondaryColor definitions... - - Revision 1.5 2004/02/20 17:18:16 savage - Forgot to prefix function pointer with @ for FPC and other Pascal compilers. - - Revision 1.4 2004/02/20 17:09:55 savage - Code tidied up in gl, glu and glut, while extensions in glext.pas are now loaded using SDL_GL_GetProcAddress, thus making it more cross-platform compatible, but now more tied to SDL. - - 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:09:19 savage - Changed uses to now make use of moduleloader.pas rather than dllfuncs.pas - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - Revision 1.7 2003/06/02 12:32:13 savage - Modified Sources to avoid warnings with Delphi by moving CVS Logging to the top of the header files. Hopefully CVS Logging still works. - -} - -interface - -{$I jedi-sdl.inc} - -uses - SysUtils, -{$IFDEF __GPC__} - gpc, -{$ENDIF} - -{$IFDEF WINDOWS} - Windows, -{$ENDIF} - moduleloader, - gl; - -// Test if the given extension name is present in the given extension string. -function glext_ExtensionSupported(const extension: PChar; const searchIn: PChar): Boolean; - -// Load a Specific Extension -function glext_LoadExtension(ext: String): Boolean; -// Some types that were introduced by extensions: -type - GLintptrARB = Integer; - PGLintptrARB = ^GLintptrARB; - - GLsizeiptrARB = Integer; - PGLsizeiptrARB = ^GLsizeiptrARB; - - GLcharARB = Char; - PGLcharARB = ^GLcharARB; - - GLhandleARB = Cardinal; - PGLhandleARB = ^GLhandleARB; - - GLintptr = Integer; - PGLintptr = ^GLintptr; - - GLsizeiptr = Integer; - PGLsizeiptr = ^GLsizeiptr; - - GLchar = Char; - PGLchar = ^GLchar; - -//***** GL_version_1_2 *****// -const - GL_UNSIGNED_BYTE_3_3_2 = $8032; - GL_UNSIGNED_SHORT_4_4_4_4 = $8033; - GL_UNSIGNED_SHORT_5_5_5_1 = $8034; - GL_UNSIGNED_INT_8_8_8_8 = $8035; - GL_UNSIGNED_INT_10_10_10_2 = $8036; - GL_RESCALE_NORMAL = $803A; - GL_UNSIGNED_BYTE_2_3_3_REV = $8362; - GL_UNSIGNED_SHORT_5_6_5 = $8363; - GL_UNSIGNED_SHORT_5_6_5_REV = $8364; - GL_UNSIGNED_SHORT_4_4_4_4_REV = $8365; - GL_UNSIGNED_SHORT_1_5_5_5_REV = $8366; - GL_UNSIGNED_INT_8_8_8_8_REV = $8367; - GL_UNSIGNED_INT_2_10_10_10_REV = $8368; - GL_BGR = $80E0; - GL_BGRA = $80E1; - GL_MAX_ELEMENTS_VERTICES = $80E8; - GL_MAX_ELEMENTS_INDICES = $80E9; - GL_CLAMP_TO_EDGE = $812F; - GL_TEXTURE_MIN_LOD = $813A; - GL_TEXTURE_MAX_LOD = $813B; - GL_TEXTURE_BASE_LEVEL = $813C; - GL_TEXTURE_MAX_LEVEL = $813D; - GL_LIGHT_MODEL_COLOR_CONTROL = $81F8; - GL_SINGLE_COLOR = $81F9; - GL_SEPARATE_SPECULAR_COLOR = $81FA; - GL_SMOOTH_POINT_SIZE_RANGE = $0B12; - GL_SMOOTH_POINT_SIZE_GRANULARITY = $0B13; - GL_SMOOTH_LINE_WIDTH_RANGE = $0B22; - GL_SMOOTH_LINE_WIDTH_GRANULARITY = $0B23; - GL_ALIASED_POINT_SIZE_RANGE = $846D; - GL_ALIASED_LINE_WIDTH_RANGE = $846E; - GL_PACK_SKIP_IMAGES = $806B; - GL_PACK_IMAGE_HEIGHT = $806C; - GL_UNPACK_SKIP_IMAGES = $806D; - GL_UNPACK_IMAGE_HEIGHT = $806E; - GL_TEXTURE_3D = $806F; - GL_PROXY_TEXTURE_3D = $8070; - GL_TEXTURE_DEPTH = $8071; - GL_TEXTURE_WRAP_R = $8072; - GL_MAX_3D_TEXTURE_SIZE = $8073; -var - glDrawRangeElements: procedure(mode: GLenum; start: GLuint; _end: GLuint; count: GLsizei; _type: GLenum; const indices: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexImage3D: procedure(target: GLenum; level: GLint; internalformat: GLint; width: GLsizei; height: GLsizei; depth: GLsizei; border: GLint; format: GLenum; _type: GLenum; const pixels: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexSubImage3D: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; zoffset: GLint; width: GLsizei; height: GLsizei; depth: GLsizei; format: GLenum; _type: GLenum; const pixels: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyTexSubImage3D: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; zoffset: GLint; x: GLint; y: GLint; width: GLsizei; height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_version_1_2: Boolean; - -//***** GL_ARB_imaging *****// -const - GL_CONSTANT_COLOR = $8001; - GL_ONE_MINUS_CONSTANT_COLOR = $8002; - GL_CONSTANT_ALPHA = $8003; - GL_ONE_MINUS_CONSTANT_ALPHA = $8004; - GL_BLEND_COLOR = $8005; - GL_FUNC_ADD = $8006; - GL_MIN = $8007; - GL_MAX = $8008; - GL_BLEND_EQUATION = $8009; - GL_FUNC_SUBTRACT = $800A; - GL_FUNC_REVERSE_SUBTRACT = $800B; - GL_CONVOLUTION_1D = $8010; - GL_CONVOLUTION_2D = $8011; - GL_SEPARABLE_2D = $8012; - GL_CONVOLUTION_BORDER_MODE = $8013; - GL_CONVOLUTION_FILTER_SCALE = $8014; - GL_CONVOLUTION_FILTER_BIAS = $8015; - GL_REDUCE = $8016; - GL_CONVOLUTION_FORMAT = $8017; - GL_CONVOLUTION_WIDTH = $8018; - GL_CONVOLUTION_HEIGHT = $8019; - GL_MAX_CONVOLUTION_WIDTH = $801A; - GL_MAX_CONVOLUTION_HEIGHT = $801B; - GL_POST_CONVOLUTION_RED_SCALE = $801C; - GL_POST_CONVOLUTION_GREEN_SCALE = $801D; - GL_POST_CONVOLUTION_BLUE_SCALE = $801E; - GL_POST_CONVOLUTION_ALPHA_SCALE = $801F; - GL_POST_CONVOLUTION_RED_BIAS = $8020; - GL_POST_CONVOLUTION_GREEN_BIAS = $8021; - GL_POST_CONVOLUTION_BLUE_BIAS = $8022; - GL_POST_CONVOLUTION_ALPHA_BIAS = $8023; - GL_HISTOGRAM = $8024; - GL_PROXY_HISTOGRAM = $8025; - GL_HISTOGRAM_WIDTH = $8026; - GL_HISTOGRAM_FORMAT = $8027; - GL_HISTOGRAM_RED_SIZE = $8028; - GL_HISTOGRAM_GREEN_SIZE = $8029; - GL_HISTOGRAM_BLUE_SIZE = $802A; - GL_HISTOGRAM_ALPHA_SIZE = $802B; - GL_HISTOGRAM_LUMINANCE_SIZE = $802C; - GL_HISTOGRAM_SINK = $802D; - GL_MINMAX = $802E; - GL_MINMAX_FORMAT = $802F; - GL_MINMAX_SINK = $8030; - GL_TABLE_TOO_LARGE = $8031; - GL_COLOR_MATRIX = $80B1; - GL_COLOR_MATRIX_STACK_DEPTH = $80B2; - GL_MAX_COLOR_MATRIX_STACK_DEPTH = $80B3; - GL_POST_COLOR_MATRIX_RED_SCALE = $80B4; - GL_POST_COLOR_MATRIX_GREEN_SCALE = $80B5; - GL_POST_COLOR_MATRIX_BLUE_SCALE = $80B6; - GL_POST_COLOR_MATRIX_ALPHA_SCALE = $80B7; - GL_POST_COLOR_MATRIX_RED_BIAS = $80B8; - GL_POST_COLOR_MATRIX_GREEN_BIAS = $80B9; - GL_POST_COLOR_MATRIX_BLUE_BIAS = $80BA; - GL_POST_COLOR_MATIX_ALPHA_BIAS = $80BB; - GL_COLOR_TABLE = $80D0; - GL_POST_CONVOLUTION_COLOR_TABLE = $80D1; - GL_POST_COLOR_MATRIX_COLOR_TABLE = $80D2; - GL_PROXY_COLOR_TABLE = $80D3; - GL_PROXY_POST_CONVOLUTION_COLOR_TABLE = $80D4; - GL_PROXY_POST_COLOR_MATRIX_COLOR_TABLE = $80D5; - GL_COLOR_TABLE_SCALE = $80D6; - GL_COLOR_TABLE_BIAS = $80D7; - GL_COLOR_TABLE_FORMAT = $80D8; - GL_COLOR_TABLE_WIDTH = $80D9; - GL_COLOR_TABLE_RED_SIZE = $80DA; - GL_COLOR_TABLE_GREEN_SIZE = $80DB; - GL_COLOR_TABLE_BLUE_SIZE = $80DC; - GL_COLOR_TABLE_ALPHA_SIZE = $80DD; - GL_COLOR_TABLE_LUMINANCE_SIZE = $80DE; - GL_COLOR_TABLE_INTENSITY_SIZE = $80DF; - GL_IGNORE_BORDER = $8150; - GL_CONSTANT_BORDER = $8151; - GL_WRAP_BORDER = $8152; - GL_REPLICATE_BORDER = $8153; - GL_CONVOLUTION_BORDER_COLOR = $8154; -var - glColorTable: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; format: GLenum; _type: GLenum; const table: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorTableParameterfv: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorTableParameteriv: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyColorTable: procedure(target: GLenum; internalformat: GLenum; x: GLint; y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTable: procedure(target: GLenum; format: GLenum; _type: GLenum; table: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableParameterfv: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableParameteriv: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorSubTable: procedure(target: GLenum; start: GLsizei; count: GLsizei; format: GLenum; _type: GLenum; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyColorSubTable: procedure(target: GLenum; start: GLsizei; x: GLint; y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionFilter1D: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; format: GLenum; _type: GLenum; const image: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionFilter2D: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; height: GLsizei; format: GLenum; _type: GLenum; const image: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameterf: procedure(target: GLenum; pname: GLenum; params: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameterfv: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameteri: procedure(target: GLenum; pname: GLenum; params: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameteriv: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyConvolutionFilter1D: procedure(target: GLenum; internalformat: GLenum; x: GLint; y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyConvolutionFilter2D: procedure(target: GLenum; internalformat: GLenum; x: GLint; y: GLint; width: GLsizei; height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetConvolutionFilter: procedure(target: GLenum; format: GLenum; _type: GLenum; image: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetConvolutionParameterfv: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetConvolutionParameteriv: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetSeparableFilter: procedure(target: GLenum; format: GLenum; _type: GLenum; row: PGLvoid; column: PGLvoid; span: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSeparableFilter2D: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; height: GLsizei; format: GLenum; _type: GLenum; const row: PGLvoid; const column: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHistogram: procedure(target: GLenum; reset: GLboolean; format: GLenum; _type: GLenum; values: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHistogramParameterfv: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHistogramParameteriv: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMinmax: procedure(target: GLenum; reset: GLboolean; format: GLenum; _type: GLenum; values: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMinmaxParameterfv: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMinmaxParameteriv: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glHistogram: procedure(target: GLenum; width: GLsizei; internalformat: GLenum; sink: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMinmax: procedure(target: GLenum; internalformat: GLenum; sink: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glResetHistogram: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glResetMinmax: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBlendEquation: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBlendColor: procedure(red: GLclampf; green: GLclampf; blue: GLclampf; alpha: GLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_imaging: Boolean; - -//***** GL_version_1_3 *****// -const - GL_TEXTURE0 = $84C0; - GL_TEXTURE1 = $84C1; - GL_TEXTURE2 = $84C2; - GL_TEXTURE3 = $84C3; - GL_TEXTURE4 = $84C4; - GL_TEXTURE5 = $84C5; - GL_TEXTURE6 = $84C6; - GL_TEXTURE7 = $84C7; - GL_TEXTURE8 = $84C8; - GL_TEXTURE9 = $84C9; - GL_TEXTURE10 = $84CA; - GL_TEXTURE11 = $84CB; - GL_TEXTURE12 = $84CC; - GL_TEXTURE13 = $84CD; - GL_TEXTURE14 = $84CE; - GL_TEXTURE15 = $84CF; - GL_TEXTURE16 = $84D0; - GL_TEXTURE17 = $84D1; - GL_TEXTURE18 = $84D2; - GL_TEXTURE19 = $84D3; - GL_TEXTURE20 = $84D4; - GL_TEXTURE21 = $84D5; - GL_TEXTURE22 = $84D6; - GL_TEXTURE23 = $84D7; - GL_TEXTURE24 = $84D8; - GL_TEXTURE25 = $84D9; - GL_TEXTURE26 = $84DA; - GL_TEXTURE27 = $84DB; - GL_TEXTURE28 = $84DC; - GL_TEXTURE29 = $84DD; - GL_TEXTURE30 = $84DE; - GL_TEXTURE31 = $84DF; - GL_ACTIVE_TEXTURE = $84E0; - GL_CLIENT_ACTIVE_TEXTURE = $84E1; - GL_MAX_TEXTURE_UNITS = $84E2; - GL_TRANSPOSE_MODELVIEW_MATRIX = $84E3; - GL_TRANSPOSE_PROJECTION_MATRIX = $84E4; - GL_TRANSPOSE_TEXTURE_MATRIX = $84E5; - GL_TRANSPOSE_COLOR_MATRIX = $84E6; - GL_MULTISAMPLE = $809D; - GL_SAMPLE_ALPHA_TO_COVERAGE = $809E; - GL_SAMPLE_ALPHA_TO_ONE = $809F; - GL_SAMPLE_COVERAGE = $80A0; - GL_SAMPLE_BUFFERS = $80A8; - GL_SAMPLES = $80A9; - GL_SAMPLE_COVERAGE_VALUE = $80AA; - GL_SAMPLE_COVERAGE_INVERT = $80AB; - GL_MULTISAMPLE_BIT = $20000000; - GL_NORMAL_MAP = $8511; - GL_REFLECTION_MAP = $8512; - GL_TEXTURE_CUBE_MAP = $8513; - GL_TEXTURE_BINDING_CUBE_MAP = $8514; - GL_TEXTURE_CUBE_MAP_POSITIVE_X = $8515; - GL_TEXTURE_CUBE_MAP_NEGATIVE_X = $8516; - GL_TEXTURE_CUBE_MAP_POSITIVE_Y = $8517; - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y = $8518; - GL_TEXTURE_CUBE_MAP_POSITIVE_Z = $8519; - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z = $851A; - GL_PROXY_TEXTURE_CUBE_MAP = $851B; - GL_MAX_CUBE_MAP_TEXTURE_SIZE = $851C; - GL_COMPRESSED_ALPHA = $84E9; - GL_COMPRESSED_LUMINANCE = $84EA; - GL_COMPRESSED_LUMINANCE_ALPHA = $84EB; - GL_COMPRESSED_INTENSITY = $84EC; - GL_COMPRESSED_RGB = $84ED; - GL_COMPRESSED_RGBA = $84EE; - GL_TEXTURE_COMPRESSION_HINT = $84EF; - GL_TEXTURE_COMPRESSED_IMAGE_SIZE = $86A0; - GL_TEXTURE_COMPRESSED = $86A1; - GL_NUM_COMPRESSED_TEXTURE_FORMATS = $86A2; - GL_COMPRESSED_TEXTURE_FORMATS = $86A3; - GL_CLAMP_TO_BORDER = $812D; - GL_CLAMP_TO_BORDER_SGIS = $812D; - GL_COMBINE = $8570; - GL_COMBINE_RGB = $8571; - GL_COMBINE_ALPHA = $8572; - GL_SOURCE0_RGB = $8580; - GL_SOURCE1_RGB = $8581; - GL_SOURCE2_RGB = $8582; - GL_SOURCE0_ALPHA = $8588; - GL_SOURCE1_ALPHA = $8589; - GL_SOURCE2_ALPHA = $858A; - GL_OPERAND0_RGB = $8590; - GL_OPERAND1_RGB = $8591; - GL_OPERAND2_RGB = $8592; - GL_OPERAND0_ALPHA = $8598; - GL_OPERAND1_ALPHA = $8599; - GL_OPERAND2_ALPHA = $859A; - GL_RGB_SCALE = $8573; - GL_ADD_SIGNED = $8574; - GL_INTERPOLATE = $8575; - GL_SUBTRACT = $84E7; - GL_CONSTANT = $8576; - GL_PRIMARY_COLOR = $8577; - GL_PREVIOUS = $8578; - GL_DOT3_RGB = $86AE; - GL_DOT3_RGBA = $86AF; -var - glActiveTexture: procedure(texture: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClientActiveTexture: procedure(texture: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1d: procedure(target: GLenum; s: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1dv: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1f: procedure(target: GLenum; s: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1fv: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1i: procedure(target: GLenum; s: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1iv: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1s: procedure(target: GLenum; s: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1sv: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2d: procedure(target: GLenum; s: GLdouble; t: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2dv: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2f: procedure(target: GLenum; s: GLfloat; t: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2fv: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2i: procedure(target: GLenum; s: GLint; t: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2iv: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2s: procedure(target: GLenum; s: GLshort; t: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2sv: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3d: procedure(target: GLenum; s: GLdouble; t: GLdouble; r: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3dv: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3f: procedure(target: GLenum; s: GLfloat; t: GLfloat; r: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3fv: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3i: procedure(target: GLenum; s: GLint; t: GLint; r: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3iv: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3s: procedure(target: GLenum; s: GLshort; t: GLshort; r: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3sv: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4d: procedure(target: GLenum; s: GLdouble; t: GLdouble; r: GLdouble; q: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4dv: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4f: procedure(target: GLenum; s: GLfloat; t: GLfloat; r: GLfloat; q: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4fv: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4i: procedure(target: GLenum; s: GLint; t: GLint; r: GLint; q: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4iv: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4s: procedure(target: GLenum; s: GLshort; t: GLshort; r: GLshort; q: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4sv: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadTransposeMatrixf: procedure(const m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadTransposeMatrixd: procedure(const m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultTransposeMatrixf: procedure(const m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultTransposeMatrixd: procedure(const m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSampleCoverage: procedure(value: GLclampf; invert: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexImage3D: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; height: GLsizei; depth: GLsizei; border: GLint; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexImage2D: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; height: GLsizei; border: GLint; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexImage1D: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; border: GLint; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexSubImage3D: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; zoffset: GLint; width: GLsizei; height: GLsizei; depth: GLsizei; format: GLenum; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexSubImage2D: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; width: GLsizei; height: GLsizei; format: GLenum; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexSubImage1D: procedure(target: GLenum; level: GLint; xoffset: GLint; width: GLsizei; format: GLenum; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCompressedTexImage: procedure(target: GLenum; level: GLint; img: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_version_1_3: Boolean; - -//***** GL_ARB_multitexture *****// -const - GL_TEXTURE0_ARB = $84C0; - GL_TEXTURE1_ARB = $84C1; - GL_TEXTURE2_ARB = $84C2; - GL_TEXTURE3_ARB = $84C3; - GL_TEXTURE4_ARB = $84C4; - GL_TEXTURE5_ARB = $84C5; - GL_TEXTURE6_ARB = $84C6; - GL_TEXTURE7_ARB = $84C7; - GL_TEXTURE8_ARB = $84C8; - GL_TEXTURE9_ARB = $84C9; - GL_TEXTURE10_ARB = $84CA; - GL_TEXTURE11_ARB = $84CB; - GL_TEXTURE12_ARB = $84CC; - GL_TEXTURE13_ARB = $84CD; - GL_TEXTURE14_ARB = $84CE; - GL_TEXTURE15_ARB = $84CF; - GL_TEXTURE16_ARB = $84D0; - GL_TEXTURE17_ARB = $84D1; - GL_TEXTURE18_ARB = $84D2; - GL_TEXTURE19_ARB = $84D3; - GL_TEXTURE20_ARB = $84D4; - GL_TEXTURE21_ARB = $84D5; - GL_TEXTURE22_ARB = $84D6; - GL_TEXTURE23_ARB = $84D7; - GL_TEXTURE24_ARB = $84D8; - GL_TEXTURE25_ARB = $84D9; - GL_TEXTURE26_ARB = $84DA; - GL_TEXTURE27_ARB = $84DB; - GL_TEXTURE28_ARB = $84DC; - GL_TEXTURE29_ARB = $84DD; - GL_TEXTURE30_ARB = $84DE; - GL_TEXTURE31_ARB = $84DF; - GL_ACTIVE_TEXTURE_ARB = $84E0; - GL_CLIENT_ACTIVE_TEXTURE_ARB = $84E1; - GL_MAX_TEXTURE_UNITS_ARB = $84E2; -var - glActiveTextureARB: procedure(texture: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClientActiveTextureARB: procedure(texture: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1dARB: procedure(target: GLenum; s: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1dvARB: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1fARB: procedure(target: GLenum; s: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1fvARB: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1iARB: procedure(target: GLenum; s: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1ivARB: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1sARB: procedure(target: GLenum; s: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1svARB: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2dARB: procedure(target: GLenum; s: GLdouble; t: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2dvARB: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2fARB: procedure(target: GLenum; s: GLfloat; t: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2fvARB: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2iARB: procedure(target: GLenum; s: GLint; t: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2ivARB: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2sARB: procedure(target: GLenum; s: GLshort; t: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2svARB: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3dARB: procedure(target: GLenum; s: GLdouble; t: GLdouble; r: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3dvARB: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3fARB: procedure(target: GLenum; s: GLfloat; t: GLfloat; r: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3fvARB: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3iARB: procedure(target: GLenum; s: GLint; t: GLint; r: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3ivARB: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3sARB: procedure(target: GLenum; s: GLshort; t: GLshort; r: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3svARB: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4dARB: procedure(target: GLenum; s: GLdouble; t: GLdouble; r: GLdouble; q: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4dvARB: procedure(target: GLenum; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4fARB: procedure(target: GLenum; s: GLfloat; t: GLfloat; r: GLfloat; q: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4fvARB: procedure(target: GLenum; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4iARB: procedure(target: GLenum; s: GLint; t: GLint; r: GLint; q: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4ivARB: procedure(target: GLenum; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4sARB: procedure(target: GLenum; s: GLshort; t: GLshort; r: GLshort; q: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4svARB: procedure(target: GLenum; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_multitexture: Boolean; - -//***** GL_ARB_transpose_matrix *****// -const - GL_TRANSPOSE_MODELVIEW_MATRIX_ARB = $84E3; - GL_TRANSPOSE_PROJECTION_MATRIX_ARB = $84E4; - GL_TRANSPOSE_TEXTURE_MATRIX_ARB = $84E5; - GL_TRANSPOSE_COLOR_MATRIX_ARB = $84E6; -var - glLoadTransposeMatrixfARB: procedure(m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadTransposeMatrixdARB: procedure(m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultTransposeMatrixfARB: procedure(m: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultTransposeMatrixdARB: procedure(m: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_transpose_matrix: Boolean; - -//***** GL_ARB_multisample *****// -const - WGL_SAMPLE_BUFFERS_ARB = $2041; - WGL_SAMPLES_ARB = $2042; - GL_MULTISAMPLE_ARB = $809D; - GL_SAMPLE_ALPHA_TO_COVERAGE_ARB = $809E; - GL_SAMPLE_ALPHA_TO_ONE_ARB = $809F; - GL_SAMPLE_COVERAGE_ARB = $80A0; - GL_MULTISAMPLE_BIT_ARB = $20000000; - GL_SAMPLE_BUFFERS_ARB = $80A8; - GL_SAMPLES_ARB = $80A9; - GL_SAMPLE_COVERAGE_VALUE_ARB = $80AA; - GL_SAMPLE_COVERAGE_INVERT_ARB = $80AB; -var - glSampleCoverageARB: procedure(value: GLclampf; invert: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_multisample: Boolean; - -//***** GL_ARB_texture_env_add *****// - -function Load_GL_ARB_texture_env_add: Boolean; - -{$IFDEF WINDOWS} -//***** WGL_ARB_extensions_string *****// -var - wglGetExtensionsStringARB: function(hdc: HDC): Pchar; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_ARB_extensions_string: Boolean; - -//***** WGL_ARB_buffer_region *****// -const - WGL_FRONT_COLOR_BUFFER_BIT_ARB = $0001; - WGL_BACK_COLOR_BUFFER_BIT_ARB = $0002; - WGL_DEPTH_BUFFER_BIT_ARB = $0004; - WGL_STENCIL_BUFFER_BIT_ARB = $0008; -var - wglCreateBufferRegionARB: function(hDC: HDC; iLayerPlane: GLint; uType: GLuint): THandle; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglDeleteBufferRegionARB: procedure(hRegion: THandle); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglSaveBufferRegionARB: function(hRegion: THandle; x: GLint; y: GLint; width: GLint; height: GLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglRestoreBufferRegionARB: function(hRegion: THandle; x: GLint; y: GLint; width: GLint; height: GLint; xSrc: GLint; ySrc: GLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_ARB_buffer_region: Boolean; -{$ENDIF} - -//***** GL_ARB_texture_cube_map *****// -const - GL_NORMAL_MAP_ARB = $8511; - GL_REFLECTION_MAP_ARB = $8512; - GL_TEXTURE_CUBE_MAP_ARB = $8513; - GL_TEXTURE_BINDING_CUBE_MAP_ARB = $8514; - GL_TEXTURE_CUBE_MAP_POSITIVE_X_ARB = $8515; - GL_TEXTURE_CUBE_MAP_NEGATIVE_X_ARB = $8516; - GL_TEXTURE_CUBE_MAP_POSITIVE_Y_ARB = $8517; - GL_TEXTURE_CUBE_MAP_NEGATIVE_Y_ARB = $8518; - GL_TEXTURE_CUBE_MAP_POSITIVE_Z_ARB = $8519; - GL_TEXTURE_CUBE_MAP_NEGATIVE_Z_ARB = $851A; - GL_PROXY_TEXTURE_CUBE_MAP_ARB = $851B; - GL_MAX_CUBE_MAP_TEXTURE_SIZE_ARB = $851C; - -function Load_GL_ARB_texture_cube_map: Boolean; - -//***** GL_ARB_depth_texture *****// -const - GL_DEPTH_COMPONENT16_ARB = $81A5; - GL_DEPTH_COMPONENT24_ARB = $81A6; - GL_DEPTH_COMPONENT32_ARB = $81A7; - GL_TEXTURE_DEPTH_SIZE_ARB = $884A; - GL_DEPTH_TEXTURE_MODE_ARB = $884B; - -function Load_GL_ARB_depth_texture: Boolean; - -//***** GL_ARB_point_parameters *****// -const - GL_POINT_SIZE_MIN_ARB = $8126; - GL_POINT_SIZE_MAX_ARB = $8127; - GL_POINT_FADE_THRESHOLD_SIZE_ARB = $8128; - GL_POINT_DISTANCE_ATTENUATION_ARB = $8129; -var - glPointParameterfARB: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameterfvARB: procedure(pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_point_parameters: Boolean; - -//***** GL_ARB_shadow *****// -const - GL_TEXTURE_COMPARE_MODE_ARB = $884C; - GL_TEXTURE_COMPARE_FUNC_ARB = $884D; - GL_COMPARE_R_TO_TEXTURE_ARB = $884E; - -function Load_GL_ARB_shadow: Boolean; - -//***** GL_ARB_shadow_ambient *****// -const - GL_TEXTURE_COMPARE_FAIL_VALUE_ARB = $80BF; - -function Load_GL_ARB_shadow_ambient: Boolean; - -//***** GL_ARB_texture_border_clamp *****// -const - GL_CLAMP_TO_BORDER_ARB = $812D; - -function Load_GL_ARB_texture_border_clamp: Boolean; - -//***** GL_ARB_texture_compression *****// -const - GL_COMPRESSED_ALPHA_ARB = $84E9; - GL_COMPRESSED_LUMINANCE_ARB = $84EA; - GL_COMPRESSED_LUMINANCE_ALPHA_ARB = $84EB; - GL_COMPRESSED_INTENSITY_ARB = $84EC; - GL_COMPRESSED_RGB_ARB = $84ED; - GL_COMPRESSED_RGBA_ARB = $84EE; - GL_TEXTURE_COMPRESSION_HINT_ARB = $84EF; - GL_TEXTURE_COMPRESSED_IMAGE_SIZE_ARB = $86A0; - GL_TEXTURE_COMPRESSED_ARB = $86A1; - GL_NUM_COMPRESSED_TEXTURE_FORMATS_ARB = $86A2; - GL_COMPRESSED_TEXTURE_FORMATS_ARB = $86A3; -var - glCompressedTexImage3DARB: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; height: GLsizei; depth: GLsizei; border: GLint; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexImage2DARB: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; height: GLsizei; border: GLint; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexImage1DARB: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; border: GLint; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexSubImage3DARB: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; zoffset: GLint; width: GLsizei; height: GLsizei; depth: GLsizei; format: GLenum; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexSubImage2DARB: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; width: GLsizei; height: GLsizei; format: GLenum; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompressedTexSubImage1DARB: procedure(target: GLenum; level: GLint; xoffset: GLint; width: GLsizei; format: GLenum; imageSize: GLsizei; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCompressedTexImageARB: procedure(target: GLenum; lod: GLint; img: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_texture_compression: Boolean; - -//***** GL_ARB_texture_env_combine *****// -const - GL_COMBINE_ARB = $8570; - GL_COMBINE_RGB_ARB = $8571; - GL_COMBINE_ALPHA_ARB = $8572; - GL_SOURCE0_RGB_ARB = $8580; - GL_SOURCE1_RGB_ARB = $8581; - GL_SOURCE2_RGB_ARB = $8582; - GL_SOURCE0_ALPHA_ARB = $8588; - GL_SOURCE1_ALPHA_ARB = $8589; - GL_SOURCE2_ALPHA_ARB = $858A; - GL_OPERAND0_RGB_ARB = $8590; - GL_OPERAND1_RGB_ARB = $8591; - GL_OPERAND2_RGB_ARB = $8592; - GL_OPERAND0_ALPHA_ARB = $8598; - GL_OPERAND1_ALPHA_ARB = $8599; - GL_OPERAND2_ALPHA_ARB = $859A; - GL_RGB_SCALE_ARB = $8573; - GL_ADD_SIGNED_ARB = $8574; - GL_INTERPOLATE_ARB = $8575; - GL_SUBTRACT_ARB = $84E7; - GL_CONSTANT_ARB = $8576; - GL_PRIMARY_COLOR_ARB = $8577; - GL_PREVIOUS_ARB = $8578; - -function Load_GL_ARB_texture_env_combine: Boolean; - -//***** GL_ARB_texture_env_crossbar *****// - -function Load_GL_ARB_texture_env_crossbar: Boolean; - -//***** GL_ARB_texture_env_dot3 *****// -const - GL_DOT3_RGB_ARB = $86AE; - GL_DOT3_RGBA_ARB = $86AF; - -function Load_GL_ARB_texture_env_dot3: Boolean; - -//***** GL_ARB_texture_mirrored_repeat *****// -const - GL_MIRRORED_REPEAT_ARB = $8370; - -function Load_GL_ARB_texture_mirrored_repeat: Boolean; - -//***** GL_ARB_vertex_blend *****// -const - GL_MAX_VERTEX_UNITS_ARB = $86A4; - GL_ACTIVE_VERTEX_UNITS_ARB = $86A5; - GL_WEIGHT_SUM_UNITY_ARB = $86A6; - GL_VERTEX_BLEND_ARB = $86A7; - GL_MODELVIEW0_ARB = $1700; - GL_MODELVIEW1_ARB = $850A; - GL_MODELVIEW2_ARB = $8722; - GL_MODELVIEW3_ARB = $8723; - GL_MODELVIEW4_ARB = $8724; - GL_MODELVIEW5_ARB = $8725; - GL_MODELVIEW6_ARB = $8726; - GL_MODELVIEW7_ARB = $8727; - GL_MODELVIEW8_ARB = $8728; - GL_MODELVIEW9_ARB = $8729; - GL_MODELVIEW10_ARB = $872A; - GL_MODELVIEW11_ARB = $872B; - GL_MODELVIEW12_ARB = $872C; - GL_MODELVIEW13_ARB = $872D; - GL_MODELVIEW14_ARB = $872E; - GL_MODELVIEW15_ARB = $872F; - GL_MODELVIEW16_ARB = $8730; - GL_MODELVIEW17_ARB = $8731; - GL_MODELVIEW18_ARB = $8732; - GL_MODELVIEW19_ARB = $8733; - GL_MODELVIEW20_ARB = $8734; - GL_MODELVIEW21_ARB = $8735; - GL_MODELVIEW22_ARB = $8736; - GL_MODELVIEW23_ARB = $8737; - GL_MODELVIEW24_ARB = $8738; - GL_MODELVIEW25_ARB = $8739; - GL_MODELVIEW26_ARB = $873A; - GL_MODELVIEW27_ARB = $873B; - GL_MODELVIEW28_ARB = $873C; - GL_MODELVIEW29_ARB = $873D; - GL_MODELVIEW30_ARB = $873E; - GL_MODELVIEW31_ARB = $873F; - GL_CURRENT_WEIGHT_ARB = $86A8; - GL_WEIGHT_ARRAY_TYPE_ARB = $86A9; - GL_WEIGHT_ARRAY_STRIDE_ARB = $86AA; - GL_WEIGHT_ARRAY_SIZE_ARB = $86AB; - GL_WEIGHT_ARRAY_POINTER_ARB = $86AC; - GL_WEIGHT_ARRAY_ARB = $86AD; -var - glWeightbvARB: procedure(size: GLint; weights: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightsvARB: procedure(size: GLint; weights: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightivARB: procedure(size: GLint; weights: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightfvARB: procedure(size: GLint; weights: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightdvARB: procedure(size: GLint; weights: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightvARB: procedure(size: GLint; weights: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightubvARB: procedure(size: GLint; weights: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightusvARB: procedure(size: GLint; weights: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightuivARB: procedure(size: GLint; weights: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWeightPointerARB: procedure(size: GLint; _type: GLenum; stride: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexBlendARB: procedure(count: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_vertex_blend: Boolean; - -//***** GL_ARB_vertex_program *****// -const - GL_VERTEX_PROGRAM_ARB = $8620; - GL_VERTEX_PROGRAM_POINT_SIZE_ARB = $8642; - GL_VERTEX_PROGRAM_TWO_SIDE_ARB = $8643; - GL_COLOR_SUM_ARB = $8458; - GL_PROGRAM_FORMAT_ASCII_ARB = $8875; - GL_VERTEX_ATTRIB_ARRAY_ENABLED_ARB = $8622; - GL_VERTEX_ATTRIB_ARRAY_SIZE_ARB = $8623; - GL_VERTEX_ATTRIB_ARRAY_STRIDE_ARB = $8624; - GL_VERTEX_ATTRIB_ARRAY_TYPE_ARB = $8625; - GL_VERTEX_ATTRIB_ARRAY_NORMALIZED_ARB = $886A; - GL_CURRENT_VERTEX_ATTRIB_ARB = $8626; - GL_VERTEX_ATTRIB_ARRAY_POINTER_ARB = $8645; - GL_PROGRAM_LENGTH_ARB = $8627; - GL_PROGRAM_FORMAT_ARB = $8876; - GL_PROGRAM_BINDING_ARB = $8677; - GL_PROGRAM_INSTRUCTIONS_ARB = $88A0; - GL_MAX_PROGRAM_INSTRUCTIONS_ARB = $88A1; - GL_PROGRAM_NATIVE_INSTRUCTIONS_ARB = $88A2; - GL_MAX_PROGRAM_NATIVE_INSTRUCTIONS_ARB = $88A3; - GL_PROGRAM_TEMPORARIES_ARB = $88A4; - GL_MAX_PROGRAM_TEMPORARIES_ARB = $88A5; - GL_PROGRAM_NATIVE_TEMPORARIES_ARB = $88A6; - GL_MAX_PROGRAM_NATIVE_TEMPORARIES_ARB = $88A7; - GL_PROGRAM_PARAMETERS_ARB = $88A8; - GL_MAX_PROGRAM_PARAMETERS_ARB = $88A9; - GL_PROGRAM_NATIVE_PARAMETERS_ARB = $88AA; - GL_MAX_PROGRAM_NATIVE_PARAMETERS_ARB = $88AB; - GL_PROGRAM_ATTRIBS_ARB = $88AC; - GL_MAX_PROGRAM_ATTRIBS_ARB = $88AD; - GL_PROGRAM_NATIVE_ATTRIBS_ARB = $88AE; - GL_MAX_PROGRAM_NATIVE_ATTRIBS_ARB = $88AF; - GL_PROGRAM_ADDRESS_REGISTERS_ARB = $88B0; - GL_MAX_PROGRAM_ADDRESS_REGISTERS_ARB = $88B1; - GL_PROGRAM_NATIVE_ADDRESS_REGISTERS_ARB = $88B2; - GL_MAX_PROGRAM_NATIVE_ADDRESS_REGISTERS_ARB = $88B3; - GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB = $88B4; - GL_MAX_PROGRAM_ENV_PARAMETERS_ARB = $88B5; - GL_PROGRAM_UNDER_NATIVE_LIMITS_ARB = $88B6; - GL_PROGRAM_STRING_ARB = $8628; - GL_PROGRAM_ERROR_POSITION_ARB = $864B; - GL_CURRENT_MATRIX_ARB = $8641; - GL_TRANSPOSE_CURRENT_MATRIX_ARB = $88B7; - GL_CURRENT_MATRIX_STACK_DEPTH_ARB = $8640; - GL_MAX_VERTEX_ATTRIBS_ARB = $8869; - GL_MAX_PROGRAM_MATRICES_ARB = $862F; - GL_MAX_PROGRAM_MATRIX_STACK_DEPTH_ARB = $862E; - GL_PROGRAM_ERROR_STRING_ARB = $8874; - GL_MATRIX0_ARB = $88C0; - GL_MATRIX1_ARB = $88C1; - GL_MATRIX2_ARB = $88C2; - GL_MATRIX3_ARB = $88C3; - GL_MATRIX4_ARB = $88C4; - GL_MATRIX5_ARB = $88C5; - GL_MATRIX6_ARB = $88C6; - GL_MATRIX7_ARB = $88C7; - GL_MATRIX8_ARB = $88C8; - GL_MATRIX9_ARB = $88C9; - GL_MATRIX10_ARB = $88CA; - GL_MATRIX11_ARB = $88CB; - GL_MATRIX12_ARB = $88CC; - GL_MATRIX13_ARB = $88CD; - GL_MATRIX14_ARB = $88CE; - GL_MATRIX15_ARB = $88CF; - GL_MATRIX16_ARB = $88D0; - GL_MATRIX17_ARB = $88D1; - GL_MATRIX18_ARB = $88D2; - GL_MATRIX19_ARB = $88D3; - GL_MATRIX20_ARB = $88D4; - GL_MATRIX21_ARB = $88D5; - GL_MATRIX22_ARB = $88D6; - GL_MATRIX23_ARB = $88D7; - GL_MATRIX24_ARB = $88D8; - GL_MATRIX25_ARB = $88D9; - GL_MATRIX26_ARB = $88DA; - GL_MATRIX27_ARB = $88DB; - GL_MATRIX28_ARB = $88DC; - GL_MATRIX29_ARB = $88DD; - GL_MATRIX30_ARB = $88DE; - GL_MATRIX31_ARB = $88DF; -var - glVertexAttrib1sARB: procedure(index: GLuint; x: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1fARB: procedure(index: GLuint; x: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1dARB: procedure(index: GLuint; x: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2sARB: procedure(index: GLuint; x: GLshort; y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2fARB: procedure(index: GLuint; x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2dARB: procedure(index: GLuint; x: GLdouble; y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3sARB: procedure(index: GLuint; x: GLshort; y: GLshort; z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3fARB: procedure(index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3dARB: procedure(index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4sARB: procedure(index: GLuint; x: GLshort; y: GLshort; z: GLshort; w: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4fARB: procedure(index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4dARB: procedure(index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NubARB: procedure(index: GLuint; x: GLubyte; y: GLubyte; z: GLubyte; w: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1svARB: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1fvARB: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1dvARB: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2svARB: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2fvARB: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2dvARB: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3svARB: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3fvARB: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3dvARB: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4bvARB: procedure(index: GLuint; const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4svARB: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4ivARB: procedure(index: GLuint; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4ubvARB: procedure(index: GLuint; const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4usvARB: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4uivARB: procedure(index: GLuint; const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4fvARB: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4dvARB: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NbvARB: procedure(index: GLuint; const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NsvARB: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NivARB: procedure(index: GLuint; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NubvARB: procedure(index: GLuint; const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NusvARB: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4NuivARB: procedure(index: GLuint; const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribPointerARB: procedure(index: GLuint; size: GLint; _type: GLenum; normalized: GLboolean; stride: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEnableVertexAttribArrayARB: procedure(index: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDisableVertexAttribArrayARB: procedure(index: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramStringARB: procedure(target: GLenum; format: GLenum; len: GLsizei; const _string: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindProgramARB: procedure(target: GLenum; _program: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteProgramsARB: procedure(n: GLsizei; const programs: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenProgramsARB: procedure(n: GLsizei; programs: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramEnvParameter4dARB: procedure(target: GLenum; index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramEnvParameter4dvARB: procedure(target: GLenum; index: GLuint; const params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramEnvParameter4fARB: procedure(target: GLenum; index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramEnvParameter4fvARB: procedure(target: GLenum; index: GLuint; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramLocalParameter4dARB: procedure(target: GLenum; index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramLocalParameter4dvARB: procedure(target: GLenum; index: GLuint; const params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramLocalParameter4fARB: procedure(target: GLenum; index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramLocalParameter4fvARB: procedure(target: GLenum; index: GLuint; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramEnvParameterdvARB: procedure(target: GLenum; index: GLuint; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramEnvParameterfvARB: procedure(target: GLenum; index: GLuint; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramLocalParameterdvARB: procedure(target: GLenum; index: GLuint; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramLocalParameterfvARB: procedure(target: GLenum; index: GLuint; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramivARB: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramStringARB: procedure(target: GLenum; pname: GLenum; _string: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribdvARB: procedure(index: GLuint; pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribfvARB: procedure(index: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribivARB: procedure(index: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribPointervARB: procedure(index: GLuint; pname: GLenum; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsProgramARB: function(_program: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_vertex_program: Boolean; - -//***** GL_ARB_window_pos *****// -var - glWindowPos2dARB: procedure(x: GLdouble; y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2fARB: procedure(x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2iARB: procedure(x: GLint; y: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2sARB: procedure(x: GLshort; y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2dvARB: procedure(const p: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2fvARB: procedure(const p: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2ivARB: procedure(const p: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2svARB: procedure(const p: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3dARB: procedure(x: GLdouble; y: GLdouble; z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3fARB: procedure(x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3iARB: procedure(x: GLint; y: GLint; z: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3sARB: procedure(x: GLshort; y: GLshort; z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3dvARB: procedure(const p: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3fvARB: procedure(const p: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3ivARB: procedure(const p: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3svARB: procedure(const p: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_window_pos: Boolean; - -//***** GL_EXT_422_pixels *****// -const - GL_422_EXT = $80CC; - GL_422_REV_EXT = $80CD; - GL_422_AVERAGE_EXT = $80CE; - GL_422_REV_AVERAGE_EXT = $80CF; - -function Load_GL_EXT_422_pixels: Boolean; - -//***** GL_EXT_abgr *****// -const - GL_ABGR_EXT = $8000; - -function Load_GL_EXT_abgr: Boolean; - -//***** GL_EXT_bgra *****// -const - GL_BGR_EXT = $80E0; - GL_BGRA_EXT = $80E1; - -function Load_GL_EXT_bgra: Boolean; - -//***** GL_EXT_blend_color *****// -const - GL_CONSTANT_COLOR_EXT = $8001; - GL_ONE_MINUS_CONSTANT_COLOR_EXT = $8002; - GL_CONSTANT_ALPHA_EXT = $8003; - GL_ONE_MINUS_CONSTANT_ALPHA_EXT = $8004; - GL_BLEND_COLOR_EXT = $8005; -var - glBlendColorEXT: procedure(red: GLclampf; green: GLclampf; blue: GLclampf; alpha: GLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_blend_color: Boolean; - -//***** GL_EXT_blend_func_separate *****// -const - GL_BLEND_DST_RGB_EXT = $80C8; - GL_BLEND_SRC_RGB_EXT = $80C9; - GL_BLEND_DST_ALPHA_EXT = $80CA; - GL_BLEND_SRC_ALPHA_EXT = $80CB; -var - glBlendFuncSeparateEXT: procedure(sfactorRGB: GLenum; dfactorRGB: GLenum; sfactorAlpha: GLenum; dfactorAlpha: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_blend_func_separate: Boolean; - -//***** GL_EXT_blend_logic_op *****// - -function Load_GL_EXT_blend_logic_op: Boolean; - -//***** GL_EXT_blend_minmax *****// -const - GL_FUNC_ADD_EXT = $8006; - GL_MIN_EXT = $8007; - GL_MAX_EXT = $8008; - GL_BLEND_EQUATION_EXT = $8009; -var - glBlendEquationEXT: procedure(mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_blend_minmax: Boolean; - -//***** GL_EXT_blend_subtract *****// -const - GL_FUNC_SUBTRACT_EXT = $800A; - GL_FUNC_REVERSE_SUBTRACT_EXT = $800B; - -function Load_GL_EXT_blend_subtract: Boolean; - -//***** GL_EXT_clip_volume_hint *****// -const - GL_CLIP_VOLUME_CLIPPING_HINT_EXT = $80F0; - -function Load_GL_EXT_clip_volume_hint: Boolean; - -//***** GL_EXT_color_subtable *****// -var - glColorSubTableEXT: procedure(target: GLenum; start: GLsizei; count: GLsizei; format: GLenum; _type: GLenum; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyColorSubTableEXT: procedure(target: GLenum; start: GLsizei; x: GLint; y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_color_subtable: Boolean; - -//***** GL_EXT_compiled_vertex_array *****// -const - GL_ARRAY_ELEMENT_LOCK_FIRST_EXT = $81A8; - GL_ARRAY_ELEMENT_LOCK_COUNT_EXT = $81A9; -var - glLockArraysEXT: procedure(first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUnlockArraysEXT: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_compiled_vertex_array: Boolean; - -//***** GL_EXT_convolution *****// -const - GL_CONVOLUTION_1D_EXT = $8010; - GL_CONVOLUTION_2D_EXT = $8011; - GL_SEPARABLE_2D_EXT = $8012; - GL_CONVOLUTION_BORDER_MODE_EXT = $8013; - GL_CONVOLUTION_FILTER_SCALE_EXT = $8014; - GL_CONVOLUTION_FILTER_BIAS_EXT = $8015; - GL_REDUCE_EXT = $8016; - GL_CONVOLUTION_FORMAT_EXT = $8017; - GL_CONVOLUTION_WIDTH_EXT = $8018; - GL_CONVOLUTION_HEIGHT_EXT = $8019; - GL_MAX_CONVOLUTION_WIDTH_EXT = $801A; - GL_MAX_CONVOLUTION_HEIGHT_EXT = $801B; - GL_POST_CONVOLUTION_RED_SCALE_EXT = $801C; - GL_POST_CONVOLUTION_GREEN_SCALE_EXT = $801D; - GL_POST_CONVOLUTION_BLUE_SCALE_EXT = $801E; - GL_POST_CONVOLUTION_ALPHA_SCALE_EXT = $801F; - GL_POST_CONVOLUTION_RED_BIAS_EXT = $8020; - GL_POST_CONVOLUTION_GREEN_BIAS_EXT = $8021; - GL_POST_CONVOLUTION_BLUE_BIAS_EXT = $8022; - GL_POST_CONVOLUTION_ALPHA_BIAS_EXT = $8023; -var - glConvolutionFilter1DEXT: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; format: GLenum; _type: GLenum; const image: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionFilter2DEXT: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; height: GLsizei; format: GLenum; _type: GLenum; const image: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyConvolutionFilter1DEXT: procedure(target: GLenum; internalformat: GLenum; x: GLint; y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyConvolutionFilter2DEXT: procedure(target: GLenum; internalformat: GLenum; x: GLint; y: GLint; width: GLsizei; height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetConvolutionFilterEXT: procedure(target: GLenum; format: GLenum; _type: GLenum; image: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSeparableFilter2DEXT: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; height: GLsizei; format: GLenum; _type: GLenum; const row: PGLvoid; const column: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetSeparableFilterEXT: procedure(target: GLenum; format: GLenum; _type: GLenum; row: PGLvoid; column: PGLvoid; span: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameteriEXT: procedure(target: GLenum; pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameterivEXT: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameterfEXT: procedure(target: GLenum; pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glConvolutionParameterfvEXT: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetConvolutionParameterivEXT: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetConvolutionParameterfvEXT: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_convolution: Boolean; - -//***** GL_EXT_histogram *****// -const - GL_HISTOGRAM_EXT = $8024; - GL_PROXY_HISTOGRAM_EXT = $8025; - GL_HISTOGRAM_WIDTH_EXT = $8026; - GL_HISTOGRAM_FORMAT_EXT = $8027; - GL_HISTOGRAM_RED_SIZE_EXT = $8028; - GL_HISTOGRAM_GREEN_SIZE_EXT = $8029; - GL_HISTOGRAM_BLUE_SIZE_EXT = $802A; - GL_HISTOGRAM_ALPHA_SIZE_EXT = $802B; - GL_HISTOGRAM_LUMINANCE_SIZE_EXT = $802C; - GL_HISTOGRAM_SINK_EXT = $802D; - GL_MINMAX_EXT = $802E; - GL_MINMAX_FORMAT_EXT = $802F; - GL_MINMAX_SINK_EXT = $8030; -var - glHistogramEXT: procedure(target: GLenum; width: GLsizei; internalformat: GLenum; sink: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glResetHistogramEXT: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHistogramEXT: procedure(target: GLenum; reset: GLboolean; format: GLenum; _type: GLenum; values: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHistogramParameterivEXT: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHistogramParameterfvEXT: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMinmaxEXT: procedure(target: GLenum; internalformat: GLenum; sink: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glResetMinmaxEXT: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMinmaxEXT: procedure(target: GLenum; reset: GLboolean; format: GLenum; _type: GLenum; values: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMinmaxParameterivEXT: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMinmaxParameterfvEXT: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_histogram: Boolean; - -//***** GL_EXT_multi_draw_arrays *****// -var - glMultiDrawArraysEXT: procedure(mode: GLenum; first: PGLint; count: PGLsizei; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawElementsEXT: procedure(mode: GLenum; count: PGLsizei; _type: GLenum; const indices: PGLvoid; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_multi_draw_arrays: Boolean; - -//***** GL_EXT_packed_pixels *****// -const - GL_UNSIGNED_BYTE_3_3_2_EXT = $8032; - GL_UNSIGNED_SHORT_4_4_4_4_EXT = $8033; - GL_UNSIGNED_SHORT_5_5_5_1_EXT = $8034; - GL_UNSIGNED_INT_8_8_8_8_EXT = $8035; - GL_UNSIGNED_INT_10_10_10_2_EXT = $8036; - -function Load_GL_EXT_packed_pixels: Boolean; - -//***** GL_EXT_paletted_texture *****// -const - GL_COLOR_INDEX1_EXT = $80E2; - GL_COLOR_INDEX2_EXT = $80E3; - GL_COLOR_INDEX4_EXT = $80E4; - GL_COLOR_INDEX8_EXT = $80E5; - GL_COLOR_INDEX12_EXT = $80E6; - GL_COLOR_INDEX16_EXT = $80E7; - GL_COLOR_TABLE_FORMAT_EXT = $80D8; - GL_COLOR_TABLE_WIDTH_EXT = $80D9; - GL_COLOR_TABLE_RED_SIZE_EXT = $80DA; - GL_COLOR_TABLE_GREEN_SIZE_EXT = $80DB; - GL_COLOR_TABLE_BLUE_SIZE_EXT = $80DC; - GL_COLOR_TABLE_ALPHA_SIZE_EXT = $80DD; - GL_COLOR_TABLE_LUMINANCE_SIZE_EXT = $80DE; - GL_COLOR_TABLE_INTENSITY_SIZE_EXT = $80DF; - GL_TEXTURE_INDEX_SIZE_EXT = $80ED; - GL_TEXTURE_1D = $0DE0; - GL_TEXTURE_2D = $0DE1; - GL_TEXTURE_3D_EXT = $806F; - // GL_TEXTURE_CUBE_MAP_ARB { already defined } - GL_PROXY_TEXTURE_1D = $8063; - GL_PROXY_TEXTURE_2D = $8064; - GL_PROXY_TEXTURE_3D_EXT = $8070; - // GL_PROXY_TEXTURE_CUBE_MAP_ARB { already defined } - // GL_TEXTURE_1D { already defined } - // GL_TEXTURE_2D { already defined } - // GL_TEXTURE_3D_EXT { already defined } - // GL_TEXTURE_CUBE_MAP_ARB { already defined } -var - glColorTableEXT: procedure(target: GLenum; internalFormat: GLenum; width: GLsizei; format: GLenum; _type: GLenum; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - // glColorSubTableEXT { already defined } - glGetColorTableEXT: procedure(target: GLenum; format: GLenum; _type: GLenum; data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableParameterivEXT: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableParameterfvEXT: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_paletted_texture: Boolean; - -//***** GL_EXT_point_parameters *****// -const - GL_POINT_SIZE_MIN_EXT = $8126; - GL_POINT_SIZE_MAX_EXT = $8127; - GL_POINT_FADE_THRESHOLD_SIZE_EXT = $8128; - GL_DISTANCE_ATTENUATION_EXT = $8129; -var - glPointParameterfEXT: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameterfvEXT: procedure(pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_point_parameters: Boolean; - -//***** GL_EXT_polygon_offset *****// -const - GL_POLYGON_OFFSET_EXT = $8037; - GL_POLYGON_OFFSET_FACTOR_EXT = $8038; - GL_POLYGON_OFFSET_BIAS_EXT = $8039; -var - glPolygonOffsetEXT: procedure(factor: GLfloat; bias: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_polygon_offset: Boolean; - -//***** GL_EXT_separate_specular_color *****// -const - GL_LIGHT_MODEL_COLOR_CONTROL_EXT = $81F8; - GL_SINGLE_COLOR_EXT = $81F9; - GL_SEPARATE_SPECULAR_COLOR_EXT = $81FA; - -function Load_GL_EXT_separate_specular_color: Boolean; - -//***** GL_EXT_shadow_funcs *****// - -function Load_GL_EXT_shadow_funcs: Boolean; - -//***** GL_EXT_shared_texture_palette *****// -const - GL_SHARED_TEXTURE_PALETTE_EXT = $81FB; - -function Load_GL_EXT_shared_texture_palette: Boolean; - -//***** GL_EXT_stencil_two_side *****// -const - GL_STENCIL_TEST_TWO_SIDE_EXT = $8910; - GL_ACTIVE_STENCIL_FACE_EXT = $8911; -var - glActiveStencilFaceEXT: procedure(face: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_stencil_two_side: Boolean; - -//***** GL_EXT_stencil_wrap *****// -const - GL_INCR_WRAP_EXT = $8507; - GL_DECR_WRAP_EXT = $8508; - -function Load_GL_EXT_stencil_wrap: Boolean; - -//***** GL_EXT_subtexture *****// -var - glTexSubImage1DEXT: procedure(target: GLenum; level: GLint; xoffset: GLint; width: GLsizei; format: GLenum; _type: GLenum; const pixels: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexSubImage2DEXT: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; width: GLsizei; height: GLsizei; format: GLenum; _type: GLenum; const pixels: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexSubImage3DEXT: procedure(target: GLenum; level: GLint; xoffset: GLint; yoffset: GLint; zoffset: GLint; width: GLsizei; height: GLsizei; depth: GLsizei; format: GLenum; _type: GLenum; const pixels: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_subtexture: Boolean; - -//***** GL_EXT_texture3D *****// -const - GL_PACK_SKIP_IMAGES_EXT = $806B; - GL_PACK_IMAGE_HEIGHT_EXT = $806C; - GL_UNPACK_SKIP_IMAGES_EXT = $806D; - GL_UNPACK_IMAGE_HEIGHT_EXT = $806E; - // GL_TEXTURE_3D_EXT { already defined } - // GL_PROXY_TEXTURE_3D_EXT { already defined } - GL_TEXTURE_DEPTH_EXT = $8071; - GL_TEXTURE_WRAP_R_EXT = $8072; - GL_MAX_3D_TEXTURE_SIZE_EXT = $8073; -var - glTexImage3DEXT: procedure(target: GLenum; level: GLint; internalformat: GLenum; width: GLsizei; height: GLsizei; depth: GLsizei; border: GLint; format: GLenum; _type: GLenum; const pixels: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_texture3D: Boolean; - -//***** GL_EXT_texture_compression_s3tc *****// -const - GL_COMPRESSED_RGB_S3TC_DXT1_EXT = $83F0; - GL_COMPRESSED_RGBA_S3TC_DXT1_EXT = $83F1; - GL_COMPRESSED_RGBA_S3TC_DXT3_EXT = $83F2; - GL_COMPRESSED_RGBA_S3TC_DXT5_EXT = $83F3; - -function Load_GL_EXT_texture_compression_s3tc: Boolean; - -//***** GL_EXT_texture_env_add *****// - -function Load_GL_EXT_texture_env_add: Boolean; - -//***** GL_EXT_texture_env_combine *****// -const - GL_COMBINE_EXT = $8570; - GL_COMBINE_RGB_EXT = $8571; - GL_COMBINE_ALPHA_EXT = $8572; - GL_SOURCE0_RGB_EXT = $8580; - GL_SOURCE1_RGB_EXT = $8581; - GL_SOURCE2_RGB_EXT = $8582; - GL_SOURCE0_ALPHA_EXT = $8588; - GL_SOURCE1_ALPHA_EXT = $8589; - GL_SOURCE2_ALPHA_EXT = $858A; - GL_OPERAND0_RGB_EXT = $8590; - GL_OPERAND1_RGB_EXT = $8591; - GL_OPERAND2_RGB_EXT = $8592; - GL_OPERAND0_ALPHA_EXT = $8598; - GL_OPERAND1_ALPHA_EXT = $8599; - GL_OPERAND2_ALPHA_EXT = $859A; - GL_RGB_SCALE_EXT = $8573; - GL_ADD_SIGNED_EXT = $8574; - GL_INTERPOLATE_EXT = $8575; - GL_CONSTANT_EXT = $8576; - GL_PRIMARY_COLOR_EXT = $8577; - GL_PREVIOUS_EXT = $8578; - -function Load_GL_EXT_texture_env_combine: Boolean; - -//***** GL_EXT_texture_env_dot3 *****// -const - GL_DOT3_RGB_EXT = $8740; - GL_DOT3_RGBA_EXT = $8741; - -function Load_GL_EXT_texture_env_dot3: Boolean; - -//***** GL_EXT_texture_filter_anisotropic *****// -const - GL_TEXTURE_MAX_ANISOTROPY_EXT = $84FE; - GL_MAX_TEXTURE_MAX_ANISOTROPY_EXT = $84FF; - -function Load_GL_EXT_texture_filter_anisotropic: Boolean; - -//***** GL_EXT_texture_lod_bias *****// -const - GL_TEXTURE_FILTER_CONTROL_EXT = $8500; - GL_TEXTURE_LOD_BIAS_EXT = $8501; - GL_MAX_TEXTURE_LOD_BIAS_EXT = $84FD; - -function Load_GL_EXT_texture_lod_bias: Boolean; - -//***** GL_EXT_texture_object *****// -const - GL_TEXTURE_PRIORITY_EXT = $8066; - GL_TEXTURE_RESIDENT_EXT = $8067; - GL_TEXTURE_1D_BINDING_EXT = $8068; - GL_TEXTURE_2D_BINDING_EXT = $8069; - GL_TEXTURE_3D_BINDING_EXT = $806A; -var - glGenTexturesEXT: procedure(n: GLsizei; textures: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteTexturesEXT: procedure(n: GLsizei; const textures: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindTextureEXT: procedure(target: GLenum; texture: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPrioritizeTexturesEXT: procedure(n: GLsizei; const textures: PGLuint; const priorities: PGLclampf); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAreTexturesResidentEXT: function(n: GLsizei; const textures: PGLuint; residences: PGLboolean): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsTextureEXT: function(texture: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_texture_object: Boolean; - -//***** GL_EXT_vertex_array *****// -const - GL_VERTEX_ARRAY_EXT = $8074; - GL_NORMAL_ARRAY_EXT = $8075; - GL_COLOR_ARRAY_EXT = $8076; - GL_INDEX_ARRAY_EXT = $8077; - GL_TEXTURE_COORD_ARRAY_EXT = $8078; - GL_EDGE_FLAG_ARRAY_EXT = $8079; - GL_DOUBLE_EXT = $140A; - GL_VERTEX_ARRAY_SIZE_EXT = $807A; - GL_VERTEX_ARRAY_TYPE_EXT = $807B; - GL_VERTEX_ARRAY_STRIDE_EXT = $807C; - GL_VERTEX_ARRAY_COUNT_EXT = $807D; - GL_NORMAL_ARRAY_TYPE_EXT = $807E; - GL_NORMAL_ARRAY_STRIDE_EXT = $807F; - GL_NORMAL_ARRAY_COUNT_EXT = $8080; - GL_COLOR_ARRAY_SIZE_EXT = $8081; - GL_COLOR_ARRAY_TYPE_EXT = $8082; - GL_COLOR_ARRAY_STRIDE_EXT = $8083; - GL_COLOR_ARRAY_COUNT_EXT = $8084; - GL_INDEX_ARRAY_TYPE_EXT = $8085; - GL_INDEX_ARRAY_STRIDE_EXT = $8086; - GL_INDEX_ARRAY_COUNT_EXT = $8087; - GL_TEXTURE_COORD_ARRAY_SIZE_EXT = $8088; - GL_TEXTURE_COORD_ARRAY_TYPE_EXT = $8089; - GL_TEXTURE_COORD_ARRAY_STRIDE_EXT = $808A; - GL_TEXTURE_COORD_ARRAY_COUNT_EXT = $808B; - GL_EDGE_FLAG_ARRAY_STRIDE_EXT = $808C; - GL_EDGE_FLAG_ARRAY_COUNT_EXT = $808D; - GL_VERTEX_ARRAY_POINTER_EXT = $808E; - GL_NORMAL_ARRAY_POINTER_EXT = $808F; - GL_COLOR_ARRAY_POINTER_EXT = $8090; - GL_INDEX_ARRAY_POINTER_EXT = $8091; - GL_TEXTURE_COORD_ARRAY_POINTER_EXT = $8092; - GL_EDGE_FLAG_ARRAY_POINTER_EXT = $8093; -var - glArrayElementEXT: procedure(i: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawArraysEXT: procedure(mode: GLenum; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexPointerEXT: procedure(size: GLint; _type: GLenum; stride: GLsizei; count: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalPointerEXT: procedure(_type: GLenum; stride: GLsizei; count: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorPointerEXT: procedure(size: GLint; _type: GLenum; stride: GLsizei; count: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIndexPointerEXT: procedure(_type: GLenum; stride: GLsizei; count: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoordPointerEXT: procedure(size: GLint; _type: GLenum; stride: GLsizei; count: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEdgeFlagPointerEXT: procedure(stride: GLsizei; count: GLsizei; const pointer: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPointervEXT: procedure(pname: GLenum; params: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_vertex_array: Boolean; - -//***** GL_EXT_vertex_shader *****// -const - GL_VERTEX_SHADER_EXT = $8780; - GL_VARIANT_VALUE_EXT = $87E4; - GL_VARIANT_DATATYPE_EXT = $87E5; - GL_VARIANT_ARRAY_STRIDE_EXT = $87E6; - GL_VARIANT_ARRAY_TYPE_EXT = $87E7; - GL_VARIANT_ARRAY_EXT = $87E8; - GL_VARIANT_ARRAY_POINTER_EXT = $87E9; - GL_INVARIANT_VALUE_EXT = $87EA; - GL_INVARIANT_DATATYPE_EXT = $87EB; - GL_LOCAL_CONSTANT_VALUE_EXT = $87EC; - GL_LOCAL_CONSTANT_DATATYPE_EXT = $87ED; - GL_OP_INDEX_EXT = $8782; - GL_OP_NEGATE_EXT = $8783; - GL_OP_DOT3_EXT = $8784; - GL_OP_DOT4_EXT = $8785; - GL_OP_MUL_EXT = $8786; - GL_OP_ADD_EXT = $8787; - GL_OP_MADD_EXT = $8788; - GL_OP_FRAC_EXT = $8789; - GL_OP_MAX_EXT = $878A; - GL_OP_MIN_EXT = $878B; - GL_OP_SET_GE_EXT = $878C; - GL_OP_SET_LT_EXT = $878D; - GL_OP_CLAMP_EXT = $878E; - GL_OP_FLOOR_EXT = $878F; - GL_OP_ROUND_EXT = $8790; - GL_OP_EXP_BASE_2_EXT = $8791; - GL_OP_LOG_BASE_2_EXT = $8792; - GL_OP_POWER_EXT = $8793; - GL_OP_RECIP_EXT = $8794; - GL_OP_RECIP_SQRT_EXT = $8795; - GL_OP_SUB_EXT = $8796; - GL_OP_CROSS_PRODUCT_EXT = $8797; - GL_OP_MULTIPLY_MATRIX_EXT = $8798; - GL_OP_MOV_EXT = $8799; - GL_OUTPUT_VERTEX_EXT = $879A; - GL_OUTPUT_COLOR0_EXT = $879B; - GL_OUTPUT_COLOR1_EXT = $879C; - GL_OUTPUT_TEXTURE_COORD0_EXT = $879D; - GL_OUTPUT_TEXTURE_COORD1_EXT = $879E; - GL_OUTPUT_TEXTURE_COORD2_EXT = $879F; - GL_OUTPUT_TEXTURE_COORD3_EXT = $87A0; - GL_OUTPUT_TEXTURE_COORD4_EXT = $87A1; - GL_OUTPUT_TEXTURE_COORD5_EXT = $87A2; - GL_OUTPUT_TEXTURE_COORD6_EXT = $87A3; - GL_OUTPUT_TEXTURE_COORD7_EXT = $87A4; - GL_OUTPUT_TEXTURE_COORD8_EXT = $87A5; - GL_OUTPUT_TEXTURE_COORD9_EXT = $87A6; - GL_OUTPUT_TEXTURE_COORD10_EXT = $87A7; - GL_OUTPUT_TEXTURE_COORD11_EXT = $87A8; - GL_OUTPUT_TEXTURE_COORD12_EXT = $87A9; - GL_OUTPUT_TEXTURE_COORD13_EXT = $87AA; - GL_OUTPUT_TEXTURE_COORD14_EXT = $87AB; - GL_OUTPUT_TEXTURE_COORD15_EXT = $87AC; - GL_OUTPUT_TEXTURE_COORD16_EXT = $87AD; - GL_OUTPUT_TEXTURE_COORD17_EXT = $87AE; - GL_OUTPUT_TEXTURE_COORD18_EXT = $87AF; - GL_OUTPUT_TEXTURE_COORD19_EXT = $87B0; - GL_OUTPUT_TEXTURE_COORD20_EXT = $87B1; - GL_OUTPUT_TEXTURE_COORD21_EXT = $87B2; - GL_OUTPUT_TEXTURE_COORD22_EXT = $87B3; - GL_OUTPUT_TEXTURE_COORD23_EXT = $87B4; - GL_OUTPUT_TEXTURE_COORD24_EXT = $87B5; - GL_OUTPUT_TEXTURE_COORD25_EXT = $87B6; - GL_OUTPUT_TEXTURE_COORD26_EXT = $87B7; - GL_OUTPUT_TEXTURE_COORD27_EXT = $87B8; - GL_OUTPUT_TEXTURE_COORD28_EXT = $87B9; - GL_OUTPUT_TEXTURE_COORD29_EXT = $87BA; - GL_OUTPUT_TEXTURE_COORD30_EXT = $87BB; - GL_OUTPUT_TEXTURE_COORD31_EXT = $87BC; - GL_OUTPUT_FOG_EXT = $87BD; - GL_SCALAR_EXT = $87BE; - GL_VECTOR_EXT = $87BF; - GL_MATRIX_EXT = $87C0; - GL_VARIANT_EXT = $87C1; - GL_INVARIANT_EXT = $87C2; - GL_LOCAL_CONSTANT_EXT = $87C3; - GL_LOCAL_EXT = $87C4; - GL_MAX_VERTEX_SHADER_INSTRUCTIONS_EXT = $87C5; - GL_MAX_VERTEX_SHADER_VARIANTS_EXT = $87C6; - GL_MAX_VERTEX_SHADER_INVARIANTS_EXT = $87C7; - GL_MAX_VERTEX_SHADER_LOCAL_CONSTANTS_EXT = $87C8; - GL_MAX_VERTEX_SHADER_LOCALS_EXT = $87C9; - GL_MAX_OPTIMIZED_VERTEX_SHADER_INSTRUCTIONS_EXT = $87CA; - GL_MAX_OPTIMIZED_VERTEX_SHADER_VARIANTS_EXT = $87CB; - GL_MAX_OPTIMIZED_VERTEX_SHADER_LOCAL_CONSTANTS_EXT = $87CC; - GL_MAX_OPTIMIZED_VERTEX_SHADER_INVARIANTS_EXT = $87CD; - GL_MAX_OPTIMIZED_VERTEX_SHADER_LOCALS_EXT = $87CE; - GL_VERTEX_SHADER_INSTRUCTIONS_EXT = $87CF; - GL_VERTEX_SHADER_VARIANTS_EXT = $87D0; - GL_VERTEX_SHADER_INVARIANTS_EXT = $87D1; - GL_VERTEX_SHADER_LOCAL_CONSTANTS_EXT = $87D2; - GL_VERTEX_SHADER_LOCALS_EXT = $87D3; - GL_VERTEX_SHADER_BINDING_EXT = $8781; - GL_VERTEX_SHADER_OPTIMIZED_EXT = $87D4; - GL_X_EXT = $87D5; - GL_Y_EXT = $87D6; - GL_Z_EXT = $87D7; - GL_W_EXT = $87D8; - GL_NEGATIVE_X_EXT = $87D9; - GL_NEGATIVE_Y_EXT = $87DA; - GL_NEGATIVE_Z_EXT = $87DB; - GL_NEGATIVE_W_EXT = $87DC; - GL_ZERO_EXT = $87DD; - GL_ONE_EXT = $87DE; - GL_NEGATIVE_ONE_EXT = $87DF; - GL_NORMALIZED_RANGE_EXT = $87E0; - GL_FULL_RANGE_EXT = $87E1; - GL_CURRENT_VERTEX_EXT = $87E2; - GL_MVP_MATRIX_EXT = $87E3; -var - glBeginVertexShaderEXT: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEndVertexShaderEXT: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindVertexShaderEXT: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenVertexShadersEXT: function(range: GLuint): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteVertexShaderEXT: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glShaderOp1EXT: procedure(op: GLenum; res: GLuint; arg1: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glShaderOp2EXT: procedure(op: GLenum; res: GLuint; arg1: GLuint; arg2: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glShaderOp3EXT: procedure(op: GLenum; res: GLuint; arg1: GLuint; arg2: GLuint; arg3: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSwizzleEXT: procedure(res: GLuint; _in: GLuint; outX: GLenum; outY: GLenum; outZ: GLenum; outW: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWriteMaskEXT: procedure(res: GLuint; _in: GLuint; outX: GLenum; outY: GLenum; outZ: GLenum; outW: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glInsertComponentEXT: procedure(res: GLuint; src: GLuint; num: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glExtractComponentEXT: procedure(res: GLuint; src: GLuint; num: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenSymbolsEXT: function(datatype: GLenum; storagetype: GLenum; range: GLenum; components: GLuint): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSetInvariantEXT: procedure(id: GLuint; _type: GLenum; addr: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSetLocalConstantEXT: procedure(id: GLuint; _type: GLenum; addr: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantbvEXT: procedure(id: GLuint; addr: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantsvEXT: procedure(id: GLuint; addr: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantivEXT: procedure(id: GLuint; addr: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantfvEXT: procedure(id: GLuint; addr: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantdvEXT: procedure(id: GLuint; addr: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantubvEXT: procedure(id: GLuint; addr: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantusvEXT: procedure(id: GLuint; addr: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantuivEXT: procedure(id: GLuint; addr: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantPointerEXT: procedure(id: GLuint; _type: GLenum; stride: GLuint; addr: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEnableVariantClientStateEXT: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDisableVariantClientStateEXT: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindLightParameterEXT: function(light: GLenum; value: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindMaterialParameterEXT: function(face: GLenum; value: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindTexGenParameterEXT: function(_unit: GLenum; coord: GLenum; value: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindTextureUnitParameterEXT: function(_unit: GLenum; value: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindParameterEXT: function(value: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsVariantEnabledEXT: function(id: GLuint; cap: GLenum): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVariantBooleanvEXT: procedure(id: GLuint; value: GLenum; data: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVariantIntegervEXT: procedure(id: GLuint; value: GLenum; data: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVariantFloatvEXT: procedure(id: GLuint; value: GLenum; data: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVariantPointervEXT: procedure(id: GLuint; value: GLenum; data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetInvariantBooleanvEXT: procedure(id: GLuint; value: GLenum; data: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetInvariantIntegervEXT: procedure(id: GLuint; value: GLenum; data: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetInvariantFloatvEXT: procedure(id: GLuint; value: GLenum; data: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetLocalConstantBooleanvEXT: procedure(id: GLuint; value: GLenum; data: PGLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetLocalConstantIntegervEXT: procedure(id: GLuint; value: GLenum; data: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetLocalConstantFloatvEXT: procedure(id: GLuint; value: GLenum; data: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_vertex_shader: Boolean; - -//***** GL_EXT_vertex_weighting *****// -const - GL_VERTEX_WEIGHTING_EXT = $8509; - GL_MODELVIEW0_EXT = $1700; - GL_MODELVIEW1_EXT = $850A; - GL_MODELVIEW0_MATRIX_EXT = $0BA6; - GL_MODELVIEW1_MATRIX_EXT = $8506; - GL_CURRENT_VERTEX_WEIGHT_EXT = $850B; - GL_VERTEX_WEIGHT_ARRAY_EXT = $850C; - GL_VERTEX_WEIGHT_ARRAY_SIZE_EXT = $850D; - GL_VERTEX_WEIGHT_ARRAY_TYPE_EXT = $850E; - GL_VERTEX_WEIGHT_ARRAY_STRIDE_EXT = $850F; - GL_MODELVIEW0_STACK_DEPTH_EXT = $0BA3; - GL_MODELVIEW1_STACK_DEPTH_EXT = $8502; - GL_VERTEX_WEIGHT_ARRAY_POINTER_EXT = $8510; -var - glVertexWeightfEXT: procedure(weight: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexWeightfvEXT: procedure(weight: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexWeightPointerEXT: procedure(size: GLint; _type: GLenum; stride: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_vertex_weighting: Boolean; - -//***** GL_HP_occlusion_test *****// -const - GL_OCCLUSION_TEST_HP = $8165; - GL_OCCLUSION_TEST_RESULT_HP = $8166; - -function Load_GL_HP_occlusion_test: Boolean; - -//***** GL_NV_blend_square *****// - -function Load_GL_NV_blend_square: Boolean; - -//***** GL_NV_copy_depth_to_color *****// -const - GL_DEPTH_STENCIL_TO_RGBA_NV = $886E; - GL_DEPTH_STENCIL_TO_BGRA_NV = $886F; - -function Load_GL_NV_copy_depth_to_color: Boolean; - -//***** GL_NV_depth_clamp *****// -const - GL_DEPTH_CLAMP_NV = $864F; - -function Load_GL_NV_depth_clamp: Boolean; - -//***** GL_NV_evaluators *****// -const - GL_EVAL_2D_NV = $86C0; - GL_EVAL_TRIANGULAR_2D_NV = $86C1; - GL_MAP_TESSELLATION_NV = $86C2; - GL_MAP_ATTRIB_U_ORDER_NV = $86C3; - GL_MAP_ATTRIB_V_ORDER_NV = $86C4; - GL_EVAL_FRACTIONAL_TESSELLATION_NV = $86C5; - GL_EVAL_VERTEX_ATTRIB0_NV = $86C6; - GL_EVAL_VERTEX_ATTRIB1_NV = $86C7; - GL_EVAL_VERTEX_ATTRIB2_NV = $86C8; - GL_EVAL_VERTEX_ATTRIB3_NV = $86C9; - GL_EVAL_VERTEX_ATTRIB4_NV = $86CA; - GL_EVAL_VERTEX_ATTRIB5_NV = $86CB; - GL_EVAL_VERTEX_ATTRIB6_NV = $86CC; - GL_EVAL_VERTEX_ATTRIB7_NV = $86CD; - GL_EVAL_VERTEX_ATTRIB8_NV = $86CE; - GL_EVAL_VERTEX_ATTRIB9_NV = $86CF; - GL_EVAL_VERTEX_ATTRIB10_NV = $86D0; - GL_EVAL_VERTEX_ATTRIB11_NV = $86D1; - GL_EVAL_VERTEX_ATTRIB12_NV = $86D2; - GL_EVAL_VERTEX_ATTRIB13_NV = $86D3; - GL_EVAL_VERTEX_ATTRIB14_NV = $86D4; - GL_EVAL_VERTEX_ATTRIB15_NV = $86D5; - GL_MAX_MAP_TESSELLATION_NV = $86D6; - GL_MAX_RATIONAL_EVAL_ORDER_NV = $86D7; -var - glMapControlPointsNV: procedure(target: GLenum; index: GLuint; _type: GLenum; ustride: GLsizei; vstride: GLsizei; uorder: GLint; vorder: GLint; _packed: GLboolean; const points: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapParameterivNV: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapParameterfvNV: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapControlPointsNV: procedure(target: GLenum; index: GLuint; _type: GLenum; ustride: GLsizei; vstride: GLsizei; _packed: GLboolean; points: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapParameterivNV: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapParameterfvNV: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapAttribParameterivNV: procedure(target: GLenum; index: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetMapAttribParameterfvNV: procedure(target: GLenum; index: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEvalMapsNV: procedure(target: GLenum; mode: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_evaluators: Boolean; - -//***** GL_NV_fence *****// -const - GL_ALL_COMPLETED_NV = $84F2; - GL_FENCE_STATUS_NV = $84F3; - GL_FENCE_CONDITION_NV = $84F4; -var - glGenFencesNV: procedure(n: GLsizei; fences: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteFencesNV: procedure(n: GLsizei; const fences: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSetFenceNV: procedure(fence: GLuint; condition: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTestFenceNV: function(fence: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFinishFenceNV: procedure(fence: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsFenceNV: function(fence: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetFenceivNV: procedure(fence: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_fence: Boolean; - -//***** GL_NV_fog_distance *****// -const - GL_FOG_DISTANCE_MODE_NV = $855A; - GL_EYE_RADIAL_NV = $855B; - GL_EYE_PLANE_ABSOLUTE_NV = $855C; - -function Load_GL_NV_fog_distance: Boolean; - -//***** GL_NV_light_max_exponent *****// -const - GL_MAX_SHININESS_NV = $8504; - GL_MAX_SPOT_EXPONENT_NV = $8505; - -function Load_GL_NV_light_max_exponent: Boolean; - -//***** GL_NV_multisample_filter_hint *****// -const - GL_MULTISAMPLE_FILTER_HINT_NV = $8534; - -function Load_GL_NV_multisample_filter_hint: Boolean; - -//***** GL_NV_occlusion_query *****// - // GL_OCCLUSION_TEST_HP { already defined } - // GL_OCCLUSION_TEST_RESULT_HP { already defined } -const - GL_PIXEL_COUNTER_BITS_NV = $8864; - GL_CURRENT_OCCLUSION_QUERY_ID_NV = $8865; - GL_PIXEL_COUNT_NV = $8866; - GL_PIXEL_COUNT_AVAILABLE_NV = $8867; -var - glGenOcclusionQueriesNV: procedure(n: GLsizei; ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteOcclusionQueriesNV: procedure(n: GLsizei; const ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsOcclusionQueryNV: function(id: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBeginOcclusionQueryNV: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEndOcclusionQueryNV: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetOcclusionQueryivNV: procedure(id: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetOcclusionQueryuivNV: procedure(id: GLuint; pname: GLenum; params: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_occlusion_query: Boolean; - -//***** GL_NV_packed_depth_stencil *****// -const - GL_DEPTH_STENCIL_NV = $84F9; - GL_UNSIGNED_INT_24_8_NV = $84FA; - -function Load_GL_NV_packed_depth_stencil: Boolean; - -//***** GL_NV_point_sprite *****// -const - GL_POINT_SPRITE_NV = $8861; - GL_COORD_REPLACE_NV = $8862; - GL_POINT_SPRITE_R_MODE_NV = $8863; -var - glPointParameteriNV: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameterivNV: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_point_sprite: Boolean; - -//***** GL_NV_register_combiners *****// -const - GL_REGISTER_COMBINERS_NV = $8522; - GL_COMBINER0_NV = $8550; - GL_COMBINER1_NV = $8551; - GL_COMBINER2_NV = $8552; - GL_COMBINER3_NV = $8553; - GL_COMBINER4_NV = $8554; - GL_COMBINER5_NV = $8555; - GL_COMBINER6_NV = $8556; - GL_COMBINER7_NV = $8557; - GL_VARIABLE_A_NV = $8523; - GL_VARIABLE_B_NV = $8524; - GL_VARIABLE_C_NV = $8525; - GL_VARIABLE_D_NV = $8526; - GL_VARIABLE_E_NV = $8527; - GL_VARIABLE_F_NV = $8528; - GL_VARIABLE_G_NV = $8529; - GL_CONSTANT_COLOR0_NV = $852A; - GL_CONSTANT_COLOR1_NV = $852B; - GL_PRIMARY_COLOR_NV = $852C; - GL_SECONDARY_COLOR_NV = $852D; - GL_SPARE0_NV = $852E; - GL_SPARE1_NV = $852F; - GL_UNSIGNED_IDENTITY_NV = $8536; - GL_UNSIGNED_INVERT_NV = $8537; - GL_EXPAND_NORMAL_NV = $8538; - GL_EXPAND_NEGATE_NV = $8539; - GL_HALF_BIAS_NORMAL_NV = $853A; - GL_HALF_BIAS_NEGATE_NV = $853B; - GL_SIGNED_IDENTITY_NV = $853C; - GL_SIGNED_NEGATE_NV = $853D; - GL_E_TIMES_F_NV = $8531; - GL_SPARE0_PLUS_SECONDARY_COLOR_NV = $8532; - GL_SCALE_BY_TWO_NV = $853E; - GL_SCALE_BY_FOUR_NV = $853F; - GL_SCALE_BY_ONE_HALF_NV = $8540; - GL_BIAS_BY_NEGATIVE_ONE_HALF_NV = $8541; - GL_DISCARD_NV = $8530; - GL_COMBINER_INPUT_NV = $8542; - GL_COMBINER_MAPPING_NV = $8543; - GL_COMBINER_COMPONENT_USAGE_NV = $8544; - GL_COMBINER_AB_DOT_PRODUCT_NV = $8545; - GL_COMBINER_CD_DOT_PRODUCT_NV = $8546; - GL_COMBINER_MUX_SUM_NV = $8547; - GL_COMBINER_SCALE_NV = $8548; - GL_COMBINER_BIAS_NV = $8549; - GL_COMBINER_AB_OUTPUT_NV = $854A; - GL_COMBINER_CD_OUTPUT_NV = $854B; - GL_COMBINER_SUM_OUTPUT_NV = $854C; - GL_NUM_GENERAL_COMBINERS_NV = $854E; - GL_COLOR_SUM_CLAMP_NV = $854F; - GL_MAX_GENERAL_COMBINERS_NV = $854D; -var - glCombinerParameterfvNV: procedure(pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCombinerParameterivNV: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCombinerParameterfNV: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCombinerParameteriNV: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCombinerInputNV: procedure(stage: GLenum; portion: GLenum; variable: GLenum; input: GLenum; mapping: GLenum; componentUsage: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCombinerOutputNV: procedure(stage: GLenum; portion: GLenum; abOutput: GLenum; cdOutput: GLenum; sumOutput: GLenum; scale: GLenum; bias: GLenum; abDotProduct: GLboolean; cdDotProduct: GLboolean; muxSum: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFinalCombinerInputNV: procedure(variable: GLenum; input: GLenum; mapping: GLenum; componentUsage: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCombinerInputParameterfvNV: procedure(stage: GLenum; portion: GLenum; variable: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCombinerInputParameterivNV: procedure(stage: GLenum; portion: GLenum; variable: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCombinerOutputParameterfvNV: procedure(stage: GLenum; portion: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCombinerOutputParameterivNV: procedure(stage: GLenum; portion: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetFinalCombinerInputParameterfvNV: procedure(variable: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetFinalCombinerInputParameterivNV: procedure(variable: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_register_combiners: Boolean; - -//***** GL_NV_register_combiners2 *****// -const - GL_PER_STAGE_CONSTANTS_NV = $8535; -var - glCombinerStageParameterfvNV: procedure(stage: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetCombinerStageParameterfvNV: procedure(stage: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_register_combiners2: Boolean; - -//***** GL_NV_texgen_emboss *****// -const - GL_EMBOSS_MAP_NV = $855F; - GL_EMBOSS_LIGHT_NV = $855D; - GL_EMBOSS_CONSTANT_NV = $855E; - -function Load_GL_NV_texgen_emboss: Boolean; - -//***** GL_NV_texgen_reflection *****// -const - GL_NORMAL_MAP_NV = $8511; - GL_REFLECTION_MAP_NV = $8512; - -function Load_GL_NV_texgen_reflection: Boolean; - -//***** GL_NV_texture_compression_vtc *****// - // GL_COMPRESSED_RGB_S3TC_DXT1_EXT { already defined } - // GL_COMPRESSED_RGBA_S3TC_DXT1_EXT { already defined } - // GL_COMPRESSED_RGBA_S3TC_DXT3_EXT { already defined } - // GL_COMPRESSED_RGBA_S3TC_DXT5_EXT { already defined } - -function Load_GL_NV_texture_compression_vtc: Boolean; - -//***** GL_NV_texture_env_combine4 *****// -const - GL_COMBINE4_NV = $8503; - GL_SOURCE3_RGB_NV = $8583; - GL_SOURCE3_ALPHA_NV = $858B; - GL_OPERAND3_RGB_NV = $8593; - GL_OPERAND3_ALPHA_NV = $859B; - -function Load_GL_NV_texture_env_combine4: Boolean; - -//***** GL_NV_texture_rectangle *****// -const - GL_TEXTURE_RECTANGLE_NV = $84F5; - GL_TEXTURE_BINDING_RECTANGLE_NV = $84F6; - GL_PROXY_TEXTURE_RECTANGLE_NV = $84F7; - GL_MAX_RECTANGLE_TEXTURE_SIZE_NV = $84F8; - -function Load_GL_NV_texture_rectangle: Boolean; - -//***** GL_NV_texture_shader *****// -const - GL_TEXTURE_SHADER_NV = $86DE; - GL_RGBA_UNSIGNED_DOT_PRODUCT_MAPPING_NV = $86D9; - GL_SHADER_OPERATION_NV = $86DF; - GL_CULL_MODES_NV = $86E0; - GL_OFFSET_TEXTURE_MATRIX_NV = $86E1; - GL_OFFSET_TEXTURE_SCALE_NV = $86E2; - GL_OFFSET_TEXTURE_BIAS_NV = $86E3; - GL_PREVIOUS_TEXTURE_INPUT_NV = $86E4; - GL_CONST_EYE_NV = $86E5; - GL_SHADER_CONSISTENT_NV = $86DD; - GL_PASS_THROUGH_NV = $86E6; - GL_CULL_FRAGMENT_NV = $86E7; - GL_OFFSET_TEXTURE_2D_NV = $86E8; - GL_OFFSET_TEXTURE_RECTANGLE_NV = $864C; - GL_OFFSET_TEXTURE_RECTANGLE_SCALE_NV = $864D; - GL_DEPENDENT_AR_TEXTURE_2D_NV = $86E9; - GL_DEPENDENT_GB_TEXTURE_2D_NV = $86EA; - GL_DOT_PRODUCT_NV = $86EC; - GL_DOT_PRODUCT_DEPTH_REPLACE_NV = $86ED; - GL_DOT_PRODUCT_TEXTURE_2D_NV = $86EE; - GL_DOT_PRODUCT_TEXTURE_RECTANGLE_NV = $864E; - GL_DOT_PRODUCT_TEXTURE_CUBE_MAP_NV = $86F0; - GL_DOT_PRODUCT_DIFFUSE_CUBE_MAP_NV = $86F1; - GL_DOT_PRODUCT_REFLECT_CUBE_MAP_NV = $86F2; - GL_DOT_PRODUCT_CONST_EYE_REFLECT_CUBE_MAP_NV = $86F3; - GL_HILO_NV = $86F4; - GL_DSDT_NV = $86F5; - GL_DSDT_MAG_NV = $86F6; - GL_DSDT_MAG_VIB_NV = $86F7; - GL_UNSIGNED_INT_S8_S8_8_8_NV = $86DA; - GL_UNSIGNED_INT_8_8_S8_S8_REV_NV = $86DB; - GL_SIGNED_RGBA_NV = $86FB; - GL_SIGNED_RGBA8_NV = $86FC; - GL_SIGNED_RGB_NV = $86FE; - GL_SIGNED_RGB8_NV = $86FF; - GL_SIGNED_LUMINANCE_NV = $8701; - GL_SIGNED_LUMINANCE8_NV = $8702; - GL_SIGNED_LUMINANCE_ALPHA_NV = $8703; - GL_SIGNED_LUMINANCE8_ALPHA8_NV = $8704; - GL_SIGNED_ALPHA_NV = $8705; - GL_SIGNED_ALPHA8_NV = $8706; - GL_SIGNED_INTENSITY_NV = $8707; - GL_SIGNED_INTENSITY8_NV = $8708; - GL_SIGNED_RGB_UNSIGNED_ALPHA_NV = $870C; - GL_SIGNED_RGB8_UNSIGNED_ALPHA8_NV = $870D; - GL_HILO16_NV = $86F8; - GL_SIGNED_HILO_NV = $86F9; - GL_SIGNED_HILO16_NV = $86FA; - GL_DSDT8_NV = $8709; - GL_DSDT8_MAG8_NV = $870A; - GL_DSDT_MAG_INTENSITY_NV = $86DC; - GL_DSDT8_MAG8_INTENSITY8_NV = $870B; - GL_HI_SCALE_NV = $870E; - GL_LO_SCALE_NV = $870F; - GL_DS_SCALE_NV = $8710; - GL_DT_SCALE_NV = $8711; - GL_MAGNITUDE_SCALE_NV = $8712; - GL_VIBRANCE_SCALE_NV = $8713; - GL_HI_BIAS_NV = $8714; - GL_LO_BIAS_NV = $8715; - GL_DS_BIAS_NV = $8716; - GL_DT_BIAS_NV = $8717; - GL_MAGNITUDE_BIAS_NV = $8718; - GL_VIBRANCE_BIAS_NV = $8719; - GL_TEXTURE_BORDER_VALUES_NV = $871A; - GL_TEXTURE_HI_SIZE_NV = $871B; - GL_TEXTURE_LO_SIZE_NV = $871C; - GL_TEXTURE_DS_SIZE_NV = $871D; - GL_TEXTURE_DT_SIZE_NV = $871E; - GL_TEXTURE_MAG_SIZE_NV = $871F; - -function Load_GL_NV_texture_shader: Boolean; - -//***** GL_NV_texture_shader2 *****// -const - GL_DOT_PRODUCT_TEXTURE_3D_NV = $86EF; - // GL_HILO_NV { already defined } - // GL_DSDT_NV { already defined } - // GL_DSDT_MAG_NV { already defined } - // GL_DSDT_MAG_VIB_NV { already defined } - // GL_UNSIGNED_INT_S8_S8_8_8_NV { already defined } - // GL_UNSIGNED_INT_8_8_S8_S8_REV_NV { already defined } - // GL_SIGNED_RGBA_NV { already defined } - // GL_SIGNED_RGBA8_NV { already defined } - // GL_SIGNED_RGB_NV { already defined } - // GL_SIGNED_RGB8_NV { already defined } - // GL_SIGNED_LUMINANCE_NV { already defined } - // GL_SIGNED_LUMINANCE8_NV { already defined } - // GL_SIGNED_LUMINANCE_ALPHA_NV { already defined } - // GL_SIGNED_LUMINANCE8_ALPHA8_NV { already defined } - // GL_SIGNED_ALPHA_NV { already defined } - // GL_SIGNED_ALPHA8_NV { already defined } - // GL_SIGNED_INTENSITY_NV { already defined } - // GL_SIGNED_INTENSITY8_NV { already defined } - // GL_SIGNED_RGB_UNSIGNED_ALPHA_NV { already defined } - // GL_SIGNED_RGB8_UNSIGNED_ALPHA8_NV { already defined } - // GL_HILO16_NV { already defined } - // GL_SIGNED_HILO_NV { already defined } - // GL_SIGNED_HILO16_NV { already defined } - // GL_DSDT8_NV { already defined } - // GL_DSDT8_MAG8_NV { already defined } - // GL_DSDT_MAG_INTENSITY_NV { already defined } - // GL_DSDT8_MAG8_INTENSITY8_NV { already defined } - -function Load_GL_NV_texture_shader2: Boolean; - -//***** GL_NV_texture_shader3 *****// -const - GL_OFFSET_PROJECTIVE_TEXTURE_2D_NV = $8850; - GL_OFFSET_PROJECTIVE_TEXTURE_2D_SCALE_NV = $8851; - GL_OFFSET_PROJECTIVE_TEXTURE_RECTANGLE_NV = $8852; - GL_OFFSET_PROJECTIVE_TEXTURE_RECTANGLE_SCALE_NV = $8853; - GL_OFFSET_HILO_TEXTURE_2D_NV = $8854; - GL_OFFSET_HILO_TEXTURE_RECTANGLE_NV = $8855; - GL_OFFSET_HILO_PROJECTIVE_TEXTURE_2D_NV = $8856; - GL_OFFSET_HILO_PROJECTIVE_TEXTURE_RECTANGLE_NV = $8857; - GL_DEPENDENT_HILO_TEXTURE_2D_NV = $8858; - GL_DEPENDENT_RGB_TEXTURE_3D_NV = $8859; - GL_DEPENDENT_RGB_TEXTURE_CUBE_MAP_NV = $885A; - GL_DOT_PRODUCT_PASS_THROUGH_NV = $885B; - GL_DOT_PRODUCT_TEXTURE_1D_NV = $885C; - GL_DOT_PRODUCT_AFFINE_DEPTH_REPLACE_NV = $885D; - GL_HILO8_NV = $885E; - GL_SIGNED_HILO8_NV = $885F; - GL_FORCE_BLUE_TO_ONE_NV = $8860; - -function Load_GL_NV_texture_shader3: Boolean; - -//***** GL_NV_vertex_array_range *****// -const - GL_VERTEX_ARRAY_RANGE_NV = $851D; - GL_VERTEX_ARRAY_RANGE_LENGTH_NV = $851E; - GL_VERTEX_ARRAY_RANGE_VALID_NV = $851F; - GL_MAX_VERTEX_ARRAY_RANGE_ELEMENT_NV = $8520; - GL_VERTEX_ARRAY_RANGE_POINTER_NV = $8521; -var - glVertexArrayRangeNV: procedure(length: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFlushVertexArrayRangeNV: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} -{$IFDEF WINDOWS} - wglAllocateMemoryNV: function(size: GLsizei; readFrequency: GLfloat; writeFrequency: GLfloat; priority: GLfloat): PGLvoid; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglFreeMemoryNV: procedure(pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} -{$ENDIF} - -function Load_GL_NV_vertex_array_range: Boolean; - -//***** GL_NV_vertex_array_range2 *****// -const - GL_VERTEX_ARRAY_RANGE_WITHOUT_FLUSH_NV = $8533; - -function Load_GL_NV_vertex_array_range2: Boolean; - -//***** GL_NV_vertex_program *****// -const - GL_VERTEX_PROGRAM_NV = $8620; - GL_VERTEX_PROGRAM_POINT_SIZE_NV = $8642; - GL_VERTEX_PROGRAM_TWO_SIDE_NV = $8643; - GL_VERTEX_STATE_PROGRAM_NV = $8621; - GL_ATTRIB_ARRAY_SIZE_NV = $8623; - GL_ATTRIB_ARRAY_STRIDE_NV = $8624; - GL_ATTRIB_ARRAY_TYPE_NV = $8625; - GL_CURRENT_ATTRIB_NV = $8626; - GL_PROGRAM_PARAMETER_NV = $8644; - GL_ATTRIB_ARRAY_POINTER_NV = $8645; - GL_PROGRAM_TARGET_NV = $8646; - GL_PROGRAM_LENGTH_NV = $8627; - GL_PROGRAM_RESIDENT_NV = $8647; - GL_PROGRAM_STRING_NV = $8628; - GL_TRACK_MATRIX_NV = $8648; - GL_TRACK_MATRIX_TRANSFORM_NV = $8649; - GL_MAX_TRACK_MATRIX_STACK_DEPTH_NV = $862E; - GL_MAX_TRACK_MATRICES_NV = $862F; - GL_CURRENT_MATRIX_STACK_DEPTH_NV = $8640; - GL_CURRENT_MATRIX_NV = $8641; - GL_VERTEX_PROGRAM_BINDING_NV = $864A; - GL_PROGRAM_ERROR_POSITION_NV = $864B; - GL_MODELVIEW_PROJECTION_NV = $8629; - GL_MATRIX0_NV = $8630; - GL_MATRIX1_NV = $8631; - GL_MATRIX2_NV = $8632; - GL_MATRIX3_NV = $8633; - GL_MATRIX4_NV = $8634; - GL_MATRIX5_NV = $8635; - GL_MATRIX6_NV = $8636; - GL_MATRIX7_NV = $8637; - GL_IDENTITY_NV = $862A; - GL_INVERSE_NV = $862B; - GL_TRANSPOSE_NV = $862C; - GL_INVERSE_TRANSPOSE_NV = $862D; - GL_VERTEX_ATTRIB_ARRAY0_NV = $8650; - GL_VERTEX_ATTRIB_ARRAY1_NV = $8651; - GL_VERTEX_ATTRIB_ARRAY2_NV = $8652; - GL_VERTEX_ATTRIB_ARRAY3_NV = $8653; - GL_VERTEX_ATTRIB_ARRAY4_NV = $8654; - GL_VERTEX_ATTRIB_ARRAY5_NV = $8655; - GL_VERTEX_ATTRIB_ARRAY6_NV = $8656; - GL_VERTEX_ATTRIB_ARRAY7_NV = $8657; - GL_VERTEX_ATTRIB_ARRAY8_NV = $8658; - GL_VERTEX_ATTRIB_ARRAY9_NV = $8659; - GL_VERTEX_ATTRIB_ARRAY10_NV = $865A; - GL_VERTEX_ATTRIB_ARRAY11_NV = $865B; - GL_VERTEX_ATTRIB_ARRAY12_NV = $865C; - GL_VERTEX_ATTRIB_ARRAY13_NV = $865D; - GL_VERTEX_ATTRIB_ARRAY14_NV = $865E; - GL_VERTEX_ATTRIB_ARRAY15_NV = $865F; - GL_MAP1_VERTEX_ATTRIB0_4_NV = $8660; - GL_MAP1_VERTEX_ATTRIB1_4_NV = $8661; - GL_MAP1_VERTEX_ATTRIB2_4_NV = $8662; - GL_MAP1_VERTEX_ATTRIB3_4_NV = $8663; - GL_MAP1_VERTEX_ATTRIB4_4_NV = $8664; - GL_MAP1_VERTEX_ATTRIB5_4_NV = $8665; - GL_MAP1_VERTEX_ATTRIB6_4_NV = $8666; - GL_MAP1_VERTEX_ATTRIB7_4_NV = $8667; - GL_MAP1_VERTEX_ATTRIB8_4_NV = $8668; - GL_MAP1_VERTEX_ATTRIB9_4_NV = $8669; - GL_MAP1_VERTEX_ATTRIB10_4_NV = $866A; - GL_MAP1_VERTEX_ATTRIB11_4_NV = $866B; - GL_MAP1_VERTEX_ATTRIB12_4_NV = $866C; - GL_MAP1_VERTEX_ATTRIB13_4_NV = $866D; - GL_MAP1_VERTEX_ATTRIB14_4_NV = $866E; - GL_MAP1_VERTEX_ATTRIB15_4_NV = $866F; - GL_MAP2_VERTEX_ATTRIB0_4_NV = $8670; - GL_MAP2_VERTEX_ATTRIB1_4_NV = $8671; - GL_MAP2_VERTEX_ATTRIB2_4_NV = $8672; - GL_MAP2_VERTEX_ATTRIB3_4_NV = $8673; - GL_MAP2_VERTEX_ATTRIB4_4_NV = $8674; - GL_MAP2_VERTEX_ATTRIB5_4_NV = $8675; - GL_MAP2_VERTEX_ATTRIB6_4_NV = $8676; - GL_MAP2_VERTEX_ATTRIB7_4_NV = $8677; - GL_MAP2_VERTEX_ATTRIB8_4_NV = $8678; - GL_MAP2_VERTEX_ATTRIB9_4_NV = $8679; - GL_MAP2_VERTEX_ATTRIB10_4_NV = $867A; - GL_MAP2_VERTEX_ATTRIB11_4_NV = $867B; - GL_MAP2_VERTEX_ATTRIB12_4_NV = $867C; - GL_MAP2_VERTEX_ATTRIB13_4_NV = $867D; - GL_MAP2_VERTEX_ATTRIB14_4_NV = $867E; - GL_MAP2_VERTEX_ATTRIB15_4_NV = $867F; -var - glBindProgramNV: procedure(target: GLenum; id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteProgramsNV: procedure(n: GLsizei; const ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glExecuteProgramNV: procedure(target: GLenum; id: GLuint; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenProgramsNV: procedure(n: GLsizei; ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAreProgramsResidentNV: function(n: GLsizei; const ids: PGLuint; residences: PGLboolean): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRequestResidentProgramsNV: procedure(n: GLsizei; ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramParameterfvNV: procedure(target: GLenum; index: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramParameterdvNV: procedure(target: GLenum; index: GLuint; pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramivNV: procedure(id: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramStringNV: procedure(id: GLuint; pname: GLenum; _program: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTrackMatrixivNV: procedure(target: GLenum; address: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribdvNV: procedure(index: GLuint; pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribfvNV: procedure(index: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribivNV: procedure(index: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribPointervNV: procedure(index: GLuint; pname: GLenum; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsProgramNV: function(id: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLoadProgramNV: procedure(target: GLenum; id: GLuint; len: GLsizei; const _program: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramParameter4fNV: procedure(target: GLenum; index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramParameter4fvNV: procedure(target: GLenum; index: GLuint; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramParameters4dvNV: procedure(target: GLenum; index: GLuint; num: GLuint; const params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramParameters4fvNV: procedure(target: GLenum; index: GLuint; num: GLuint; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTrackMatrixNV: procedure(target: GLenum; address: GLuint; matrix: GLenum; transform: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribPointerNV: procedure(index: GLuint; size: GLint; _type: GLenum; stride: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1sNV: procedure(index: GLuint; x: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1fNV: procedure(index: GLuint; x: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1dNV: procedure(index: GLuint; x: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2sNV: procedure(index: GLuint; x: GLshort; y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2fNV: procedure(index: GLuint; x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2dNV: procedure(index: GLuint; x: GLdouble; y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3sNV: procedure(index: GLuint; x: GLshort; y: GLshort; z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3fNV: procedure(index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3dNV: procedure(index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4sNV: procedure(index: GLuint; x: GLshort; y: GLshort; z: GLshort; w: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4fNV: procedure(index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4dNV: procedure(index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4ubNV: procedure(index: GLuint; x: GLubyte; y: GLubyte; z: GLubyte; w: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1svNV: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1fvNV: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1dvNV: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2svNV: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2fvNV: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2dvNV: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3svNV: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3fvNV: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3dvNV: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4svNV: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4fvNV: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4dvNV: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4ubvNV: procedure(index: GLuint; const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs1svNV: procedure(index: GLuint; n: GLsizei; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs1fvNV: procedure(index: GLuint; n: GLsizei; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs1dvNV: procedure(index: GLuint; n: GLsizei; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs2svNV: procedure(index: GLuint; n: GLsizei; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs2fvNV: procedure(index: GLuint; n: GLsizei; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs2dvNV: procedure(index: GLuint; n: GLsizei; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs3svNV: procedure(index: GLuint; n: GLsizei; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs3fvNV: procedure(index: GLuint; n: GLsizei; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs3dvNV: procedure(index: GLuint; n: GLsizei; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs4svNV: procedure(index: GLuint; n: GLsizei; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs4fvNV: procedure(index: GLuint; n: GLsizei; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs4dvNV: procedure(index: GLuint; n: GLsizei; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs4ubvNV: procedure(index: GLuint; n: GLsizei; const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_vertex_program: Boolean; - -//***** GL_NV_vertex_program1_1 *****// - -function Load_GL_NV_vertex_program1_1: Boolean; - -//***** GL_ATI_element_array *****// -const - GL_ELEMENT_ARRAY_ATI = $8768; - GL_ELEMENT_ARRAY_TYPE_ATI = $8769; - GL_ELEMENT_ARRAY_POINTER_ATI = $876A; -var - glElementPointerATI: procedure(_type: GLenum; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawElementArrayATI: procedure(mode: GLenum; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawRangeElementArrayATI: procedure(mode: GLenum; start: GLuint; _end: GLuint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_element_array: Boolean; - -//***** GL_ATI_envmap_bumpmap *****// -const - GL_BUMP_ROT_MATRIX_ATI = $8775; - GL_BUMP_ROT_MATRIX_SIZE_ATI = $8776; - GL_BUMP_NUM_TEX_UNITS_ATI = $8777; - GL_BUMP_TEX_UNITS_ATI = $8778; - GL_DUDV_ATI = $8779; - GL_DU8DV8_ATI = $877A; - GL_BUMP_ENVMAP_ATI = $877B; - GL_BUMP_TARGET_ATI = $877C; -var - glTexBumpParameterivATI: procedure(pname: GLenum; param: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexBumpParameterfvATI: procedure(pname: GLenum; param: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexBumpParameterivATI: procedure(pname: GLenum; param: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetTexBumpParameterfvATI: procedure(pname: GLenum; param: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_envmap_bumpmap: Boolean; - -//***** GL_ATI_fragment_shader *****// -const - GL_FRAGMENT_SHADER_ATI = $8920; - GL_REG_0_ATI = $8921; - GL_REG_1_ATI = $8922; - GL_REG_2_ATI = $8923; - GL_REG_3_ATI = $8924; - GL_REG_4_ATI = $8925; - GL_REG_5_ATI = $8926; - GL_CON_0_ATI = $8941; - GL_CON_1_ATI = $8942; - GL_CON_2_ATI = $8943; - GL_CON_3_ATI = $8944; - GL_CON_4_ATI = $8945; - GL_CON_5_ATI = $8946; - GL_CON_6_ATI = $8947; - GL_CON_7_ATI = $8948; - GL_MOV_ATI = $8961; - GL_ADD_ATI = $8963; - GL_MUL_ATI = $8964; - GL_SUB_ATI = $8965; - GL_DOT3_ATI = $8966; - GL_DOT4_ATI = $8967; - GL_MAD_ATI = $8968; - GL_LERP_ATI = $8969; - GL_CND_ATI = $896A; - GL_CND0_ATI = $896B; - GL_DOT2_ADD_ATI = $896C; - GL_SECONDARY_INTERPOLATOR_ATI = $896D; - GL_SWIZZLE_STR_ATI = $8976; - GL_SWIZZLE_STQ_ATI = $8977; - GL_SWIZZLE_STR_DR_ATI = $8978; - GL_SWIZZLE_STQ_DQ_ATI = $8979; - GL_RED_BIT_ATI = $0001; - GL_GREEN_BIT_ATI = $0002; - GL_BLUE_BIT_ATI = $0004; - GL_2X_BIT_ATI = $0001; - GL_4X_BIT_ATI = $0002; - GL_8X_BIT_ATI = $0004; - GL_HALF_BIT_ATI = $0008; - GL_QUARTER_BIT_ATI = $0010; - GL_EIGHTH_BIT_ATI = $0020; - GL_SATURATE_BIT_ATI = $0040; - // GL_2X_BIT_ATI { already defined } - GL_COMP_BIT_ATI = $0002; - GL_NEGATE_BIT_ATI = $0004; - GL_BIAS_BIT_ATI = $0008; -var - glGenFragmentShadersATI: function(range: GLuint): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindFragmentShaderATI: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteFragmentShaderATI: procedure(id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBeginFragmentShaderATI: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEndFragmentShaderATI: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPassTexCoordATI: procedure(dst: GLuint; coord: GLuint; swizzle: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSampleMapATI: procedure(dst: GLuint; interp: GLuint; swizzle: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorFragmentOp1ATI: procedure(op: GLenum; dst: GLuint; dstMask: GLuint; dstMod: GLuint; arg1: GLuint; arg1Rep: GLuint; arg1Mod: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorFragmentOp2ATI: procedure(op: GLenum; dst: GLuint; dstMask: GLuint; dstMod: GLuint; arg1: GLuint; arg1Rep: GLuint; arg1Mod: GLuint; arg2: GLuint; arg2Rep: GLuint; arg2Mod: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorFragmentOp3ATI: procedure(op: GLenum; dst: GLuint; dstMask: GLuint; dstMod: GLuint; arg1: GLuint; arg1Rep: GLuint; arg1Mod: GLuint; arg2: GLuint; arg2Rep: GLuint; arg2Mod: GLuint; arg3: GLuint; arg3Rep: GLuint; arg3Mod: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAlphaFragmentOp1ATI: procedure(op: GLenum; dst: GLuint; dstMod: GLuint; arg1: GLuint; arg1Rep: GLuint; arg1Mod: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAlphaFragmentOp2ATI: procedure(op: GLenum; dst: GLuint; dstMod: GLuint; arg1: GLuint; arg1Rep: GLuint; arg1Mod: GLuint; arg2: GLuint; arg2Rep: GLuint; arg2Mod: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAlphaFragmentOp3ATI: procedure(op: GLenum; dst: GLuint; dstMod: GLuint; arg1: GLuint; arg1Rep: GLuint; arg1Mod: GLuint; arg2: GLuint; arg2Rep: GLuint; arg2Mod: GLuint; arg3: GLuint; arg3Rep: GLuint; arg3Mod: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSetFragmentShaderConstantATI: procedure(dst: GLuint; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_fragment_shader: Boolean; - -//***** GL_ATI_pn_triangles *****// -const - GL_PN_TRIANGLES_ATI = $87F0; - GL_MAX_PN_TRIANGLES_TESSELATION_LEVEL_ATI = $87F1; - GL_PN_TRIANGLES_POINT_MODE_ATI = $87F2; - GL_PN_TRIANGLES_NORMAL_MODE_ATI = $87F3; - GL_PN_TRIANGLES_TESSELATION_LEVEL_ATI = $87F4; - GL_PN_TRIANGLES_POINT_MODE_LINEAR_ATI = $87F5; - GL_PN_TRIANGLES_POINT_MODE_CUBIC_ATI = $87F6; - GL_PN_TRIANGLES_NORMAL_MODE_LINEAR_ATI = $87F7; - GL_PN_TRIANGLES_NORMAL_MODE_QUADRATIC_ATI = $87F8; -var - glPNTrianglesiATI: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPNTrianglesfATI: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_pn_triangles: Boolean; - -//***** GL_ATI_texture_mirror_once *****// -const - GL_MIRROR_CLAMP_ATI = $8742; - GL_MIRROR_CLAMP_TO_EDGE_ATI = $8743; - -function Load_GL_ATI_texture_mirror_once: Boolean; - -//***** GL_ATI_vertex_array_object *****// -const - GL_STATIC_ATI = $8760; - GL_DYNAMIC_ATI = $8761; - GL_PRESERVE_ATI = $8762; - GL_DISCARD_ATI = $8763; - GL_OBJECT_BUFFER_SIZE_ATI = $8764; - GL_OBJECT_BUFFER_USAGE_ATI = $8765; - GL_ARRAY_OBJECT_BUFFER_ATI = $8766; - GL_ARRAY_OBJECT_OFFSET_ATI = $8767; -var - glNewObjectBufferATI: function(size: GLsizei; const pointer: PGLvoid; usage: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsObjectBufferATI: function(buffer: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUpdateObjectBufferATI: procedure(buffer: GLuint; offset: GLuint; size: GLsizei; const pointer: PGLvoid; preserve: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetObjectBufferfvATI: procedure(buffer: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetObjectBufferivATI: procedure(buffer: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteObjectBufferATI: procedure(buffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glArrayObjectATI: procedure(_array: GLenum; size: GLint; _type: GLenum; stride: GLsizei; buffer: GLuint; offset: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetArrayObjectfvATI: procedure(_array: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetArrayObjectivATI: procedure(_array: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVariantArrayObjectATI: procedure(id: GLuint; _type: GLenum; stride: GLsizei; buffer: GLuint; offset: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVariantArrayObjectfvATI: procedure(id: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVariantArrayObjectivATI: procedure(id: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_vertex_array_object: Boolean; - -//***** GL_ATI_vertex_streams *****// -const - GL_MAX_VERTEX_STREAMS_ATI = $876B; - GL_VERTEX_STREAM0_ATI = $876C; - GL_VERTEX_STREAM1_ATI = $876D; - GL_VERTEX_STREAM2_ATI = $876E; - GL_VERTEX_STREAM3_ATI = $876F; - GL_VERTEX_STREAM4_ATI = $8770; - GL_VERTEX_STREAM5_ATI = $8771; - GL_VERTEX_STREAM6_ATI = $8772; - GL_VERTEX_STREAM7_ATI = $8773; - GL_VERTEX_SOURCE_ATI = $8774; -var - glVertexStream1s: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1i: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1f: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1d: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1sv: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1iv: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1fv: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream1dv: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2s: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2i: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2f: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2d: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2sv: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2iv: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2fv: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream2dv: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3s: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3i: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3f: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3d: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3sv: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3iv: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3fv: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream3dv: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4s: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4i: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4f: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4d: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4sv: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4iv: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4fv: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexStream4dv: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3b: procedure(stream: GLenum; coords: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3s: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3i: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3f: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3d: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3bv: procedure(stream: GLenum; coords: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3sv: procedure(stream: GLenum; coords: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3iv: procedure(stream: GLenum; coords: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3fv: procedure(stream: GLenum; coords: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalStream3dv: procedure(stream: GLenum; coords: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glClientActiveVertexStream: procedure(stream: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexBlendEnvi: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexBlendEnvf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_vertex_streams: Boolean; - -{$IFDEF WINDOWS} -//***** WGL_I3D_image_buffer *****// -const - WGL_IMAGE_BUFFER_MIN_ACCESS_I3D = $0001; - WGL_IMAGE_BUFFER_LOCK_I3D = $0002; -var - wglCreateImageBufferI3D: function(hDC: HDC; dwSize: DWORD; uFlags: UINT): PGLvoid; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglDestroyImageBufferI3D: function(hDC: HDC; pAddress: PGLvoid): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglAssociateImageBufferEventsI3D: function(hdc: HDC; pEvent: PHandle; pAddress: PGLvoid; pSize: PDWORD; count: UINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglReleaseImageBufferEventsI3D: function(hdc: HDC; pAddress: PGLvoid; count: UINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_I3D_image_buffer: Boolean; - -//***** WGL_I3D_swap_frame_lock *****// -var - wglEnableFrameLockI3D: function(): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglDisableFrameLockI3D: function(): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglIsEnabledFrameLockI3D: function(pFlag: PBOOL): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglQueryFrameLockMasterI3D: function(pFlag: PBOOL): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_I3D_swap_frame_lock: Boolean; - -//***** WGL_I3D_swap_frame_usage *****// -var - wglGetFrameUsageI3D: function(pUsage: PGLfloat): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglBeginFrameTrackingI3D: function(): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglEndFrameTrackingI3D: function(): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglQueryFrameTrackingI3D: function(pFrameCount: PDWORD; pMissedFrames: PDWORD; pLastMissedUsage: PGLfloat): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_I3D_swap_frame_usage: Boolean; -{$ENDIF} - -//***** GL_3DFX_texture_compression_FXT1 *****// -const - GL_COMPRESSED_RGB_FXT1_3DFX = $86B0; - GL_COMPRESSED_RGBA_FXT1_3DFX = $86B1; - -function Load_GL_3DFX_texture_compression_FXT1: Boolean; - -//***** GL_IBM_cull_vertex *****// -const - GL_CULL_VERTEX_IBM = $1928A; - -function Load_GL_IBM_cull_vertex: Boolean; - -//***** GL_IBM_multimode_draw_arrays *****// -var - glMultiModeDrawArraysIBM: procedure(mode: PGLenum; first: PGLint; count: PGLsizei; primcount: GLsizei; modestride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiModeDrawElementsIBM: procedure(mode: PGLenum; count: PGLsizei; _type: GLenum; const indices: PGLvoid; primcount: GLsizei; modestride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_IBM_multimode_draw_arrays: Boolean; - -//***** GL_IBM_raster_pos_clip *****// -const - GL_RASTER_POSITION_UNCLIPPED_IBM = $19262; - -function Load_GL_IBM_raster_pos_clip: Boolean; - -//***** GL_IBM_texture_mirrored_repeat *****// -const - GL_MIRRORED_REPEAT_IBM = $8370; - -function Load_GL_IBM_texture_mirrored_repeat: Boolean; - -//***** GL_IBM_vertex_array_lists *****// -const - GL_VERTEX_ARRAY_LIST_IBM = $1929E; - GL_NORMAL_ARRAY_LIST_IBM = $1929F; - GL_COLOR_ARRAY_LIST_IBM = $192A0; - GL_INDEX_ARRAY_LIST_IBM = $192A1; - GL_TEXTURE_COORD_ARRAY_LIST_IBM = $192A2; - GL_EDGE_FLAG_ARRAY_LIST_IBM = $192A3; - GL_FOG_COORDINATE_ARRAY_LIST_IBM = $192A4; - GL_SECONDARY_COLOR_ARRAY_LIST_IBM = $192A5; - GL_VERTEX_ARRAY_LIST_STRIDE_IBM = $192A8; - GL_NORMAL_ARRAY_LIST_STRIDE_IBM = $192A9; - GL_COLOR_ARRAY_LIST_STRIDE_IBM = $192AA; - GL_INDEX_ARRAY_LIST_STRIDE_IBM = $192AB; - GL_TEXTURE_COORD_ARRAY_LIST_STRIDE_IBM = $192AC; - GL_EDGE_FLAG_ARRAY_LIST_STRIDE_IBM = $192AD; - GL_FOG_COORDINATE_ARRAY_LIST_STRIDE_IBM = $192AE; - GL_SECONDARY_COLOR_ARRAY_LIST_STRIDE_IBM = $192AF; -var - glColorPointerListIBM: procedure(size: GLint; _type: GLenum; stride: GLint; const pointer: PGLvoid; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColorPointerListIBM: procedure(size: GLint; _type: GLenum; stride: GLint; const pointer: PGLvoid; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEdgeFlagPointerListIBM: procedure(stride: GLint; const pointer: PGLboolean; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordPointerListIBM: procedure(_type: GLenum; stride: GLint; const pointer: PGLvoid; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormalPointerListIBM: procedure(_type: GLenum; stride: GLint; const pointer: PGLvoid; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoordPointerListIBM: procedure(size: GLint; _type: GLenum; stride: GLint; const pointer: PGLvoid; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexPointerListIBM: procedure(size: GLint; _type: GLenum; stride: GLint; const pointer: PGLvoid; ptrstride: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_IBM_vertex_array_lists: Boolean; - -//***** GL_MESA_resize_buffers *****// -var - glResizeBuffersMESA: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_MESA_resize_buffers: Boolean; - -//***** GL_MESA_window_pos *****// -var - glWindowPos2dMESA: procedure(x: GLdouble; y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2fMESA: procedure(x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2iMESA: procedure(x: GLint; y: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2sMESA: procedure(x: GLshort; y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2ivMESA: procedure(const p: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2svMESA: procedure(const p: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2fvMESA: procedure(const p: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2dvMESA: procedure(const p: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3iMESA: procedure(x: GLint; y: GLint; z: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3sMESA: procedure(x: GLshort; y: GLshort; z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3fMESA: procedure(x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3dMESA: procedure(x: GLdouble; y: GLdouble; z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3ivMESA: procedure(const p: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3svMESA: procedure(const p: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3fvMESA: procedure(const p: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3dvMESA: procedure(const p: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4iMESA: procedure(x: GLint; y: GLint; z: GLint; w: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4sMESA: procedure(x: GLshort; y: GLshort; z: GLshort; w: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4fMESA: procedure(x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4dMESA: procedure(x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4ivMESA: procedure(const p: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4svMESA: procedure(const p: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4fvMESA: procedure(const p: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos4dvMESA: procedure(const p: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_MESA_window_pos: Boolean; - -//***** GL_OML_interlace *****// -const - GL_INTERLACE_OML = $8980; - GL_INTERLACE_READ_OML = $8981; - -function Load_GL_OML_interlace: Boolean; - -//***** GL_OML_resample *****// -const - GL_PACK_RESAMPLE_OML = $8984; - GL_UNPACK_RESAMPLE_OML = $8985; - GL_RESAMPLE_REPLICATE_OML = $8986; - GL_RESAMPLE_ZERO_FILL_OML = $8987; - GL_RESAMPLE_AVERAGE_OML = $8988; - GL_RESAMPLE_DECIMATE_OML = $8989; - // GL_RESAMPLE_AVERAGE_OML { already defined } - -function Load_GL_OML_resample: Boolean; - -//***** GL_OML_subsample *****// -const - GL_FORMAT_SUBSAMPLE_24_24_OML = $8982; - GL_FORMAT_SUBSAMPLE_244_244_OML = $8983; - -function Load_GL_OML_subsample: Boolean; - -//***** GL_SGIS_generate_mipmap *****// -const - GL_GENERATE_MIPMAP_SGIS = $8191; - GL_GENERATE_MIPMAP_HINT_SGIS = $8192; - -function Load_GL_SGIS_generate_mipmap: Boolean; - -//***** GL_SGIS_multisample *****// -const - GLX_SAMPLE_BUFFERS_SGIS = $186A0; - GLX_SAMPLES_SGIS = $186A1; - GL_MULTISAMPLE_SGIS = $809D; - GL_SAMPLE_ALPHA_TO_MASK_SGIS = $809E; - GL_SAMPLE_ALPHA_TO_ONE_SGIS = $809F; - GL_SAMPLE_MASK_SGIS = $80A0; - GL_MULTISAMPLE_BIT_EXT = $20000000; - GL_1PASS_SGIS = $80A1; - GL_2PASS_0_SGIS = $80A2; - GL_2PASS_1_SGIS = $80A3; - GL_4PASS_0_SGIS = $80A4; - GL_4PASS_1_SGIS = $80A5; - GL_4PASS_2_SGIS = $80A6; - GL_4PASS_3_SGIS = $80A7; - GL_SAMPLE_BUFFERS_SGIS = $80A8; - GL_SAMPLES_SGIS = $80A9; - GL_SAMPLE_MASK_VALUE_SGIS = $80AA; - GL_SAMPLE_MASK_INVERT_SGIS = $80AB; - GL_SAMPLE_PATTERN_SGIS = $80AC; -var - glSampleMaskSGIS: procedure(value: GLclampf; invert: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSamplePatternSGIS: procedure(pattern: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_SGIS_multisample: Boolean; - -//***** GL_SGIS_pixel_texture *****// -const - GL_PIXEL_TEXTURE_SGIS = $8353; - GL_PIXEL_FRAGMENT_RGB_SOURCE_SGIS = $8354; - GL_PIXEL_FRAGMENT_ALPHA_SOURCE_SGIS = $8355; - GL_PIXEL_GROUP_COLOR_SGIS = $8356; -var - glPixelTexGenParameteriSGIS: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPixelTexGenParameterfSGIS: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPixelTexGenParameterivSGIS: procedure(pname: GLenum; params: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetPixelTexGenParameterfvSGIS: procedure(pname: GLenum; params: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_SGIS_pixel_texture: Boolean; - -//***** GL_SGIS_texture_border_clamp *****// - // GL_CLAMP_TO_BORDER_SGIS { already defined } - -function Load_GL_SGIS_texture_border_clamp: Boolean; - -//***** GL_SGIS_texture_color_mask *****// -const - GL_TEXTURE_COLOR_WRITEMASK_SGIS = $81EF; -var - glTextureColorMaskSGIS: procedure(r: GLboolean; g: GLboolean; b: GLboolean; a: GLboolean); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_SGIS_texture_color_mask: Boolean; - -//***** GL_SGIS_texture_edge_clamp *****// -const - GL_CLAMP_TO_EDGE_SGIS = $812F; - -function Load_GL_SGIS_texture_edge_clamp: Boolean; - -//***** GL_SGIS_texture_lod *****// -const - GL_TEXTURE_MIN_LOD_SGIS = $813A; - GL_TEXTURE_MAX_LOD_SGIS = $813B; - GL_TEXTURE_BASE_LEVEL_SGIS = $813C; - GL_TEXTURE_MAX_LEVEL_SGIS = $813D; - -function Load_GL_SGIS_texture_lod: Boolean; - -//***** GL_SGIS_depth_texture *****// -const - GL_DEPTH_COMPONENT16_SGIX = $81A5; - GL_DEPTH_COMPONENT24_SGIX = $81A6; - GL_DEPTH_COMPONENT32_SGIX = $81A7; - -function Load_GL_SGIS_depth_texture: Boolean; - -//***** GL_SGIX_fog_offset *****// -const - GL_FOG_OFFSET_SGIX = $8198; - GL_FOG_OFFSET_VALUE_SGIX = $8199; - -function Load_GL_SGIX_fog_offset: Boolean; - -//***** GL_SGIX_interlace *****// -const - GL_INTERLACE_SGIX = $8094; - -function Load_GL_SGIX_interlace: Boolean; - -//***** GL_SGIX_shadow_ambient *****// -const - GL_SHADOW_AMBIENT_SGIX = $80BF; - -function Load_GL_SGIX_shadow_ambient: Boolean; - -//***** GL_SGI_color_matrix *****// -const - GL_COLOR_MATRIX_SGI = $80B1; - GL_COLOR_MATRIX_STACK_DEPTH_SGI = $80B2; - GL_MAX_COLOR_MATRIX_STACK_DEPTH_SGI = $80B3; - GL_POST_COLOR_MATRIX_RED_SCALE_SGI = $80B4; - GL_POST_COLOR_MATRIX_GREEN_SCALE_SGI = $80B5; - GL_POST_COLOR_MATRIX_BLUE_SCALE_SGI = $80B6; - GL_POST_COLOR_MATRIX_ALPHA_SCALE_SGI = $80B7; - GL_POST_COLOR_MATRIX_RED_BIAS_SGI = $80B8; - GL_POST_COLOR_MATRIX_GREEN_BIAS_SGI = $80B9; - GL_POST_COLOR_MATRIX_BLUE_BIAS_SGI = $80BA; - GL_POST_COLOR_MATRIX_ALPHA_BIAS_SGI = $80BB; - -function Load_GL_SGI_color_matrix: Boolean; - -//***** GL_SGI_color_table *****// -const - GL_COLOR_TABLE_SGI = $80D0; - GL_POST_CONVOLUTION_COLOR_TABLE_SGI = $80D1; - GL_POST_COLOR_MATRIX_COLOR_TABLE_SGI = $80D2; - GL_PROXY_COLOR_TABLE_SGI = $80D3; - GL_PROXY_POST_CONVOLUTION_COLOR_TABLE_SGI = $80D4; - GL_PROXY_POST_COLOR_MATRIX_COLOR_TABLE_SGI = $80D5; - GL_COLOR_TABLE_SCALE_SGI = $80D6; - GL_COLOR_TABLE_BIAS_SGI = $80D7; - GL_COLOR_TABLE_FORMAT_SGI = $80D8; - GL_COLOR_TABLE_WIDTH_SGI = $80D9; - GL_COLOR_TABLE_RED_SIZE_SGI = $80DA; - GL_COLOR_TABLE_GREEN_SIZE_SGI = $80DB; - GL_COLOR_TABLE_BLUE_SIZE_SGI = $80DC; - GL_COLOR_TABLE_ALPHA_SIZE_SGI = $80DD; - GL_COLOR_TABLE_LUMINANCE_SIZE_SGI = $80DE; - GL_COLOR_TABLE_INTENSITY_SIZE_SGI = $80DF; -var - glColorTableSGI: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; format: GLenum; _type: GLenum; const table: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCopyColorTableSGI: procedure(target: GLenum; internalformat: GLenum; x: GLint; y: GLint; width: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorTableParameterivSGI: procedure(target: GLenum; pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColorTableParameterfvSGI: procedure(target: GLenum; pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableSGI: procedure(target: GLenum; format: GLenum; _type: GLenum; table: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableParameterivSGI: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetColorTableParameterfvSGI: procedure(target: GLenum; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_SGI_color_table: Boolean; - -//***** GL_SGI_texture_color_table *****// -const - GL_TEXTURE_COLOR_TABLE_SGI = $80BC; - GL_PROXY_TEXTURE_COLOR_TABLE_SGI = $80BD; - -function Load_GL_SGI_texture_color_table: Boolean; - -//***** GL_SUN_vertex *****// -var - glColor4ubVertex2fSUN: procedure(r: GLubyte; g: GLubyte; b: GLubyte; a: GLubyte; x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4ubVertex2fvSUN: procedure(const c: PGLubyte; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4ubVertex3fSUN: procedure(r: GLubyte; g: GLubyte; b: GLubyte; a: GLubyte; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4ubVertex3fvSUN: procedure(const c: PGLubyte; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3fVertex3fSUN: procedure(r: GLfloat; g: GLfloat; b: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3fVertex3fvSUN: procedure(const c: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3fVertex3fSUN: procedure(nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3fVertex3fvSUN: procedure(const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4fNormal3fVertex3fSUN: procedure(r: GLfloat; g: GLfloat; b: GLfloat; a: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4fNormal3fVertex3fvSUN: procedure(const c: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fVertex3fSUN: procedure(s: GLfloat; t: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fVertex3fvSUN: procedure(const tc: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4fVertex4fSUN: procedure(s: GLfloat; t: GLfloat; p: GLfloat; q: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4fVertex4fvSUN: procedure(const tc: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fColor4ubVertex3fSUN: procedure(s: GLfloat; t: GLfloat; r: GLubyte; g: GLubyte; b: GLubyte; a: GLubyte; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fColor4ubVertex3fvSUN: procedure(const tc: PGLfloat; const c: PGLubyte; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fColor3fVertex3fSUN: procedure(s: GLfloat; t: GLfloat; r: GLfloat; g: GLfloat; b: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fColor3fVertex3fvSUN: procedure(const tc: PGLfloat; const c: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fNormal3fVertex3fSUN: procedure(s: GLfloat; t: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fNormal3fVertex3fvSUN: procedure(const tc: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fColor4fNormal3fVertex3fSUN: procedure(s: GLfloat; t: GLfloat; r: GLfloat; g: GLfloat; b: GLfloat; a: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2fColor4fNormal3fVertex3fvSUN: procedure(const tc: PGLfloat; const c: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4fColor4fNormal3fVertex4fSUN: procedure(s: GLfloat; t: GLfloat; p: GLfloat; q: GLfloat; r: GLfloat; g: GLfloat; b: GLfloat; a: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4fColor4fNormal3fVertex4fvSUN: procedure(const tc: PGLfloat; const c: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiVertex3fSUN: procedure(rc: GLuint; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiVertex3fvSUN: procedure(const rc: PGLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiColor4ubVertex3fSUN: procedure(rc: GLuint; r: GLubyte; g: GLubyte; b: GLubyte; a: GLubyte; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiColor4ubVertex3fvSUN: procedure(const rc: PGLuint; const c: PGLubyte; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiColor3fVertex3fSUN: procedure(rc: GLuint; r: GLfloat; g: GLfloat; b: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiColor3fVertex3fvSUN: procedure(const rc: PGLuint; const c: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiNormal3fVertex3fSUN: procedure(rc: GLuint; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiNormal3fVertex3fvSUN: procedure(const rc: PGLuint; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiColor4fNormal3fVertex3fSUN: procedure(rc: GLuint; r: GLfloat; g: GLfloat; b: GLfloat; a: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiColor4fNormal3fVertex3fvSUN: procedure(const rc: PGLuint; const c: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiTexCoord2fVertex3fSUN: procedure(rc: GLuint; s: GLfloat; t: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiTexCoord2fVertex3fvSUN: procedure(const rc: PGLuint; const tc: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiTexCoord2fNormal3fVertex3fSUN: procedure(rc: GLuint; s: GLfloat; t: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiTexCoord2fNormal3fVertex3fvSUN: procedure(const rc: PGLuint; const tc: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fSUN: procedure(rc: GLuint; s: GLfloat; t: GLfloat; r: GLfloat; g: GLfloat; b: GLfloat; a: GLfloat; nx: GLfloat; ny: GLfloat; nz: GLfloat; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fvSUN: procedure(const rc: PGLuint; const tc: PGLfloat; const c: PGLfloat; const n: PGLfloat; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_SUN_vertex: Boolean; - -//***** GL_ARB_fragment_program *****// -const - GL_FRAGMENT_PROGRAM_ARB = $8804; - // GL_PROGRAM_FORMAT_ASCII_ARB { already defined } - // GL_PROGRAM_LENGTH_ARB { already defined } - // GL_PROGRAM_FORMAT_ARB { already defined } - // GL_PROGRAM_BINDING_ARB { already defined } - // GL_PROGRAM_INSTRUCTIONS_ARB { already defined } - // GL_MAX_PROGRAM_INSTRUCTIONS_ARB { already defined } - // GL_PROGRAM_NATIVE_INSTRUCTIONS_ARB { already defined } - // GL_MAX_PROGRAM_NATIVE_INSTRUCTIONS_ARB { already defined } - // GL_PROGRAM_TEMPORARIES_ARB { already defined } - // GL_MAX_PROGRAM_TEMPORARIES_ARB { already defined } - // GL_PROGRAM_NATIVE_TEMPORARIES_ARB { already defined } - // GL_MAX_PROGRAM_NATIVE_TEMPORARIES_ARB { already defined } - // GL_PROGRAM_PARAMETERS_ARB { already defined } - // GL_MAX_PROGRAM_PARAMETERS_ARB { already defined } - // GL_PROGRAM_NATIVE_PARAMETERS_ARB { already defined } - // GL_MAX_PROGRAM_NATIVE_PARAMETERS_ARB { already defined } - // GL_PROGRAM_ATTRIBS_ARB { already defined } - // GL_MAX_PROGRAM_ATTRIBS_ARB { already defined } - // GL_PROGRAM_NATIVE_ATTRIBS_ARB { already defined } - // GL_MAX_PROGRAM_NATIVE_ATTRIBS_ARB { already defined } - // GL_MAX_PROGRAM_LOCAL_PARAMETERS_ARB { already defined } - // GL_MAX_PROGRAM_ENV_PARAMETERS_ARB { already defined } - // GL_PROGRAM_UNDER_NATIVE_LIMITS_ARB { already defined } - GL_PROGRAM_ALU_INSTRUCTIONS_ARB = $8805; - GL_PROGRAM_TEX_INSTRUCTIONS_ARB = $8806; - GL_PROGRAM_TEX_INDIRECTIONS_ARB = $8807; - GL_PROGRAM_NATIVE_ALU_INSTRUCTIONS_ARB = $8808; - GL_PROGRAM_NATIVE_TEX_INSTRUCTIONS_ARB = $8809; - GL_PROGRAM_NATIVE_TEX_INDIRECTIONS_ARB = $880A; - GL_MAX_PROGRAM_ALU_INSTRUCTIONS_ARB = $880B; - GL_MAX_PROGRAM_TEX_INSTRUCTIONS_ARB = $880C; - GL_MAX_PROGRAM_TEX_INDIRECTIONS_ARB = $880D; - GL_MAX_PROGRAM_NATIVE_ALU_INSTRUCTIONS_ARB = $880E; - GL_MAX_PROGRAM_NATIVE_TEX_INSTRUCTIONS_ARB = $880F; - GL_MAX_PROGRAM_NATIVE_TEX_INDIRECTIONS_ARB = $8810; - // GL_PROGRAM_STRING_ARB { already defined } - // GL_PROGRAM_ERROR_POSITION_ARB { already defined } - // GL_CURRENT_MATRIX_ARB { already defined } - // GL_TRANSPOSE_CURRENT_MATRIX_ARB { already defined } - // GL_CURRENT_MATRIX_STACK_DEPTH_ARB { already defined } - // GL_MAX_PROGRAM_MATRICES_ARB { already defined } - // GL_MAX_PROGRAM_MATRIX_STACK_DEPTH_ARB { already defined } - GL_MAX_TEXTURE_COORDS_ARB = $8871; - GL_MAX_TEXTURE_IMAGE_UNITS_ARB = $8872; - // GL_PROGRAM_ERROR_STRING_ARB { already defined } - // GL_MATRIX0_ARB { already defined } - // GL_MATRIX1_ARB { already defined } - // GL_MATRIX2_ARB { already defined } - // GL_MATRIX3_ARB { already defined } - // GL_MATRIX4_ARB { already defined } - // GL_MATRIX5_ARB { already defined } - // GL_MATRIX6_ARB { already defined } - // GL_MATRIX7_ARB { already defined } - // GL_MATRIX8_ARB { already defined } - // GL_MATRIX9_ARB { already defined } - // GL_MATRIX10_ARB { already defined } - // GL_MATRIX11_ARB { already defined } - // GL_MATRIX12_ARB { already defined } - // GL_MATRIX13_ARB { already defined } - // GL_MATRIX14_ARB { already defined } - // GL_MATRIX15_ARB { already defined } - // GL_MATRIX16_ARB { already defined } - // GL_MATRIX17_ARB { already defined } - // GL_MATRIX18_ARB { already defined } - // GL_MATRIX19_ARB { already defined } - // GL_MATRIX20_ARB { already defined } - // GL_MATRIX21_ARB { already defined } - // GL_MATRIX22_ARB { already defined } - // GL_MATRIX23_ARB { already defined } - // GL_MATRIX24_ARB { already defined } - // GL_MATRIX25_ARB { already defined } - // GL_MATRIX26_ARB { already defined } - // GL_MATRIX27_ARB { already defined } - // GL_MATRIX28_ARB { already defined } - // GL_MATRIX29_ARB { already defined } - // GL_MATRIX30_ARB { already defined } - // GL_MATRIX31_ARB { already defined } - // glProgramStringARB { already defined } - // glBindProgramARB { already defined } - // glDeleteProgramsARB { already defined } - // glGenProgramsARB { already defined } - // glProgramEnvParameter4dARB { already defined } - // glProgramEnvParameter4dvARB { already defined } - // glProgramEnvParameter4fARB { already defined } - // glProgramEnvParameter4fvARB { already defined } - // glProgramLocalParameter4dARB { already defined } - // glProgramLocalParameter4dvARB { already defined } - // glProgramLocalParameter4fARB { already defined } - // glProgramLocalParameter4fvARB { already defined } - // glGetProgramEnvParameterdvARB { already defined } - // glGetProgramEnvParameterfvARB { already defined } - // glGetProgramLocalParameterdvARB { already defined } - // glGetProgramLocalParameterfvARB { already defined } - // glGetProgramivARB { already defined } - // glGetProgramStringARB { already defined } - // glIsProgramARB { already defined } - -function Load_GL_ARB_fragment_program: Boolean; - -//***** GL_ATI_text_fragment_shader *****// -const - GL_TEXT_FRAGMENT_SHADER_ATI = $8200; - -function Load_GL_ATI_text_fragment_shader: Boolean; - -//***** GL_APPLE_client_storage *****// -const - GL_UNPACK_CLIENT_STORAGE_APPLE = $85B2; - -function Load_GL_APPLE_client_storage: Boolean; - -//***** GL_APPLE_element_array *****// -const - GL_ELEMENT_ARRAY_APPLE = $8768; - GL_ELEMENT_ARRAY_TYPE_APPLE = $8769; - GL_ELEMENT_ARRAY_POINTER_APPLE = $876A; -var - glElementPointerAPPLE: procedure(_type: GLenum; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawElementArrayAPPLE: procedure(mode: GLenum; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawRangeElementArrayAPPLE: procedure(mode: GLenum; start: GLuint; _end: GLuint; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawElementArrayAPPLE: procedure(mode: GLenum; const first: PGLint; const count: PGLsizei; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawRangeElementArrayAPPLE: procedure(mode: GLenum; start: GLuint; _end: GLuint; const first: PGLint; const count: PGLsizei; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_APPLE_element_array: Boolean; - -//***** GL_APPLE_fence *****// -const - GL_DRAW_PIXELS_APPLE = $8A0A; - GL_FENCE_APPLE = $8A0B; -var - glGenFencesAPPLE: procedure(n: GLsizei; fences: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteFencesAPPLE: procedure(n: GLsizei; const fences: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSetFenceAPPLE: procedure(fence: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsFenceAPPLE: function(fence: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTestFenceAPPLE: function(fence: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFinishFenceAPPLE: procedure(fence: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTestObjectAPPLE: function(_object: GLenum; name: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFinishObjectAPPLE: procedure(_object: GLenum; name: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_APPLE_fence: Boolean; - -//***** GL_APPLE_vertex_array_object *****// -const - GL_VERTEX_ARRAY_BINDING_APPLE = $85B5; -var - glBindVertexArrayAPPLE: procedure(_array: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteVertexArraysAPPLE: procedure(n: GLsizei; const arrays: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenVertexArraysAPPLE: procedure(n: GLsizei; const arrays: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsVertexArrayAPPLE: function(_array: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_APPLE_vertex_array_object: Boolean; - -//***** GL_APPLE_vertex_array_range *****// -const - GL_VERTEX_ARRAY_RANGE_APPLE = $851D; - GL_VERTEX_ARRAY_RANGE_LENGTH_APPLE = $851E; - GL_MAX_VERTEX_ARRAY_RANGE_ELEMENT_APPLE = $8520; - GL_VERTEX_ARRAY_RANGE_POINTER_APPLE = $8521; - GL_VERTEX_ARRAY_STORAGE_HINT_APPLE = $851F; - GL_STORAGE_CACHED_APPLE = $85BE; - GL_STORAGE_SHARED_APPLE = $85BF; -var - glVertexArrayRangeAPPLE: procedure(length: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFlushVertexArrayRangeAPPLE: procedure(length: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexArrayParameteriAPPLE: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_APPLE_vertex_array_range: Boolean; - -{$IFDEF WINDOWS} -//***** WGL_ARB_pixel_format *****// -const - WGL_NUMBER_PIXEL_FORMATS_ARB = $2000; - WGL_DRAW_TO_WINDOW_ARB = $2001; - WGL_DRAW_TO_BITMAP_ARB = $2002; - WGL_ACCELERATION_ARB = $2003; - WGL_NEED_PALETTE_ARB = $2004; - WGL_NEED_SYSTEM_PALETTE_ARB = $2005; - WGL_SWAP_LAYER_BUFFERS_ARB = $2006; - WGL_SWAP_METHOD_ARB = $2007; - WGL_NUMBER_OVERLAYS_ARB = $2008; - WGL_NUMBER_UNDERLAYS_ARB = $2009; - WGL_TRANSPARENT_ARB = $200A; - WGL_TRANSPARENT_RED_VALUE_ARB = $2037; - WGL_TRANSPARENT_GREEN_VALUE_ARB = $2038; - WGL_TRANSPARENT_BLUE_VALUE_ARB = $2039; - WGL_TRANSPARENT_ALPHA_VALUE_ARB = $203A; - WGL_TRANSPARENT_INDEX_VALUE_ARB = $203B; - WGL_SHARE_DEPTH_ARB = $200C; - WGL_SHARE_STENCIL_ARB = $200D; - WGL_SHARE_ACCUM_ARB = $200E; - WGL_SUPPORT_GDI_ARB = $200F; - WGL_SUPPORT_OPENGL_ARB = $2010; - WGL_DOUBLE_BUFFER_ARB = $2011; - WGL_STEREO_ARB = $2012; - WGL_PIXEL_TYPE_ARB = $2013; - WGL_COLOR_BITS_ARB = $2014; - WGL_RED_BITS_ARB = $2015; - WGL_RED_SHIFT_ARB = $2016; - WGL_GREEN_BITS_ARB = $2017; - WGL_GREEN_SHIFT_ARB = $2018; - WGL_BLUE_BITS_ARB = $2019; - WGL_BLUE_SHIFT_ARB = $201A; - WGL_ALPHA_BITS_ARB = $201B; - WGL_ALPHA_SHIFT_ARB = $201C; - WGL_ACCUM_BITS_ARB = $201D; - WGL_ACCUM_RED_BITS_ARB = $201E; - WGL_ACCUM_GREEN_BITS_ARB = $201F; - WGL_ACCUM_BLUE_BITS_ARB = $2020; - WGL_ACCUM_ALPHA_BITS_ARB = $2021; - WGL_DEPTH_BITS_ARB = $2022; - WGL_STENCIL_BITS_ARB = $2023; - WGL_AUX_BUFFERS_ARB = $2024; - WGL_NO_ACCELERATION_ARB = $2025; - WGL_GENERIC_ACCELERATION_ARB = $2026; - WGL_FULL_ACCELERATION_ARB = $2027; - WGL_SWAP_EXCHANGE_ARB = $2028; - WGL_SWAP_COPY_ARB = $2029; - WGL_SWAP_UNDEFINED_ARB = $202A; - WGL_TYPE_RGBA_ARB = $202B; - WGL_TYPE_COLORINDEX_ARB = $202C; -var - wglGetPixelFormatAttribivARB: function(hdc: HDC; iPixelFormat: GLint; iLayerPlane: GLint; nAttributes: GLuint; const piAttributes: PGLint; piValues: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetPixelFormatAttribfvARB: function(hdc: HDC; iPixelFormat: GLint; iLayerPlane: GLint; nAttributes: GLuint; const piAttributes: PGLint; pfValues: PGLfloat): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglChoosePixelFormatARB: function(hdc: HDC; const piAttribIList: PGLint; const pfAttribFList: PGLfloat; nMaxFormats: GLuint; piFormats: PGLint; nNumFormats: PGLuint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_ARB_pixel_format: Boolean; - -//***** WGL_ARB_make_current_read *****// -const - WGL_ERROR_INVALID_PIXEL_TYPE_ARB = $2043; - WGL_ERROR_INCOMPATIBLE_DEVICE_CONTEXTS_ARB = $2054; -var - wglMakeContextCurrentARB: function(hDrawDC: HDC; hReadDC: HDC; hglrc: HGLRC): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetCurrentReadDCARB: function(): HDC; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_ARB_make_current_read: Boolean; - -//***** WGL_ARB_pbuffer *****// -const - WGL_DRAW_TO_PBUFFER_ARB = $202D; - // WGL_DRAW_TO_PBUFFER_ARB { already defined } - WGL_MAX_PBUFFER_PIXELS_ARB = $202E; - WGL_MAX_PBUFFER_WIDTH_ARB = $202F; - WGL_MAX_PBUFFER_HEIGHT_ARB = $2030; - WGL_PBUFFER_LARGEST_ARB = $2033; - WGL_PBUFFER_WIDTH_ARB = $2034; - WGL_PBUFFER_HEIGHT_ARB = $2035; - WGL_PBUFFER_LOST_ARB = $2036; -var - wglCreatePbufferARB: function(hDC: HDC; iPixelFormat: GLint; iWidth: GLint; iHeight: GLint; const piAttribList: PGLint): THandle; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetPbufferDCARB: function(hPbuffer: THandle): HDC; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglReleasePbufferDCARB: function(hPbuffer: THandle; hDC: HDC): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglDestroyPbufferARB: function(hPbuffer: THandle): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglQueryPbufferARB: function(hPbuffer: THandle; iAttribute: GLint; piValue: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_ARB_pbuffer: Boolean; - -//***** WGL_EXT_swap_control *****// -var - wglSwapIntervalEXT: function(interval: GLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetSwapIntervalEXT: function(): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_EXT_swap_control: Boolean; - -//***** WGL_ARB_render_texture *****// -const - WGL_BIND_TO_TEXTURE_RGB_ARB = $2070; - WGL_BIND_TO_TEXTURE_RGBA_ARB = $2071; - WGL_TEXTURE_FORMAT_ARB = $2072; - WGL_TEXTURE_TARGET_ARB = $2073; - WGL_MIPMAP_TEXTURE_ARB = $2074; - WGL_TEXTURE_RGB_ARB = $2075; - WGL_TEXTURE_RGBA_ARB = $2076; - WGL_NO_TEXTURE_ARB = $2077; - WGL_TEXTURE_CUBE_MAP_ARB = $2078; - WGL_TEXTURE_1D_ARB = $2079; - WGL_TEXTURE_2D_ARB = $207A; - // WGL_NO_TEXTURE_ARB { already defined } - WGL_MIPMAP_LEVEL_ARB = $207B; - WGL_CUBE_MAP_FACE_ARB = $207C; - WGL_TEXTURE_CUBE_MAP_POSITIVE_X_ARB = $207D; - WGL_TEXTURE_CUBE_MAP_NEGATIVE_X_ARB = $207E; - WGL_TEXTURE_CUBE_MAP_POSITIVE_Y_ARB = $207F; - WGL_TEXTURE_CUBE_MAP_NEGATIVE_Y_ARB = $2080; - WGL_TEXTURE_CUBE_MAP_POSITIVE_Z_ARB = $2081; - WGL_TEXTURE_CUBE_MAP_NEGATIVE_Z_ARB = $2082; - WGL_FRONT_LEFT_ARB = $2083; - WGL_FRONT_RIGHT_ARB = $2084; - WGL_BACK_LEFT_ARB = $2085; - WGL_BACK_RIGHT_ARB = $2086; - WGL_AUX0_ARB = $2087; - WGL_AUX1_ARB = $2088; - WGL_AUX2_ARB = $2089; - WGL_AUX3_ARB = $208A; - WGL_AUX4_ARB = $208B; - WGL_AUX5_ARB = $208C; - WGL_AUX6_ARB = $208D; - WGL_AUX7_ARB = $208E; - WGL_AUX8_ARB = $208F; - WGL_AUX9_ARB = $2090; -var - wglBindTexImageARB: function(hPbuffer: THandle; iBuffer: GLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglReleaseTexImageARB: function(hPbuffer: THandle; iBuffer: GLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglSetPbufferAttribARB: function(hPbuffer: THandle; const piAttribList: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_ARB_render_texture: Boolean; - -//***** WGL_EXT_extensions_string *****// -var - wglGetExtensionsStringEXT: function(): Pchar; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_EXT_extensions_string: Boolean; - -//***** WGL_EXT_make_current_read *****// -var - wglMakeContextCurrentEXT: function(hDrawDC: HDC; hReadDC: HDC; hglrc: HGLRC): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetCurrentReadDCEXT: function(): HDC; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_EXT_make_current_read: Boolean; - -//***** WGL_EXT_pbuffer *****// -const - WGL_DRAW_TO_PBUFFER_EXT = $202D; - WGL_MAX_PBUFFER_PIXELS_EXT = $202E; - WGL_MAX_PBUFFER_WIDTH_EXT = $202F; - WGL_MAX_PBUFFER_HEIGHT_EXT = $2030; - WGL_OPTIMAL_PBUFFER_WIDTH_EXT = $2031; - WGL_OPTIMAL_PBUFFER_HEIGHT_EXT = $2032; - WGL_PBUFFER_LARGEST_EXT = $2033; - WGL_PBUFFER_WIDTH_EXT = $2034; - WGL_PBUFFER_HEIGHT_EXT = $2035; -var - wglCreatePbufferEXT: function(hDC: HDC; iPixelFormat: GLint; iWidth: GLint; iHeight: GLint; const piAttribList: PGLint): THandle; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetPbufferDCEXT: function(hPbuffer: THandle): HDC; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglReleasePbufferDCEXT: function(hPbuffer: THandle; hDC: HDC): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglDestroyPbufferEXT: function(hPbuffer: THandle): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglQueryPbufferEXT: function(hPbuffer: THandle; iAttribute: GLint; piValue: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_EXT_pbuffer: Boolean; - -//***** WGL_EXT_pixel_format *****// -const - WGL_NUMBER_PIXEL_FORMATS_EXT = $2000; - WGL_DRAW_TO_WINDOW_EXT = $2001; - WGL_DRAW_TO_BITMAP_EXT = $2002; - WGL_ACCELERATION_EXT = $2003; - WGL_NEED_PALETTE_EXT = $2004; - WGL_NEED_SYSTEM_PALETTE_EXT = $2005; - WGL_SWAP_LAYER_BUFFERS_EXT = $2006; - WGL_SWAP_METHOD_EXT = $2007; - WGL_NUMBER_OVERLAYS_EXT = $2008; - WGL_NUMBER_UNDERLAYS_EXT = $2009; - WGL_TRANSPARENT_EXT = $200A; - WGL_TRANSPARENT_VALUE_EXT = $200B; - WGL_SHARE_DEPTH_EXT = $200C; - WGL_SHARE_STENCIL_EXT = $200D; - WGL_SHARE_ACCUM_EXT = $200E; - WGL_SUPPORT_GDI_EXT = $200F; - WGL_SUPPORT_OPENGL_EXT = $2010; - WGL_DOUBLE_BUFFER_EXT = $2011; - WGL_STEREO_EXT = $2012; - WGL_PIXEL_TYPE_EXT = $2013; - WGL_COLOR_BITS_EXT = $2014; - WGL_RED_BITS_EXT = $2015; - WGL_RED_SHIFT_EXT = $2016; - WGL_GREEN_BITS_EXT = $2017; - WGL_GREEN_SHIFT_EXT = $2018; - WGL_BLUE_BITS_EXT = $2019; - WGL_BLUE_SHIFT_EXT = $201A; - WGL_ALPHA_BITS_EXT = $201B; - WGL_ALPHA_SHIFT_EXT = $201C; - WGL_ACCUM_BITS_EXT = $201D; - WGL_ACCUM_RED_BITS_EXT = $201E; - WGL_ACCUM_GREEN_BITS_EXT = $201F; - WGL_ACCUM_BLUE_BITS_EXT = $2020; - WGL_ACCUM_ALPHA_BITS_EXT = $2021; - WGL_DEPTH_BITS_EXT = $2022; - WGL_STENCIL_BITS_EXT = $2023; - WGL_AUX_BUFFERS_EXT = $2024; - WGL_NO_ACCELERATION_EXT = $2025; - WGL_GENERIC_ACCELERATION_EXT = $2026; - WGL_FULL_ACCELERATION_EXT = $2027; - WGL_SWAP_EXCHANGE_EXT = $2028; - WGL_SWAP_COPY_EXT = $2029; - WGL_SWAP_UNDEFINED_EXT = $202A; - WGL_TYPE_RGBA_EXT = $202B; - WGL_TYPE_COLORINDEX_EXT = $202C; -var - wglGetPixelFormatAttribivEXT: function(hdc: HDC; iPixelFormat: GLint; iLayerPlane: GLint; nAttributes: GLuint; piAttributes: PGLint; piValues: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetPixelFormatAttribfvEXT: function(hdc: HDC; iPixelFormat: GLint; iLayerPlane: GLint; nAttributes: GLuint; piAttributes: PGLint; pfValues: PGLfloat): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglChoosePixelFormatEXT: function(hdc: HDC; const piAttribIList: PGLint; const pfAttribFList: PGLfloat; nMaxFormats: GLuint; piFormats: PGLint; nNumFormats: PGLuint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_EXT_pixel_format: Boolean; - -//***** WGL_I3D_digital_video_control *****// -const - WGL_DIGITAL_VIDEO_CURSOR_ALPHA_FRAMEBUFFER_I3D = $2050; - WGL_DIGITAL_VIDEO_CURSOR_ALPHA_VALUE_I3D = $2051; - WGL_DIGITAL_VIDEO_CURSOR_INCLUDED_I3D = $2052; - WGL_DIGITAL_VIDEO_GAMMA_CORRECTED_I3D = $2053; -var - wglGetDigitalVideoParametersI3D: function(hDC: HDC; iAttribute: GLint; piValue: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglSetDigitalVideoParametersI3D: function(hDC: HDC; iAttribute: GLint; const piValue: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_I3D_digital_video_control: Boolean; - -//***** WGL_I3D_gamma *****// -const - WGL_GAMMA_TABLE_SIZE_I3D = $204E; - WGL_GAMMA_EXCLUDE_DESKTOP_I3D = $204F; - // WGL_GAMMA_EXCLUDE_DESKTOP_I3D { already defined } -var - wglGetGammaTableParametersI3D: function(hDC: HDC; iAttribute: GLint; piValue: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglSetGammaTableParametersI3D: function(hDC: HDC; iAttribute: GLint; const piValue: PGLint): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetGammaTableI3D: function(hDC: HDC; iEntries: GLint; puRed: PGLUSHORT; puGreen: PGLUSHORT; puBlue: PGLUSHORT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglSetGammaTableI3D: function(hDC: HDC; iEntries: GLint; const puRed: PGLUSHORT; const puGreen: PGLUSHORT; const puBlue: PGLUSHORT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_I3D_gamma: Boolean; - -//***** WGL_I3D_genlock *****// -const - WGL_GENLOCK_SOURCE_MULTIVIEW_I3D = $2044; - WGL_GENLOCK_SOURCE_EXTERNAL_SYNC_I3D = $2045; - WGL_GENLOCK_SOURCE_EXTERNAL_FIELD_I3D = $2046; - WGL_GENLOCK_SOURCE_EXTERNAL_TTL_I3D = $2047; - WGL_GENLOCK_SOURCE_DIGITAL_SYNC_I3D = $2048; - WGL_GENLOCK_SOURCE_DIGITAL_FIELD_I3D = $2049; - WGL_GENLOCK_SOURCE_EDGE_FALLING_I3D = $204A; - WGL_GENLOCK_SOURCE_EDGE_RISING_I3D = $204B; - WGL_GENLOCK_SOURCE_EDGE_BOTH_I3D = $204C; -var - wglEnableGenlockI3D: function(hDC: HDC): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglDisableGenlockI3D: function(hDC: HDC): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglIsEnabledGenlockI3D: function(hDC: HDC; pFlag: PBOOL): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGenlockSourceI3D: function(hDC: HDC; uSource: GLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetGenlockSourceI3D: function(hDC: HDC; uSource: PGLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGenlockSourceEdgeI3D: function(hDC: HDC; uEdge: GLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetGenlockSourceEdgeI3D: function(hDC: HDC; uEdge: PGLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGenlockSampleRateI3D: function(hDC: HDC; uRate: GLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetGenlockSampleRateI3D: function(hDC: HDC; uRate: PGLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGenlockSourceDelayI3D: function(hDC: HDC; uDelay: GLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglGetGenlockSourceDelayI3D: function(hDC: HDC; uDelay: PGLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - wglQueryGenlockMaxSourceDelayI3D: function(hDC: HDC; uMaxLineDelay: PGLUINT; uMaxPixelDelay: PGLUINT): BOOL; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_WGL_I3D_genlock: Boolean; -{$ENDIF} - -//***** GL_ARB_matrix_palette *****// -const - GL_MATRIX_PALETTE_ARB = $8840; - GL_MAX_MATRIX_PALETTE_STACK_DEPTH_ARB = $8841; - GL_MAX_PALETTE_MATRICES_ARB = $8842; - GL_CURRENT_PALETTE_MATRIX_ARB = $8843; - GL_MATRIX_INDEX_ARRAY_ARB = $8844; - GL_CURRENT_MATRIX_INDEX_ARB = $8845; - GL_MATRIX_INDEX_ARRAY_SIZE_ARB = $8846; - GL_MATRIX_INDEX_ARRAY_TYPE_ARB = $8847; - GL_MATRIX_INDEX_ARRAY_STRIDE_ARB = $8848; - GL_MATRIX_INDEX_ARRAY_POINTER_ARB = $8849; -var - glCurrentPaletteMatrixARB: procedure(index: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMatrixIndexubvARB: procedure(size: GLint; indices: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMatrixIndexusvARB: procedure(size: GLint; indices: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMatrixIndexuivARB: procedure(size: GLint; indices: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMatrixIndexPointerARB: procedure(size: GLint; _type: GLenum; stride: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_matrix_palette: Boolean; - -//***** GL_NV_element_array *****// -const - GL_ELEMENT_ARRAY_TYPE_NV = $8769; - GL_ELEMENT_ARRAY_POINTER_NV = $876A; -var - glElementPointerNV: procedure(_type: GLenum; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawElementArrayNV: procedure(mode: GLenum; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawRangeElementArrayNV: procedure(mode: GLenum; start: GLuint; _end: GLuint; first: GLint; count: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawElementArrayNV: procedure(mode: GLenum; const first: PGLint; const count: PGLsizei; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawRangeElementArrayNV: procedure(mode: GLenum; start: GLuint; _end: GLuint; const first: PGLint; const count: PGLsizei; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_element_array: Boolean; - -//***** GL_NV_float_buffer *****// -const - GL_FLOAT_R_NV = $8880; - GL_FLOAT_RG_NV = $8881; - GL_FLOAT_RGB_NV = $8882; - GL_FLOAT_RGBA_NV = $8883; - GL_FLOAT_R16_NV = $8884; - GL_FLOAT_R32_NV = $8885; - GL_FLOAT_RG16_NV = $8886; - GL_FLOAT_RG32_NV = $8887; - GL_FLOAT_RGB16_NV = $8888; - GL_FLOAT_RGB32_NV = $8889; - GL_FLOAT_RGBA16_NV = $888A; - GL_FLOAT_RGBA32_NV = $888B; - GL_TEXTURE_FLOAT_COMPONENTS_NV = $888C; - GL_FLOAT_CLEAR_COLOR_VALUE_NV = $888D; - GL_FLOAT_RGBA_MODE_NV = $888E; -{$IFDEF WINDOWS} - WGL_FLOAT_COMPONENTS_NV = $20B0; - WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_R_NV = $20B1; - WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RG_NV = $20B2; - WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGB_NV = $20B3; - WGL_BIND_TO_TEXTURE_RECTANGLE_FLOAT_RGBA_NV = $20B4; - WGL_TEXTURE_FLOAT_R_NV = $20B5; - WGL_TEXTURE_FLOAT_RG_NV = $20B6; - WGL_TEXTURE_FLOAT_RGB_NV = $20B7; - WGL_TEXTURE_FLOAT_RGBA_NV = $20B8; -{$ENDIF} - -function Load_GL_NV_float_buffer: Boolean; - -//***** GL_NV_fragment_program *****// -const - GL_FRAGMENT_PROGRAM_NV = $8870; - GL_MAX_TEXTURE_COORDS_NV = $8871; - GL_MAX_TEXTURE_IMAGE_UNITS_NV = $8872; - GL_FRAGMENT_PROGRAM_BINDING_NV = $8873; - GL_MAX_FRAGMENT_PROGRAM_LOCAL_PARAMETERS_NV = $8868; - GL_PROGRAM_ERROR_STRING_NV = $8874; -var - glProgramNamedParameter4fNV: procedure(id: GLuint; len: GLsizei; const name: PGLubyte; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glProgramNamedParameter4dNV: procedure(id: GLuint; len: GLsizei; const name: PGLubyte; x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramNamedParameterfvNV: procedure(id: GLuint; len: GLsizei; const name: PGLubyte; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramNamedParameterdvNV: procedure(id: GLuint; len: GLsizei; const name: PGLubyte; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - // glProgramLocalParameter4dARB { already defined } - // glProgramLocalParameter4dvARB { already defined } - // glProgramLocalParameter4fARB { already defined } - // glProgramLocalParameter4fvARB { already defined } - // glGetProgramLocalParameterdvARB { already defined } - // glGetProgramLocalParameterfvARB { already defined } - -function Load_GL_NV_fragment_program: Boolean; - -//***** GL_NV_primitive_restart *****// -const - GL_PRIMITIVE_RESTART_NV = $8558; - GL_PRIMITIVE_RESTART_INDEX_NV = $8559; -var - glPrimitiveRestartNV: procedure(); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPrimitiveRestartIndexNV: procedure(index: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_primitive_restart: Boolean; - -//***** GL_NV_vertex_program2 *****// - -function Load_GL_NV_vertex_program2: Boolean; - -{$IFDEF WINDOWS} -//***** WGL_NV_render_texture_rectangle *****// -const - WGL_BIND_TO_TEXTURE_RECTANGLE_RGB_NV = $20A0; - WGL_BIND_TO_TEXTURE_RECTANGLE_RGBA_NV = $20A1; - WGL_TEXTURE_RECTANGLE_NV = $20A2; - -function Load_WGL_NV_render_texture_rectangle: Boolean; -{$ENDIF} - -//***** GL_NV_pixel_data_range *****// -const - GL_WRITE_PIXEL_DATA_RANGE_NV = $8878; - GL_READ_PIXEL_DATA_RANGE_NV = $8879; - GL_WRITE_PIXEL_DATA_RANGE_LENGTH_NV = $887A; - GL_READ_PIXEL_DATA_RANGE_LENGTH_NV = $887B; - GL_WRITE_PIXEL_DATA_RANGE_POINTER_NV = $887C; - GL_READ_PIXEL_DATA_RANGE_POINTER_NV = $887D; -var - glPixelDataRangeNV: procedure(target: GLenum; length: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFlushPixelDataRangeNV: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - // wglAllocateMemoryNV { already defined } - // wglFreeMemoryNV { already defined } - -function Load_GL_NV_pixel_data_range: Boolean; - -//***** GL_EXT_texture_rectangle *****// -const - GL_TEXTURE_RECTANGLE_EXT = $84F5; - GL_TEXTURE_BINDING_RECTANGLE_EXT = $84F6; - GL_PROXY_TEXTURE_RECTANGLE_EXT = $84F7; - GL_MAX_RECTANGLE_TEXTURE_SIZE_EXT = $84F8; - -function Load_GL_EXT_texture_rectangle: Boolean; - -//***** GL_S3_s3tc *****// -const - GL_RGB_S3TC = $83A0; - GL_RGB4_S3TC = $83A1; - GL_RGBA_S3TC = $83A2; - GL_RGBA4_S3TC = $83A3; - -function Load_GL_S3_s3tc: Boolean; - -//***** GL_ATI_draw_buffers *****// -const - GL_MAX_DRAW_BUFFERS_ATI = $8824; - GL_DRAW_BUFFER0_ATI = $8825; - GL_DRAW_BUFFER1_ATI = $8826; - GL_DRAW_BUFFER2_ATI = $8827; - GL_DRAW_BUFFER3_ATI = $8828; - GL_DRAW_BUFFER4_ATI = $8829; - GL_DRAW_BUFFER5_ATI = $882A; - GL_DRAW_BUFFER6_ATI = $882B; - GL_DRAW_BUFFER7_ATI = $882C; - GL_DRAW_BUFFER8_ATI = $882D; - GL_DRAW_BUFFER9_ATI = $882E; - GL_DRAW_BUFFER10_ATI = $882F; - GL_DRAW_BUFFER11_ATI = $8830; - GL_DRAW_BUFFER12_ATI = $8831; - GL_DRAW_BUFFER13_ATI = $8832; - GL_DRAW_BUFFER14_ATI = $8833; - GL_DRAW_BUFFER15_ATI = $8834; -var - glDrawBuffersATI: procedure(n: GLsizei; const bufs: PGLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_draw_buffers: Boolean; - -{$IFDEF WINDOWS} -//***** WGL_ATI_pixel_format_float *****// -const - WGL_RGBA_FLOAT_MODE_ATI = $8820; - WGL_COLOR_CLEAR_UNCLAMPED_VALUE_ATI = $8835; - WGL_TYPE_RGBA_FLOAT_ATI = $21A0; - -function Load_WGL_ATI_pixel_format_float: Boolean; -{$ENDIF} - -//***** GL_ATI_texture_env_combine3 *****// -const - GL_MODULATE_ADD_ATI = $8744; - GL_MODULATE_SIGNED_ADD_ATI = $8745; - GL_MODULATE_SUBTRACT_ATI = $8746; - -function Load_GL_ATI_texture_env_combine3: Boolean; - -//***** GL_ATI_texture_float *****// -const - GL_RGBA_FLOAT32_ATI = $8814; - GL_RGB_FLOAT32_ATI = $8815; - GL_ALPHA_FLOAT32_ATI = $8816; - GL_INTENSITY_FLOAT32_ATI = $8817; - GL_LUMINANCE_FLOAT32_ATI = $8818; - GL_LUMINANCE_ALPHA_FLOAT32_ATI = $8819; - GL_RGBA_FLOAT16_ATI = $881A; - GL_RGB_FLOAT16_ATI = $881B; - GL_ALPHA_FLOAT16_ATI = $881C; - GL_INTENSITY_FLOAT16_ATI = $881D; - GL_LUMINANCE_FLOAT16_ATI = $881E; - GL_LUMINANCE_ALPHA_FLOAT16_ATI = $881F; - -function Load_GL_ATI_texture_float: Boolean; - -//***** GL_NV_texture_expand_normal *****// -const - GL_TEXTURE_UNSIGNED_REMAP_MODE_NV = $888F; - -function Load_GL_NV_texture_expand_normal: Boolean; - -//***** GL_NV_half_float *****// -const - GL_HALF_FLOAT_NV = $140B; -var - glVertex2hNV: procedure(x: GLushort; y: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex2hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3hNV: procedure(x: GLushort; y: GLushort; z: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex3hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4hNV: procedure(x: GLushort; y: GLushort; z: GLushort; w: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertex4hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3hNV: procedure(nx: GLushort; ny: GLushort; nz: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glNormal3hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3hNV: procedure(red: GLushort; green: GLushort; blue: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor3hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4hNV: procedure(red: GLushort; green: GLushort; blue: GLushort; alpha: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glColor4hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1hNV: procedure(s: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord1hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2hNV: procedure(s: GLushort; t: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord2hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3hNV: procedure(s: GLushort; t: GLushort; r: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord3hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4hNV: procedure(s: GLushort; t: GLushort; r: GLushort; q: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glTexCoord4hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1hNV: procedure(target: GLenum; s: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord1hvNV: procedure(target: GLenum; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2hNV: procedure(target: GLenum; s: GLushort; t: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord2hvNV: procedure(target: GLenum; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3hNV: procedure(target: GLenum; s: GLushort; t: GLushort; r: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord3hvNV: procedure(target: GLenum; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4hNV: procedure(target: GLenum; s: GLushort; t: GLushort; r: GLushort; q: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiTexCoord4hvNV: procedure(target: GLenum; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordhNV: procedure(fog: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordhvNV: procedure(const fog: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3hNV: procedure(red: GLushort; green: GLushort; blue: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3hvNV: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexWeighthNV: procedure(weight: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexWeighthvNV: procedure(const weight: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1hNV: procedure(index: GLuint; x: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1hvNV: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2hNV: procedure(index: GLuint; x: GLushort; y: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2hvNV: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3hNV: procedure(index: GLuint; x: GLushort; y: GLushort; z: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3hvNV: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4hNV: procedure(index: GLuint; x: GLushort; y: GLushort; z: GLushort; w: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4hvNV: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs1hvNV: procedure(index: GLuint; n: GLsizei; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs2hvNV: procedure(index: GLuint; n: GLsizei; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs3hvNV: procedure(index: GLuint; n: GLsizei; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribs4hvNV: procedure(index: GLuint; n: GLsizei; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_NV_half_float: Boolean; - -//***** GL_ATI_map_object_buffer *****// -var - glMapObjectBufferATI: function(buffer: GLuint): PGLvoid; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUnmapObjectBufferATI: procedure(buffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_map_object_buffer: Boolean; - -//***** GL_ATI_separate_stencil *****// -const - GL_KEEP = $1E00; - GL_ZERO = $0000; - GL_REPLACE = $1E01; - GL_INCR = $1E02; - GL_DECR = $1E03; - GL_INVERT = $150A; - GL_NEVER = $0200; - GL_LESS = $0201; - GL_LEQUAL = $0203; - GL_GREATER = $0204; - GL_GEQUAL = $0206; - GL_EQUAL = $0202; - GL_NOTEQUAL = $0205; - GL_ALWAYS = $0207; - GL_FRONT = $0404; - GL_BACK = $0405; - GL_FRONT_AND_BACK = $0408; - GL_STENCIL_BACK_FUNC_ATI = $8800; - GL_STENCIL_BACK_FAIL_ATI = $8801; - GL_STENCIL_BACK_PASS_DEPTH_FAIL_ATI = $8802; - GL_STENCIL_BACK_PASS_DEPTH_PASS_ATI = $8803; -var - glStencilOpSeparateATI: procedure(face: GLenum; sfail: GLenum; dpfail: GLenum; dppass: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilFuncSeparateATI: procedure(frontfunc: GLenum; backfunc: GLenum; ref: GLint; mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_separate_stencil: Boolean; - -//***** GL_ATI_vertex_attrib_array_object *****// -var - glVertexAttribArrayObjectATI: procedure(index: GLuint; size: GLint; _type: GLenum; normalized: GLboolean; stride: GLsizei; buffer: GLuint; offset: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribArrayObjectfvATI: procedure(index: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribArrayObjectivATI: procedure(index: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ATI_vertex_attrib_array_object: Boolean; - -//***** GL_ARB_vertex_buffer_object *****// -const - GL_ARRAY_BUFFER_ARB = $8892; - GL_ELEMENT_ARRAY_BUFFER_ARB = $8893; - GL_ARRAY_BUFFER_BINDING_ARB = $8894; - GL_ELEMENT_ARRAY_BUFFER_BINDING_ARB = $8895; - GL_VERTEX_ARRAY_BUFFER_BINDING_ARB = $8896; - GL_NORMAL_ARRAY_BUFFER_BINDING_ARB = $8897; - GL_COLOR_ARRAY_BUFFER_BINDING_ARB = $8898; - GL_INDEX_ARRAY_BUFFER_BINDING_ARB = $8899; - GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING_ARB = $889A; - GL_EDGE_FLAG_ARRAY_BUFFER_BINDING_ARB = $889B; - GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING_ARB = $889C; - GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING_ARB = $889D; - GL_WEIGHT_ARRAY_BUFFER_BINDING_ARB = $889E; - GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING_ARB = $889F; - GL_STREAM_DRAW_ARB = $88E0; - GL_STREAM_READ_ARB = $88E1; - GL_STREAM_COPY_ARB = $88E2; - GL_STATIC_DRAW_ARB = $88E4; - GL_STATIC_READ_ARB = $88E5; - GL_STATIC_COPY_ARB = $88E6; - GL_DYNAMIC_DRAW_ARB = $88E8; - GL_DYNAMIC_READ_ARB = $88E9; - GL_DYNAMIC_COPY_ARB = $88EA; - GL_READ_ONLY_ARB = $88B8; - GL_WRITE_ONLY_ARB = $88B9; - GL_READ_WRITE_ARB = $88BA; - GL_BUFFER_SIZE_ARB = $8764; - GL_BUFFER_USAGE_ARB = $8765; - GL_BUFFER_ACCESS_ARB = $88BB; - GL_BUFFER_MAPPED_ARB = $88BC; - GL_BUFFER_MAP_POINTER_ARB = $88BD; -var - glBindBufferARB: procedure(target: GLenum; buffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteBuffersARB: procedure(n: GLsizei; const buffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenBuffersARB: procedure(n: GLsizei; buffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsBufferARB: function(buffer: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBufferDataARB: procedure(target: GLenum; size: GLsizeiptrARB; const data: PGLvoid; usage: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBufferSubDataARB: procedure(target: GLenum; offset: GLintptrARB; size: GLsizeiptrARB; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBufferSubDataARB: procedure(target: GLenum; offset: GLintptrARB; size: GLsizeiptrARB; data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapBufferARB: function(target: GLenum; access: GLenum): PGLvoid; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUnmapBufferARB: function(target: GLenum): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBufferParameterivARB: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBufferPointervARB: procedure(target: GLenum; pname: GLenum; params: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_vertex_buffer_object: Boolean; - -//***** GL_ARB_occlusion_query *****// -const - GL_SAMPLES_PASSED_ARB = $8914; - GL_QUERY_COUNTER_BITS_ARB = $8864; - GL_CURRENT_QUERY_ARB = $8865; - GL_QUERY_RESULT_ARB = $8866; - GL_QUERY_RESULT_AVAILABLE_ARB = $8867; -var - glGenQueriesARB: procedure(n: GLsizei; ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteQueriesARB: procedure(n: GLsizei; const ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsQueryARB: function(id: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBeginQueryARB: procedure(target: GLenum; id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEndQueryARB: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetQueryivARB: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetQueryObjectivARB: procedure(id: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetQueryObjectuivARB: procedure(id: GLuint; pname: GLenum; params: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_occlusion_query: Boolean; - -//***** GL_ARB_shader_objects *****// -const - GL_PROGRAM_OBJECT_ARB = $8B40; - GL_OBJECT_TYPE_ARB = $8B4E; - GL_OBJECT_SUBTYPE_ARB = $8B4F; - GL_OBJECT_DELETE_STATUS_ARB = $8B80; - GL_OBJECT_COMPILE_STATUS_ARB = $8B81; - GL_OBJECT_LINK_STATUS_ARB = $8B82; - GL_OBJECT_VALIDATE_STATUS_ARB = $8B83; - GL_OBJECT_INFO_LOG_LENGTH_ARB = $8B84; - GL_OBJECT_ATTACHED_OBJECTS_ARB = $8B85; - GL_OBJECT_ACTIVE_UNIFORMS_ARB = $8B86; - GL_OBJECT_ACTIVE_UNIFORM_MAX_LENGTH_ARB = $8B87; - GL_OBJECT_SHADER_SOURCE_LENGTH_ARB = $8B88; - GL_SHADER_OBJECT_ARB = $8B48; - GL_FLOAT = $1406; - GL_FLOAT_VEC2_ARB = $8B50; - GL_FLOAT_VEC3_ARB = $8B51; - GL_FLOAT_VEC4_ARB = $8B52; - GL_INT = $1404; - GL_INT_VEC2_ARB = $8B53; - GL_INT_VEC3_ARB = $8B54; - GL_INT_VEC4_ARB = $8B55; - GL_BOOL_ARB = $8B56; - GL_BOOL_VEC2_ARB = $8B57; - GL_BOOL_VEC3_ARB = $8B58; - GL_BOOL_VEC4_ARB = $8B59; - GL_FLOAT_MAT2_ARB = $8B5A; - GL_FLOAT_MAT3_ARB = $8B5B; - GL_FLOAT_MAT4_ARB = $8B5C; -var - glDeleteObjectARB: procedure(obj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetHandleARB: function(pname: GLenum): GLhandleARB; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDetachObjectARB: procedure(containerObj: GLhandleARB; attachedObj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCreateShaderObjectARB: function(shaderType: GLenum): GLhandleARB; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glShaderSourceARB: procedure(shaderObj: GLhandleARB; count: GLsizei; const _string: PGLvoid; const length: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompileShaderARB: procedure(shaderObj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCreateProgramObjectARB: function(): GLhandleARB; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAttachObjectARB: procedure(containerObj: GLhandleARB; obj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLinkProgramARB: procedure(programObj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUseProgramObjectARB: procedure(programObj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glValidateProgramARB: procedure(programObj: GLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1fARB: procedure(location: GLint; v0: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2fARB: procedure(location: GLint; v0: GLfloat; v1: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3fARB: procedure(location: GLint; v0: GLfloat; v1: GLfloat; v2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4fARB: procedure(location: GLint; v0: GLfloat; v1: GLfloat; v2: GLfloat; v3: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1iARB: procedure(location: GLint; v0: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2iARB: procedure(location: GLint; v0: GLint; v1: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3iARB: procedure(location: GLint; v0: GLint; v1: GLint; v2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4iARB: procedure(location: GLint; v0: GLint; v1: GLint; v2: GLint; v3: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1fvARB: procedure(location: GLint; count: GLsizei; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2fvARB: procedure(location: GLint; count: GLsizei; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3fvARB: procedure(location: GLint; count: GLsizei; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4fvARB: procedure(location: GLint; count: GLsizei; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1ivARB: procedure(location: GLint; count: GLsizei; value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2ivARB: procedure(location: GLint; count: GLsizei; value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3ivARB: procedure(location: GLint; count: GLsizei; value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4ivARB: procedure(location: GLint; count: GLsizei; value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniformMatrix2fvARB: procedure(location: GLint; count: GLsizei; transpose: GLboolean; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniformMatrix3fvARB: procedure(location: GLint; count: GLsizei; transpose: GLboolean; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniformMatrix4fvARB: procedure(location: GLint; count: GLsizei; transpose: GLboolean; value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetObjectParameterfvARB: procedure(obj: GLhandleARB; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetObjectParameterivARB: procedure(obj: GLhandleARB; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetInfoLogARB: procedure(obj: GLhandleARB; maxLength: GLsizei; length: PGLsizei; infoLog: PGLcharARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetAttachedObjectsARB: procedure(containerObj: GLhandleARB; maxCount: GLsizei; count: PGLsizei; obj: PGLhandleARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetUniformLocationARB: function(programObj: GLhandleARB; const name: PGLcharARB): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetActiveUniformARB: procedure(programObj: GLhandleARB; index: GLuint; maxLength: GLsizei; length: PGLsizei; size: PGLint; _type: PGLenum; name: PGLcharARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetUniformfvARB: procedure(programObj: GLhandleARB; location: GLint; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetUniformivARB: procedure(programObj: GLhandleARB; location: GLint; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetShaderSourceARB: procedure(obj: GLhandleARB; maxLength: GLsizei; length: PGLsizei; source: PGLcharARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_shader_objects: Boolean; - -//***** GL_ARB_vertex_shader *****// -const - GL_VERTEX_SHADER_ARB = $8B31; - GL_MAX_VERTEX_UNIFORM_COMPONENTS_ARB = $8B4A; - GL_MAX_VARYING_FLOATS_ARB = $8B4B; - // GL_MAX_VERTEX_ATTRIBS_ARB { already defined } - // GL_MAX_TEXTURE_IMAGE_UNITS_ARB { already defined } - GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS_ARB = $8B4C; - GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS_ARB = $8B4D; - // GL_MAX_TEXTURE_COORDS_ARB { already defined } - // GL_VERTEX_PROGRAM_POINT_SIZE_ARB { already defined } - // GL_VERTEX_PROGRAM_TWO_SIDE_ARB { already defined } - // GL_OBJECT_TYPE_ARB { already defined } - // GL_OBJECT_SUBTYPE_ARB { already defined } - GL_OBJECT_ACTIVE_ATTRIBUTES_ARB = $8B89; - GL_OBJECT_ACTIVE_ATTRIBUTE_MAX_LENGTH_ARB = $8B8A; - // GL_SHADER_OBJECT_ARB { already defined } - // GL_VERTEX_ATTRIB_ARRAY_ENABLED_ARB { already defined } - // GL_VERTEX_ATTRIB_ARRAY_SIZE_ARB { already defined } - // GL_VERTEX_ATTRIB_ARRAY_STRIDE_ARB { already defined } - // GL_VERTEX_ATTRIB_ARRAY_TYPE_ARB { already defined } - // GL_VERTEX_ATTRIB_ARRAY_NORMALIZED_ARB { already defined } - // GL_CURRENT_VERTEX_ATTRIB_ARB { already defined } - // GL_VERTEX_ATTRIB_ARRAY_POINTER_ARB { already defined } - // GL_FLOAT { already defined } - // GL_FLOAT_VEC2_ARB { already defined } - // GL_FLOAT_VEC3_ARB { already defined } - // GL_FLOAT_VEC4_ARB { already defined } - // GL_FLOAT_MAT2_ARB { already defined } - // GL_FLOAT_MAT3_ARB { already defined } - // GL_FLOAT_MAT4_ARB { already defined } - // glVertexAttrib1fARB { already defined } - // glVertexAttrib1sARB { already defined } - // glVertexAttrib1dARB { already defined } - // glVertexAttrib2fARB { already defined } - // glVertexAttrib2sARB { already defined } - // glVertexAttrib2dARB { already defined } - // glVertexAttrib3fARB { already defined } - // glVertexAttrib3sARB { already defined } - // glVertexAttrib3dARB { already defined } - // glVertexAttrib4fARB { already defined } - // glVertexAttrib4sARB { already defined } - // glVertexAttrib4dARB { already defined } - // glVertexAttrib4NubARB { already defined } - // glVertexAttrib1fvARB { already defined } - // glVertexAttrib1svARB { already defined } - // glVertexAttrib1dvARB { already defined } - // glVertexAttrib2fvARB { already defined } - // glVertexAttrib2svARB { already defined } - // glVertexAttrib2dvARB { already defined } - // glVertexAttrib3fvARB { already defined } - // glVertexAttrib3svARB { already defined } - // glVertexAttrib3dvARB { already defined } - // glVertexAttrib4fvARB { already defined } - // glVertexAttrib4svARB { already defined } - // glVertexAttrib4dvARB { already defined } - // glVertexAttrib4ivARB { already defined } - // glVertexAttrib4bvARB { already defined } - // glVertexAttrib4ubvARB { already defined } - // glVertexAttrib4usvARB { already defined } - // glVertexAttrib4uivARB { already defined } - // glVertexAttrib4NbvARB { already defined } - // glVertexAttrib4NsvARB { already defined } - // glVertexAttrib4NivARB { already defined } - // glVertexAttrib4NubvARB { already defined } - // glVertexAttrib4NusvARB { already defined } - // glVertexAttrib4NuivARB { already defined } - // glVertexAttribPointerARB { already defined } - // glEnableVertexAttribArrayARB { already defined } - // glDisableVertexAttribArrayARB { already defined } -var - glBindAttribLocationARB: procedure(programObj: GLhandleARB; index: GLuint; const name: PGLcharARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetActiveAttribARB: procedure(programObj: GLhandleARB; index: GLuint; maxLength: GLsizei; length: PGLsizei; size: PGLint; _type: PGLenum; name: PGLcharARB); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetAttribLocationARB: function(programObj: GLhandleARB; const name: PGLcharARB): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - // glGetVertexAttribdvARB { already defined } - // glGetVertexAttribfvARB { already defined } - // glGetVertexAttribivARB { already defined } - // glGetVertexAttribPointervARB { already defined } - -function Load_GL_ARB_vertex_shader: Boolean; - -//***** GL_ARB_fragment_shader *****// -const - GL_FRAGMENT_SHADER_ARB = $8B30; - GL_MAX_FRAGMENT_UNIFORM_COMPONENTS_ARB = $8B49; - // GL_MAX_TEXTURE_COORDS_ARB { already defined } - // GL_MAX_TEXTURE_IMAGE_UNITS_ARB { already defined } - // GL_OBJECT_TYPE_ARB { already defined } - // GL_OBJECT_SUBTYPE_ARB { already defined } - // GL_SHADER_OBJECT_ARB { already defined } - -function Load_GL_ARB_fragment_shader: Boolean; - -//***** GL_ARB_shading_language_100 *****// - -function Load_GL_ARB_shading_language_100: Boolean; - -//***** GL_ARB_texture_non_power_of_two *****// - -function Load_GL_ARB_texture_non_power_of_two: Boolean; - -//***** GL_ARB_point_sprite *****// -const - GL_POINT_SPRITE_ARB = $8861; - GL_COORD_REPLACE_ARB = $8862; - -function Load_GL_ARB_point_sprite: Boolean; - -//***** GL_EXT_depth_bounds_test *****// -const - GL_DEPTH_BOUNDS_TEST_EXT = $8890; - GL_DEPTH_BOUNDS_EXT = $8891; -var - glDepthBoundsEXT: procedure(zmin: GLclampd; zmax: GLclampd); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_depth_bounds_test: Boolean; - -//***** GL_EXT_secondary_color *****// -const - GL_COLOR_SUM_EXT = $8458; - GL_CURRENT_SECONDARY_COLOR_EXT = $8459; - GL_SECONDARY_COLOR_ARRAY_SIZE_EXT = $845A; - GL_SECONDARY_COLOR_ARRAY_TYPE_EXT = $845B; - GL_SECONDARY_COLOR_ARRAY_STRIDE_EXT = $845C; - GL_SECONDARY_COLOR_ARRAY_POINTER_EXT = $845D; - GL_SECONDARY_COLOR_ARRAY_EXT = $845E; -var - glSecondaryColor3bEXT: procedure(r: GLbyte; g: GLbyte; b: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3sEXT: procedure(r: GLshort; g: GLshort; b: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3iEXT: procedure(r: GLint; g: GLint; b: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3fEXT: procedure(r: GLfloat; g: GLfloat; b: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3dEXT: procedure(r: GLdouble; g: GLdouble; b: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3ubEXT: procedure(r: GLubyte; g: GLubyte; b: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3usEXT: procedure(r: GLushort; g: GLushort; b: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3uiEXT: procedure(r: GLuint; g: GLuint; b: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3bvEXT: procedure(components: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3svEXT: procedure(components: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3ivEXT: procedure(components: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3fvEXT: procedure(components: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3dvEXT: procedure(components: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3ubvEXT: procedure(components: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3usvEXT: procedure(components: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3uivEXT: procedure(components: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColorPointerEXT: procedure(size: GLint; _type: GLenum; stride: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_secondary_color: Boolean; - -//***** GL_EXT_texture_mirror_clamp *****// -const - GL_MIRROR_CLAMP_EXT = $8742; - GL_MIRROR_CLAMP_TO_EDGE_EXT = $8743; - GL_MIRROR_CLAMP_TO_BORDER_EXT = $8912; - -function Load_GL_EXT_texture_mirror_clamp: Boolean; - -//***** GL_EXT_blend_equation_separate *****// -const - GL_BLEND_EQUATION_RGB_EXT = $8009; - GL_BLEND_EQUATION_ALPHA_EXT = $883D; -var - glBlendEquationSeparateEXT: procedure(modeRGB: GLenum; modeAlpha: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_blend_equation_separate: Boolean; - -//***** GL_MESA_pack_invert *****// -const - GL_PACK_INVERT_MESA = $8758; - -function Load_GL_MESA_pack_invert: Boolean; - -//***** GL_MESA_ycbcr_texture *****// -const - GL_YCBCR_MESA = $8757; - GL_UNSIGNED_SHORT_8_8_MESA = $85BA; - GL_UNSIGNED_SHORT_8_8_REV_MESA = $85BB; - -function Load_GL_MESA_ycbcr_texture: Boolean; - -//***** GL_ARB_fragment_program_shadow *****// - -function Load_GL_ARB_fragment_program_shadow: Boolean; - -//***** GL_EXT_fog_coord *****// -const - GL_FOG_COORDINATE_SOURCE_EXT = $8450; - GL_FOG_COORDINATE_EXT = $8451; - GL_FRAGMENT_DEPTH_EXT = $8452; - GL_CURRENT_FOG_COORDINATE_EXT = $8453; - GL_FOG_COORDINATE_ARRAY_TYPE_EXT = $8454; - GL_FOG_COORDINATE_ARRAY_STRIDE_EXT = $8455; - GL_FOG_COORDINATE_ARRAY_POINTER_EXT = $8456; - GL_FOG_COORDINATE_ARRAY_EXT = $8457; -var - glFogCoordfEXT: procedure(coord: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoorddEXT: procedure(coord: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordfvEXT: procedure(coord: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoorddvEXT: procedure(coord: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordPointerEXT: procedure(_type: GLenum; stride: GLsizei; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_fog_coord: Boolean; - -//***** GL_NV_fragment_program_option *****// - -function Load_GL_NV_fragment_program_option: Boolean; - -//***** GL_EXT_pixel_buffer_object *****// -const - GL_PIXEL_PACK_BUFFER_EXT = $88EB; - GL_PIXEL_UNPACK_BUFFER_EXT = $88EC; - GL_PIXEL_PACK_BUFFER_BINDING_EXT = $88ED; - GL_PIXEL_UNPACK_BUFFER_BINDING_EXT = $88EF; - -function Load_GL_EXT_pixel_buffer_object: Boolean; - -//***** GL_NV_fragment_program2 *****// -const - GL_MAX_PROGRAM_EXEC_INSTRUCTIONS_NV = $88F4; - GL_MAX_PROGRAM_CALL_DEPTH_NV = $88F5; - GL_MAX_PROGRAM_IF_DEPTH_NV = $88F6; - GL_MAX_PROGRAM_LOOP_DEPTH_NV = $88F7; - GL_MAX_PROGRAM_LOOP_COUNT_NV = $88F8; - -function Load_GL_NV_fragment_program2: Boolean; - -//***** GL_NV_vertex_program2_option *****// - // GL_MAX_PROGRAM_EXEC_INSTRUCTIONS_NV { already defined } - // GL_MAX_PROGRAM_CALL_DEPTH_NV { already defined } - -function Load_GL_NV_vertex_program2_option: Boolean; - -//***** GL_NV_vertex_program3 *****// - // GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS_ARB { already defined } - -function Load_GL_NV_vertex_program3: Boolean; - -//***** GL_ARB_draw_buffers *****// -const - GL_MAX_DRAW_BUFFERS_ARB = $8824; - GL_DRAW_BUFFER0_ARB = $8825; - GL_DRAW_BUFFER1_ARB = $8826; - GL_DRAW_BUFFER2_ARB = $8827; - GL_DRAW_BUFFER3_ARB = $8828; - GL_DRAW_BUFFER4_ARB = $8829; - GL_DRAW_BUFFER5_ARB = $882A; - GL_DRAW_BUFFER6_ARB = $882B; - GL_DRAW_BUFFER7_ARB = $882C; - GL_DRAW_BUFFER8_ARB = $882D; - GL_DRAW_BUFFER9_ARB = $882E; - GL_DRAW_BUFFER10_ARB = $882F; - GL_DRAW_BUFFER11_ARB = $8830; - GL_DRAW_BUFFER12_ARB = $8831; - GL_DRAW_BUFFER13_ARB = $8832; - GL_DRAW_BUFFER14_ARB = $8833; - GL_DRAW_BUFFER15_ARB = $8834; -var - glDrawBuffersARB: procedure(n: GLsizei; const bufs: PGLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_draw_buffers: Boolean; - -//***** GL_ARB_texture_rectangle *****// -const - GL_TEXTURE_RECTANGLE_ARB = $84F5; - GL_TEXTURE_BINDING_RECTANGLE_ARB = $84F6; - GL_PROXY_TEXTURE_RECTANGLE_ARB = $84F7; - GL_MAX_RECTANGLE_TEXTURE_SIZE_ARB = $84F8; - -function Load_GL_ARB_texture_rectangle: Boolean; - -//***** GL_ARB_color_buffer_float *****// -const - GL_RGBA_FLOAT_MODE_ARB = $8820; - GL_CLAMP_VERTEX_COLOR_ARB = $891A; - GL_CLAMP_FRAGMENT_COLOR_ARB = $891B; - GL_CLAMP_READ_COLOR_ARB = $891C; - GL_FIXED_ONLY_ARB = $891D; - WGL_TYPE_RGBA_FLOAT_ARB = $21A0; -var - glClampColorARB: procedure(target: GLenum; clamp: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_ARB_color_buffer_float: Boolean; - -//***** GL_ARB_half_float_pixel *****// -const - GL_HALF_FLOAT_ARB = $140B; - -function Load_GL_ARB_half_float_pixel: Boolean; - -//***** GL_ARB_texture_float *****// -const - GL_TEXTURE_RED_TYPE_ARB = $8C10; - GL_TEXTURE_GREEN_TYPE_ARB = $8C11; - GL_TEXTURE_BLUE_TYPE_ARB = $8C12; - GL_TEXTURE_ALPHA_TYPE_ARB = $8C13; - GL_TEXTURE_LUMINANCE_TYPE_ARB = $8C14; - GL_TEXTURE_INTENSITY_TYPE_ARB = $8C15; - GL_TEXTURE_DEPTH_TYPE_ARB = $8C16; - GL_UNSIGNED_NORMALIZED_ARB = $8C17; - GL_RGBA32F_ARB = $8814; - GL_RGB32F_ARB = $8815; - GL_ALPHA32F_ARB = $8816; - GL_INTENSITY32F_ARB = $8817; - GL_LUMINANCE32F_ARB = $8818; - GL_LUMINANCE_ALPHA32F_ARB = $8819; - GL_RGBA16F_ARB = $881A; - GL_RGB16F_ARB = $881B; - GL_ALPHA16F_ARB = $881C; - GL_INTENSITY16F_ARB = $881D; - GL_LUMINANCE16F_ARB = $881E; - GL_LUMINANCE_ALPHA16F_ARB = $881F; - -function Load_GL_ARB_texture_float: Boolean; - -//***** GL_EXT_texture_compression_dxt1 *****// - // GL_COMPRESSED_RGB_S3TC_DXT1_EXT { already defined } - // GL_COMPRESSED_RGBA_S3TC_DXT1_EXT { already defined } - -function Load_GL_EXT_texture_compression_dxt1: Boolean; - -//***** GL_ARB_pixel_buffer_object *****// -const - GL_PIXEL_PACK_BUFFER_ARB = $88EB; - GL_PIXEL_UNPACK_BUFFER_ARB = $88EC; - GL_PIXEL_PACK_BUFFER_BINDING_ARB = $88ED; - GL_PIXEL_UNPACK_BUFFER_BINDING_ARB = $88EF; - -function Load_GL_ARB_pixel_buffer_object: Boolean; - -//***** GL_EXT_framebuffer_object *****// -const - GL_FRAMEBUFFER_EXT = $8D40; - GL_RENDERBUFFER_EXT = $8D41; - GL_STENCIL_INDEX_EXT = $8D45; - GL_STENCIL_INDEX1_EXT = $8D46; - GL_STENCIL_INDEX4_EXT = $8D47; - GL_STENCIL_INDEX8_EXT = $8D48; - GL_STENCIL_INDEX16_EXT = $8D49; - GL_RENDERBUFFER_WIDTH_EXT = $8D42; - GL_RENDERBUFFER_HEIGHT_EXT = $8D43; - GL_RENDERBUFFER_INTERNAL_FORMAT_EXT = $8D44; - GL_FRAMEBUFFER_ATTACHMENT_OBJECT_TYPE_EXT = $8CD0; - GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT = $8CD1; - GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LEVEL_EXT = $8CD2; - GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_CUBE_MAP_FACE_EXT = $8CD3; - GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT = $8CD4; - GL_COLOR_ATTACHMENT0_EXT = $8CE0; - GL_COLOR_ATTACHMENT1_EXT = $8CE1; - GL_COLOR_ATTACHMENT2_EXT = $8CE2; - GL_COLOR_ATTACHMENT3_EXT = $8CE3; - GL_COLOR_ATTACHMENT4_EXT = $8CE4; - GL_COLOR_ATTACHMENT5_EXT = $8CE5; - GL_COLOR_ATTACHMENT6_EXT = $8CE6; - GL_COLOR_ATTACHMENT7_EXT = $8CE7; - GL_COLOR_ATTACHMENT8_EXT = $8CE8; - GL_COLOR_ATTACHMENT9_EXT = $8CE9; - GL_COLOR_ATTACHMENT10_EXT = $8CEA; - GL_COLOR_ATTACHMENT11_EXT = $8CEB; - GL_COLOR_ATTACHMENT12_EXT = $8CEC; - GL_COLOR_ATTACHMENT13_EXT = $8CED; - GL_COLOR_ATTACHMENT14_EXT = $8CEE; - GL_COLOR_ATTACHMENT15_EXT = $8CEF; - GL_DEPTH_ATTACHMENT_EXT = $8D00; - GL_STENCIL_ATTACHMENT_EXT = $8D20; - GL_FRAMEBUFFER_COMPLETE_EXT = $8CD5; - GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT = $8CD6; - GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT = $8CD7; - GL_FRAMEBUFFER_INCOMPLETE_DUPLICATE_ATTACHMENT_EXT = $8CD8; - GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT = $8CD9; - GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT = $8CDA; - GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT = $8CDB; - GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT = $8CDC; - GL_FRAMEBUFFER_UNSUPPORTED_EXT = $8CDD; - GL_FRAMEBUFFER_STATUS_ERROR_EXT = $8CDE; - GL_FRAMEBUFFER_BINDING_EXT = $8CA6; - GL_RENDERBUFFER_BINDING_EXT = $8CA7; - GL_MAX_COLOR_ATTACHMENTS_EXT = $8CDF; - GL_MAX_RENDERBUFFER_SIZE_EXT = $84E8; - GL_INVALID_FRAMEBUFFER_OPERATION_EXT = $0506; -var - glIsRenderbufferEXT: function(renderbuffer: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindRenderbufferEXT: procedure(target: GLenum; renderbuffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteRenderbuffersEXT: procedure(n: GLsizei; const renderbuffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenRenderbuffersEXT: procedure(n: GLsizei; renderbuffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glRenderbufferStorageEXT: procedure(target: GLenum; internalformat: GLenum; width: GLsizei; height: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetRenderbufferParameterivEXT: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsFramebufferEXT: function(framebuffer: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindFramebufferEXT: procedure(target: GLenum; framebuffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteFramebuffersEXT: procedure(n: GLsizei; const framebuffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenFramebuffersEXT: procedure(n: GLsizei; framebuffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCheckFramebufferStatusEXT: function(target: GLenum): GLenum; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFramebufferTexture1DEXT: procedure(target: GLenum; attachment: GLenum; textarget: GLenum; texture: GLuint; level: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFramebufferTexture2DEXT: procedure(target: GLenum; attachment: GLenum; textarget: GLenum; texture: GLuint; level: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFramebufferTexture3DEXT: procedure(target: GLenum; attachment: GLenum; textarget: GLenum; texture: GLuint; level: GLint; zoffset: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFramebufferRenderbufferEXT: procedure(target: GLenum; attachment: GLenum; renderbuffertarget: GLenum; renderbuffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetFramebufferAttachmentParameterivEXT: procedure(target: GLenum; attachment: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenerateMipmapEXT: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_EXT_framebuffer_object: Boolean; - -//***** GL_version_1_4 *****// -const - GL_BLEND_DST_RGB = $80C8; - GL_BLEND_SRC_RGB = $80C9; - GL_BLEND_DST_ALPHA = $80CA; - GL_BLEND_SRC_ALPHA = $80CB; - GL_POINT_SIZE_MIN = $8126; - GL_POINT_SIZE_MAX = $8127; - GL_POINT_FADE_THRESHOLD_SIZE = $8128; - GL_POINT_DISTANCE_ATTENUATION = $8129; - GL_GENERATE_MIPMAP = $8191; - GL_GENERATE_MIPMAP_HINT = $8192; - GL_DEPTH_COMPONENT16 = $81A5; - GL_DEPTH_COMPONENT24 = $81A6; - GL_DEPTH_COMPONENT32 = $81A7; - GL_MIRRORED_REPEAT = $8370; - GL_FOG_COORDINATE_SOURCE = $8450; - GL_FOG_COORDINATE = $8451; - GL_FRAGMENT_DEPTH = $8452; - GL_CURRENT_FOG_COORDINATE = $8453; - GL_FOG_COORDINATE_ARRAY_TYPE = $8454; - GL_FOG_COORDINATE_ARRAY_STRIDE = $8455; - GL_FOG_COORDINATE_ARRAY_POINTER = $8456; - GL_FOG_COORDINATE_ARRAY = $8457; - GL_COLOR_SUM = $8458; - GL_CURRENT_SECONDARY_COLOR = $8459; - GL_SECONDARY_COLOR_ARRAY_SIZE = $845A; - GL_SECONDARY_COLOR_ARRAY_TYPE = $845B; - GL_SECONDARY_COLOR_ARRAY_STRIDE = $845C; - GL_SECONDARY_COLOR_ARRAY_POINTER = $845D; - GL_SECONDARY_COLOR_ARRAY = $845E; - GL_MAX_TEXTURE_LOD_BIAS = $84FD; - GL_TEXTURE_FILTER_CONTROL = $8500; - GL_TEXTURE_LOD_BIAS = $8501; - GL_INCR_WRAP = $8507; - GL_DECR_WRAP = $8508; - GL_TEXTURE_DEPTH_SIZE = $884A; - GL_DEPTH_TEXTURE_MODE = $884B; - GL_TEXTURE_COMPARE_MODE = $884C; - GL_TEXTURE_COMPARE_FUNC = $884D; - GL_COMPARE_R_TO_TEXTURE = $884E; -var - glBlendFuncSeparate: procedure(sfactorRGB: GLenum; dfactorRGB: GLenum; sfactorAlpha: GLenum; dfactorAlpha: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordf: procedure(coord: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordfv: procedure(const coord: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordd: procedure(coord: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoorddv: procedure(const coord: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glFogCoordPointer: procedure(_type: GLenum; stride: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawArrays: procedure(mode: GLenum; first: PGLint; count: PGLsizei; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMultiDrawElements: procedure(mode: GLenum; const count: PGLsizei; _type: GLenum; const indices: PGLvoid; primcount: GLsizei); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameterf: procedure(pname: GLenum; param: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameterfv: procedure(pname: GLenum; const params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameteri: procedure(pname: GLenum; param: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glPointParameteriv: procedure(pname: GLenum; const params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3b: procedure(red: GLbyte; green: GLbyte; blue: GLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3bv: procedure(const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3d: procedure(red: GLdouble; green: GLdouble; blue: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3f: procedure(red: GLfloat; green: GLfloat; blue: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3i: procedure(red: GLint; green: GLint; blue: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3s: procedure(red: GLshort; green: GLshort; blue: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3ub: procedure(red: GLubyte; green: GLubyte; blue: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3ubv: procedure(const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3ui: procedure(red: GLuint; green: GLuint; blue: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3uiv: procedure(const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3us: procedure(red: GLushort; green: GLushort; blue: GLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColor3usv: procedure(const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glSecondaryColorPointer: procedure(size: GLint; _type: GLenum; stride: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2d: procedure(x: GLdouble; y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2f: procedure(x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2i: procedure(x: GLint; y: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2s: procedure(x: GLshort; y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos2sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3d: procedure(x: GLdouble; y: GLdouble; z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3dv: procedure(const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3f: procedure(x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3fv: procedure(const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3i: procedure(x: GLint; y: GLint; z: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3iv: procedure(const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3s: procedure(x: GLshort; y: GLshort; z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glWindowPos3sv: procedure(const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_version_1_4: Boolean; - -//***** GL_version_1_5 *****// -const - GL_BUFFER_SIZE = $8764; - GL_BUFFER_USAGE = $8765; - GL_QUERY_COUNTER_BITS = $8864; - GL_CURRENT_QUERY = $8865; - GL_QUERY_RESULT = $8866; - GL_QUERY_RESULT_AVAILABLE = $8867; - GL_ARRAY_BUFFER = $8892; - GL_ELEMENT_ARRAY_BUFFER = $8893; - GL_ARRAY_BUFFER_BINDING = $8894; - GL_ELEMENT_ARRAY_BUFFER_BINDING = $8895; - GL_VERTEX_ARRAY_BUFFER_BINDING = $8896; - GL_NORMAL_ARRAY_BUFFER_BINDING = $8897; - GL_COLOR_ARRAY_BUFFER_BINDING = $8898; - GL_INDEX_ARRAY_BUFFER_BINDING = $8899; - GL_TEXTURE_COORD_ARRAY_BUFFER_BINDING = $889A; - GL_EDGE_FLAG_ARRAY_BUFFER_BINDING = $889B; - GL_SECONDARY_COLOR_ARRAY_BUFFER_BINDING = $889C; - GL_FOG_COORDINATE_ARRAY_BUFFER_BINDING = $889D; - GL_WEIGHT_ARRAY_BUFFER_BINDING = $889E; - GL_VERTEX_ATTRIB_ARRAY_BUFFER_BINDING = $889F; - GL_READ_ONLY = $88B8; - GL_WRITE_ONLY = $88B9; - GL_READ_WRITE = $88BA; - GL_BUFFER_ACCESS = $88BB; - GL_BUFFER_MAPPED = $88BC; - GL_BUFFER_MAP_POINTER = $88BD; - GL_STREAM_DRAW = $88E0; - GL_STREAM_READ = $88E1; - GL_STREAM_COPY = $88E2; - GL_STATIC_DRAW = $88E4; - GL_STATIC_READ = $88E5; - GL_STATIC_COPY = $88E6; - GL_DYNAMIC_DRAW = $88E8; - GL_DYNAMIC_READ = $88E9; - GL_DYNAMIC_COPY = $88EA; - GL_SAMPLES_PASSED = $8914; - GL_FOG_COORD_SRC = $8450; - GL_FOG_COORD = $8451; - GL_CURRENT_FOG_COORD = $8453; - GL_FOG_COORD_ARRAY_TYPE = $8454; - GL_FOG_COORD_ARRAY_STRIDE = $8455; - GL_FOG_COORD_ARRAY_POINTER = $8456; - GL_FOG_COORD_ARRAY = $8457; - GL_FOG_COORD_ARRAY_BUFFER_BINDING = $889D; - GL_SRC0_RGB = $8580; - GL_SRC1_RGB = $8581; - GL_SRC2_RGB = $8582; - GL_SRC0_ALPHA = $8588; - GL_SRC1_ALPHA = $8589; - GL_SRC2_ALPHA = $858A; -var - glGenQueries: procedure(n: GLsizei; ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteQueries: procedure(n: GLsizei; const ids: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsQuery: function(id: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBeginQuery: procedure(target: GLenum; id: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEndQuery: procedure(target: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetQueryiv: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetQueryObjectiv: procedure(id: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetQueryObjectuiv: procedure(id: GLuint; pname: GLenum; params: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindBuffer: procedure(target: GLenum; buffer: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteBuffers: procedure(n: GLsizei; const buffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGenBuffers: procedure(n: GLsizei; buffers: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsBuffer: function(buffer: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBufferData: procedure(target: GLenum; size: GLsizeiptr; const data: PGLvoid; usage: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBufferSubData: procedure(target: GLenum; offset: GLintptr; size: GLsizeiptr; const data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBufferSubData: procedure(target: GLenum; offset: GLintptr; size: GLsizeiptr; data: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glMapBuffer: function(target: GLenum; access: GLenum): PGLvoid; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUnmapBuffer: function(target: GLenum): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBufferParameteriv: procedure(target: GLenum; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetBufferPointerv: procedure(target: GLenum; pname: GLenum; params: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_version_1_5: Boolean; - -//***** GL_version_2_0 *****// -const - GL_BLEND_EQUATION_RGB = $8009; - GL_VERTEX_ATTRIB_ARRAY_ENABLED = $8622; - GL_VERTEX_ATTRIB_ARRAY_SIZE = $8623; - GL_VERTEX_ATTRIB_ARRAY_STRIDE = $8624; - GL_VERTEX_ATTRIB_ARRAY_TYPE = $8625; - GL_CURRENT_VERTEX_ATTRIB = $8626; - GL_VERTEX_PROGRAM_POINT_SIZE = $8642; - GL_VERTEX_PROGRAM_TWO_SIDE = $8643; - GL_VERTEX_ATTRIB_ARRAY_POINTER = $8645; - GL_STENCIL_BACK_FUNC = $8800; - GL_STENCIL_BACK_FAIL = $8801; - GL_STENCIL_BACK_PASS_DEPTH_FAIL = $8802; - GL_STENCIL_BACK_PASS_DEPTH_PASS = $8803; - GL_MAX_DRAW_BUFFERS = $8824; - GL_DRAW_BUFFER0 = $8825; - GL_DRAW_BUFFER1 = $8826; - GL_DRAW_BUFFER2 = $8827; - GL_DRAW_BUFFER3 = $8828; - GL_DRAW_BUFFER4 = $8829; - GL_DRAW_BUFFER5 = $882A; - GL_DRAW_BUFFER6 = $882B; - GL_DRAW_BUFFER7 = $882C; - GL_DRAW_BUFFER8 = $882D; - GL_DRAW_BUFFER9 = $882E; - GL_DRAW_BUFFER10 = $882F; - GL_DRAW_BUFFER11 = $8830; - GL_DRAW_BUFFER12 = $8831; - GL_DRAW_BUFFER13 = $8832; - GL_DRAW_BUFFER14 = $8833; - GL_DRAW_BUFFER15 = $8834; - GL_BLEND_EQUATION_ALPHA = $883D; - GL_POINT_SPRITE = $8861; - GL_COORD_REPLACE = $8862; - GL_MAX_VERTEX_ATTRIBS = $8869; - GL_VERTEX_ATTRIB_ARRAY_NORMALIZED = $886A; - GL_MAX_TEXTURE_COORDS = $8871; - GL_MAX_TEXTURE_IMAGE_UNITS = $8872; - GL_FRAGMENT_SHADER = $8B30; - GL_VERTEX_SHADER = $8B31; - GL_MAX_FRAGMENT_UNIFORM_COMPONENTS = $8B49; - GL_MAX_VERTEX_UNIFORM_COMPONENTS = $8B4A; - GL_MAX_VARYING_FLOATS = $8B4B; - GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS = $8B4C; - GL_MAX_COMBINED_TEXTURE_IMAGE_UNITS = $8B4D; - GL_SHADER_TYPE = $8B4F; - GL_FLOAT_VEC2 = $8B50; - GL_FLOAT_VEC3 = $8B51; - GL_FLOAT_VEC4 = $8B52; - GL_INT_VEC2 = $8B53; - GL_INT_VEC3 = $8B54; - GL_INT_VEC4 = $8B55; - GL_BOOL = $8B56; - GL_BOOL_VEC2 = $8B57; - GL_BOOL_VEC3 = $8B58; - GL_BOOL_VEC4 = $8B59; - GL_FLOAT_MAT2 = $8B5A; - GL_FLOAT_MAT3 = $8B5B; - GL_FLOAT_MAT4 = $8B5C; - GL_SAMPLER_1D = $8B5D; - GL_SAMPLER_2D = $8B5E; - GL_SAMPLER_3D = $8B5F; - GL_SAMPLER_CUBE = $8B60; - GL_SAMPLER_1D_SHADOW = $8B61; - GL_SAMPLER_2D_SHADOW = $8B62; - GL_DELETE_STATUS = $8B80; - GL_COMPILE_STATUS = $8B81; - GL_LINK_STATUS = $8B82; - GL_VALIDATE_STATUS = $8B83; - GL_INFO_LOG_LENGTH = $8B84; - GL_ATTACHED_SHADERS = $8B85; - GL_ACTIVE_UNIFORMS = $8B86; - GL_ACTIVE_UNIFORM_MAX_LENGTH = $8B87; - GL_SHADER_SOURCE_LENGTH = $8B88; - GL_ACTIVE_ATTRIBUTES = $8B89; - GL_ACTIVE_ATTRIBUTE_MAX_LENGTH = $8B8A; - GL_FRAGMENT_SHADER_DERIVATIVE_HINT = $8B8B; - GL_SHADING_LANGUAGE_VERSION = $8B8C; - GL_CURRENT_PROGRAM = $8B8D; - GL_POINT_SPRITE_COORD_ORIGIN = $8CA0; - GL_LOWER_LEFT = $8CA1; - GL_UPPER_LEFT = $8CA2; - GL_STENCIL_BACK_REF = $8CA3; - GL_STENCIL_BACK_VALUE_MASK = $8CA4; - GL_STENCIL_BACK_WRITEMASK = $8CA5; -var - glBlendEquationSeparate: procedure(modeRGB: GLenum; modeAlpha: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDrawBuffers: procedure(n: GLsizei; const bufs: PGLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilOpSeparate: procedure(face: GLenum; sfail: GLenum; dpfail: GLenum; dppass: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilFuncSeparate: procedure(frontfunc: GLenum; backfunc: GLenum; ref: GLint; mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glStencilMaskSeparate: procedure(face: GLenum; mask: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glAttachShader: procedure(_program: GLuint; shader: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glBindAttribLocation: procedure(_program: GLuint; index: GLuint; const name: PGLchar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCompileShader: procedure(shader: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCreateProgram: function(): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glCreateShader: function(_type: GLenum): GLuint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteProgram: procedure(_program: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDeleteShader: procedure(shader: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDetachShader: procedure(_program: GLuint; shader: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glDisableVertexAttribArray: procedure(index: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glEnableVertexAttribArray: procedure(index: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetActiveAttrib: procedure(_program: GLuint; index: GLuint; bufSize: GLsizei; length: PGLsizei; size: PGLint; _type: PGLenum; name: PGLchar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetActiveUniform: procedure(_program: GLuint; index: GLuint; bufSize: GLsizei; length: PGLsizei; size: PGLint; _type: PGLenum; name: PGLchar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetAttachedShaders: procedure(_program: GLuint; maxCount: GLsizei; count: PGLsizei; obj: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetAttribLocation: function(_program: GLuint; const name: PGLchar): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramiv: procedure(_program: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetProgramInfoLog: procedure(_program: GLuint; bufSize: GLsizei; length: PGLsizei; infoLog: PGLchar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetShaderiv: procedure(shader: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetShaderInfoLog: procedure(shader: GLuint; bufSize: GLsizei; length: PGLsizei; infoLog: PGLchar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetShaderSource: procedure(shader: GLuint; bufSize: GLsizei; length: PGLsizei; source: PGLchar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetUniformLocation: function(_program: GLuint; const name: PGLchar): GLint; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetUniformfv: procedure(_program: GLuint; location: GLint; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetUniformiv: procedure(_program: GLuint; location: GLint; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribdv: procedure(index: GLuint; pname: GLenum; params: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribfv: procedure(index: GLuint; pname: GLenum; params: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribiv: procedure(index: GLuint; pname: GLenum; params: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glGetVertexAttribPointerv: procedure(index: GLuint; pname: GLenum; pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsProgram: function(_program: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glIsShader: function(shader: GLuint): GLboolean; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glLinkProgram: procedure(_program: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glShaderSource: procedure(shader: GLuint; count: GLsizei; const _string: PGLchar; const length: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUseProgram: procedure(_program: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1f: procedure(location: GLint; v0: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2f: procedure(location: GLint; v0: GLfloat; v1: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3f: procedure(location: GLint; v0: GLfloat; v1: GLfloat; v2: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4f: procedure(location: GLint; v0: GLfloat; v1: GLfloat; v2: GLfloat; v3: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1i: procedure(location: GLint; v0: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2i: procedure(location: GLint; v0: GLint; v1: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3i: procedure(location: GLint; v0: GLint; v1: GLint; v2: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4i: procedure(location: GLint; v0: GLint; v1: GLint; v2: GLint; v3: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1fv: procedure(location: GLint; count: GLsizei; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2fv: procedure(location: GLint; count: GLsizei; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3fv: procedure(location: GLint; count: GLsizei; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4fv: procedure(location: GLint; count: GLsizei; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform1iv: procedure(location: GLint; count: GLsizei; const value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform2iv: procedure(location: GLint; count: GLsizei; const value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform3iv: procedure(location: GLint; count: GLsizei; const value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniform4iv: procedure(location: GLint; count: GLsizei; const value: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniformMatrix2fv: procedure(location: GLint; count: GLsizei; transpose: GLboolean; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniformMatrix3fv: procedure(location: GLint; count: GLsizei; transpose: GLboolean; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glUniformMatrix4fv: procedure(location: GLint; count: GLsizei; transpose: GLboolean; const value: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glValidateProgram: procedure(_program: GLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1d: procedure(index: GLuint; x: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1dv: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1f: procedure(index: GLuint; x: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1fv: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1s: procedure(index: GLuint; x: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib1sv: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2d: procedure(index: GLuint; x: GLdouble; y: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2dv: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2f: procedure(index: GLuint; x: GLfloat; y: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2fv: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2s: procedure(index: GLuint; x: GLshort; y: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib2sv: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3d: procedure(index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3dv: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3f: procedure(index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3fv: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3s: procedure(index: GLuint; x: GLshort; y: GLshort; z: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib3sv: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Nbv: procedure(index: GLuint; const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Niv: procedure(index: GLuint; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Nsv: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Nub: procedure(index: GLuint; x: GLubyte; y: GLubyte; z: GLubyte; w: GLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Nubv: procedure(index: GLuint; const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Nuiv: procedure(index: GLuint; const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4Nusv: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4bv: procedure(index: GLuint; const v: PGLbyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4d: procedure(index: GLuint; x: GLdouble; y: GLdouble; z: GLdouble; w: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4dv: procedure(index: GLuint; const v: PGLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4f: procedure(index: GLuint; x: GLfloat; y: GLfloat; z: GLfloat; w: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4fv: procedure(index: GLuint; const v: PGLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4iv: procedure(index: GLuint; const v: PGLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4s: procedure(index: GLuint; x: GLshort; y: GLshort; z: GLshort; w: GLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4sv: procedure(index: GLuint; const v: PGLshort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4ubv: procedure(index: GLuint; const v: PGLubyte); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4uiv: procedure(index: GLuint; const v: PGLuint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttrib4usv: procedure(index: GLuint; const v: PGLushort); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glVertexAttribPointer: procedure(index: GLuint; size: GLint; _type: GLenum; normalized: GLboolean; stride: GLsizei; const pointer: PGLvoid); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -function Load_GL_version_2_0: Boolean; - -implementation - -uses - sdl; - -function glext_ExtensionSupported(const extension: PChar; const searchIn: PChar): Boolean; -var - extensions: PChar; - start: PChar; - where, terminator: PChar; -begin - - if (Pos(' ', extension) <> 0) or (extension = '') then - begin - Result := false; - Exit; - end; - - if searchIn = '' then - extensions := glGetString(GL_EXTENSIONS) - else - //StrLCopy(extensions, searchIn, StrLen(searchIn) + 1); - extensions := searchIn; - start := extensions; - while true do - begin - where := StrPos(start, extension); - if where = nil then - Break; - terminator := where + Length(extension); - if (where = start) or ((where - 1)^ = ' ') then - begin - if (terminator^ = ' ') or (terminator^ = #0) then - begin - Result := true; - Exit; - end; - end; - start := terminator; - end; - Result := false; - -end; - -function Load_GL_version_1_2: Boolean; -{var - extstring : PChar;} -begin - - Result := FALSE; - //extstring := glGetString( GL_EXTENSIONS ); - - @glCopyTexSubImage3D := SDL_GL_GetProcAddress('glCopyTexSubImage3D'); - if not Assigned(glCopyTexSubImage3D) then Exit; - @glDrawRangeElements := SDL_GL_GetProcAddress('glDrawRangeElements'); - if not Assigned(glDrawRangeElements) then Exit; - @glTexImage3D := SDL_GL_GetProcAddress('glTexImage3D'); - if not Assigned(glTexImage3D) then Exit; - @glTexSubImage3D := SDL_GL_GetProcAddress('glTexSubImage3D'); - if not Assigned(glTexSubImage3D) then Exit; - - Result := TRUE; - -end; - -function Load_GL_ARB_imaging: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_imaging', extstring) then - begin - @glColorTable := SDL_GL_GetProcAddress('glColorTable'); - if not Assigned(glColorTable) then Exit; - @glColorTableParameterfv := SDL_GL_GetProcAddress('glColorTableParameterfv'); - if not Assigned(glColorTableParameterfv) then Exit; - @glColorTableParameteriv := SDL_GL_GetProcAddress('glColorTableParameteriv'); - if not Assigned(glColorTableParameteriv) then Exit; - @glCopyColorTable := SDL_GL_GetProcAddress('glCopyColorTable'); - if not Assigned(glCopyColorTable) then Exit; - @glGetColorTable := SDL_GL_GetProcAddress('glGetColorTable'); - if not Assigned(glGetColorTable) then Exit; - @glGetColorTableParameterfv := SDL_GL_GetProcAddress('glGetColorTableParameterfv'); - if not Assigned(glGetColorTableParameterfv) then Exit; - @glGetColorTableParameteriv := SDL_GL_GetProcAddress('glGetColorTableParameteriv'); - if not Assigned(glGetColorTableParameteriv) then Exit; - @glColorSubTable := SDL_GL_GetProcAddress('glColorSubTable'); - if not Assigned(glColorSubTable) then Exit; - @glCopyColorSubTable := SDL_GL_GetProcAddress('glCopyColorSubTable'); - if not Assigned(glCopyColorSubTable) then Exit; - @glConvolutionFilter1D := SDL_GL_GetProcAddress('glConvolutionFilter1D'); - if not Assigned(glConvolutionFilter1D) then Exit; - @glConvolutionFilter2D := SDL_GL_GetProcAddress('glConvolutionFilter2D'); - if not Assigned(glConvolutionFilter2D) then Exit; - @glConvolutionParameterf := SDL_GL_GetProcAddress('glConvolutionParameterf'); - if not Assigned(glConvolutionParameterf) then Exit; - @glConvolutionParameterfv := SDL_GL_GetProcAddress('glConvolutionParameterfv'); - if not Assigned(glConvolutionParameterfv) then Exit; - @glConvolutionParameteri := SDL_GL_GetProcAddress('glConvolutionParameteri'); - if not Assigned(glConvolutionParameteri) then Exit; - @glConvolutionParameteriv := SDL_GL_GetProcAddress('glConvolutionParameteriv'); - if not Assigned(glConvolutionParameteriv) then Exit; - @glCopyConvolutionFilter1D := SDL_GL_GetProcAddress('glCopyConvolutionFilter1D'); - if not Assigned(glCopyConvolutionFilter1D) then Exit; - @glCopyConvolutionFilter2D := SDL_GL_GetProcAddress('glCopyConvolutionFilter2D'); - if not Assigned(glCopyConvolutionFilter2D) then Exit; - @glGetConvolutionFilter := SDL_GL_GetProcAddress('glGetConvolutionFilter'); - if not Assigned(glGetConvolutionFilter) then Exit; - @glGetConvolutionParameterfv := SDL_GL_GetProcAddress('glGetConvolutionParameterfv'); - if not Assigned(glGetConvolutionParameterfv) then Exit; - @glGetConvolutionParameteriv := SDL_GL_GetProcAddress('glGetConvolutionParameteriv'); - if not Assigned(glGetConvolutionParameteriv) then Exit; - @glGetSeparableFilter := SDL_GL_GetProcAddress('glGetSeparableFilter'); - if not Assigned(glGetSeparableFilter) then Exit; - @glSeparableFilter2D := SDL_GL_GetProcAddress('glSeparableFilter2D'); - if not Assigned(glSeparableFilter2D) then Exit; - @glGetHistogram := SDL_GL_GetProcAddress('glGetHistogram'); - if not Assigned(glGetHistogram) then Exit; - @glGetHistogramParameterfv := SDL_GL_GetProcAddress('glGetHistogramParameterfv'); - if not Assigned(glGetHistogramParameterfv) then Exit; - @glGetHistogramParameteriv := SDL_GL_GetProcAddress('glGetHistogramParameteriv'); - if not Assigned(glGetHistogramParameteriv) then Exit; - @glGetMinmax := SDL_GL_GetProcAddress('glGetMinmax'); - if not Assigned(glGetMinmax) then Exit; - @glGetMinmaxParameterfv := SDL_GL_GetProcAddress('glGetMinmaxParameterfv'); - if not Assigned(glGetMinmaxParameterfv) then Exit; - @glGetMinmaxParameteriv := SDL_GL_GetProcAddress('glGetMinmaxParameteriv'); - if not Assigned(glGetMinmaxParameteriv) then Exit; - @glHistogram := SDL_GL_GetProcAddress('glHistogram'); - if not Assigned(glHistogram) then Exit; - @glMinmax := SDL_GL_GetProcAddress('glMinmax'); - if not Assigned(glMinmax) then Exit; - @glResetHistogram := SDL_GL_GetProcAddress('glResetHistogram'); - if not Assigned(glResetHistogram) then Exit; - @glResetMinmax := SDL_GL_GetProcAddress('glResetMinmax'); - if not Assigned(glResetMinmax) then Exit; - @glBlendEquation := SDL_GL_GetProcAddress('glBlendEquation'); - if not Assigned(glBlendEquation) then Exit; - @glBlendColor := SDL_GL_GetProcAddress('glBlendColor'); - if not Assigned(glBlendColor) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_version_1_3: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - @glActiveTexture := SDL_GL_GetProcAddress('glActiveTexture'); - if not Assigned(glActiveTexture) then Exit; - @glClientActiveTexture := SDL_GL_GetProcAddress('glClientActiveTexture'); - if not Assigned(glClientActiveTexture) then Exit; - @glMultiTexCoord1d := SDL_GL_GetProcAddress('glMultiTexCoord1d'); - if not Assigned(glMultiTexCoord1d) then Exit; - @glMultiTexCoord1dv := SDL_GL_GetProcAddress('glMultiTexCoord1dv'); - if not Assigned(glMultiTexCoord1dv) then Exit; - @glMultiTexCoord1f := SDL_GL_GetProcAddress('glMultiTexCoord1f'); - if not Assigned(glMultiTexCoord1f) then Exit; - @glMultiTexCoord1fv := SDL_GL_GetProcAddress('glMultiTexCoord1fv'); - if not Assigned(glMultiTexCoord1fv) then Exit; - @glMultiTexCoord1i := SDL_GL_GetProcAddress('glMultiTexCoord1i'); - if not Assigned(glMultiTexCoord1i) then Exit; - @glMultiTexCoord1iv := SDL_GL_GetProcAddress('glMultiTexCoord1iv'); - if not Assigned(glMultiTexCoord1iv) then Exit; - @glMultiTexCoord1s := SDL_GL_GetProcAddress('glMultiTexCoord1s'); - if not Assigned(glMultiTexCoord1s) then Exit; - @glMultiTexCoord1sv := SDL_GL_GetProcAddress('glMultiTexCoord1sv'); - if not Assigned(glMultiTexCoord1sv) then Exit; - @glMultiTexCoord2d := SDL_GL_GetProcAddress('glMultiTexCoord2d'); - if not Assigned(glMultiTexCoord2d) then Exit; - @glMultiTexCoord2dv := SDL_GL_GetProcAddress('glMultiTexCoord2dv'); - if not Assigned(glMultiTexCoord2dv) then Exit; - @glMultiTexCoord2f := SDL_GL_GetProcAddress('glMultiTexCoord2f'); - if not Assigned(glMultiTexCoord2f) then Exit; - @glMultiTexCoord2fv := SDL_GL_GetProcAddress('glMultiTexCoord2fv'); - if not Assigned(glMultiTexCoord2fv) then Exit; - @glMultiTexCoord2i := SDL_GL_GetProcAddress('glMultiTexCoord2i'); - if not Assigned(glMultiTexCoord2i) then Exit; - @glMultiTexCoord2iv := SDL_GL_GetProcAddress('glMultiTexCoord2iv'); - if not Assigned(glMultiTexCoord2iv) then Exit; - @glMultiTexCoord2s := SDL_GL_GetProcAddress('glMultiTexCoord2s'); - if not Assigned(glMultiTexCoord2s) then Exit; - @glMultiTexCoord2sv := SDL_GL_GetProcAddress('glMultiTexCoord2sv'); - if not Assigned(glMultiTexCoord2sv) then Exit; - @glMultiTexCoord3d := SDL_GL_GetProcAddress('glMultiTexCoord3d'); - if not Assigned(glMultiTexCoord3d) then Exit; - @glMultiTexCoord3dv := SDL_GL_GetProcAddress('glMultiTexCoord3dv'); - if not Assigned(glMultiTexCoord3dv) then Exit; - @glMultiTexCoord3f := SDL_GL_GetProcAddress('glMultiTexCoord3f'); - if not Assigned(glMultiTexCoord3f) then Exit; - @glMultiTexCoord3fv := SDL_GL_GetProcAddress('glMultiTexCoord3fv'); - if not Assigned(glMultiTexCoord3fv) then Exit; - @glMultiTexCoord3i := SDL_GL_GetProcAddress('glMultiTexCoord3i'); - if not Assigned(glMultiTexCoord3i) then Exit; - @glMultiTexCoord3iv := SDL_GL_GetProcAddress('glMultiTexCoord3iv'); - if not Assigned(glMultiTexCoord3iv) then Exit; - @glMultiTexCoord3s := SDL_GL_GetProcAddress('glMultiTexCoord3s'); - if not Assigned(glMultiTexCoord3s) then Exit; - @glMultiTexCoord3sv := SDL_GL_GetProcAddress('glMultiTexCoord3sv'); - if not Assigned(glMultiTexCoord3sv) then Exit; - @glMultiTexCoord4d := SDL_GL_GetProcAddress('glMultiTexCoord4d'); - if not Assigned(glMultiTexCoord4d) then Exit; - @glMultiTexCoord4dv := SDL_GL_GetProcAddress('glMultiTexCoord4dv'); - if not Assigned(glMultiTexCoord4dv) then Exit; - @glMultiTexCoord4f := SDL_GL_GetProcAddress('glMultiTexCoord4f'); - if not Assigned(glMultiTexCoord4f) then Exit; - @glMultiTexCoord4fv := SDL_GL_GetProcAddress('glMultiTexCoord4fv'); - if not Assigned(glMultiTexCoord4fv) then Exit; - @glMultiTexCoord4i := SDL_GL_GetProcAddress('glMultiTexCoord4i'); - if not Assigned(glMultiTexCoord4i) then Exit; - @glMultiTexCoord4iv := SDL_GL_GetProcAddress('glMultiTexCoord4iv'); - if not Assigned(glMultiTexCoord4iv) then Exit; - @glMultiTexCoord4s := SDL_GL_GetProcAddress('glMultiTexCoord4s'); - if not Assigned(glMultiTexCoord4s) then Exit; - @glMultiTexCoord4sv := SDL_GL_GetProcAddress('glMultiTexCoord4sv'); - if not Assigned(glMultiTexCoord4sv) then Exit; - @glLoadTransposeMatrixf := SDL_GL_GetProcAddress('glLoadTransposeMatrixf'); - if not Assigned(glLoadTransposeMatrixf) then Exit; - @glLoadTransposeMatrixd := SDL_GL_GetProcAddress('glLoadTransposeMatrixd'); - if not Assigned(glLoadTransposeMatrixd) then Exit; - @glMultTransposeMatrixf := SDL_GL_GetProcAddress('glMultTransposeMatrixf'); - if not Assigned(glMultTransposeMatrixf) then Exit; - @glMultTransposeMatrixd := SDL_GL_GetProcAddress('glMultTransposeMatrixd'); - if not Assigned(glMultTransposeMatrixd) then Exit; - @glSampleCoverage := SDL_GL_GetProcAddress('glSampleCoverage'); - if not Assigned(glSampleCoverage) then Exit; - @glCompressedTexImage3D := SDL_GL_GetProcAddress('glCompressedTexImage3D'); - if not Assigned(glCompressedTexImage3D) then Exit; - @glCompressedTexImage2D := SDL_GL_GetProcAddress('glCompressedTexImage2D'); - if not Assigned(glCompressedTexImage2D) then Exit; - @glCompressedTexImage1D := SDL_GL_GetProcAddress('glCompressedTexImage1D'); - if not Assigned(glCompressedTexImage1D) then Exit; - @glCompressedTexSubImage3D := SDL_GL_GetProcAddress('glCompressedTexSubImage3D'); - if not Assigned(glCompressedTexSubImage3D) then Exit; - @glCompressedTexSubImage2D := SDL_GL_GetProcAddress('glCompressedTexSubImage2D'); - if not Assigned(glCompressedTexSubImage2D) then Exit; - @glCompressedTexSubImage1D := SDL_GL_GetProcAddress('glCompressedTexSubImage1D'); - if not Assigned(glCompressedTexSubImage1D) then Exit; - @glGetCompressedTexImage := SDL_GL_GetProcAddress('glGetCompressedTexImage'); - if not Assigned(glGetCompressedTexImage) then Exit; - Result := TRUE; - -end; - -function Load_GL_ARB_multitexture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_multitexture', extstring) then - begin - @glActiveTextureARB := SDL_GL_GetProcAddress('glActiveTextureARB'); - if not Assigned(glActiveTextureARB) then Exit; - @glClientActiveTextureARB := SDL_GL_GetProcAddress('glClientActiveTextureARB'); - if not Assigned(glClientActiveTextureARB) then Exit; - @glMultiTexCoord1dARB := SDL_GL_GetProcAddress('glMultiTexCoord1dARB'); - if not Assigned(glMultiTexCoord1dARB) then Exit; - @glMultiTexCoord1dvARB := SDL_GL_GetProcAddress('glMultiTexCoord1dvARB'); - if not Assigned(glMultiTexCoord1dvARB) then Exit; - @glMultiTexCoord1fARB := SDL_GL_GetProcAddress('glMultiTexCoord1fARB'); - if not Assigned(glMultiTexCoord1fARB) then Exit; - @glMultiTexCoord1fvARB := SDL_GL_GetProcAddress('glMultiTexCoord1fvARB'); - if not Assigned(glMultiTexCoord1fvARB) then Exit; - @glMultiTexCoord1iARB := SDL_GL_GetProcAddress('glMultiTexCoord1iARB'); - if not Assigned(glMultiTexCoord1iARB) then Exit; - @glMultiTexCoord1ivARB := SDL_GL_GetProcAddress('glMultiTexCoord1ivARB'); - if not Assigned(glMultiTexCoord1ivARB) then Exit; - @glMultiTexCoord1sARB := SDL_GL_GetProcAddress('glMultiTexCoord1sARB'); - if not Assigned(glMultiTexCoord1sARB) then Exit; - @glMultiTexCoord1svARB := SDL_GL_GetProcAddress('glMultiTexCoord1svARB'); - if not Assigned(glMultiTexCoord1svARB) then Exit; - @glMultiTexCoord2dARB := SDL_GL_GetProcAddress('glMultiTexCoord2dARB'); - if not Assigned(glMultiTexCoord2dARB) then Exit; - @glMultiTexCoord2dvARB := SDL_GL_GetProcAddress('glMultiTexCoord2dvARB'); - if not Assigned(glMultiTexCoord2dvARB) then Exit; - @glMultiTexCoord2fARB := SDL_GL_GetProcAddress('glMultiTexCoord2fARB'); - if not Assigned(glMultiTexCoord2fARB) then Exit; - @glMultiTexCoord2fvARB := SDL_GL_GetProcAddress('glMultiTexCoord2fvARB'); - if not Assigned(glMultiTexCoord2fvARB) then Exit; - @glMultiTexCoord2iARB := SDL_GL_GetProcAddress('glMultiTexCoord2iARB'); - if not Assigned(glMultiTexCoord2iARB) then Exit; - @glMultiTexCoord2ivARB := SDL_GL_GetProcAddress('glMultiTexCoord2ivARB'); - if not Assigned(glMultiTexCoord2ivARB) then Exit; - @glMultiTexCoord2sARB := SDL_GL_GetProcAddress('glMultiTexCoord2sARB'); - if not Assigned(glMultiTexCoord2sARB) then Exit; - @glMultiTexCoord2svARB := SDL_GL_GetProcAddress('glMultiTexCoord2svARB'); - if not Assigned(glMultiTexCoord2svARB) then Exit; - @glMultiTexCoord3dARB := SDL_GL_GetProcAddress('glMultiTexCoord3dARB'); - if not Assigned(glMultiTexCoord3dARB) then Exit; - @glMultiTexCoord3dvARB := SDL_GL_GetProcAddress('glMultiTexCoord3dvARB'); - if not Assigned(glMultiTexCoord3dvARB) then Exit; - @glMultiTexCoord3fARB := SDL_GL_GetProcAddress('glMultiTexCoord3fARB'); - if not Assigned(glMultiTexCoord3fARB) then Exit; - @glMultiTexCoord3fvARB := SDL_GL_GetProcAddress('glMultiTexCoord3fvARB'); - if not Assigned(glMultiTexCoord3fvARB) then Exit; - @glMultiTexCoord3iARB := SDL_GL_GetProcAddress('glMultiTexCoord3iARB'); - if not Assigned(glMultiTexCoord3iARB) then Exit; - @glMultiTexCoord3ivARB := SDL_GL_GetProcAddress('glMultiTexCoord3ivARB'); - if not Assigned(glMultiTexCoord3ivARB) then Exit; - @glMultiTexCoord3sARB := SDL_GL_GetProcAddress('glMultiTexCoord3sARB'); - if not Assigned(glMultiTexCoord3sARB) then Exit; - @glMultiTexCoord3svARB := SDL_GL_GetProcAddress('glMultiTexCoord3svARB'); - if not Assigned(glMultiTexCoord3svARB) then Exit; - @glMultiTexCoord4dARB := SDL_GL_GetProcAddress('glMultiTexCoord4dARB'); - if not Assigned(glMultiTexCoord4dARB) then Exit; - @glMultiTexCoord4dvARB := SDL_GL_GetProcAddress('glMultiTexCoord4dvARB'); - if not Assigned(glMultiTexCoord4dvARB) then Exit; - @glMultiTexCoord4fARB := SDL_GL_GetProcAddress('glMultiTexCoord4fARB'); - if not Assigned(glMultiTexCoord4fARB) then Exit; - @glMultiTexCoord4fvARB := SDL_GL_GetProcAddress('glMultiTexCoord4fvARB'); - if not Assigned(glMultiTexCoord4fvARB) then Exit; - @glMultiTexCoord4iARB := SDL_GL_GetProcAddress('glMultiTexCoord4iARB'); - if not Assigned(glMultiTexCoord4iARB) then Exit; - @glMultiTexCoord4ivARB := SDL_GL_GetProcAddress('glMultiTexCoord4ivARB'); - if not Assigned(glMultiTexCoord4ivARB) then Exit; - @glMultiTexCoord4sARB := SDL_GL_GetProcAddress('glMultiTexCoord4sARB'); - if not Assigned(glMultiTexCoord4sARB) then Exit; - @glMultiTexCoord4svARB := SDL_GL_GetProcAddress('glMultiTexCoord4svARB'); - if not Assigned(glMultiTexCoord4svARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_transpose_matrix: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_transpose_matrix', extstring) then - begin - @glLoadTransposeMatrixfARB := SDL_GL_GetProcAddress('glLoadTransposeMatrixfARB'); - if not Assigned(glLoadTransposeMatrixfARB) then Exit; - @glLoadTransposeMatrixdARB := SDL_GL_GetProcAddress('glLoadTransposeMatrixdARB'); - if not Assigned(glLoadTransposeMatrixdARB) then Exit; - @glMultTransposeMatrixfARB := SDL_GL_GetProcAddress('glMultTransposeMatrixfARB'); - if not Assigned(glMultTransposeMatrixfARB) then Exit; - @glMultTransposeMatrixdARB := SDL_GL_GetProcAddress('glMultTransposeMatrixdARB'); - if not Assigned(glMultTransposeMatrixdARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_multisample: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_multisample', extstring) then - begin - @glSampleCoverageARB := SDL_GL_GetProcAddress('glSampleCoverageARB'); - if not Assigned(glSampleCoverageARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_env_add: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_env_add', extstring) then - begin - Result := TRUE; - end; - -end; - -{$IFDEF WINDOWS} -function Load_WGL_ARB_extensions_string: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ARB_extensions_string', extstring) then - begin - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_ARB_buffer_region: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ARB_buffer_region', extstring) then - begin - @wglCreateBufferRegionARB := SDL_GL_GetProcAddress('wglCreateBufferRegionARB'); - if not Assigned(wglCreateBufferRegionARB) then Exit; - @wglDeleteBufferRegionARB := SDL_GL_GetProcAddress('wglDeleteBufferRegionARB'); - if not Assigned(wglDeleteBufferRegionARB) then Exit; - @wglSaveBufferRegionARB := SDL_GL_GetProcAddress('wglSaveBufferRegionARB'); - if not Assigned(wglSaveBufferRegionARB) then Exit; - @wglRestoreBufferRegionARB := SDL_GL_GetProcAddress('wglRestoreBufferRegionARB'); - if not Assigned(wglRestoreBufferRegionARB) then Exit; - Result := TRUE; - end; - -end; -{$ENDIF} - -function Load_GL_ARB_texture_cube_map: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_cube_map', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_depth_texture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_depth_texture', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_point_parameters: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_point_parameters', extstring) then - begin - @glPointParameterfARB := SDL_GL_GetProcAddress('glPointParameterfARB'); - if not Assigned(glPointParameterfARB) then Exit; - @glPointParameterfvARB := SDL_GL_GetProcAddress('glPointParameterfvARB'); - if not Assigned(glPointParameterfvARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_shadow: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_shadow', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_shadow_ambient: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_shadow_ambient', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_border_clamp: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_border_clamp', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_compression: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_compression', extstring) then - begin - @glCompressedTexImage3DARB := SDL_GL_GetProcAddress('glCompressedTexImage3DARB'); - if not Assigned(glCompressedTexImage3DARB) then Exit; - @glCompressedTexImage2DARB := SDL_GL_GetProcAddress('glCompressedTexImage2DARB'); - if not Assigned(glCompressedTexImage2DARB) then Exit; - @glCompressedTexImage1DARB := SDL_GL_GetProcAddress('glCompressedTexImage1DARB'); - if not Assigned(glCompressedTexImage1DARB) then Exit; - @glCompressedTexSubImage3DARB := SDL_GL_GetProcAddress('glCompressedTexSubImage3DARB'); - if not Assigned(glCompressedTexSubImage3DARB) then Exit; - @glCompressedTexSubImage2DARB := SDL_GL_GetProcAddress('glCompressedTexSubImage2DARB'); - if not Assigned(glCompressedTexSubImage2DARB) then Exit; - @glCompressedTexSubImage1DARB := SDL_GL_GetProcAddress('glCompressedTexSubImage1DARB'); - if not Assigned(glCompressedTexSubImage1DARB) then Exit; - @glGetCompressedTexImageARB := SDL_GL_GetProcAddress('glGetCompressedTexImageARB'); - if not Assigned(glGetCompressedTexImageARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_env_combine: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_env_combine', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_env_crossbar: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_env_crossbar', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_env_dot3: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_env_dot3', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_mirrored_repeat: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_mirrored_repeat', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_vertex_blend: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_vertex_blend', extstring) then - begin - @glWeightbvARB := SDL_GL_GetProcAddress('glWeightbvARB'); - if not Assigned(glWeightbvARB) then Exit; - @glWeightsvARB := SDL_GL_GetProcAddress('glWeightsvARB'); - if not Assigned(glWeightsvARB) then Exit; - @glWeightivARB := SDL_GL_GetProcAddress('glWeightivARB'); - if not Assigned(glWeightivARB) then Exit; - @glWeightfvARB := SDL_GL_GetProcAddress('glWeightfvARB'); - if not Assigned(glWeightfvARB) then Exit; - @glWeightdvARB := SDL_GL_GetProcAddress('glWeightdvARB'); - if not Assigned(glWeightdvARB) then Exit; - @glWeightvARB := SDL_GL_GetProcAddress('glWeightvARB'); - if not Assigned(glWeightvARB) then Exit; - @glWeightubvARB := SDL_GL_GetProcAddress('glWeightubvARB'); - if not Assigned(glWeightubvARB) then Exit; - @glWeightusvARB := SDL_GL_GetProcAddress('glWeightusvARB'); - if not Assigned(glWeightusvARB) then Exit; - @glWeightuivARB := SDL_GL_GetProcAddress('glWeightuivARB'); - if not Assigned(glWeightuivARB) then Exit; - @glWeightPointerARB := SDL_GL_GetProcAddress('glWeightPointerARB'); - if not Assigned(glWeightPointerARB) then Exit; - @glVertexBlendARB := SDL_GL_GetProcAddress('glVertexBlendARB'); - if not Assigned(glVertexBlendARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_vertex_program: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_vertex_program', extstring) then - begin - @glVertexAttrib1sARB := SDL_GL_GetProcAddress('glVertexAttrib1sARB'); - if not Assigned(glVertexAttrib1sARB) then Exit; - @glVertexAttrib1fARB := SDL_GL_GetProcAddress('glVertexAttrib1fARB'); - if not Assigned(glVertexAttrib1fARB) then Exit; - @glVertexAttrib1dARB := SDL_GL_GetProcAddress('glVertexAttrib1dARB'); - if not Assigned(glVertexAttrib1dARB) then Exit; - @glVertexAttrib2sARB := SDL_GL_GetProcAddress('glVertexAttrib2sARB'); - if not Assigned(glVertexAttrib2sARB) then Exit; - @glVertexAttrib2fARB := SDL_GL_GetProcAddress('glVertexAttrib2fARB'); - if not Assigned(glVertexAttrib2fARB) then Exit; - @glVertexAttrib2dARB := SDL_GL_GetProcAddress('glVertexAttrib2dARB'); - if not Assigned(glVertexAttrib2dARB) then Exit; - @glVertexAttrib3sARB := SDL_GL_GetProcAddress('glVertexAttrib3sARB'); - if not Assigned(glVertexAttrib3sARB) then Exit; - @glVertexAttrib3fARB := SDL_GL_GetProcAddress('glVertexAttrib3fARB'); - if not Assigned(glVertexAttrib3fARB) then Exit; - @glVertexAttrib3dARB := SDL_GL_GetProcAddress('glVertexAttrib3dARB'); - if not Assigned(glVertexAttrib3dARB) then Exit; - @glVertexAttrib4sARB := SDL_GL_GetProcAddress('glVertexAttrib4sARB'); - if not Assigned(glVertexAttrib4sARB) then Exit; - @glVertexAttrib4fARB := SDL_GL_GetProcAddress('glVertexAttrib4fARB'); - if not Assigned(glVertexAttrib4fARB) then Exit; - @glVertexAttrib4dARB := SDL_GL_GetProcAddress('glVertexAttrib4dARB'); - if not Assigned(glVertexAttrib4dARB) then Exit; - @glVertexAttrib4NubARB := SDL_GL_GetProcAddress('glVertexAttrib4NubARB'); - if not Assigned(glVertexAttrib4NubARB) then Exit; - @glVertexAttrib1svARB := SDL_GL_GetProcAddress('glVertexAttrib1svARB'); - if not Assigned(glVertexAttrib1svARB) then Exit; - @glVertexAttrib1fvARB := SDL_GL_GetProcAddress('glVertexAttrib1fvARB'); - if not Assigned(glVertexAttrib1fvARB) then Exit; - @glVertexAttrib1dvARB := SDL_GL_GetProcAddress('glVertexAttrib1dvARB'); - if not Assigned(glVertexAttrib1dvARB) then Exit; - @glVertexAttrib2svARB := SDL_GL_GetProcAddress('glVertexAttrib2svARB'); - if not Assigned(glVertexAttrib2svARB) then Exit; - @glVertexAttrib2fvARB := SDL_GL_GetProcAddress('glVertexAttrib2fvARB'); - if not Assigned(glVertexAttrib2fvARB) then Exit; - @glVertexAttrib2dvARB := SDL_GL_GetProcAddress('glVertexAttrib2dvARB'); - if not Assigned(glVertexAttrib2dvARB) then Exit; - @glVertexAttrib3svARB := SDL_GL_GetProcAddress('glVertexAttrib3svARB'); - if not Assigned(glVertexAttrib3svARB) then Exit; - @glVertexAttrib3fvARB := SDL_GL_GetProcAddress('glVertexAttrib3fvARB'); - if not Assigned(glVertexAttrib3fvARB) then Exit; - @glVertexAttrib3dvARB := SDL_GL_GetProcAddress('glVertexAttrib3dvARB'); - if not Assigned(glVertexAttrib3dvARB) then Exit; - @glVertexAttrib4bvARB := SDL_GL_GetProcAddress('glVertexAttrib4bvARB'); - if not Assigned(glVertexAttrib4bvARB) then Exit; - @glVertexAttrib4svARB := SDL_GL_GetProcAddress('glVertexAttrib4svARB'); - if not Assigned(glVertexAttrib4svARB) then Exit; - @glVertexAttrib4ivARB := SDL_GL_GetProcAddress('glVertexAttrib4ivARB'); - if not Assigned(glVertexAttrib4ivARB) then Exit; - @glVertexAttrib4ubvARB := SDL_GL_GetProcAddress('glVertexAttrib4ubvARB'); - if not Assigned(glVertexAttrib4ubvARB) then Exit; - @glVertexAttrib4usvARB := SDL_GL_GetProcAddress('glVertexAttrib4usvARB'); - if not Assigned(glVertexAttrib4usvARB) then Exit; - @glVertexAttrib4uivARB := SDL_GL_GetProcAddress('glVertexAttrib4uivARB'); - if not Assigned(glVertexAttrib4uivARB) then Exit; - @glVertexAttrib4fvARB := SDL_GL_GetProcAddress('glVertexAttrib4fvARB'); - if not Assigned(glVertexAttrib4fvARB) then Exit; - @glVertexAttrib4dvARB := SDL_GL_GetProcAddress('glVertexAttrib4dvARB'); - if not Assigned(glVertexAttrib4dvARB) then Exit; - @glVertexAttrib4NbvARB := SDL_GL_GetProcAddress('glVertexAttrib4NbvARB'); - if not Assigned(glVertexAttrib4NbvARB) then Exit; - @glVertexAttrib4NsvARB := SDL_GL_GetProcAddress('glVertexAttrib4NsvARB'); - if not Assigned(glVertexAttrib4NsvARB) then Exit; - @glVertexAttrib4NivARB := SDL_GL_GetProcAddress('glVertexAttrib4NivARB'); - if not Assigned(glVertexAttrib4NivARB) then Exit; - @glVertexAttrib4NubvARB := SDL_GL_GetProcAddress('glVertexAttrib4NubvARB'); - if not Assigned(glVertexAttrib4NubvARB) then Exit; - @glVertexAttrib4NusvARB := SDL_GL_GetProcAddress('glVertexAttrib4NusvARB'); - if not Assigned(glVertexAttrib4NusvARB) then Exit; - @glVertexAttrib4NuivARB := SDL_GL_GetProcAddress('glVertexAttrib4NuivARB'); - if not Assigned(glVertexAttrib4NuivARB) then Exit; - @glVertexAttribPointerARB := SDL_GL_GetProcAddress('glVertexAttribPointerARB'); - if not Assigned(glVertexAttribPointerARB) then Exit; - @glEnableVertexAttribArrayARB := SDL_GL_GetProcAddress('glEnableVertexAttribArrayARB'); - if not Assigned(glEnableVertexAttribArrayARB) then Exit; - @glDisableVertexAttribArrayARB := SDL_GL_GetProcAddress('glDisableVertexAttribArrayARB'); - if not Assigned(glDisableVertexAttribArrayARB) then Exit; - @glProgramStringARB := SDL_GL_GetProcAddress('glProgramStringARB'); - if not Assigned(glProgramStringARB) then Exit; - @glBindProgramARB := SDL_GL_GetProcAddress('glBindProgramARB'); - if not Assigned(glBindProgramARB) then Exit; - @glDeleteProgramsARB := SDL_GL_GetProcAddress('glDeleteProgramsARB'); - if not Assigned(glDeleteProgramsARB) then Exit; - @glGenProgramsARB := SDL_GL_GetProcAddress('glGenProgramsARB'); - if not Assigned(glGenProgramsARB) then Exit; - @glProgramEnvParameter4dARB := SDL_GL_GetProcAddress('glProgramEnvParameter4dARB'); - if not Assigned(glProgramEnvParameter4dARB) then Exit; - @glProgramEnvParameter4dvARB := SDL_GL_GetProcAddress('glProgramEnvParameter4dvARB'); - if not Assigned(glProgramEnvParameter4dvARB) then Exit; - @glProgramEnvParameter4fARB := SDL_GL_GetProcAddress('glProgramEnvParameter4fARB'); - if not Assigned(glProgramEnvParameter4fARB) then Exit; - @glProgramEnvParameter4fvARB := SDL_GL_GetProcAddress('glProgramEnvParameter4fvARB'); - if not Assigned(glProgramEnvParameter4fvARB) then Exit; - @glProgramLocalParameter4dARB := SDL_GL_GetProcAddress('glProgramLocalParameter4dARB'); - if not Assigned(glProgramLocalParameter4dARB) then Exit; - @glProgramLocalParameter4dvARB := SDL_GL_GetProcAddress('glProgramLocalParameter4dvARB'); - if not Assigned(glProgramLocalParameter4dvARB) then Exit; - @glProgramLocalParameter4fARB := SDL_GL_GetProcAddress('glProgramLocalParameter4fARB'); - if not Assigned(glProgramLocalParameter4fARB) then Exit; - @glProgramLocalParameter4fvARB := SDL_GL_GetProcAddress('glProgramLocalParameter4fvARB'); - if not Assigned(glProgramLocalParameter4fvARB) then Exit; - @glGetProgramEnvParameterdvARB := SDL_GL_GetProcAddress('glGetProgramEnvParameterdvARB'); - if not Assigned(glGetProgramEnvParameterdvARB) then Exit; - @glGetProgramEnvParameterfvARB := SDL_GL_GetProcAddress('glGetProgramEnvParameterfvARB'); - if not Assigned(glGetProgramEnvParameterfvARB) then Exit; - @glGetProgramLocalParameterdvARB := SDL_GL_GetProcAddress('glGetProgramLocalParameterdvARB'); - if not Assigned(glGetProgramLocalParameterdvARB) then Exit; - @glGetProgramLocalParameterfvARB := SDL_GL_GetProcAddress('glGetProgramLocalParameterfvARB'); - if not Assigned(glGetProgramLocalParameterfvARB) then Exit; - @glGetProgramivARB := SDL_GL_GetProcAddress('glGetProgramivARB'); - if not Assigned(glGetProgramivARB) then Exit; - @glGetProgramStringARB := SDL_GL_GetProcAddress('glGetProgramStringARB'); - if not Assigned(glGetProgramStringARB) then Exit; - @glGetVertexAttribdvARB := SDL_GL_GetProcAddress('glGetVertexAttribdvARB'); - if not Assigned(glGetVertexAttribdvARB) then Exit; - @glGetVertexAttribfvARB := SDL_GL_GetProcAddress('glGetVertexAttribfvARB'); - if not Assigned(glGetVertexAttribfvARB) then Exit; - @glGetVertexAttribivARB := SDL_GL_GetProcAddress('glGetVertexAttribivARB'); - if not Assigned(glGetVertexAttribivARB) then Exit; - @glGetVertexAttribPointervARB := SDL_GL_GetProcAddress('glGetVertexAttribPointervARB'); - if not Assigned(glGetVertexAttribPointervARB) then Exit; - @glIsProgramARB := SDL_GL_GetProcAddress('glIsProgramARB'); - if not Assigned(glIsProgramARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_window_pos: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_window_pos', extstring) then - begin - @glWindowPos2dARB := SDL_GL_GetProcAddress('glWindowPos2dARB'); - if not Assigned(glWindowPos2dARB) then Exit; - @glWindowPos2fARB := SDL_GL_GetProcAddress('glWindowPos2fARB'); - if not Assigned(glWindowPos2fARB) then Exit; - @glWindowPos2iARB := SDL_GL_GetProcAddress('glWindowPos2iARB'); - if not Assigned(glWindowPos2iARB) then Exit; - @glWindowPos2sARB := SDL_GL_GetProcAddress('glWindowPos2sARB'); - if not Assigned(glWindowPos2sARB) then Exit; - @glWindowPos2dvARB := SDL_GL_GetProcAddress('glWindowPos2dvARB'); - if not Assigned(glWindowPos2dvARB) then Exit; - @glWindowPos2fvARB := SDL_GL_GetProcAddress('glWindowPos2fvARB'); - if not Assigned(glWindowPos2fvARB) then Exit; - @glWindowPos2ivARB := SDL_GL_GetProcAddress('glWindowPos2ivARB'); - if not Assigned(glWindowPos2ivARB) then Exit; - @glWindowPos2svARB := SDL_GL_GetProcAddress('glWindowPos2svARB'); - if not Assigned(glWindowPos2svARB) then Exit; - @glWindowPos3dARB := SDL_GL_GetProcAddress('glWindowPos3dARB'); - if not Assigned(glWindowPos3dARB) then Exit; - @glWindowPos3fARB := SDL_GL_GetProcAddress('glWindowPos3fARB'); - if not Assigned(glWindowPos3fARB) then Exit; - @glWindowPos3iARB := SDL_GL_GetProcAddress('glWindowPos3iARB'); - if not Assigned(glWindowPos3iARB) then Exit; - @glWindowPos3sARB := SDL_GL_GetProcAddress('glWindowPos3sARB'); - if not Assigned(glWindowPos3sARB) then Exit; - @glWindowPos3dvARB := SDL_GL_GetProcAddress('glWindowPos3dvARB'); - if not Assigned(glWindowPos3dvARB) then Exit; - @glWindowPos3fvARB := SDL_GL_GetProcAddress('glWindowPos3fvARB'); - if not Assigned(glWindowPos3fvARB) then Exit; - @glWindowPos3ivARB := SDL_GL_GetProcAddress('glWindowPos3ivARB'); - if not Assigned(glWindowPos3ivARB) then Exit; - @glWindowPos3svARB := SDL_GL_GetProcAddress('glWindowPos3svARB'); - if not Assigned(glWindowPos3svARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_422_pixels: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_422_pixels', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_abgr: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_abgr', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_bgra: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_bgra', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_blend_color: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_blend_color', extstring) then - begin - @glBlendColorEXT := SDL_GL_GetProcAddress('glBlendColorEXT'); - if not Assigned(glBlendColorEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_blend_func_separate: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_blend_func_separate', extstring) then - begin - @glBlendFuncSeparateEXT := SDL_GL_GetProcAddress('glBlendFuncSeparateEXT'); - if not Assigned(glBlendFuncSeparateEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_blend_logic_op: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_blend_logic_op', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_blend_minmax: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_blend_minmax', extstring) then - begin - @glBlendEquationEXT := SDL_GL_GetProcAddress('glBlendEquationEXT'); - if not Assigned(glBlendEquationEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_blend_subtract: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_blend_subtract', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_clip_volume_hint: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_clip_volume_hint', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_color_subtable: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_color_subtable', extstring) then - begin - @glColorSubTableEXT := SDL_GL_GetProcAddress('glColorSubTableEXT'); - if not Assigned(glColorSubTableEXT) then Exit; - @glCopyColorSubTableEXT := SDL_GL_GetProcAddress('glCopyColorSubTableEXT'); - if not Assigned(glCopyColorSubTableEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_compiled_vertex_array: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_compiled_vertex_array', extstring) then - begin - @glLockArraysEXT := SDL_GL_GetProcAddress('glLockArraysEXT'); - if not Assigned(glLockArraysEXT) then Exit; - @glUnlockArraysEXT := SDL_GL_GetProcAddress('glUnlockArraysEXT'); - if not Assigned(glUnlockArraysEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_convolution: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_convolution', extstring) then - begin - @glConvolutionFilter1DEXT := SDL_GL_GetProcAddress('glConvolutionFilter1DEXT'); - if not Assigned(glConvolutionFilter1DEXT) then Exit; - @glConvolutionFilter2DEXT := SDL_GL_GetProcAddress('glConvolutionFilter2DEXT'); - if not Assigned(glConvolutionFilter2DEXT) then Exit; - @glCopyConvolutionFilter1DEXT := SDL_GL_GetProcAddress('glCopyConvolutionFilter1DEXT'); - if not Assigned(glCopyConvolutionFilter1DEXT) then Exit; - @glCopyConvolutionFilter2DEXT := SDL_GL_GetProcAddress('glCopyConvolutionFilter2DEXT'); - if not Assigned(glCopyConvolutionFilter2DEXT) then Exit; - @glGetConvolutionFilterEXT := SDL_GL_GetProcAddress('glGetConvolutionFilterEXT'); - if not Assigned(glGetConvolutionFilterEXT) then Exit; - @glSeparableFilter2DEXT := SDL_GL_GetProcAddress('glSeparableFilter2DEXT'); - if not Assigned(glSeparableFilter2DEXT) then Exit; - @glGetSeparableFilterEXT := SDL_GL_GetProcAddress('glGetSeparableFilterEXT'); - if not Assigned(glGetSeparableFilterEXT) then Exit; - @glConvolutionParameteriEXT := SDL_GL_GetProcAddress('glConvolutionParameteriEXT'); - if not Assigned(glConvolutionParameteriEXT) then Exit; - @glConvolutionParameterivEXT := SDL_GL_GetProcAddress('glConvolutionParameterivEXT'); - if not Assigned(glConvolutionParameterivEXT) then Exit; - @glConvolutionParameterfEXT := SDL_GL_GetProcAddress('glConvolutionParameterfEXT'); - if not Assigned(glConvolutionParameterfEXT) then Exit; - @glConvolutionParameterfvEXT := SDL_GL_GetProcAddress('glConvolutionParameterfvEXT'); - if not Assigned(glConvolutionParameterfvEXT) then Exit; - @glGetConvolutionParameterivEXT := SDL_GL_GetProcAddress('glGetConvolutionParameterivEXT'); - if not Assigned(glGetConvolutionParameterivEXT) then Exit; - @glGetConvolutionParameterfvEXT := SDL_GL_GetProcAddress('glGetConvolutionParameterfvEXT'); - if not Assigned(glGetConvolutionParameterfvEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_histogram: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_histogram', extstring) then - begin - @glHistogramEXT := SDL_GL_GetProcAddress('glHistogramEXT'); - if not Assigned(glHistogramEXT) then Exit; - @glResetHistogramEXT := SDL_GL_GetProcAddress('glResetHistogramEXT'); - if not Assigned(glResetHistogramEXT) then Exit; - @glGetHistogramEXT := SDL_GL_GetProcAddress('glGetHistogramEXT'); - if not Assigned(glGetHistogramEXT) then Exit; - @glGetHistogramParameterivEXT := SDL_GL_GetProcAddress('glGetHistogramParameterivEXT'); - if not Assigned(glGetHistogramParameterivEXT) then Exit; - @glGetHistogramParameterfvEXT := SDL_GL_GetProcAddress('glGetHistogramParameterfvEXT'); - if not Assigned(glGetHistogramParameterfvEXT) then Exit; - @glMinmaxEXT := SDL_GL_GetProcAddress('glMinmaxEXT'); - if not Assigned(glMinmaxEXT) then Exit; - @glResetMinmaxEXT := SDL_GL_GetProcAddress('glResetMinmaxEXT'); - if not Assigned(glResetMinmaxEXT) then Exit; - @glGetMinmaxEXT := SDL_GL_GetProcAddress('glGetMinmaxEXT'); - if not Assigned(glGetMinmaxEXT) then Exit; - @glGetMinmaxParameterivEXT := SDL_GL_GetProcAddress('glGetMinmaxParameterivEXT'); - if not Assigned(glGetMinmaxParameterivEXT) then Exit; - @glGetMinmaxParameterfvEXT := SDL_GL_GetProcAddress('glGetMinmaxParameterfvEXT'); - if not Assigned(glGetMinmaxParameterfvEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_multi_draw_arrays: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_multi_draw_arrays', extstring) then - begin - @glMultiDrawArraysEXT := SDL_GL_GetProcAddress('glMultiDrawArraysEXT'); - if not Assigned(glMultiDrawArraysEXT) then Exit; - @glMultiDrawElementsEXT := SDL_GL_GetProcAddress('glMultiDrawElementsEXT'); - if not Assigned(glMultiDrawElementsEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_packed_pixels: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_packed_pixels', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_paletted_texture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_paletted_texture', extstring) then - begin - @glColorTableEXT := SDL_GL_GetProcAddress('glColorTableEXT'); - if not Assigned(glColorTableEXT) then Exit; - @glColorSubTableEXT := SDL_GL_GetProcAddress('glColorSubTableEXT'); - if not Assigned(glColorSubTableEXT) then Exit; - @glGetColorTableEXT := SDL_GL_GetProcAddress('glGetColorTableEXT'); - if not Assigned(glGetColorTableEXT) then Exit; - @glGetColorTableParameterivEXT := SDL_GL_GetProcAddress('glGetColorTableParameterivEXT'); - if not Assigned(glGetColorTableParameterivEXT) then Exit; - @glGetColorTableParameterfvEXT := SDL_GL_GetProcAddress('glGetColorTableParameterfvEXT'); - if not Assigned(glGetColorTableParameterfvEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_point_parameters: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_point_parameters', extstring) then - begin - @glPointParameterfEXT := SDL_GL_GetProcAddress('glPointParameterfEXT'); - if not Assigned(glPointParameterfEXT) then Exit; - @glPointParameterfvEXT := SDL_GL_GetProcAddress('glPointParameterfvEXT'); - if not Assigned(glPointParameterfvEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_polygon_offset: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_polygon_offset', extstring) then - begin - @glPolygonOffsetEXT := SDL_GL_GetProcAddress('glPolygonOffsetEXT'); - if not Assigned(glPolygonOffsetEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_separate_specular_color: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_separate_specular_color', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_shadow_funcs: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_shadow_funcs', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_shared_texture_palette: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_shared_texture_palette', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_stencil_two_side: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_stencil_two_side', extstring) then - begin - @glActiveStencilFaceEXT := SDL_GL_GetProcAddress('glActiveStencilFaceEXT'); - if not Assigned(glActiveStencilFaceEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_stencil_wrap: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_stencil_wrap', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_subtexture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_subtexture', extstring) then - begin - @glTexSubImage1DEXT := SDL_GL_GetProcAddress('glTexSubImage1DEXT'); - if not Assigned(glTexSubImage1DEXT) then Exit; - @glTexSubImage2DEXT := SDL_GL_GetProcAddress('glTexSubImage2DEXT'); - if not Assigned(glTexSubImage2DEXT) then Exit; - @glTexSubImage3DEXT := SDL_GL_GetProcAddress('glTexSubImage3DEXT'); - if not Assigned(glTexSubImage3DEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture3D: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture3D', extstring) then - begin - glTexImage3DEXT := SDL_GL_GetProcAddress('glTexImage3DEXT'); - if not Assigned(glTexImage3DEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_compression_s3tc: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_compression_s3tc', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_env_add: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_env_add', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_env_combine: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_env_combine', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_env_dot3: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_env_dot3', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_filter_anisotropic: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_filter_anisotropic', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_lod_bias: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_lod_bias', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_object: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_object', extstring) then - begin - @glGenTexturesEXT := SDL_GL_GetProcAddress('glGenTexturesEXT'); - if not Assigned(glGenTexturesEXT) then Exit; - @glDeleteTexturesEXT := SDL_GL_GetProcAddress('glDeleteTexturesEXT'); - if not Assigned(glDeleteTexturesEXT) then Exit; - @glBindTextureEXT := SDL_GL_GetProcAddress('glBindTextureEXT'); - if not Assigned(glBindTextureEXT) then Exit; - @glPrioritizeTexturesEXT := SDL_GL_GetProcAddress('glPrioritizeTexturesEXT'); - if not Assigned(glPrioritizeTexturesEXT) then Exit; - @glAreTexturesResidentEXT := SDL_GL_GetProcAddress('glAreTexturesResidentEXT'); - if not Assigned(glAreTexturesResidentEXT) then Exit; - @glIsTextureEXT := SDL_GL_GetProcAddress('glIsTextureEXT'); - if not Assigned(glIsTextureEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_vertex_array: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_vertex_array', extstring) then - begin - @glArrayElementEXT := SDL_GL_GetProcAddress('glArrayElementEXT'); - if not Assigned(glArrayElementEXT) then Exit; - @glDrawArraysEXT := SDL_GL_GetProcAddress('glDrawArraysEXT'); - if not Assigned(glDrawArraysEXT) then Exit; - @glVertexPointerEXT := SDL_GL_GetProcAddress('glVertexPointerEXT'); - if not Assigned(glVertexPointerEXT) then Exit; - @glNormalPointerEXT := SDL_GL_GetProcAddress('glNormalPointerEXT'); - if not Assigned(glNormalPointerEXT) then Exit; - @glColorPointerEXT := SDL_GL_GetProcAddress('glColorPointerEXT'); - if not Assigned(glColorPointerEXT) then Exit; - @glIndexPointerEXT := SDL_GL_GetProcAddress('glIndexPointerEXT'); - if not Assigned(glIndexPointerEXT) then Exit; - @glTexCoordPointerEXT := SDL_GL_GetProcAddress('glTexCoordPointerEXT'); - if not Assigned(glTexCoordPointerEXT) then Exit; - @glEdgeFlagPointerEXT := SDL_GL_GetProcAddress('glEdgeFlagPointerEXT'); - if not Assigned(glEdgeFlagPointerEXT) then Exit; - @glGetPointervEXT := SDL_GL_GetProcAddress('glGetPointervEXT'); - if not Assigned(glGetPointervEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_vertex_shader: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_vertex_shader', extstring) then - begin - @glBeginVertexShaderEXT := SDL_GL_GetProcAddress('glBeginVertexShaderEXT'); - if not Assigned(glBeginVertexShaderEXT) then Exit; - @glEndVertexShaderEXT := SDL_GL_GetProcAddress('glEndVertexShaderEXT'); - if not Assigned(glEndVertexShaderEXT) then Exit; - @glBindVertexShaderEXT := SDL_GL_GetProcAddress('glBindVertexShaderEXT'); - if not Assigned(glBindVertexShaderEXT) then Exit; - @glGenVertexShadersEXT := SDL_GL_GetProcAddress('glGenVertexShadersEXT'); - if not Assigned(glGenVertexShadersEXT) then Exit; - @glDeleteVertexShaderEXT := SDL_GL_GetProcAddress('glDeleteVertexShaderEXT'); - if not Assigned(glDeleteVertexShaderEXT) then Exit; - @glShaderOp1EXT := SDL_GL_GetProcAddress('glShaderOp1EXT'); - if not Assigned(glShaderOp1EXT) then Exit; - @glShaderOp2EXT := SDL_GL_GetProcAddress('glShaderOp2EXT'); - if not Assigned(glShaderOp2EXT) then Exit; - @glShaderOp3EXT := SDL_GL_GetProcAddress('glShaderOp3EXT'); - if not Assigned(glShaderOp3EXT) then Exit; - @glSwizzleEXT := SDL_GL_GetProcAddress('glSwizzleEXT'); - if not Assigned(glSwizzleEXT) then Exit; - @glWriteMaskEXT := SDL_GL_GetProcAddress('glWriteMaskEXT'); - if not Assigned(glWriteMaskEXT) then Exit; - @glInsertComponentEXT := SDL_GL_GetProcAddress('glInsertComponentEXT'); - if not Assigned(glInsertComponentEXT) then Exit; - @glExtractComponentEXT := SDL_GL_GetProcAddress('glExtractComponentEXT'); - if not Assigned(glExtractComponentEXT) then Exit; - @glGenSymbolsEXT := SDL_GL_GetProcAddress('glGenSymbolsEXT'); - if not Assigned(glGenSymbolsEXT) then Exit; - @glSetInvariantEXT := SDL_GL_GetProcAddress('glSetInvariantEXT'); - if not Assigned(glSetInvariantEXT) then Exit; - @glSetLocalConstantEXT := SDL_GL_GetProcAddress('glSetLocalConstantEXT'); - if not Assigned(glSetLocalConstantEXT) then Exit; - @glVariantbvEXT := SDL_GL_GetProcAddress('glVariantbvEXT'); - if not Assigned(glVariantbvEXT) then Exit; - @glVariantsvEXT := SDL_GL_GetProcAddress('glVariantsvEXT'); - if not Assigned(glVariantsvEXT) then Exit; - @glVariantivEXT := SDL_GL_GetProcAddress('glVariantivEXT'); - if not Assigned(glVariantivEXT) then Exit; - @glVariantfvEXT := SDL_GL_GetProcAddress('glVariantfvEXT'); - if not Assigned(glVariantfvEXT) then Exit; - @glVariantdvEXT := SDL_GL_GetProcAddress('glVariantdvEXT'); - if not Assigned(glVariantdvEXT) then Exit; - @glVariantubvEXT := SDL_GL_GetProcAddress('glVariantubvEXT'); - if not Assigned(glVariantubvEXT) then Exit; - @glVariantusvEXT := SDL_GL_GetProcAddress('glVariantusvEXT'); - if not Assigned(glVariantusvEXT) then Exit; - @glVariantuivEXT := SDL_GL_GetProcAddress('glVariantuivEXT'); - if not Assigned(glVariantuivEXT) then Exit; - @glVariantPointerEXT := SDL_GL_GetProcAddress('glVariantPointerEXT'); - if not Assigned(glVariantPointerEXT) then Exit; - @glEnableVariantClientStateEXT := SDL_GL_GetProcAddress('glEnableVariantClientStateEXT'); - if not Assigned(glEnableVariantClientStateEXT) then Exit; - @glDisableVariantClientStateEXT := SDL_GL_GetProcAddress('glDisableVariantClientStateEXT'); - if not Assigned(glDisableVariantClientStateEXT) then Exit; - @glBindLightParameterEXT := SDL_GL_GetProcAddress('glBindLightParameterEXT'); - if not Assigned(glBindLightParameterEXT) then Exit; - @glBindMaterialParameterEXT := SDL_GL_GetProcAddress('glBindMaterialParameterEXT'); - if not Assigned(glBindMaterialParameterEXT) then Exit; - @glBindTexGenParameterEXT := SDL_GL_GetProcAddress('glBindTexGenParameterEXT'); - if not Assigned(glBindTexGenParameterEXT) then Exit; - @glBindTextureUnitParameterEXT := SDL_GL_GetProcAddress('glBindTextureUnitParameterEXT'); - if not Assigned(glBindTextureUnitParameterEXT) then Exit; - @glBindParameterEXT := SDL_GL_GetProcAddress('glBindParameterEXT'); - if not Assigned(glBindParameterEXT) then Exit; - @glIsVariantEnabledEXT := SDL_GL_GetProcAddress('glIsVariantEnabledEXT'); - if not Assigned(glIsVariantEnabledEXT) then Exit; - @glGetVariantBooleanvEXT := SDL_GL_GetProcAddress('glGetVariantBooleanvEXT'); - if not Assigned(glGetVariantBooleanvEXT) then Exit; - @glGetVariantIntegervEXT := SDL_GL_GetProcAddress('glGetVariantIntegervEXT'); - if not Assigned(glGetVariantIntegervEXT) then Exit; - @glGetVariantFloatvEXT := SDL_GL_GetProcAddress('glGetVariantFloatvEXT'); - if not Assigned(glGetVariantFloatvEXT) then Exit; - @glGetVariantPointervEXT := SDL_GL_GetProcAddress('glGetVariantPointervEXT'); - if not Assigned(glGetVariantPointervEXT) then Exit; - @glGetInvariantBooleanvEXT := SDL_GL_GetProcAddress('glGetInvariantBooleanvEXT'); - if not Assigned(glGetInvariantBooleanvEXT) then Exit; - @glGetInvariantIntegervEXT := SDL_GL_GetProcAddress('glGetInvariantIntegervEXT'); - if not Assigned(glGetInvariantIntegervEXT) then Exit; - @glGetInvariantFloatvEXT := SDL_GL_GetProcAddress('glGetInvariantFloatvEXT'); - if not Assigned(glGetInvariantFloatvEXT) then Exit; - @glGetLocalConstantBooleanvEXT := SDL_GL_GetProcAddress('glGetLocalConstantBooleanvEXT'); - if not Assigned(glGetLocalConstantBooleanvEXT) then Exit; - @glGetLocalConstantIntegervEXT := SDL_GL_GetProcAddress('glGetLocalConstantIntegervEXT'); - if not Assigned(glGetLocalConstantIntegervEXT) then Exit; - @glGetLocalConstantFloatvEXT := SDL_GL_GetProcAddress('glGetLocalConstantFloatvEXT'); - if not Assigned(glGetLocalConstantFloatvEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_vertex_weighting: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_vertex_weighting', extstring) then - begin - @glVertexWeightfEXT := SDL_GL_GetProcAddress('glVertexWeightfEXT'); - if not Assigned(glVertexWeightfEXT) then Exit; - @glVertexWeightfvEXT := SDL_GL_GetProcAddress('glVertexWeightfvEXT'); - if not Assigned(glVertexWeightfvEXT) then Exit; - @glVertexWeightPointerEXT := SDL_GL_GetProcAddress('glVertexWeightPointerEXT'); - if not Assigned(glVertexWeightPointerEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_HP_occlusion_test: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_HP_occlusion_test', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_blend_square: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_blend_square', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_copy_depth_to_color: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_copy_depth_to_color', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_depth_clamp: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_depth_clamp', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_evaluators: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_evaluators', extstring) then - begin - @glMapControlPointsNV := SDL_GL_GetProcAddress('glMapControlPointsNV'); - if not Assigned(glMapControlPointsNV) then Exit; - @glMapParameterivNV := SDL_GL_GetProcAddress('glMapParameterivNV'); - if not Assigned(glMapParameterivNV) then Exit; - @glMapParameterfvNV := SDL_GL_GetProcAddress('glMapParameterfvNV'); - if not Assigned(glMapParameterfvNV) then Exit; - @glGetMapControlPointsNV := SDL_GL_GetProcAddress('glGetMapControlPointsNV'); - if not Assigned(glGetMapControlPointsNV) then Exit; - @glGetMapParameterivNV := SDL_GL_GetProcAddress('glGetMapParameterivNV'); - if not Assigned(glGetMapParameterivNV) then Exit; - @glGetMapParameterfvNV := SDL_GL_GetProcAddress('glGetMapParameterfvNV'); - if not Assigned(glGetMapParameterfvNV) then Exit; - @glGetMapAttribParameterivNV := SDL_GL_GetProcAddress('glGetMapAttribParameterivNV'); - if not Assigned(glGetMapAttribParameterivNV) then Exit; - @glGetMapAttribParameterfvNV := SDL_GL_GetProcAddress('glGetMapAttribParameterfvNV'); - if not Assigned(glGetMapAttribParameterfvNV) then Exit; - @glEvalMapsNV := SDL_GL_GetProcAddress('glEvalMapsNV'); - if not Assigned(glEvalMapsNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_fence: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_fence', extstring) then - begin - @glGenFencesNV := SDL_GL_GetProcAddress('glGenFencesNV'); - if not Assigned(glGenFencesNV) then Exit; - @glDeleteFencesNV := SDL_GL_GetProcAddress('glDeleteFencesNV'); - if not Assigned(glDeleteFencesNV) then Exit; - @glSetFenceNV := SDL_GL_GetProcAddress('glSetFenceNV'); - if not Assigned(glSetFenceNV) then Exit; - @glTestFenceNV := SDL_GL_GetProcAddress('glTestFenceNV'); - if not Assigned(glTestFenceNV) then Exit; - @glFinishFenceNV := SDL_GL_GetProcAddress('glFinishFenceNV'); - if not Assigned(glFinishFenceNV) then Exit; - @glIsFenceNV := SDL_GL_GetProcAddress('glIsFenceNV'); - if not Assigned(glIsFenceNV) then Exit; - @glGetFenceivNV := SDL_GL_GetProcAddress('glGetFenceivNV'); - if not Assigned(glGetFenceivNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_fog_distance: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_fog_distance', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_light_max_exponent: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_light_max_exponent', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_multisample_filter_hint: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_multisample_filter_hint', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_occlusion_query: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_occlusion_query', extstring) then - begin - @glGenOcclusionQueriesNV := SDL_GL_GetProcAddress('glGenOcclusionQueriesNV'); - if not Assigned(glGenOcclusionQueriesNV) then Exit; - @glDeleteOcclusionQueriesNV := SDL_GL_GetProcAddress('glDeleteOcclusionQueriesNV'); - if not Assigned(glDeleteOcclusionQueriesNV) then Exit; - @glIsOcclusionQueryNV := SDL_GL_GetProcAddress('glIsOcclusionQueryNV'); - if not Assigned(glIsOcclusionQueryNV) then Exit; - @glBeginOcclusionQueryNV := SDL_GL_GetProcAddress('glBeginOcclusionQueryNV'); - if not Assigned(glBeginOcclusionQueryNV) then Exit; - @glEndOcclusionQueryNV := SDL_GL_GetProcAddress('glEndOcclusionQueryNV'); - if not Assigned(glEndOcclusionQueryNV) then Exit; - @glGetOcclusionQueryivNV := SDL_GL_GetProcAddress('glGetOcclusionQueryivNV'); - if not Assigned(glGetOcclusionQueryivNV) then Exit; - @glGetOcclusionQueryuivNV := SDL_GL_GetProcAddress('glGetOcclusionQueryuivNV'); - if not Assigned(glGetOcclusionQueryuivNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_packed_depth_stencil: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_packed_depth_stencil', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_point_sprite: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_point_sprite', extstring) then - begin - @glPointParameteriNV := SDL_GL_GetProcAddress('glPointParameteriNV'); - if not Assigned(glPointParameteriNV) then Exit; - @glPointParameterivNV := SDL_GL_GetProcAddress('glPointParameterivNV'); - if not Assigned(glPointParameterivNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_register_combiners: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_register_combiners', extstring) then - begin - @glCombinerParameterfvNV := SDL_GL_GetProcAddress('glCombinerParameterfvNV'); - if not Assigned(glCombinerParameterfvNV) then Exit; - @glCombinerParameterivNV := SDL_GL_GetProcAddress('glCombinerParameterivNV'); - if not Assigned(glCombinerParameterivNV) then Exit; - @glCombinerParameterfNV := SDL_GL_GetProcAddress('glCombinerParameterfNV'); - if not Assigned(glCombinerParameterfNV) then Exit; - @glCombinerParameteriNV := SDL_GL_GetProcAddress('glCombinerParameteriNV'); - if not Assigned(glCombinerParameteriNV) then Exit; - @glCombinerInputNV := SDL_GL_GetProcAddress('glCombinerInputNV'); - if not Assigned(glCombinerInputNV) then Exit; - @glCombinerOutputNV := SDL_GL_GetProcAddress('glCombinerOutputNV'); - if not Assigned(glCombinerOutputNV) then Exit; - @glFinalCombinerInputNV := SDL_GL_GetProcAddress('glFinalCombinerInputNV'); - if not Assigned(glFinalCombinerInputNV) then Exit; - @glGetCombinerInputParameterfvNV := SDL_GL_GetProcAddress('glGetCombinerInputParameterfvNV'); - if not Assigned(glGetCombinerInputParameterfvNV) then Exit; - @glGetCombinerInputParameterivNV := SDL_GL_GetProcAddress('glGetCombinerInputParameterivNV'); - if not Assigned(glGetCombinerInputParameterivNV) then Exit; - @glGetCombinerOutputParameterfvNV := SDL_GL_GetProcAddress('glGetCombinerOutputParameterfvNV'); - if not Assigned(glGetCombinerOutputParameterfvNV) then Exit; - @glGetCombinerOutputParameterivNV := SDL_GL_GetProcAddress('glGetCombinerOutputParameterivNV'); - if not Assigned(glGetCombinerOutputParameterivNV) then Exit; - @glGetFinalCombinerInputParameterfvNV := SDL_GL_GetProcAddress('glGetFinalCombinerInputParameterfvNV'); - if not Assigned(glGetFinalCombinerInputParameterfvNV) then Exit; - @glGetFinalCombinerInputParameterivNV := SDL_GL_GetProcAddress('glGetFinalCombinerInputParameterivNV'); - if not Assigned(glGetFinalCombinerInputParameterivNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_register_combiners2: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_register_combiners2', extstring) then - begin - @glCombinerStageParameterfvNV := SDL_GL_GetProcAddress('glCombinerStageParameterfvNV'); - if not Assigned(glCombinerStageParameterfvNV) then Exit; - @glGetCombinerStageParameterfvNV := SDL_GL_GetProcAddress('glGetCombinerStageParameterfvNV'); - if not Assigned(glGetCombinerStageParameterfvNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_texgen_emboss: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texgen_emboss', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texgen_reflection: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texgen_reflection', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_compression_vtc: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_compression_vtc', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_env_combine4: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_env_combine4', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_rectangle: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_rectangle', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_shader: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_shader', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_shader2: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_shader2', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_shader3: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_shader3', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_array_range: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_array_range', extstring) then - begin - @glVertexArrayRangeNV := SDL_GL_GetProcAddress('glVertexArrayRangeNV'); - if not Assigned(glVertexArrayRangeNV) then Exit; - @glFlushVertexArrayRangeNV := SDL_GL_GetProcAddress('glFlushVertexArrayRangeNV'); - if not Assigned(glFlushVertexArrayRangeNV) then Exit; - {$IFDEF WINDOWS} - @wglAllocateMemoryNV := SDL_GL_GetProcAddress('wglAllocateMemoryNV'); - if not Assigned(wglAllocateMemoryNV) then Exit; - @wglFreeMemoryNV := SDL_GL_GetProcAddress('wglFreeMemoryNV'); - if not Assigned(wglFreeMemoryNV) then Exit; - {$ENDIF} - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_array_range2: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_array_range2', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_program: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_program', extstring) then - begin - @glBindProgramNV := SDL_GL_GetProcAddress('glBindProgramNV'); - if not Assigned(glBindProgramNV) then Exit; - @glDeleteProgramsNV := SDL_GL_GetProcAddress('glDeleteProgramsNV'); - if not Assigned(glDeleteProgramsNV) then Exit; - @glExecuteProgramNV := SDL_GL_GetProcAddress('glExecuteProgramNV'); - if not Assigned(glExecuteProgramNV) then Exit; - @glGenProgramsNV := SDL_GL_GetProcAddress('glGenProgramsNV'); - if not Assigned(glGenProgramsNV) then Exit; - @glAreProgramsResidentNV := SDL_GL_GetProcAddress('glAreProgramsResidentNV'); - if not Assigned(glAreProgramsResidentNV) then Exit; - @glRequestResidentProgramsNV := SDL_GL_GetProcAddress('glRequestResidentProgramsNV'); - if not Assigned(glRequestResidentProgramsNV) then Exit; - @glGetProgramParameterfvNV := SDL_GL_GetProcAddress('glGetProgramParameterfvNV'); - if not Assigned(glGetProgramParameterfvNV) then Exit; - @glGetProgramParameterdvNV := SDL_GL_GetProcAddress('glGetProgramParameterdvNV'); - if not Assigned(glGetProgramParameterdvNV) then Exit; - @glGetProgramivNV := SDL_GL_GetProcAddress('glGetProgramivNV'); - if not Assigned(glGetProgramivNV) then Exit; - @glGetProgramStringNV := SDL_GL_GetProcAddress('glGetProgramStringNV'); - if not Assigned(glGetProgramStringNV) then Exit; - @glGetTrackMatrixivNV := SDL_GL_GetProcAddress('glGetTrackMatrixivNV'); - if not Assigned(glGetTrackMatrixivNV) then Exit; - @glGetVertexAttribdvNV := SDL_GL_GetProcAddress('glGetVertexAttribdvNV'); - if not Assigned(glGetVertexAttribdvNV) then Exit; - @glGetVertexAttribfvNV := SDL_GL_GetProcAddress('glGetVertexAttribfvNV'); - if not Assigned(glGetVertexAttribfvNV) then Exit; - @glGetVertexAttribivNV := SDL_GL_GetProcAddress('glGetVertexAttribivNV'); - if not Assigned(glGetVertexAttribivNV) then Exit; - @glGetVertexAttribPointervNV := SDL_GL_GetProcAddress('glGetVertexAttribPointervNV'); - if not Assigned(glGetVertexAttribPointervNV) then Exit; - @glIsProgramNV := SDL_GL_GetProcAddress('glIsProgramNV'); - if not Assigned(glIsProgramNV) then Exit; - @glLoadProgramNV := SDL_GL_GetProcAddress('glLoadProgramNV'); - if not Assigned(glLoadProgramNV) then Exit; - @glProgramParameter4fNV := SDL_GL_GetProcAddress('glProgramParameter4fNV'); - if not Assigned(glProgramParameter4fNV) then Exit; - @glProgramParameter4fvNV := SDL_GL_GetProcAddress('glProgramParameter4fvNV'); - if not Assigned(glProgramParameter4fvNV) then Exit; - @glProgramParameters4dvNV := SDL_GL_GetProcAddress('glProgramParameters4dvNV'); - if not Assigned(glProgramParameters4dvNV) then Exit; - @glProgramParameters4fvNV := SDL_GL_GetProcAddress('glProgramParameters4fvNV'); - if not Assigned(glProgramParameters4fvNV) then Exit; - @glTrackMatrixNV := SDL_GL_GetProcAddress('glTrackMatrixNV'); - if not Assigned(glTrackMatrixNV) then Exit; - @glVertexAttribPointerNV := SDL_GL_GetProcAddress('glVertexAttribPointerNV'); - if not Assigned(glVertexAttribPointerNV) then Exit; - @glVertexAttrib1sNV := SDL_GL_GetProcAddress('glVertexAttrib1sNV'); - if not Assigned(glVertexAttrib1sNV) then Exit; - @glVertexAttrib1fNV := SDL_GL_GetProcAddress('glVertexAttrib1fNV'); - if not Assigned(glVertexAttrib1fNV) then Exit; - @glVertexAttrib1dNV := SDL_GL_GetProcAddress('glVertexAttrib1dNV'); - if not Assigned(glVertexAttrib1dNV) then Exit; - @glVertexAttrib2sNV := SDL_GL_GetProcAddress('glVertexAttrib2sNV'); - if not Assigned(glVertexAttrib2sNV) then Exit; - @glVertexAttrib2fNV := SDL_GL_GetProcAddress('glVertexAttrib2fNV'); - if not Assigned(glVertexAttrib2fNV) then Exit; - @glVertexAttrib2dNV := SDL_GL_GetProcAddress('glVertexAttrib2dNV'); - if not Assigned(glVertexAttrib2dNV) then Exit; - @glVertexAttrib3sNV := SDL_GL_GetProcAddress('glVertexAttrib3sNV'); - if not Assigned(glVertexAttrib3sNV) then Exit; - @glVertexAttrib3fNV := SDL_GL_GetProcAddress('glVertexAttrib3fNV'); - if not Assigned(glVertexAttrib3fNV) then Exit; - @glVertexAttrib3dNV := SDL_GL_GetProcAddress('glVertexAttrib3dNV'); - if not Assigned(glVertexAttrib3dNV) then Exit; - @glVertexAttrib4sNV := SDL_GL_GetProcAddress('glVertexAttrib4sNV'); - if not Assigned(glVertexAttrib4sNV) then Exit; - @glVertexAttrib4fNV := SDL_GL_GetProcAddress('glVertexAttrib4fNV'); - if not Assigned(glVertexAttrib4fNV) then Exit; - @glVertexAttrib4dNV := SDL_GL_GetProcAddress('glVertexAttrib4dNV'); - if not Assigned(glVertexAttrib4dNV) then Exit; - @glVertexAttrib4ubNV := SDL_GL_GetProcAddress('glVertexAttrib4ubNV'); - if not Assigned(glVertexAttrib4ubNV) then Exit; - @glVertexAttrib1svNV := SDL_GL_GetProcAddress('glVertexAttrib1svNV'); - if not Assigned(glVertexAttrib1svNV) then Exit; - @glVertexAttrib1fvNV := SDL_GL_GetProcAddress('glVertexAttrib1fvNV'); - if not Assigned(glVertexAttrib1fvNV) then Exit; - @glVertexAttrib1dvNV := SDL_GL_GetProcAddress('glVertexAttrib1dvNV'); - if not Assigned(glVertexAttrib1dvNV) then Exit; - @glVertexAttrib2svNV := SDL_GL_GetProcAddress('glVertexAttrib2svNV'); - if not Assigned(glVertexAttrib2svNV) then Exit; - @glVertexAttrib2fvNV := SDL_GL_GetProcAddress('glVertexAttrib2fvNV'); - if not Assigned(glVertexAttrib2fvNV) then Exit; - @glVertexAttrib2dvNV := SDL_GL_GetProcAddress('glVertexAttrib2dvNV'); - if not Assigned(glVertexAttrib2dvNV) then Exit; - @glVertexAttrib3svNV := SDL_GL_GetProcAddress('glVertexAttrib3svNV'); - if not Assigned(glVertexAttrib3svNV) then Exit; - @glVertexAttrib3fvNV := SDL_GL_GetProcAddress('glVertexAttrib3fvNV'); - if not Assigned(glVertexAttrib3fvNV) then Exit; - @glVertexAttrib3dvNV := SDL_GL_GetProcAddress('glVertexAttrib3dvNV'); - if not Assigned(glVertexAttrib3dvNV) then Exit; - @glVertexAttrib4svNV := SDL_GL_GetProcAddress('glVertexAttrib4svNV'); - if not Assigned(glVertexAttrib4svNV) then Exit; - @glVertexAttrib4fvNV := SDL_GL_GetProcAddress('glVertexAttrib4fvNV'); - if not Assigned(glVertexAttrib4fvNV) then Exit; - @glVertexAttrib4dvNV := SDL_GL_GetProcAddress('glVertexAttrib4dvNV'); - if not Assigned(glVertexAttrib4dvNV) then Exit; - @glVertexAttrib4ubvNV := SDL_GL_GetProcAddress('glVertexAttrib4ubvNV'); - if not Assigned(glVertexAttrib4ubvNV) then Exit; - @glVertexAttribs1svNV := SDL_GL_GetProcAddress('glVertexAttribs1svNV'); - if not Assigned(glVertexAttribs1svNV) then Exit; - @glVertexAttribs1fvNV := SDL_GL_GetProcAddress('glVertexAttribs1fvNV'); - if not Assigned(glVertexAttribs1fvNV) then Exit; - @glVertexAttribs1dvNV := SDL_GL_GetProcAddress('glVertexAttribs1dvNV'); - if not Assigned(glVertexAttribs1dvNV) then Exit; - @glVertexAttribs2svNV := SDL_GL_GetProcAddress('glVertexAttribs2svNV'); - if not Assigned(glVertexAttribs2svNV) then Exit; - @glVertexAttribs2fvNV := SDL_GL_GetProcAddress('glVertexAttribs2fvNV'); - if not Assigned(glVertexAttribs2fvNV) then Exit; - @glVertexAttribs2dvNV := SDL_GL_GetProcAddress('glVertexAttribs2dvNV'); - if not Assigned(glVertexAttribs2dvNV) then Exit; - @glVertexAttribs3svNV := SDL_GL_GetProcAddress('glVertexAttribs3svNV'); - if not Assigned(glVertexAttribs3svNV) then Exit; - @glVertexAttribs3fvNV := SDL_GL_GetProcAddress('glVertexAttribs3fvNV'); - if not Assigned(glVertexAttribs3fvNV) then Exit; - @glVertexAttribs3dvNV := SDL_GL_GetProcAddress('glVertexAttribs3dvNV'); - if not Assigned(glVertexAttribs3dvNV) then Exit; - @glVertexAttribs4svNV := SDL_GL_GetProcAddress('glVertexAttribs4svNV'); - if not Assigned(glVertexAttribs4svNV) then Exit; - @glVertexAttribs4fvNV := SDL_GL_GetProcAddress('glVertexAttribs4fvNV'); - if not Assigned(glVertexAttribs4fvNV) then Exit; - @glVertexAttribs4dvNV := SDL_GL_GetProcAddress('glVertexAttribs4dvNV'); - if not Assigned(glVertexAttribs4dvNV) then Exit; - @glVertexAttribs4ubvNV := SDL_GL_GetProcAddress('glVertexAttribs4ubvNV'); - if not Assigned(glVertexAttribs4ubvNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_program1_1: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_program1_1', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ATI_element_array: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_element_array', extstring) then - begin - @glElementPointerATI := SDL_GL_GetProcAddress('glElementPointerATI'); - if not Assigned(glElementPointerATI) then Exit; - @glDrawElementArrayATI := SDL_GL_GetProcAddress('glDrawElementArrayATI'); - if not Assigned(glDrawElementArrayATI) then Exit; - @glDrawRangeElementArrayATI := SDL_GL_GetProcAddress('glDrawRangeElementArrayATI'); - if not Assigned(glDrawRangeElementArrayATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_envmap_bumpmap: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_envmap_bumpmap', extstring) then - begin - @glTexBumpParameterivATI := SDL_GL_GetProcAddress('glTexBumpParameterivATI'); - if not Assigned(glTexBumpParameterivATI) then Exit; - @glTexBumpParameterfvATI := SDL_GL_GetProcAddress('glTexBumpParameterfvATI'); - if not Assigned(glTexBumpParameterfvATI) then Exit; - @glGetTexBumpParameterivATI := SDL_GL_GetProcAddress('glGetTexBumpParameterivATI'); - if not Assigned(glGetTexBumpParameterivATI) then Exit; - @glGetTexBumpParameterfvATI := SDL_GL_GetProcAddress('glGetTexBumpParameterfvATI'); - if not Assigned(glGetTexBumpParameterfvATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_fragment_shader: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_fragment_shader', extstring) then - begin - @glGenFragmentShadersATI := SDL_GL_GetProcAddress('glGenFragmentShadersATI'); - if not Assigned(glGenFragmentShadersATI) then Exit; - @glBindFragmentShaderATI := SDL_GL_GetProcAddress('glBindFragmentShaderATI'); - if not Assigned(glBindFragmentShaderATI) then Exit; - @glDeleteFragmentShaderATI := SDL_GL_GetProcAddress('glDeleteFragmentShaderATI'); - if not Assigned(glDeleteFragmentShaderATI) then Exit; - @glBeginFragmentShaderATI := SDL_GL_GetProcAddress('glBeginFragmentShaderATI'); - if not Assigned(glBeginFragmentShaderATI) then Exit; - @glEndFragmentShaderATI := SDL_GL_GetProcAddress('glEndFragmentShaderATI'); - if not Assigned(glEndFragmentShaderATI) then Exit; - @glPassTexCoordATI := SDL_GL_GetProcAddress('glPassTexCoordATI'); - if not Assigned(glPassTexCoordATI) then Exit; - @glSampleMapATI := SDL_GL_GetProcAddress('glSampleMapATI'); - if not Assigned(glSampleMapATI) then Exit; - @glColorFragmentOp1ATI := SDL_GL_GetProcAddress('glColorFragmentOp1ATI'); - if not Assigned(glColorFragmentOp1ATI) then Exit; - @glColorFragmentOp2ATI := SDL_GL_GetProcAddress('glColorFragmentOp2ATI'); - if not Assigned(glColorFragmentOp2ATI) then Exit; - @glColorFragmentOp3ATI := SDL_GL_GetProcAddress('glColorFragmentOp3ATI'); - if not Assigned(glColorFragmentOp3ATI) then Exit; - @glAlphaFragmentOp1ATI := SDL_GL_GetProcAddress('glAlphaFragmentOp1ATI'); - if not Assigned(glAlphaFragmentOp1ATI) then Exit; - @glAlphaFragmentOp2ATI := SDL_GL_GetProcAddress('glAlphaFragmentOp2ATI'); - if not Assigned(glAlphaFragmentOp2ATI) then Exit; - @glAlphaFragmentOp3ATI := SDL_GL_GetProcAddress('glAlphaFragmentOp3ATI'); - if not Assigned(glAlphaFragmentOp3ATI) then Exit; - @glSetFragmentShaderConstantATI := SDL_GL_GetProcAddress('glSetFragmentShaderConstantATI'); - if not Assigned(glSetFragmentShaderConstantATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_pn_triangles: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_pn_triangles', extstring) then - begin - @glPNTrianglesiATI := SDL_GL_GetProcAddress('glPNTrianglesiATI'); - if not Assigned(glPNTrianglesiATI) then Exit; - @glPNTrianglesfATI := SDL_GL_GetProcAddress('glPNTrianglesfATI'); - if not Assigned(glPNTrianglesfATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_texture_mirror_once: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_texture_mirror_once', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ATI_vertex_array_object: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_vertex_array_object', extstring) then - begin - @glNewObjectBufferATI := SDL_GL_GetProcAddress('glNewObjectBufferATI'); - if not Assigned(glNewObjectBufferATI) then Exit; - @glIsObjectBufferATI := SDL_GL_GetProcAddress('glIsObjectBufferATI'); - if not Assigned(glIsObjectBufferATI) then Exit; - @glUpdateObjectBufferATI := SDL_GL_GetProcAddress('glUpdateObjectBufferATI'); - if not Assigned(glUpdateObjectBufferATI) then Exit; - @glGetObjectBufferfvATI := SDL_GL_GetProcAddress('glGetObjectBufferfvATI'); - if not Assigned(glGetObjectBufferfvATI) then Exit; - @glGetObjectBufferivATI := SDL_GL_GetProcAddress('glGetObjectBufferivATI'); - if not Assigned(glGetObjectBufferivATI) then Exit; - @glDeleteObjectBufferATI := SDL_GL_GetProcAddress('glDeleteObjectBufferATI'); - if not Assigned(glDeleteObjectBufferATI) then Exit; - @glArrayObjectATI := SDL_GL_GetProcAddress('glArrayObjectATI'); - if not Assigned(glArrayObjectATI) then Exit; - @glGetArrayObjectfvATI := SDL_GL_GetProcAddress('glGetArrayObjectfvATI'); - if not Assigned(glGetArrayObjectfvATI) then Exit; - @glGetArrayObjectivATI := SDL_GL_GetProcAddress('glGetArrayObjectivATI'); - if not Assigned(glGetArrayObjectivATI) then Exit; - @glVariantArrayObjectATI := SDL_GL_GetProcAddress('glVariantArrayObjectATI'); - if not Assigned(glVariantArrayObjectATI) then Exit; - @glGetVariantArrayObjectfvATI := SDL_GL_GetProcAddress('glGetVariantArrayObjectfvATI'); - if not Assigned(glGetVariantArrayObjectfvATI) then Exit; - @glGetVariantArrayObjectivATI := SDL_GL_GetProcAddress('glGetVariantArrayObjectivATI'); - if not Assigned(glGetVariantArrayObjectivATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_vertex_streams: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_vertex_streams', extstring) then - begin - @glVertexStream1s := SDL_GL_GetProcAddress('glVertexStream1s'); - if not Assigned(glVertexStream1s) then Exit; - @glVertexStream1i := SDL_GL_GetProcAddress('glVertexStream1i'); - if not Assigned(glVertexStream1i) then Exit; - @glVertexStream1f := SDL_GL_GetProcAddress('glVertexStream1f'); - if not Assigned(glVertexStream1f) then Exit; - @glVertexStream1d := SDL_GL_GetProcAddress('glVertexStream1d'); - if not Assigned(glVertexStream1d) then Exit; - @glVertexStream1sv := SDL_GL_GetProcAddress('glVertexStream1sv'); - if not Assigned(glVertexStream1sv) then Exit; - @glVertexStream1iv := SDL_GL_GetProcAddress('glVertexStream1iv'); - if not Assigned(glVertexStream1iv) then Exit; - @glVertexStream1fv := SDL_GL_GetProcAddress('glVertexStream1fv'); - if not Assigned(glVertexStream1fv) then Exit; - @glVertexStream1dv := SDL_GL_GetProcAddress('glVertexStream1dv'); - if not Assigned(glVertexStream1dv) then Exit; - @glVertexStream2s := SDL_GL_GetProcAddress('glVertexStream2s'); - if not Assigned(glVertexStream2s) then Exit; - @glVertexStream2i := SDL_GL_GetProcAddress('glVertexStream2i'); - if not Assigned(glVertexStream2i) then Exit; - @glVertexStream2f := SDL_GL_GetProcAddress('glVertexStream2f'); - if not Assigned(glVertexStream2f) then Exit; - @glVertexStream2d := SDL_GL_GetProcAddress('glVertexStream2d'); - if not Assigned(glVertexStream2d) then Exit; - @glVertexStream2sv := SDL_GL_GetProcAddress('glVertexStream2sv'); - if not Assigned(glVertexStream2sv) then Exit; - @glVertexStream2iv := SDL_GL_GetProcAddress('glVertexStream2iv'); - if not Assigned(glVertexStream2iv) then Exit; - @glVertexStream2fv := SDL_GL_GetProcAddress('glVertexStream2fv'); - if not Assigned(glVertexStream2fv) then Exit; - @glVertexStream2dv := SDL_GL_GetProcAddress('glVertexStream2dv'); - if not Assigned(glVertexStream2dv) then Exit; - @glVertexStream3s := SDL_GL_GetProcAddress('glVertexStream3s'); - if not Assigned(glVertexStream3s) then Exit; - @glVertexStream3i := SDL_GL_GetProcAddress('glVertexStream3i'); - if not Assigned(glVertexStream3i) then Exit; - @glVertexStream3f := SDL_GL_GetProcAddress('glVertexStream3f'); - if not Assigned(glVertexStream3f) then Exit; - @glVertexStream3d := SDL_GL_GetProcAddress('glVertexStream3d'); - if not Assigned(glVertexStream3d) then Exit; - @glVertexStream3sv := SDL_GL_GetProcAddress('glVertexStream3sv'); - if not Assigned(glVertexStream3sv) then Exit; - @glVertexStream3iv := SDL_GL_GetProcAddress('glVertexStream3iv'); - if not Assigned(glVertexStream3iv) then Exit; - @glVertexStream3fv := SDL_GL_GetProcAddress('glVertexStream3fv'); - if not Assigned(glVertexStream3fv) then Exit; - @glVertexStream3dv := SDL_GL_GetProcAddress('glVertexStream3dv'); - if not Assigned(glVertexStream3dv) then Exit; - @glVertexStream4s := SDL_GL_GetProcAddress('glVertexStream4s'); - if not Assigned(glVertexStream4s) then Exit; - @glVertexStream4i := SDL_GL_GetProcAddress('glVertexStream4i'); - if not Assigned(glVertexStream4i) then Exit; - @glVertexStream4f := SDL_GL_GetProcAddress('glVertexStream4f'); - if not Assigned(glVertexStream4f) then Exit; - @glVertexStream4d := SDL_GL_GetProcAddress('glVertexStream4d'); - if not Assigned(glVertexStream4d) then Exit; - @glVertexStream4sv := SDL_GL_GetProcAddress('glVertexStream4sv'); - if not Assigned(glVertexStream4sv) then Exit; - @glVertexStream4iv := SDL_GL_GetProcAddress('glVertexStream4iv'); - if not Assigned(glVertexStream4iv) then Exit; - @glVertexStream4fv := SDL_GL_GetProcAddress('glVertexStream4fv'); - if not Assigned(glVertexStream4fv) then Exit; - @glVertexStream4dv := SDL_GL_GetProcAddress('glVertexStream4dv'); - if not Assigned(glVertexStream4dv) then Exit; - @glNormalStream3b := SDL_GL_GetProcAddress('glNormalStream3b'); - if not Assigned(glNormalStream3b) then Exit; - @glNormalStream3s := SDL_GL_GetProcAddress('glNormalStream3s'); - if not Assigned(glNormalStream3s) then Exit; - @glNormalStream3i := SDL_GL_GetProcAddress('glNormalStream3i'); - if not Assigned(glNormalStream3i) then Exit; - @glNormalStream3f := SDL_GL_GetProcAddress('glNormalStream3f'); - if not Assigned(glNormalStream3f) then Exit; - @glNormalStream3d := SDL_GL_GetProcAddress('glNormalStream3d'); - if not Assigned(glNormalStream3d) then Exit; - @glNormalStream3bv := SDL_GL_GetProcAddress('glNormalStream3bv'); - if not Assigned(glNormalStream3bv) then Exit; - @glNormalStream3sv := SDL_GL_GetProcAddress('glNormalStream3sv'); - if not Assigned(glNormalStream3sv) then Exit; - @glNormalStream3iv := SDL_GL_GetProcAddress('glNormalStream3iv'); - if not Assigned(glNormalStream3iv) then Exit; - @glNormalStream3fv := SDL_GL_GetProcAddress('glNormalStream3fv'); - if not Assigned(glNormalStream3fv) then Exit; - @glNormalStream3dv := SDL_GL_GetProcAddress('glNormalStream3dv'); - if not Assigned(glNormalStream3dv) then Exit; - @glClientActiveVertexStream := SDL_GL_GetProcAddress('glClientActiveVertexStream'); - if not Assigned(glClientActiveVertexStream) then Exit; - @glVertexBlendEnvi := SDL_GL_GetProcAddress('glVertexBlendEnvi'); - if not Assigned(glVertexBlendEnvi) then Exit; - @glVertexBlendEnvf := SDL_GL_GetProcAddress('glVertexBlendEnvf'); - if not Assigned(glVertexBlendEnvf) then Exit; - Result := TRUE; - end; - -end; - -{$IFDEF WINDOWS} -function Load_WGL_I3D_image_buffer: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_I3D_image_buffer', extstring) then - begin - @wglCreateImageBufferI3D := SDL_GL_GetProcAddress('wglCreateImageBufferI3D'); - if not Assigned(wglCreateImageBufferI3D) then Exit; - @wglDestroyImageBufferI3D := SDL_GL_GetProcAddress('wglDestroyImageBufferI3D'); - if not Assigned(wglDestroyImageBufferI3D) then Exit; - @wglAssociateImageBufferEventsI3D := SDL_GL_GetProcAddress('wglAssociateImageBufferEventsI3D'); - if not Assigned(wglAssociateImageBufferEventsI3D) then Exit; - @wglReleaseImageBufferEventsI3D := SDL_GL_GetProcAddress('wglReleaseImageBufferEventsI3D'); - if not Assigned(wglReleaseImageBufferEventsI3D) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_I3D_swap_frame_lock: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_I3D_swap_frame_lock', extstring) then - begin - @wglEnableFrameLockI3D := SDL_GL_GetProcAddress('wglEnableFrameLockI3D'); - if not Assigned(wglEnableFrameLockI3D) then Exit; - @wglDisableFrameLockI3D := SDL_GL_GetProcAddress('wglDisableFrameLockI3D'); - if not Assigned(wglDisableFrameLockI3D) then Exit; - @wglIsEnabledFrameLockI3D := SDL_GL_GetProcAddress('wglIsEnabledFrameLockI3D'); - if not Assigned(wglIsEnabledFrameLockI3D) then Exit; - @wglQueryFrameLockMasterI3D := SDL_GL_GetProcAddress('wglQueryFrameLockMasterI3D'); - if not Assigned(wglQueryFrameLockMasterI3D) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_I3D_swap_frame_usage: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_I3D_swap_frame_usage', extstring) then - begin - @wglGetFrameUsageI3D := SDL_GL_GetProcAddress('wglGetFrameUsageI3D'); - if not Assigned(wglGetFrameUsageI3D) then Exit; - @wglBeginFrameTrackingI3D := SDL_GL_GetProcAddress('wglBeginFrameTrackingI3D'); - if not Assigned(wglBeginFrameTrackingI3D) then Exit; - @wglEndFrameTrackingI3D := SDL_GL_GetProcAddress('wglEndFrameTrackingI3D'); - if not Assigned(wglEndFrameTrackingI3D) then Exit; - @wglQueryFrameTrackingI3D := SDL_GL_GetProcAddress('wglQueryFrameTrackingI3D'); - if not Assigned(wglQueryFrameTrackingI3D) then Exit; - Result := TRUE; - end; - -end; -{$ENDIF} - -function Load_GL_3DFX_texture_compression_FXT1: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_3DFX_texture_compression_FXT1', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_IBM_cull_vertex: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_IBM_cull_vertex', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_IBM_multimode_draw_arrays: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_IBM_multimode_draw_arrays', extstring) then - begin - @glMultiModeDrawArraysIBM := SDL_GL_GetProcAddress('glMultiModeDrawArraysIBM'); - if not Assigned(glMultiModeDrawArraysIBM) then Exit; - @glMultiModeDrawElementsIBM := SDL_GL_GetProcAddress('glMultiModeDrawElementsIBM'); - if not Assigned(glMultiModeDrawElementsIBM) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_IBM_raster_pos_clip: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_IBM_raster_pos_clip', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_IBM_texture_mirrored_repeat: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_IBM_texture_mirrored_repeat', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_IBM_vertex_array_lists: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_IBM_vertex_array_lists', extstring) then - begin - @glColorPointerListIBM := SDL_GL_GetProcAddress('glColorPointerListIBM'); - if not Assigned(glColorPointerListIBM) then Exit; - @glSecondaryColorPointerListIBM := SDL_GL_GetProcAddress('glSecondaryColorPointerListIBM'); - if not Assigned(glSecondaryColorPointerListIBM) then Exit; - @glEdgeFlagPointerListIBM := SDL_GL_GetProcAddress('glEdgeFlagPointerListIBM'); - if not Assigned(glEdgeFlagPointerListIBM) then Exit; - @glFogCoordPointerListIBM := SDL_GL_GetProcAddress('glFogCoordPointerListIBM'); - if not Assigned(glFogCoordPointerListIBM) then Exit; - @glNormalPointerListIBM := SDL_GL_GetProcAddress('glNormalPointerListIBM'); - if not Assigned(glNormalPointerListIBM) then Exit; - @glTexCoordPointerListIBM := SDL_GL_GetProcAddress('glTexCoordPointerListIBM'); - if not Assigned(glTexCoordPointerListIBM) then Exit; - @glVertexPointerListIBM := SDL_GL_GetProcAddress('glVertexPointerListIBM'); - if not Assigned(glVertexPointerListIBM) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_MESA_resize_buffers: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_MESA_resize_buffers', extstring) then - begin - @glResizeBuffersMESA := SDL_GL_GetProcAddress('glResizeBuffersMESA'); - if not Assigned(glResizeBuffersMESA) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_MESA_window_pos: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_MESA_window_pos', extstring) then - begin - @glWindowPos2dMESA := SDL_GL_GetProcAddress('glWindowPos2dMESA'); - if not Assigned(glWindowPos2dMESA) then Exit; - @glWindowPos2fMESA := SDL_GL_GetProcAddress('glWindowPos2fMESA'); - if not Assigned(glWindowPos2fMESA) then Exit; - @glWindowPos2iMESA := SDL_GL_GetProcAddress('glWindowPos2iMESA'); - if not Assigned(glWindowPos2iMESA) then Exit; - @glWindowPos2sMESA := SDL_GL_GetProcAddress('glWindowPos2sMESA'); - if not Assigned(glWindowPos2sMESA) then Exit; - @glWindowPos2ivMESA := SDL_GL_GetProcAddress('glWindowPos2ivMESA'); - if not Assigned(glWindowPos2ivMESA) then Exit; - @glWindowPos2svMESA := SDL_GL_GetProcAddress('glWindowPos2svMESA'); - if not Assigned(glWindowPos2svMESA) then Exit; - @glWindowPos2fvMESA := SDL_GL_GetProcAddress('glWindowPos2fvMESA'); - if not Assigned(glWindowPos2fvMESA) then Exit; - @glWindowPos2dvMESA := SDL_GL_GetProcAddress('glWindowPos2dvMESA'); - if not Assigned(glWindowPos2dvMESA) then Exit; - @glWindowPos3iMESA := SDL_GL_GetProcAddress('glWindowPos3iMESA'); - if not Assigned(glWindowPos3iMESA) then Exit; - @glWindowPos3sMESA := SDL_GL_GetProcAddress('glWindowPos3sMESA'); - if not Assigned(glWindowPos3sMESA) then Exit; - @glWindowPos3fMESA := SDL_GL_GetProcAddress('glWindowPos3fMESA'); - if not Assigned(glWindowPos3fMESA) then Exit; - @glWindowPos3dMESA := SDL_GL_GetProcAddress('glWindowPos3dMESA'); - if not Assigned(glWindowPos3dMESA) then Exit; - @glWindowPos3ivMESA := SDL_GL_GetProcAddress('glWindowPos3ivMESA'); - if not Assigned(glWindowPos3ivMESA) then Exit; - @glWindowPos3svMESA := SDL_GL_GetProcAddress('glWindowPos3svMESA'); - if not Assigned(glWindowPos3svMESA) then Exit; - @glWindowPos3fvMESA := SDL_GL_GetProcAddress('glWindowPos3fvMESA'); - if not Assigned(glWindowPos3fvMESA) then Exit; - @glWindowPos3dvMESA := SDL_GL_GetProcAddress('glWindowPos3dvMESA'); - if not Assigned(glWindowPos3dvMESA) then Exit; - @glWindowPos4iMESA := SDL_GL_GetProcAddress('glWindowPos4iMESA'); - if not Assigned(glWindowPos4iMESA) then Exit; - @glWindowPos4sMESA := SDL_GL_GetProcAddress('glWindowPos4sMESA'); - if not Assigned(glWindowPos4sMESA) then Exit; - @glWindowPos4fMESA := SDL_GL_GetProcAddress('glWindowPos4fMESA'); - if not Assigned(glWindowPos4fMESA) then Exit; - @glWindowPos4dMESA := SDL_GL_GetProcAddress('glWindowPos4dMESA'); - if not Assigned(glWindowPos4dMESA) then Exit; - @glWindowPos4ivMESA := SDL_GL_GetProcAddress('glWindowPos4ivMESA'); - if not Assigned(glWindowPos4ivMESA) then Exit; - @glWindowPos4svMESA := SDL_GL_GetProcAddress('glWindowPos4svMESA'); - if not Assigned(glWindowPos4svMESA) then Exit; - @glWindowPos4fvMESA := SDL_GL_GetProcAddress('glWindowPos4fvMESA'); - if not Assigned(glWindowPos4fvMESA) then Exit; - @glWindowPos4dvMESA := SDL_GL_GetProcAddress('glWindowPos4dvMESA'); - if not Assigned(glWindowPos4dvMESA) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_OML_interlace: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_OML_interlace', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_OML_resample: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_OML_resample', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_OML_subsample: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_OML_subsample', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_generate_mipmap: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_generate_mipmap', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_multisample: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_multisample', extstring) then - begin - @glSampleMaskSGIS := SDL_GL_GetProcAddress('glSampleMaskSGIS'); - if not Assigned(glSampleMaskSGIS) then Exit; - @glSamplePatternSGIS := SDL_GL_GetProcAddress('glSamplePatternSGIS'); - if not Assigned(glSamplePatternSGIS) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_pixel_texture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_pixel_texture', extstring) then - begin - @glPixelTexGenParameteriSGIS := SDL_GL_GetProcAddress('glPixelTexGenParameteriSGIS'); - if not Assigned(glPixelTexGenParameteriSGIS) then Exit; - @glPixelTexGenParameterfSGIS := SDL_GL_GetProcAddress('glPixelTexGenParameterfSGIS'); - if not Assigned(glPixelTexGenParameterfSGIS) then Exit; - @glGetPixelTexGenParameterivSGIS := SDL_GL_GetProcAddress('glGetPixelTexGenParameterivSGIS'); - if not Assigned(glGetPixelTexGenParameterivSGIS) then Exit; - @glGetPixelTexGenParameterfvSGIS := SDL_GL_GetProcAddress('glGetPixelTexGenParameterfvSGIS'); - if not Assigned(glGetPixelTexGenParameterfvSGIS) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_texture_border_clamp: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_texture_border_clamp', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_texture_color_mask: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_texture_color_mask', extstring) then - begin - @glTextureColorMaskSGIS := SDL_GL_GetProcAddress('glTextureColorMaskSGIS'); - if not Assigned(glTextureColorMaskSGIS) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_texture_edge_clamp: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_texture_edge_clamp', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_texture_lod: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_texture_lod', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIS_depth_texture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIS_depth_texture', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIX_fog_offset: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIX_fog_offset', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIX_interlace: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIX_interlace', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGIX_shadow_ambient: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGIX_shadow_ambient', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGI_color_matrix: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGI_color_matrix', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SGI_color_table: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGI_color_table', extstring) then - begin - @glColorTableSGI := SDL_GL_GetProcAddress('glColorTableSGI'); - if not Assigned(glColorTableSGI) then Exit; - @glCopyColorTableSGI := SDL_GL_GetProcAddress('glCopyColorTableSGI'); - if not Assigned(glCopyColorTableSGI) then Exit; - @glColorTableParameterivSGI := SDL_GL_GetProcAddress('glColorTableParameterivSGI'); - if not Assigned(glColorTableParameterivSGI) then Exit; - @glColorTableParameterfvSGI := SDL_GL_GetProcAddress('glColorTableParameterfvSGI'); - if not Assigned(glColorTableParameterfvSGI) then Exit; - @glGetColorTableSGI := SDL_GL_GetProcAddress('glGetColorTableSGI'); - if not Assigned(glGetColorTableSGI) then Exit; - @glGetColorTableParameterivSGI := SDL_GL_GetProcAddress('glGetColorTableParameterivSGI'); - if not Assigned(glGetColorTableParameterivSGI) then Exit; - @glGetColorTableParameterfvSGI := SDL_GL_GetProcAddress('glGetColorTableParameterfvSGI'); - if not Assigned(glGetColorTableParameterfvSGI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_SGI_texture_color_table: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SGI_texture_color_table', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_SUN_vertex: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_SUN_vertex', extstring) then - begin - @glColor4ubVertex2fSUN := SDL_GL_GetProcAddress('glColor4ubVertex2fSUN'); - if not Assigned(glColor4ubVertex2fSUN) then Exit; - @glColor4ubVertex2fvSUN := SDL_GL_GetProcAddress('glColor4ubVertex2fvSUN'); - if not Assigned(glColor4ubVertex2fvSUN) then Exit; - @glColor4ubVertex3fSUN := SDL_GL_GetProcAddress('glColor4ubVertex3fSUN'); - if not Assigned(glColor4ubVertex3fSUN) then Exit; - @glColor4ubVertex3fvSUN := SDL_GL_GetProcAddress('glColor4ubVertex3fvSUN'); - if not Assigned(glColor4ubVertex3fvSUN) then Exit; - @glColor3fVertex3fSUN := SDL_GL_GetProcAddress('glColor3fVertex3fSUN'); - if not Assigned(glColor3fVertex3fSUN) then Exit; - @glColor3fVertex3fvSUN := SDL_GL_GetProcAddress('glColor3fVertex3fvSUN'); - if not Assigned(glColor3fVertex3fvSUN) then Exit; - @glNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glNormal3fVertex3fSUN'); - if not Assigned(glNormal3fVertex3fSUN) then Exit; - @glNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glNormal3fVertex3fvSUN'); - if not Assigned(glNormal3fVertex3fvSUN) then Exit; - @glColor4fNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glColor4fNormal3fVertex3fSUN'); - if not Assigned(glColor4fNormal3fVertex3fSUN) then Exit; - @glColor4fNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glColor4fNormal3fVertex3fvSUN'); - if not Assigned(glColor4fNormal3fVertex3fvSUN) then Exit; - @glTexCoord2fVertex3fSUN := SDL_GL_GetProcAddress('glTexCoord2fVertex3fSUN'); - if not Assigned(glTexCoord2fVertex3fSUN) then Exit; - @glTexCoord2fVertex3fvSUN := SDL_GL_GetProcAddress('glTexCoord2fVertex3fvSUN'); - if not Assigned(glTexCoord2fVertex3fvSUN) then Exit; - @glTexCoord4fVertex4fSUN := SDL_GL_GetProcAddress('glTexCoord4fVertex4fSUN'); - if not Assigned(glTexCoord4fVertex4fSUN) then Exit; - @glTexCoord4fVertex4fvSUN := SDL_GL_GetProcAddress('glTexCoord4fVertex4fvSUN'); - if not Assigned(glTexCoord4fVertex4fvSUN) then Exit; - @glTexCoord2fColor4ubVertex3fSUN := SDL_GL_GetProcAddress('glTexCoord2fColor4ubVertex3fSUN'); - if not Assigned(glTexCoord2fColor4ubVertex3fSUN) then Exit; - @glTexCoord2fColor4ubVertex3fvSUN := SDL_GL_GetProcAddress('glTexCoord2fColor4ubVertex3fvSUN'); - if not Assigned(glTexCoord2fColor4ubVertex3fvSUN) then Exit; - @glTexCoord2fColor3fVertex3fSUN := SDL_GL_GetProcAddress('glTexCoord2fColor3fVertex3fSUN'); - if not Assigned(glTexCoord2fColor3fVertex3fSUN) then Exit; - @glTexCoord2fColor3fVertex3fvSUN := SDL_GL_GetProcAddress('glTexCoord2fColor3fVertex3fvSUN'); - if not Assigned(glTexCoord2fColor3fVertex3fvSUN) then Exit; - @glTexCoord2fNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glTexCoord2fNormal3fVertex3fSUN'); - if not Assigned(glTexCoord2fNormal3fVertex3fSUN) then Exit; - @glTexCoord2fNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glTexCoord2fNormal3fVertex3fvSUN'); - if not Assigned(glTexCoord2fNormal3fVertex3fvSUN) then Exit; - @glTexCoord2fColor4fNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glTexCoord2fColor4fNormal3fVertex3fSUN'); - if not Assigned(glTexCoord2fColor4fNormal3fVertex3fSUN) then Exit; - @glTexCoord2fColor4fNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glTexCoord2fColor4fNormal3fVertex3fvSUN'); - if not Assigned(glTexCoord2fColor4fNormal3fVertex3fvSUN) then Exit; - @glTexCoord4fColor4fNormal3fVertex4fSUN := SDL_GL_GetProcAddress('glTexCoord4fColor4fNormal3fVertex4fSUN'); - if not Assigned(glTexCoord4fColor4fNormal3fVertex4fSUN) then Exit; - @glTexCoord4fColor4fNormal3fVertex4fvSUN := SDL_GL_GetProcAddress('glTexCoord4fColor4fNormal3fVertex4fvSUN'); - if not Assigned(glTexCoord4fColor4fNormal3fVertex4fvSUN) then Exit; - @glReplacementCodeuiVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiVertex3fSUN'); - if not Assigned(glReplacementCodeuiVertex3fSUN) then Exit; - @glReplacementCodeuiVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiVertex3fvSUN'); - if not Assigned(glReplacementCodeuiVertex3fvSUN) then Exit; - @glReplacementCodeuiColor4ubVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiColor4ubVertex3fSUN'); - if not Assigned(glReplacementCodeuiColor4ubVertex3fSUN) then Exit; - @glReplacementCodeuiColor4ubVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiColor4ubVertex3fvSUN'); - if not Assigned(glReplacementCodeuiColor4ubVertex3fvSUN) then Exit; - @glReplacementCodeuiColor3fVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiColor3fVertex3fSUN'); - if not Assigned(glReplacementCodeuiColor3fVertex3fSUN) then Exit; - @glReplacementCodeuiColor3fVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiColor3fVertex3fvSUN'); - if not Assigned(glReplacementCodeuiColor3fVertex3fvSUN) then Exit; - @glReplacementCodeuiNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiNormal3fVertex3fSUN'); - if not Assigned(glReplacementCodeuiNormal3fVertex3fSUN) then Exit; - @glReplacementCodeuiNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiNormal3fVertex3fvSUN'); - if not Assigned(glReplacementCodeuiNormal3fVertex3fvSUN) then Exit; - @glReplacementCodeuiColor4fNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiColor4fNormal3fVertex3fSUN'); - if not Assigned(glReplacementCodeuiColor4fNormal3fVertex3fSUN) then Exit; - @glReplacementCodeuiColor4fNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiColor4fNormal3fVertex3fvSUN'); - if not Assigned(glReplacementCodeuiColor4fNormal3fVertex3fvSUN) then Exit; - @glReplacementCodeuiTexCoord2fVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiTexCoord2fVertex3fSUN'); - if not Assigned(glReplacementCodeuiTexCoord2fVertex3fSUN) then Exit; - @glReplacementCodeuiTexCoord2fVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiTexCoord2fVertex3fvSUN'); - if not Assigned(glReplacementCodeuiTexCoord2fVertex3fvSUN) then Exit; - @glReplacementCodeuiTexCoord2fNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiTexCoord2fNormal3fVertex3fSUN'); - if not Assigned(glReplacementCodeuiTexCoord2fNormal3fVertex3fSUN) then Exit; - @glReplacementCodeuiTexCoord2fNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiTexCoord2fNormal3fVertex3fvSUN'); - if not Assigned(glReplacementCodeuiTexCoord2fNormal3fVertex3fvSUN) then Exit; - @glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fSUN := SDL_GL_GetProcAddress('glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fSUN'); - if not Assigned(glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fSUN) then Exit; - @glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fvSUN := SDL_GL_GetProcAddress('glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fvSUN'); - if not Assigned(glReplacementCodeuiTexCoord2fColor4fNormal3fVertex3fvSUN) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_fragment_program: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_fragment_program', extstring) then - begin - @glProgramStringARB := SDL_GL_GetProcAddress('glProgramStringARB'); - if not Assigned(glProgramStringARB) then Exit; - @glBindProgramARB := SDL_GL_GetProcAddress('glBindProgramARB'); - if not Assigned(glBindProgramARB) then Exit; - @glDeleteProgramsARB := SDL_GL_GetProcAddress('glDeleteProgramsARB'); - if not Assigned(glDeleteProgramsARB) then Exit; - @glGenProgramsARB := SDL_GL_GetProcAddress('glGenProgramsARB'); - if not Assigned(glGenProgramsARB) then Exit; - @glProgramEnvParameter4dARB := SDL_GL_GetProcAddress('glProgramEnvParameter4dARB'); - if not Assigned(glProgramEnvParameter4dARB) then Exit; - @glProgramEnvParameter4dvARB := SDL_GL_GetProcAddress('glProgramEnvParameter4dvARB'); - if not Assigned(glProgramEnvParameter4dvARB) then Exit; - @glProgramEnvParameter4fARB := SDL_GL_GetProcAddress('glProgramEnvParameter4fARB'); - if not Assigned(glProgramEnvParameter4fARB) then Exit; - @glProgramEnvParameter4fvARB := SDL_GL_GetProcAddress('glProgramEnvParameter4fvARB'); - if not Assigned(glProgramEnvParameter4fvARB) then Exit; - @glProgramLocalParameter4dARB := SDL_GL_GetProcAddress('glProgramLocalParameter4dARB'); - if not Assigned(glProgramLocalParameter4dARB) then Exit; - @glProgramLocalParameter4dvARB := SDL_GL_GetProcAddress('glProgramLocalParameter4dvARB'); - if not Assigned(glProgramLocalParameter4dvARB) then Exit; - @glProgramLocalParameter4fARB := SDL_GL_GetProcAddress('glProgramLocalParameter4fARB'); - if not Assigned(glProgramLocalParameter4fARB) then Exit; - @glProgramLocalParameter4fvARB := SDL_GL_GetProcAddress('glProgramLocalParameter4fvARB'); - if not Assigned(glProgramLocalParameter4fvARB) then Exit; - @glGetProgramEnvParameterdvARB := SDL_GL_GetProcAddress('glGetProgramEnvParameterdvARB'); - if not Assigned(glGetProgramEnvParameterdvARB) then Exit; - @glGetProgramEnvParameterfvARB := SDL_GL_GetProcAddress('glGetProgramEnvParameterfvARB'); - if not Assigned(glGetProgramEnvParameterfvARB) then Exit; - @glGetProgramLocalParameterdvARB := SDL_GL_GetProcAddress('glGetProgramLocalParameterdvARB'); - if not Assigned(glGetProgramLocalParameterdvARB) then Exit; - @glGetProgramLocalParameterfvARB := SDL_GL_GetProcAddress('glGetProgramLocalParameterfvARB'); - if not Assigned(glGetProgramLocalParameterfvARB) then Exit; - @glGetProgramivARB := SDL_GL_GetProcAddress('glGetProgramivARB'); - if not Assigned(glGetProgramivARB) then Exit; - @glGetProgramStringARB := SDL_GL_GetProcAddress('glGetProgramStringARB'); - if not Assigned(glGetProgramStringARB) then Exit; - @glIsProgramARB := SDL_GL_GetProcAddress('glIsProgramARB'); - if not Assigned(glIsProgramARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_text_fragment_shader: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_text_fragment_shader', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_APPLE_client_storage: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_APPLE_client_storage', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_APPLE_element_array: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_APPLE_element_array', extstring) then - begin - @glElementPointerAPPLE := SDL_GL_GetProcAddress('glElementPointerAPPLE'); - if not Assigned(glElementPointerAPPLE) then Exit; - @glDrawElementArrayAPPLE := SDL_GL_GetProcAddress('glDrawElementArrayAPPLE'); - if not Assigned(glDrawElementArrayAPPLE) then Exit; - @glDrawRangeElementArrayAPPLE := SDL_GL_GetProcAddress('glDrawRangeElementArrayAPPLE'); - if not Assigned(glDrawRangeElementArrayAPPLE) then Exit; - @glMultiDrawElementArrayAPPLE := SDL_GL_GetProcAddress('glMultiDrawElementArrayAPPLE'); - if not Assigned(glMultiDrawElementArrayAPPLE) then Exit; - @glMultiDrawRangeElementArrayAPPLE := SDL_GL_GetProcAddress('glMultiDrawRangeElementArrayAPPLE'); - if not Assigned(glMultiDrawRangeElementArrayAPPLE) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_APPLE_fence: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_APPLE_fence', extstring) then - begin - @glGenFencesAPPLE := SDL_GL_GetProcAddress('glGenFencesAPPLE'); - if not Assigned(glGenFencesAPPLE) then Exit; - @glDeleteFencesAPPLE := SDL_GL_GetProcAddress('glDeleteFencesAPPLE'); - if not Assigned(glDeleteFencesAPPLE) then Exit; - @glSetFenceAPPLE := SDL_GL_GetProcAddress('glSetFenceAPPLE'); - if not Assigned(glSetFenceAPPLE) then Exit; - @glIsFenceAPPLE := SDL_GL_GetProcAddress('glIsFenceAPPLE'); - if not Assigned(glIsFenceAPPLE) then Exit; - @glTestFenceAPPLE := SDL_GL_GetProcAddress('glTestFenceAPPLE'); - if not Assigned(glTestFenceAPPLE) then Exit; - @glFinishFenceAPPLE := SDL_GL_GetProcAddress('glFinishFenceAPPLE'); - if not Assigned(glFinishFenceAPPLE) then Exit; - @glTestObjectAPPLE := SDL_GL_GetProcAddress('glTestObjectAPPLE'); - if not Assigned(glTestObjectAPPLE) then Exit; - @glFinishObjectAPPLE := SDL_GL_GetProcAddress('glFinishObjectAPPLE'); - if not Assigned(glFinishObjectAPPLE) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_APPLE_vertex_array_object: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_APPLE_vertex_array_object', extstring) then - begin - @glBindVertexArrayAPPLE := SDL_GL_GetProcAddress('glBindVertexArrayAPPLE'); - if not Assigned(glBindVertexArrayAPPLE) then Exit; - @glDeleteVertexArraysAPPLE := SDL_GL_GetProcAddress('glDeleteVertexArraysAPPLE'); - if not Assigned(glDeleteVertexArraysAPPLE) then Exit; - @glGenVertexArraysAPPLE := SDL_GL_GetProcAddress('glGenVertexArraysAPPLE'); - if not Assigned(glGenVertexArraysAPPLE) then Exit; - @glIsVertexArrayAPPLE := SDL_GL_GetProcAddress('glIsVertexArrayAPPLE'); - if not Assigned(glIsVertexArrayAPPLE) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_APPLE_vertex_array_range: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_APPLE_vertex_array_range', extstring) then - begin - @glVertexArrayRangeAPPLE := SDL_GL_GetProcAddress('glVertexArrayRangeAPPLE'); - if not Assigned(glVertexArrayRangeAPPLE) then Exit; - @glFlushVertexArrayRangeAPPLE := SDL_GL_GetProcAddress('glFlushVertexArrayRangeAPPLE'); - if not Assigned(glFlushVertexArrayRangeAPPLE) then Exit; - @glVertexArrayParameteriAPPLE := SDL_GL_GetProcAddress('glVertexArrayParameteriAPPLE'); - if not Assigned(glVertexArrayParameteriAPPLE) then Exit; - Result := TRUE; - end; - -end; - -{$IFDEF WINDOWS} -function Load_WGL_ARB_pixel_format: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ARB_pixel_format', extstring) then - begin - @wglGetPixelFormatAttribivARB := SDL_GL_GetProcAddress('wglGetPixelFormatAttribivARB'); - if not Assigned(wglGetPixelFormatAttribivARB) then Exit; - @wglGetPixelFormatAttribfvARB := SDL_GL_GetProcAddress('wglGetPixelFormatAttribfvARB'); - if not Assigned(wglGetPixelFormatAttribfvARB) then Exit; - @wglChoosePixelFormatARB := SDL_GL_GetProcAddress('wglChoosePixelFormatARB'); - if not Assigned(wglChoosePixelFormatARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_ARB_make_current_read: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ARB_make_current_read', extstring) then - begin - @wglMakeContextCurrentARB := SDL_GL_GetProcAddress('wglMakeContextCurrentARB'); - if not Assigned(wglMakeContextCurrentARB) then Exit; - @wglGetCurrentReadDCARB := SDL_GL_GetProcAddress('wglGetCurrentReadDCARB'); - if not Assigned(wglGetCurrentReadDCARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_ARB_pbuffer: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ARB_pbuffer', extstring) then - begin - @wglCreatePbufferARB := SDL_GL_GetProcAddress('wglCreatePbufferARB'); - if not Assigned(wglCreatePbufferARB) then Exit; - @wglGetPbufferDCARB := SDL_GL_GetProcAddress('wglGetPbufferDCARB'); - if not Assigned(wglGetPbufferDCARB) then Exit; - @wglReleasePbufferDCARB := SDL_GL_GetProcAddress('wglReleasePbufferDCARB'); - if not Assigned(wglReleasePbufferDCARB) then Exit; - @wglDestroyPbufferARB := SDL_GL_GetProcAddress('wglDestroyPbufferARB'); - if not Assigned(wglDestroyPbufferARB) then Exit; - @wglQueryPbufferARB := SDL_GL_GetProcAddress('wglQueryPbufferARB'); - if not Assigned(wglQueryPbufferARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_EXT_swap_control: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_EXT_swap_control', extstring) then - begin - @wglSwapIntervalEXT := SDL_GL_GetProcAddress('wglSwapIntervalEXT'); - if not Assigned(wglSwapIntervalEXT) then Exit; - @wglGetSwapIntervalEXT := SDL_GL_GetProcAddress('wglGetSwapIntervalEXT'); - if not Assigned(wglGetSwapIntervalEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_ARB_render_texture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ARB_render_texture', extstring) then - begin - @wglBindTexImageARB := SDL_GL_GetProcAddress('wglBindTexImageARB'); - if not Assigned(wglBindTexImageARB) then Exit; - @wglReleaseTexImageARB := SDL_GL_GetProcAddress('wglReleaseTexImageARB'); - if not Assigned(wglReleaseTexImageARB) then Exit; - @wglSetPbufferAttribARB := SDL_GL_GetProcAddress('wglSetPbufferAttribARB'); - if not Assigned(wglSetPbufferAttribARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_EXT_extensions_string: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_EXT_extensions_string', extstring) then - begin - @wglGetExtensionsStringEXT := SDL_GL_GetProcAddress('wglGetExtensionsStringEXT'); - if not Assigned(wglGetExtensionsStringEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_EXT_make_current_read: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_EXT_make_current_read', extstring) then - begin - @wglMakeContextCurrentEXT := SDL_GL_GetProcAddress('wglMakeContextCurrentEXT'); - if not Assigned(wglMakeContextCurrentEXT) then Exit; - @wglGetCurrentReadDCEXT := SDL_GL_GetProcAddress('wglGetCurrentReadDCEXT'); - if not Assigned(wglGetCurrentReadDCEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_EXT_pbuffer: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_EXT_pbuffer', extstring) then - begin - @wglCreatePbufferEXT := SDL_GL_GetProcAddress('wglCreatePbufferEXT'); - if not Assigned(wglCreatePbufferEXT) then Exit; - @wglGetPbufferDCEXT := SDL_GL_GetProcAddress('wglGetPbufferDCEXT'); - if not Assigned(wglGetPbufferDCEXT) then Exit; - @wglReleasePbufferDCEXT := SDL_GL_GetProcAddress('wglReleasePbufferDCEXT'); - if not Assigned(wglReleasePbufferDCEXT) then Exit; - @wglDestroyPbufferEXT := SDL_GL_GetProcAddress('wglDestroyPbufferEXT'); - if not Assigned(wglDestroyPbufferEXT) then Exit; - @wglQueryPbufferEXT := SDL_GL_GetProcAddress('wglQueryPbufferEXT'); - if not Assigned(wglQueryPbufferEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_EXT_pixel_format: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_EXT_pixel_format', extstring) then - begin - @wglGetPixelFormatAttribivEXT := SDL_GL_GetProcAddress('wglGetPixelFormatAttribivEXT'); - if not Assigned(wglGetPixelFormatAttribivEXT) then Exit; - @wglGetPixelFormatAttribfvEXT := SDL_GL_GetProcAddress('wglGetPixelFormatAttribfvEXT'); - if not Assigned(wglGetPixelFormatAttribfvEXT) then Exit; - @wglChoosePixelFormatEXT := SDL_GL_GetProcAddress('wglChoosePixelFormatEXT'); - if not Assigned(wglChoosePixelFormatEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_I3D_digital_video_control: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_I3D_digital_video_control', extstring) then - begin - @wglGetDigitalVideoParametersI3D := SDL_GL_GetProcAddress('wglGetDigitalVideoParametersI3D'); - if not Assigned(wglGetDigitalVideoParametersI3D) then Exit; - @wglSetDigitalVideoParametersI3D := SDL_GL_GetProcAddress('wglSetDigitalVideoParametersI3D'); - if not Assigned(wglSetDigitalVideoParametersI3D) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_I3D_gamma: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_I3D_gamma', extstring) then - begin - @wglGetGammaTableParametersI3D := SDL_GL_GetProcAddress('wglGetGammaTableParametersI3D'); - if not Assigned(wglGetGammaTableParametersI3D) then Exit; - @wglSetGammaTableParametersI3D := SDL_GL_GetProcAddress('wglSetGammaTableParametersI3D'); - if not Assigned(wglSetGammaTableParametersI3D) then Exit; - @wglGetGammaTableI3D := SDL_GL_GetProcAddress('wglGetGammaTableI3D'); - if not Assigned(wglGetGammaTableI3D) then Exit; - @wglSetGammaTableI3D := SDL_GL_GetProcAddress('wglSetGammaTableI3D'); - if not Assigned(wglSetGammaTableI3D) then Exit; - Result := TRUE; - end; - -end; - -function Load_WGL_I3D_genlock: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_I3D_genlock', extstring) then - begin - @wglEnableGenlockI3D := SDL_GL_GetProcAddress('wglEnableGenlockI3D'); - if not Assigned(wglEnableGenlockI3D) then Exit; - @wglDisableGenlockI3D := SDL_GL_GetProcAddress('wglDisableGenlockI3D'); - if not Assigned(wglDisableGenlockI3D) then Exit; - @wglIsEnabledGenlockI3D := SDL_GL_GetProcAddress('wglIsEnabledGenlockI3D'); - if not Assigned(wglIsEnabledGenlockI3D) then Exit; - @wglGenlockSourceI3D := SDL_GL_GetProcAddress('wglGenlockSourceI3D'); - if not Assigned(wglGenlockSourceI3D) then Exit; - @wglGetGenlockSourceI3D := SDL_GL_GetProcAddress('wglGetGenlockSourceI3D'); - if not Assigned(wglGetGenlockSourceI3D) then Exit; - @wglGenlockSourceEdgeI3D := SDL_GL_GetProcAddress('wglGenlockSourceEdgeI3D'); - if not Assigned(wglGenlockSourceEdgeI3D) then Exit; - @wglGetGenlockSourceEdgeI3D := SDL_GL_GetProcAddress('wglGetGenlockSourceEdgeI3D'); - if not Assigned(wglGetGenlockSourceEdgeI3D) then Exit; - @wglGenlockSampleRateI3D := SDL_GL_GetProcAddress('wglGenlockSampleRateI3D'); - if not Assigned(wglGenlockSampleRateI3D) then Exit; - @wglGetGenlockSampleRateI3D := SDL_GL_GetProcAddress('wglGetGenlockSampleRateI3D'); - if not Assigned(wglGetGenlockSampleRateI3D) then Exit; - @wglGenlockSourceDelayI3D := SDL_GL_GetProcAddress('wglGenlockSourceDelayI3D'); - if not Assigned(wglGenlockSourceDelayI3D) then Exit; - @wglGetGenlockSourceDelayI3D := SDL_GL_GetProcAddress('wglGetGenlockSourceDelayI3D'); - if not Assigned(wglGetGenlockSourceDelayI3D) then Exit; - @wglQueryGenlockMaxSourceDelayI3D := SDL_GL_GetProcAddress('wglQueryGenlockMaxSourceDelayI3D'); - if not Assigned(wglQueryGenlockMaxSourceDelayI3D) then Exit; - Result := TRUE; - end; - -end; -{$ENDIF} - -function Load_GL_ARB_matrix_palette: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_matrix_palette', extstring) then - begin - @glCurrentPaletteMatrixARB := SDL_GL_GetProcAddress('glCurrentPaletteMatrixARB'); - if not Assigned(glCurrentPaletteMatrixARB) then Exit; - @glMatrixIndexubvARB := SDL_GL_GetProcAddress('glMatrixIndexubvARB'); - if not Assigned(glMatrixIndexubvARB) then Exit; - @glMatrixIndexusvARB := SDL_GL_GetProcAddress('glMatrixIndexusvARB'); - if not Assigned(glMatrixIndexusvARB) then Exit; - @glMatrixIndexuivARB := SDL_GL_GetProcAddress('glMatrixIndexuivARB'); - if not Assigned(glMatrixIndexuivARB) then Exit; - @glMatrixIndexPointerARB := SDL_GL_GetProcAddress('glMatrixIndexPointerARB'); - if not Assigned(glMatrixIndexPointerARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_element_array: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_element_array', extstring) then - begin - @glElementPointerNV := SDL_GL_GetProcAddress('glElementPointerNV'); - if not Assigned(glElementPointerNV) then Exit; - @glDrawElementArrayNV := SDL_GL_GetProcAddress('glDrawElementArrayNV'); - if not Assigned(glDrawElementArrayNV) then Exit; - @glDrawRangeElementArrayNV := SDL_GL_GetProcAddress('glDrawRangeElementArrayNV'); - if not Assigned(glDrawRangeElementArrayNV) then Exit; - @glMultiDrawElementArrayNV := SDL_GL_GetProcAddress('glMultiDrawElementArrayNV'); - if not Assigned(glMultiDrawElementArrayNV) then Exit; - @glMultiDrawRangeElementArrayNV := SDL_GL_GetProcAddress('glMultiDrawRangeElementArrayNV'); - if not Assigned(glMultiDrawRangeElementArrayNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_float_buffer: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_float_buffer', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_fragment_program: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_fragment_program', extstring) then - begin - @glProgramNamedParameter4fNV := SDL_GL_GetProcAddress('glProgramNamedParameter4fNV'); - if not Assigned(glProgramNamedParameter4fNV) then Exit; - @glProgramNamedParameter4dNV := SDL_GL_GetProcAddress('glProgramNamedParameter4dNV'); - if not Assigned(glProgramNamedParameter4dNV) then Exit; - @glGetProgramNamedParameterfvNV := SDL_GL_GetProcAddress('glGetProgramNamedParameterfvNV'); - if not Assigned(glGetProgramNamedParameterfvNV) then Exit; - @glGetProgramNamedParameterdvNV := SDL_GL_GetProcAddress('glGetProgramNamedParameterdvNV'); - if not Assigned(glGetProgramNamedParameterdvNV) then Exit; - @glProgramLocalParameter4dARB := SDL_GL_GetProcAddress('glProgramLocalParameter4dARB'); - if not Assigned(glProgramLocalParameter4dARB) then Exit; - @glProgramLocalParameter4dvARB := SDL_GL_GetProcAddress('glProgramLocalParameter4dvARB'); - if not Assigned(glProgramLocalParameter4dvARB) then Exit; - @glProgramLocalParameter4fARB := SDL_GL_GetProcAddress('glProgramLocalParameter4fARB'); - if not Assigned(glProgramLocalParameter4fARB) then Exit; - @glProgramLocalParameter4fvARB := SDL_GL_GetProcAddress('glProgramLocalParameter4fvARB'); - if not Assigned(glProgramLocalParameter4fvARB) then Exit; - @glGetProgramLocalParameterdvARB := SDL_GL_GetProcAddress('glGetProgramLocalParameterdvARB'); - if not Assigned(glGetProgramLocalParameterdvARB) then Exit; - @glGetProgramLocalParameterfvARB := SDL_GL_GetProcAddress('glGetProgramLocalParameterfvARB'); - if not Assigned(glGetProgramLocalParameterfvARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_primitive_restart: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_primitive_restart', extstring) then - begin - @glPrimitiveRestartNV := SDL_GL_GetProcAddress('glPrimitiveRestartNV'); - if not Assigned(glPrimitiveRestartNV) then Exit; - @glPrimitiveRestartIndexNV := SDL_GL_GetProcAddress('glPrimitiveRestartIndexNV'); - if not Assigned(glPrimitiveRestartIndexNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_program2: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_program2', extstring) then - begin - Result := TRUE; - end; - -end; - -{$IFDEF WINDOWS} -function Load_WGL_NV_render_texture_rectangle: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_NV_render_texture_rectangle', extstring) then - begin - Result := TRUE; - end; - -end; -{$ENDIF} - -function Load_GL_NV_pixel_data_range: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_pixel_data_range', extstring) then - begin - @glPixelDataRangeNV := SDL_GL_GetProcAddress('glPixelDataRangeNV'); - if not Assigned(glPixelDataRangeNV) then Exit; - @glFlushPixelDataRangeNV := SDL_GL_GetProcAddress('glFlushPixelDataRangeNV'); - if not Assigned(glFlushPixelDataRangeNV) then Exit; - {$IFDEF WINDOWS} - @wglAllocateMemoryNV := SDL_GL_GetProcAddress('wglAllocateMemoryNV'); - if not Assigned(wglAllocateMemoryNV) then Exit; - @wglFreeMemoryNV := SDL_GL_GetProcAddress('wglFreeMemoryNV'); - if not Assigned(wglFreeMemoryNV) then Exit; - {$ENDIF} - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_rectangle: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_rectangle', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_S3_s3tc: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_S3_s3tc', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ATI_draw_buffers: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_draw_buffers', extstring) then - begin - @glDrawBuffersATI := SDL_GL_GetProcAddress('glDrawBuffersATI'); - if not Assigned(glDrawBuffersATI) then Exit; - Result := TRUE; - end; - -end; - -{$IFDEF WINDOWS} -function Load_WGL_ATI_pixel_format_float: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - @wglGetExtensionsStringARB := SDL_GL_GetProcAddress('wglGetExtensionsStringARB'); - if not Assigned(wglGetExtensionsStringARB) then Exit; - extstring := wglGetExtensionsStringARB(wglGetCurrentDC); - - if glext_ExtensionSupported('WGL_ATI_pixel_format_float', extstring) then - begin - Result := TRUE; - end; - -end; -{$ENDIF} - -function Load_GL_ATI_texture_env_combine3: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_texture_env_combine3', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ATI_texture_float: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_texture_float', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_texture_expand_normal: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_texture_expand_normal', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_half_float: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_half_float', extstring) then - begin - @glVertex2hNV := SDL_GL_GetProcAddress('glVertex2hNV'); - if not Assigned(glVertex2hNV) then Exit; - @glVertex2hvNV := SDL_GL_GetProcAddress('glVertex2hvNV'); - if not Assigned(glVertex2hvNV) then Exit; - @glVertex3hNV := SDL_GL_GetProcAddress('glVertex3hNV'); - if not Assigned(glVertex3hNV) then Exit; - @glVertex3hvNV := SDL_GL_GetProcAddress('glVertex3hvNV'); - if not Assigned(glVertex3hvNV) then Exit; - @glVertex4hNV := SDL_GL_GetProcAddress('glVertex4hNV'); - if not Assigned(glVertex4hNV) then Exit; - @glVertex4hvNV := SDL_GL_GetProcAddress('glVertex4hvNV'); - if not Assigned(glVertex4hvNV) then Exit; - @glNormal3hNV := SDL_GL_GetProcAddress('glNormal3hNV'); - if not Assigned(glNormal3hNV) then Exit; - @glNormal3hvNV := SDL_GL_GetProcAddress('glNormal3hvNV'); - if not Assigned(glNormal3hvNV) then Exit; - @glColor3hNV := SDL_GL_GetProcAddress('glColor3hNV'); - if not Assigned(glColor3hNV) then Exit; - @glColor3hvNV := SDL_GL_GetProcAddress('glColor3hvNV'); - if not Assigned(glColor3hvNV) then Exit; - @glColor4hNV := SDL_GL_GetProcAddress('glColor4hNV'); - if not Assigned(glColor4hNV) then Exit; - @glColor4hvNV := SDL_GL_GetProcAddress('glColor4hvNV'); - if not Assigned(glColor4hvNV) then Exit; - @glTexCoord1hNV := SDL_GL_GetProcAddress('glTexCoord1hNV'); - if not Assigned(glTexCoord1hNV) then Exit; - @glTexCoord1hvNV := SDL_GL_GetProcAddress('glTexCoord1hvNV'); - if not Assigned(glTexCoord1hvNV) then Exit; - @glTexCoord2hNV := SDL_GL_GetProcAddress('glTexCoord2hNV'); - if not Assigned(glTexCoord2hNV) then Exit; - @glTexCoord2hvNV := SDL_GL_GetProcAddress('glTexCoord2hvNV'); - if not Assigned(glTexCoord2hvNV) then Exit; - @glTexCoord3hNV := SDL_GL_GetProcAddress('glTexCoord3hNV'); - if not Assigned(glTexCoord3hNV) then Exit; - @glTexCoord3hvNV := SDL_GL_GetProcAddress('glTexCoord3hvNV'); - if not Assigned(glTexCoord3hvNV) then Exit; - @glTexCoord4hNV := SDL_GL_GetProcAddress('glTexCoord4hNV'); - if not Assigned(glTexCoord4hNV) then Exit; - @glTexCoord4hvNV := SDL_GL_GetProcAddress('glTexCoord4hvNV'); - if not Assigned(glTexCoord4hvNV) then Exit; - @glMultiTexCoord1hNV := SDL_GL_GetProcAddress('glMultiTexCoord1hNV'); - if not Assigned(glMultiTexCoord1hNV) then Exit; - @glMultiTexCoord1hvNV := SDL_GL_GetProcAddress('glMultiTexCoord1hvNV'); - if not Assigned(glMultiTexCoord1hvNV) then Exit; - @glMultiTexCoord2hNV := SDL_GL_GetProcAddress('glMultiTexCoord2hNV'); - if not Assigned(glMultiTexCoord2hNV) then Exit; - @glMultiTexCoord2hvNV := SDL_GL_GetProcAddress('glMultiTexCoord2hvNV'); - if not Assigned(glMultiTexCoord2hvNV) then Exit; - @glMultiTexCoord3hNV := SDL_GL_GetProcAddress('glMultiTexCoord3hNV'); - if not Assigned(glMultiTexCoord3hNV) then Exit; - @glMultiTexCoord3hvNV := SDL_GL_GetProcAddress('glMultiTexCoord3hvNV'); - if not Assigned(glMultiTexCoord3hvNV) then Exit; - @glMultiTexCoord4hNV := SDL_GL_GetProcAddress('glMultiTexCoord4hNV'); - if not Assigned(glMultiTexCoord4hNV) then Exit; - @glMultiTexCoord4hvNV := SDL_GL_GetProcAddress('glMultiTexCoord4hvNV'); - if not Assigned(glMultiTexCoord4hvNV) then Exit; - @glFogCoordhNV := SDL_GL_GetProcAddress('glFogCoordhNV'); - if not Assigned(glFogCoordhNV) then Exit; - @glFogCoordhvNV := SDL_GL_GetProcAddress('glFogCoordhvNV'); - if not Assigned(glFogCoordhvNV) then Exit; - @glSecondaryColor3hNV := SDL_GL_GetProcAddress('glSecondaryColor3hNV'); - if not Assigned(glSecondaryColor3hNV) then Exit; - @glSecondaryColor3hvNV := SDL_GL_GetProcAddress('glSecondaryColor3hvNV'); - if not Assigned(glSecondaryColor3hvNV) then Exit; - @glVertexWeighthNV := SDL_GL_GetProcAddress('glVertexWeighthNV'); - if not Assigned(glVertexWeighthNV) then Exit; - @glVertexWeighthvNV := SDL_GL_GetProcAddress('glVertexWeighthvNV'); - if not Assigned(glVertexWeighthvNV) then Exit; - @glVertexAttrib1hNV := SDL_GL_GetProcAddress('glVertexAttrib1hNV'); - if not Assigned(glVertexAttrib1hNV) then Exit; - @glVertexAttrib1hvNV := SDL_GL_GetProcAddress('glVertexAttrib1hvNV'); - if not Assigned(glVertexAttrib1hvNV) then Exit; - @glVertexAttrib2hNV := SDL_GL_GetProcAddress('glVertexAttrib2hNV'); - if not Assigned(glVertexAttrib2hNV) then Exit; - @glVertexAttrib2hvNV := SDL_GL_GetProcAddress('glVertexAttrib2hvNV'); - if not Assigned(glVertexAttrib2hvNV) then Exit; - @glVertexAttrib3hNV := SDL_GL_GetProcAddress('glVertexAttrib3hNV'); - if not Assigned(glVertexAttrib3hNV) then Exit; - @glVertexAttrib3hvNV := SDL_GL_GetProcAddress('glVertexAttrib3hvNV'); - if not Assigned(glVertexAttrib3hvNV) then Exit; - @glVertexAttrib4hNV := SDL_GL_GetProcAddress('glVertexAttrib4hNV'); - if not Assigned(glVertexAttrib4hNV) then Exit; - @glVertexAttrib4hvNV := SDL_GL_GetProcAddress('glVertexAttrib4hvNV'); - if not Assigned(glVertexAttrib4hvNV) then Exit; - @glVertexAttribs1hvNV := SDL_GL_GetProcAddress('glVertexAttribs1hvNV'); - if not Assigned(glVertexAttribs1hvNV) then Exit; - @glVertexAttribs2hvNV := SDL_GL_GetProcAddress('glVertexAttribs2hvNV'); - if not Assigned(glVertexAttribs2hvNV) then Exit; - @glVertexAttribs3hvNV := SDL_GL_GetProcAddress('glVertexAttribs3hvNV'); - if not Assigned(glVertexAttribs3hvNV) then Exit; - @glVertexAttribs4hvNV := SDL_GL_GetProcAddress('glVertexAttribs4hvNV'); - if not Assigned(glVertexAttribs4hvNV) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_map_object_buffer: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_map_object_buffer', extstring) then - begin - @glMapObjectBufferATI := SDL_GL_GetProcAddress('glMapObjectBufferATI'); - if not Assigned(glMapObjectBufferATI) then Exit; - @glUnmapObjectBufferATI := SDL_GL_GetProcAddress('glUnmapObjectBufferATI'); - if not Assigned(glUnmapObjectBufferATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_separate_stencil: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_separate_stencil', extstring) then - begin - @glStencilOpSeparateATI := SDL_GL_GetProcAddress('glStencilOpSeparateATI'); - if not Assigned(glStencilOpSeparateATI) then Exit; - @glStencilFuncSeparateATI := SDL_GL_GetProcAddress('glStencilFuncSeparateATI'); - if not Assigned(glStencilFuncSeparateATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ATI_vertex_attrib_array_object: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ATI_vertex_attrib_array_object', extstring) then - begin - @glVertexAttribArrayObjectATI := SDL_GL_GetProcAddress('glVertexAttribArrayObjectATI'); - if not Assigned(glVertexAttribArrayObjectATI) then Exit; - @glGetVertexAttribArrayObjectfvATI := SDL_GL_GetProcAddress('glGetVertexAttribArrayObjectfvATI'); - if not Assigned(glGetVertexAttribArrayObjectfvATI) then Exit; - @glGetVertexAttribArrayObjectivATI := SDL_GL_GetProcAddress('glGetVertexAttribArrayObjectivATI'); - if not Assigned(glGetVertexAttribArrayObjectivATI) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_vertex_buffer_object: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_vertex_buffer_object', extstring) then - begin - @glBindBufferARB := SDL_GL_GetProcAddress('glBindBufferARB'); - if not Assigned(glBindBufferARB) then Exit; - @glDeleteBuffersARB := SDL_GL_GetProcAddress('glDeleteBuffersARB'); - if not Assigned(glDeleteBuffersARB) then Exit; - @glGenBuffersARB := SDL_GL_GetProcAddress('glGenBuffersARB'); - if not Assigned(glGenBuffersARB) then Exit; - @glIsBufferARB := SDL_GL_GetProcAddress('glIsBufferARB'); - if not Assigned(glIsBufferARB) then Exit; - @glBufferDataARB := SDL_GL_GetProcAddress('glBufferDataARB'); - if not Assigned(glBufferDataARB) then Exit; - @glBufferSubDataARB := SDL_GL_GetProcAddress('glBufferSubDataARB'); - if not Assigned(glBufferSubDataARB) then Exit; - @glGetBufferSubDataARB := SDL_GL_GetProcAddress('glGetBufferSubDataARB'); - if not Assigned(glGetBufferSubDataARB) then Exit; - @glMapBufferARB := SDL_GL_GetProcAddress('glMapBufferARB'); - if not Assigned(glMapBufferARB) then Exit; - @glUnmapBufferARB := SDL_GL_GetProcAddress('glUnmapBufferARB'); - if not Assigned(glUnmapBufferARB) then Exit; - @glGetBufferParameterivARB := SDL_GL_GetProcAddress('glGetBufferParameterivARB'); - if not Assigned(glGetBufferParameterivARB) then Exit; - @glGetBufferPointervARB := SDL_GL_GetProcAddress('glGetBufferPointervARB'); - if not Assigned(glGetBufferPointervARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_occlusion_query: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_occlusion_query', extstring) then - begin - @glGenQueriesARB := SDL_GL_GetProcAddress('glGenQueriesARB'); - if not Assigned(glGenQueriesARB) then Exit; - @glDeleteQueriesARB := SDL_GL_GetProcAddress('glDeleteQueriesARB'); - if not Assigned(glDeleteQueriesARB) then Exit; - @glIsQueryARB := SDL_GL_GetProcAddress('glIsQueryARB'); - if not Assigned(glIsQueryARB) then Exit; - @glBeginQueryARB := SDL_GL_GetProcAddress('glBeginQueryARB'); - if not Assigned(glBeginQueryARB) then Exit; - @glEndQueryARB := SDL_GL_GetProcAddress('glEndQueryARB'); - if not Assigned(glEndQueryARB) then Exit; - @glGetQueryivARB := SDL_GL_GetProcAddress('glGetQueryivARB'); - if not Assigned(glGetQueryivARB) then Exit; - @glGetQueryObjectivARB := SDL_GL_GetProcAddress('glGetQueryObjectivARB'); - if not Assigned(glGetQueryObjectivARB) then Exit; - @glGetQueryObjectuivARB := SDL_GL_GetProcAddress('glGetQueryObjectuivARB'); - if not Assigned(glGetQueryObjectuivARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_shader_objects: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_shader_objects', extstring) then - begin - @glDeleteObjectARB := SDL_GL_GetProcAddress('glDeleteObjectARB'); - if not Assigned(glDeleteObjectARB) then Exit; - @glGetHandleARB := SDL_GL_GetProcAddress('glGetHandleARB'); - if not Assigned(glGetHandleARB) then Exit; - @glDetachObjectARB := SDL_GL_GetProcAddress('glDetachObjectARB'); - if not Assigned(glDetachObjectARB) then Exit; - @glCreateShaderObjectARB := SDL_GL_GetProcAddress('glCreateShaderObjectARB'); - if not Assigned(glCreateShaderObjectARB) then Exit; - @glShaderSourceARB := SDL_GL_GetProcAddress('glShaderSourceARB'); - if not Assigned(glShaderSourceARB) then Exit; - @glCompileShaderARB := SDL_GL_GetProcAddress('glCompileShaderARB'); - if not Assigned(glCompileShaderARB) then Exit; - @glCreateProgramObjectARB := SDL_GL_GetProcAddress('glCreateProgramObjectARB'); - if not Assigned(glCreateProgramObjectARB) then Exit; - @glAttachObjectARB := SDL_GL_GetProcAddress('glAttachObjectARB'); - if not Assigned(glAttachObjectARB) then Exit; - @glLinkProgramARB := SDL_GL_GetProcAddress('glLinkProgramARB'); - if not Assigned(glLinkProgramARB) then Exit; - @glUseProgramObjectARB := SDL_GL_GetProcAddress('glUseProgramObjectARB'); - if not Assigned(glUseProgramObjectARB) then Exit; - @glValidateProgramARB := SDL_GL_GetProcAddress('glValidateProgramARB'); - if not Assigned(glValidateProgramARB) then Exit; - @glUniform1fARB := SDL_GL_GetProcAddress('glUniform1fARB'); - if not Assigned(glUniform1fARB) then Exit; - @glUniform2fARB := SDL_GL_GetProcAddress('glUniform2fARB'); - if not Assigned(glUniform2fARB) then Exit; - @glUniform3fARB := SDL_GL_GetProcAddress('glUniform3fARB'); - if not Assigned(glUniform3fARB) then Exit; - @glUniform4fARB := SDL_GL_GetProcAddress('glUniform4fARB'); - if not Assigned(glUniform4fARB) then Exit; - @glUniform1iARB := SDL_GL_GetProcAddress('glUniform1iARB'); - if not Assigned(glUniform1iARB) then Exit; - @glUniform2iARB := SDL_GL_GetProcAddress('glUniform2iARB'); - if not Assigned(glUniform2iARB) then Exit; - @glUniform3iARB := SDL_GL_GetProcAddress('glUniform3iARB'); - if not Assigned(glUniform3iARB) then Exit; - @glUniform4iARB := SDL_GL_GetProcAddress('glUniform4iARB'); - if not Assigned(glUniform4iARB) then Exit; - @glUniform1fvARB := SDL_GL_GetProcAddress('glUniform1fvARB'); - if not Assigned(glUniform1fvARB) then Exit; - @glUniform2fvARB := SDL_GL_GetProcAddress('glUniform2fvARB'); - if not Assigned(glUniform2fvARB) then Exit; - @glUniform3fvARB := SDL_GL_GetProcAddress('glUniform3fvARB'); - if not Assigned(glUniform3fvARB) then Exit; - @glUniform4fvARB := SDL_GL_GetProcAddress('glUniform4fvARB'); - if not Assigned(glUniform4fvARB) then Exit; - @glUniform1ivARB := SDL_GL_GetProcAddress('glUniform1ivARB'); - if not Assigned(glUniform1ivARB) then Exit; - @glUniform2ivARB := SDL_GL_GetProcAddress('glUniform2ivARB'); - if not Assigned(glUniform2ivARB) then Exit; - @glUniform3ivARB := SDL_GL_GetProcAddress('glUniform3ivARB'); - if not Assigned(glUniform3ivARB) then Exit; - @glUniform4ivARB := SDL_GL_GetProcAddress('glUniform4ivARB'); - if not Assigned(glUniform4ivARB) then Exit; - @glUniformMatrix2fvARB := SDL_GL_GetProcAddress('glUniformMatrix2fvARB'); - if not Assigned(glUniformMatrix2fvARB) then Exit; - @glUniformMatrix3fvARB := SDL_GL_GetProcAddress('glUniformMatrix3fvARB'); - if not Assigned(glUniformMatrix3fvARB) then Exit; - @glUniformMatrix4fvARB := SDL_GL_GetProcAddress('glUniformMatrix4fvARB'); - if not Assigned(glUniformMatrix4fvARB) then Exit; - @glGetObjectParameterfvARB := SDL_GL_GetProcAddress('glGetObjectParameterfvARB'); - if not Assigned(glGetObjectParameterfvARB) then Exit; - @glGetObjectParameterivARB := SDL_GL_GetProcAddress('glGetObjectParameterivARB'); - if not Assigned(glGetObjectParameterivARB) then Exit; - @glGetInfoLogARB := SDL_GL_GetProcAddress('glGetInfoLogARB'); - if not Assigned(glGetInfoLogARB) then Exit; - @glGetAttachedObjectsARB := SDL_GL_GetProcAddress('glGetAttachedObjectsARB'); - if not Assigned(glGetAttachedObjectsARB) then Exit; - @glGetUniformLocationARB := SDL_GL_GetProcAddress('glGetUniformLocationARB'); - if not Assigned(glGetUniformLocationARB) then Exit; - @glGetActiveUniformARB := SDL_GL_GetProcAddress('glGetActiveUniformARB'); - if not Assigned(glGetActiveUniformARB) then Exit; - @glGetUniformfvARB := SDL_GL_GetProcAddress('glGetUniformfvARB'); - if not Assigned(glGetUniformfvARB) then Exit; - @glGetUniformivARB := SDL_GL_GetProcAddress('glGetUniformivARB'); - if not Assigned(glGetUniformivARB) then Exit; - @glGetShaderSourceARB := SDL_GL_GetProcAddress('glGetShaderSourceARB'); - if not Assigned(glGetShaderSourceARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_vertex_shader: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_vertex_shader', extstring) then - begin - @glVertexAttrib1fARB := SDL_GL_GetProcAddress('glVertexAttrib1fARB'); - if not Assigned(glVertexAttrib1fARB) then Exit; - @glVertexAttrib1sARB := SDL_GL_GetProcAddress('glVertexAttrib1sARB'); - if not Assigned(glVertexAttrib1sARB) then Exit; - @glVertexAttrib1dARB := SDL_GL_GetProcAddress('glVertexAttrib1dARB'); - if not Assigned(glVertexAttrib1dARB) then Exit; - @glVertexAttrib2fARB := SDL_GL_GetProcAddress('glVertexAttrib2fARB'); - if not Assigned(glVertexAttrib2fARB) then Exit; - @glVertexAttrib2sARB := SDL_GL_GetProcAddress('glVertexAttrib2sARB'); - if not Assigned(glVertexAttrib2sARB) then Exit; - @glVertexAttrib2dARB := SDL_GL_GetProcAddress('glVertexAttrib2dARB'); - if not Assigned(glVertexAttrib2dARB) then Exit; - @glVertexAttrib3fARB := SDL_GL_GetProcAddress('glVertexAttrib3fARB'); - if not Assigned(glVertexAttrib3fARB) then Exit; - @glVertexAttrib3sARB := SDL_GL_GetProcAddress('glVertexAttrib3sARB'); - if not Assigned(glVertexAttrib3sARB) then Exit; - @glVertexAttrib3dARB := SDL_GL_GetProcAddress('glVertexAttrib3dARB'); - if not Assigned(glVertexAttrib3dARB) then Exit; - @glVertexAttrib4fARB := SDL_GL_GetProcAddress('glVertexAttrib4fARB'); - if not Assigned(glVertexAttrib4fARB) then Exit; - @glVertexAttrib4sARB := SDL_GL_GetProcAddress('glVertexAttrib4sARB'); - if not Assigned(glVertexAttrib4sARB) then Exit; - @glVertexAttrib4dARB := SDL_GL_GetProcAddress('glVertexAttrib4dARB'); - if not Assigned(glVertexAttrib4dARB) then Exit; - @glVertexAttrib4NubARB := SDL_GL_GetProcAddress('glVertexAttrib4NubARB'); - if not Assigned(glVertexAttrib4NubARB) then Exit; - @glVertexAttrib1fvARB := SDL_GL_GetProcAddress('glVertexAttrib1fvARB'); - if not Assigned(glVertexAttrib1fvARB) then Exit; - @glVertexAttrib1svARB := SDL_GL_GetProcAddress('glVertexAttrib1svARB'); - if not Assigned(glVertexAttrib1svARB) then Exit; - @glVertexAttrib1dvARB := SDL_GL_GetProcAddress('glVertexAttrib1dvARB'); - if not Assigned(glVertexAttrib1dvARB) then Exit; - @glVertexAttrib2fvARB := SDL_GL_GetProcAddress('glVertexAttrib2fvARB'); - if not Assigned(glVertexAttrib2fvARB) then Exit; - @glVertexAttrib2svARB := SDL_GL_GetProcAddress('glVertexAttrib2svARB'); - if not Assigned(glVertexAttrib2svARB) then Exit; - @glVertexAttrib2dvARB := SDL_GL_GetProcAddress('glVertexAttrib2dvARB'); - if not Assigned(glVertexAttrib2dvARB) then Exit; - @glVertexAttrib3fvARB := SDL_GL_GetProcAddress('glVertexAttrib3fvARB'); - if not Assigned(glVertexAttrib3fvARB) then Exit; - @glVertexAttrib3svARB := SDL_GL_GetProcAddress('glVertexAttrib3svARB'); - if not Assigned(glVertexAttrib3svARB) then Exit; - @glVertexAttrib3dvARB := SDL_GL_GetProcAddress('glVertexAttrib3dvARB'); - if not Assigned(glVertexAttrib3dvARB) then Exit; - @glVertexAttrib4fvARB := SDL_GL_GetProcAddress('glVertexAttrib4fvARB'); - if not Assigned(glVertexAttrib4fvARB) then Exit; - @glVertexAttrib4svARB := SDL_GL_GetProcAddress('glVertexAttrib4svARB'); - if not Assigned(glVertexAttrib4svARB) then Exit; - @glVertexAttrib4dvARB := SDL_GL_GetProcAddress('glVertexAttrib4dvARB'); - if not Assigned(glVertexAttrib4dvARB) then Exit; - @glVertexAttrib4ivARB := SDL_GL_GetProcAddress('glVertexAttrib4ivARB'); - if not Assigned(glVertexAttrib4ivARB) then Exit; - @glVertexAttrib4bvARB := SDL_GL_GetProcAddress('glVertexAttrib4bvARB'); - if not Assigned(glVertexAttrib4bvARB) then Exit; - @glVertexAttrib4ubvARB := SDL_GL_GetProcAddress('glVertexAttrib4ubvARB'); - if not Assigned(glVertexAttrib4ubvARB) then Exit; - @glVertexAttrib4usvARB := SDL_GL_GetProcAddress('glVertexAttrib4usvARB'); - if not Assigned(glVertexAttrib4usvARB) then Exit; - @glVertexAttrib4uivARB := SDL_GL_GetProcAddress('glVertexAttrib4uivARB'); - if not Assigned(glVertexAttrib4uivARB) then Exit; - @glVertexAttrib4NbvARB := SDL_GL_GetProcAddress('glVertexAttrib4NbvARB'); - if not Assigned(glVertexAttrib4NbvARB) then Exit; - @glVertexAttrib4NsvARB := SDL_GL_GetProcAddress('glVertexAttrib4NsvARB'); - if not Assigned(glVertexAttrib4NsvARB) then Exit; - @glVertexAttrib4NivARB := SDL_GL_GetProcAddress('glVertexAttrib4NivARB'); - if not Assigned(glVertexAttrib4NivARB) then Exit; - @glVertexAttrib4NubvARB := SDL_GL_GetProcAddress('glVertexAttrib4NubvARB'); - if not Assigned(glVertexAttrib4NubvARB) then Exit; - @glVertexAttrib4NusvARB := SDL_GL_GetProcAddress('glVertexAttrib4NusvARB'); - if not Assigned(glVertexAttrib4NusvARB) then Exit; - @glVertexAttrib4NuivARB := SDL_GL_GetProcAddress('glVertexAttrib4NuivARB'); - if not Assigned(glVertexAttrib4NuivARB) then Exit; - @glVertexAttribPointerARB := SDL_GL_GetProcAddress('glVertexAttribPointerARB'); - if not Assigned(glVertexAttribPointerARB) then Exit; - @glEnableVertexAttribArrayARB := SDL_GL_GetProcAddress('glEnableVertexAttribArrayARB'); - if not Assigned(glEnableVertexAttribArrayARB) then Exit; - @glDisableVertexAttribArrayARB := SDL_GL_GetProcAddress('glDisableVertexAttribArrayARB'); - if not Assigned(glDisableVertexAttribArrayARB) then Exit; - @glBindAttribLocationARB := SDL_GL_GetProcAddress('glBindAttribLocationARB'); - if not Assigned(glBindAttribLocationARB) then Exit; - @glGetActiveAttribARB := SDL_GL_GetProcAddress('glGetActiveAttribARB'); - if not Assigned(glGetActiveAttribARB) then Exit; - @glGetAttribLocationARB := SDL_GL_GetProcAddress('glGetAttribLocationARB'); - if not Assigned(glGetAttribLocationARB) then Exit; - @glGetVertexAttribdvARB := SDL_GL_GetProcAddress('glGetVertexAttribdvARB'); - if not Assigned(glGetVertexAttribdvARB) then Exit; - @glGetVertexAttribfvARB := SDL_GL_GetProcAddress('glGetVertexAttribfvARB'); - if not Assigned(glGetVertexAttribfvARB) then Exit; - @glGetVertexAttribivARB := SDL_GL_GetProcAddress('glGetVertexAttribivARB'); - if not Assigned(glGetVertexAttribivARB) then Exit; - @glGetVertexAttribPointervARB := SDL_GL_GetProcAddress('glGetVertexAttribPointervARB'); - if not Assigned(glGetVertexAttribPointervARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_fragment_shader: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_fragment_shader', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_shading_language_100: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_shading_language_100', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_non_power_of_two: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_texture_non_power_of_two', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_point_sprite: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_point_sprite', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_depth_bounds_test: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_depth_bounds_test', extstring) then - begin - @glDepthBoundsEXT := SDL_GL_GetProcAddress('glDepthBoundsEXT'); - if not Assigned(glDepthBoundsEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_secondary_color: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_secondary_color', extstring) then - begin - @glSecondaryColor3bEXT := SDL_GL_GetProcAddress('glSecondaryColor3bEXT'); - if not Assigned(glSecondaryColor3bEXT) then Exit; - @glSecondaryColor3sEXT := SDL_GL_GetProcAddress('glSecondaryColor3sEXT'); - if not Assigned(glSecondaryColor3sEXT) then Exit; - @glSecondaryColor3iEXT := SDL_GL_GetProcAddress('glSecondaryColor3iEXT'); - if not Assigned(glSecondaryColor3iEXT) then Exit; - @glSecondaryColor3fEXT := SDL_GL_GetProcAddress('glSecondaryColor3fEXT'); - if not Assigned(glSecondaryColor3fEXT) then Exit; - @glSecondaryColor3dEXT := SDL_GL_GetProcAddress('glSecondaryColor3dEXT'); - if not Assigned(glSecondaryColor3dEXT) then Exit; - @glSecondaryColor3ubEXT := SDL_GL_GetProcAddress('glSecondaryColor3ubEXT'); - if not Assigned(glSecondaryColor3ubEXT) then Exit; - @glSecondaryColor3usEXT := SDL_GL_GetProcAddress('glSecondaryColor3usEXT'); - if not Assigned(glSecondaryColor3usEXT) then Exit; - @glSecondaryColor3uiEXT := SDL_GL_GetProcAddress('glSecondaryColor3uiEXT'); - if not Assigned(glSecondaryColor3uiEXT) then Exit; - @glSecondaryColor3bvEXT := SDL_GL_GetProcAddress('glSecondaryColor3bvEXT'); - if not Assigned(glSecondaryColor3bvEXT) then Exit; - @glSecondaryColor3svEXT := SDL_GL_GetProcAddress('glSecondaryColor3svEXT'); - if not Assigned(glSecondaryColor3svEXT) then Exit; - @glSecondaryColor3ivEXT := SDL_GL_GetProcAddress('glSecondaryColor3ivEXT'); - if not Assigned(glSecondaryColor3ivEXT) then Exit; - @glSecondaryColor3fvEXT := SDL_GL_GetProcAddress('glSecondaryColor3fvEXT'); - if not Assigned(glSecondaryColor3fvEXT) then Exit; - @glSecondaryColor3dvEXT := SDL_GL_GetProcAddress('glSecondaryColor3dvEXT'); - if not Assigned(glSecondaryColor3dvEXT) then Exit; - @glSecondaryColor3ubvEXT := SDL_GL_GetProcAddress('glSecondaryColor3ubvEXT'); - if not Assigned(glSecondaryColor3ubvEXT) then Exit; - @glSecondaryColor3usvEXT := SDL_GL_GetProcAddress('glSecondaryColor3usvEXT'); - if not Assigned(glSecondaryColor3usvEXT) then Exit; - @glSecondaryColor3uivEXT := SDL_GL_GetProcAddress('glSecondaryColor3uivEXT'); - if not Assigned(glSecondaryColor3uivEXT) then Exit; - @glSecondaryColorPointerEXT := SDL_GL_GetProcAddress('glSecondaryColorPointerEXT'); - if not Assigned(glSecondaryColorPointerEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_mirror_clamp: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_texture_mirror_clamp', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_blend_equation_separate: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_blend_equation_separate', extstring) then - begin - @glBlendEquationSeparateEXT := SDL_GL_GetProcAddress('glBlendEquationSeparateEXT'); - if not Assigned(glBlendEquationSeparateEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_MESA_pack_invert: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_MESA_pack_invert', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_MESA_ycbcr_texture: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_MESA_ycbcr_texture', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_fragment_program_shadow: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_ARB_fragment_program_shadow', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_fog_coord: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_fog_coord', extstring) then - begin - @glFogCoordfEXT := SDL_GL_GetProcAddress('glFogCoordfEXT'); - if not Assigned(glFogCoordfEXT) then Exit; - @glFogCoorddEXT := SDL_GL_GetProcAddress('glFogCoorddEXT'); - if not Assigned(glFogCoorddEXT) then Exit; - @glFogCoordfvEXT := SDL_GL_GetProcAddress('glFogCoordfvEXT'); - if not Assigned(glFogCoordfvEXT) then Exit; - @glFogCoorddvEXT := SDL_GL_GetProcAddress('glFogCoorddvEXT'); - if not Assigned(glFogCoorddvEXT) then Exit; - @glFogCoordPointerEXT := SDL_GL_GetProcAddress('glFogCoordPointerEXT'); - if not Assigned(glFogCoordPointerEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_NV_fragment_program_option: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_fragment_program_option', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_pixel_buffer_object: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_EXT_pixel_buffer_object', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_fragment_program2: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_fragment_program2', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_program2_option: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_program2_option', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_NV_vertex_program3: Boolean; -var - extstring : PChar; -begin - - Result := FALSE; - extstring := glGetString( GL_EXTENSIONS ); - - if glext_ExtensionSupported('GL_NV_vertex_program3', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_draw_buffers: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_ARB_draw_buffers', extstring) then - begin - glDrawBuffersARB := SDL_GL_GetProcAddress('glDrawBuffersARB'); - if not Assigned(glDrawBuffersARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_rectangle: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_ARB_texture_rectangle', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_color_buffer_float: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_ARB_color_buffer_float', extstring) then - begin - glClampColorARB := SDL_GL_GetProcAddress('glClampColorARB'); - if not Assigned(glClampColorARB) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_ARB_half_float_pixel: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_ARB_half_float_pixel', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_texture_float: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_ARB_texture_float', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_texture_compression_dxt1: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_EXT_texture_compression_dxt1', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_ARB_pixel_buffer_object: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_ARB_pixel_buffer_object', extstring) then - begin - Result := TRUE; - end; - -end; - -function Load_GL_EXT_framebuffer_object: Boolean; -var - extstring: PChar; -begin - - Result := FALSE; - extstring := glGetString(GL_EXTENSIONS); - - if glext_ExtensionSupported('GL_EXT_framebuffer_object', extstring) then - begin - glIsRenderbufferEXT := SDL_GL_GetProcAddress('glIsRenderbufferEXT'); - if not Assigned(glIsRenderbufferEXT) then Exit; - glBindRenderbufferEXT := SDL_GL_GetProcAddress('glBindRenderbufferEXT'); - if not Assigned(glBindRenderbufferEXT) then Exit; - glDeleteRenderbuffersEXT := SDL_GL_GetProcAddress('glDeleteRenderbuffersEXT'); - if not Assigned(glDeleteRenderbuffersEXT) then Exit; - glGenRenderbuffersEXT := SDL_GL_GetProcAddress('glGenRenderbuffersEXT'); - if not Assigned(glGenRenderbuffersEXT) then Exit; - glRenderbufferStorageEXT := SDL_GL_GetProcAddress('glRenderbufferStorageEXT'); - if not Assigned(glRenderbufferStorageEXT) then Exit; - glGetRenderbufferParameterivEXT := SDL_GL_GetProcAddress('glGetRenderbufferParameterivEXT'); - if not Assigned(glGetRenderbufferParameterivEXT) then Exit; - glIsFramebufferEXT := SDL_GL_GetProcAddress('glIsFramebufferEXT'); - if not Assigned(glIsFramebufferEXT) then Exit; - glBindFramebufferEXT := SDL_GL_GetProcAddress('glBindFramebufferEXT'); - if not Assigned(glBindFramebufferEXT) then Exit; - glDeleteFramebuffersEXT := SDL_GL_GetProcAddress('glDeleteFramebuffersEXT'); - if not Assigned(glDeleteFramebuffersEXT) then Exit; - glGenFramebuffersEXT := SDL_GL_GetProcAddress('glGenFramebuffersEXT'); - if not Assigned(glGenFramebuffersEXT) then Exit; - glCheckFramebufferStatusEXT := SDL_GL_GetProcAddress('glCheckFramebufferStatusEXT'); - if not Assigned(glCheckFramebufferStatusEXT) then Exit; - glFramebufferTexture1DEXT := SDL_GL_GetProcAddress('glFramebufferTexture1DEXT'); - if not Assigned(glFramebufferTexture1DEXT) then Exit; - glFramebufferTexture2DEXT := SDL_GL_GetProcAddress('glFramebufferTexture2DEXT'); - if not Assigned(glFramebufferTexture2DEXT) then Exit; - glFramebufferTexture3DEXT := SDL_GL_GetProcAddress('glFramebufferTexture3DEXT'); - if not Assigned(glFramebufferTexture3DEXT) then Exit; - glFramebufferRenderbufferEXT := SDL_GL_GetProcAddress('glFramebufferRenderbufferEXT'); - if not Assigned(glFramebufferRenderbufferEXT) then Exit; - glGetFramebufferAttachmentParameterivEXT := SDL_GL_GetProcAddress('glGetFramebufferAttachmentParameterivEXT'); - if not Assigned(glGetFramebufferAttachmentParameterivEXT) then Exit; - glGenerateMipmapEXT := SDL_GL_GetProcAddress('glGenerateMipmapEXT'); - if not Assigned(glGenerateMipmapEXT) then Exit; - Result := TRUE; - end; - -end; - -function Load_GL_version_1_4: Boolean; -var - extstring: String; -begin - - Result := FALSE; - extstring := String(PChar(glGetString(GL_EXTENSIONS))); - - glBlendFuncSeparate := SDL_GL_GetProcAddress('glBlendFuncSeparate'); - if not Assigned(glBlendFuncSeparate) then Exit; - glFogCoordf := SDL_GL_GetProcAddress('glFogCoordf'); - if not Assigned(glFogCoordf) then Exit; - glFogCoordfv := SDL_GL_GetProcAddress('glFogCoordfv'); - if not Assigned(glFogCoordfv) then Exit; - glFogCoordd := SDL_GL_GetProcAddress('glFogCoordd'); - if not Assigned(glFogCoordd) then Exit; - glFogCoorddv := SDL_GL_GetProcAddress('glFogCoorddv'); - if not Assigned(glFogCoorddv) then Exit; - glFogCoordPointer := SDL_GL_GetProcAddress('glFogCoordPointer'); - if not Assigned(glFogCoordPointer) then Exit; - glMultiDrawArrays := SDL_GL_GetProcAddress('glMultiDrawArrays'); - if not Assigned(glMultiDrawArrays) then Exit; - glMultiDrawElements := SDL_GL_GetProcAddress('glMultiDrawElements'); - if not Assigned(glMultiDrawElements) then Exit; - glPointParameterf := SDL_GL_GetProcAddress('glPointParameterf'); - if not Assigned(glPointParameterf) then Exit; - glPointParameterfv := SDL_GL_GetProcAddress('glPointParameterfv'); - if not Assigned(glPointParameterfv) then Exit; - glPointParameteri := SDL_GL_GetProcAddress('glPointParameteri'); - if not Assigned(glPointParameteri) then Exit; - glPointParameteriv := SDL_GL_GetProcAddress('glPointParameteriv'); - if not Assigned(glPointParameteriv) then Exit; - glSecondaryColor3b := SDL_GL_GetProcAddress('glSecondaryColor3b'); - if not Assigned(glSecondaryColor3b) then Exit; - glSecondaryColor3bv := SDL_GL_GetProcAddress('glSecondaryColor3bv'); - if not Assigned(glSecondaryColor3bv) then Exit; - glSecondaryColor3d := SDL_GL_GetProcAddress('glSecondaryColor3d'); - if not Assigned(glSecondaryColor3d) then Exit; - glSecondaryColor3dv := SDL_GL_GetProcAddress('glSecondaryColor3dv'); - if not Assigned(glSecondaryColor3dv) then Exit; - glSecondaryColor3f := SDL_GL_GetProcAddress('glSecondaryColor3f'); - if not Assigned(glSecondaryColor3f) then Exit; - glSecondaryColor3fv := SDL_GL_GetProcAddress('glSecondaryColor3fv'); - if not Assigned(glSecondaryColor3fv) then Exit; - glSecondaryColor3i := SDL_GL_GetProcAddress('glSecondaryColor3i'); - if not Assigned(glSecondaryColor3i) then Exit; - glSecondaryColor3iv := SDL_GL_GetProcAddress('glSecondaryColor3iv'); - if not Assigned(glSecondaryColor3iv) then Exit; - glSecondaryColor3s := SDL_GL_GetProcAddress('glSecondaryColor3s'); - if not Assigned(glSecondaryColor3s) then Exit; - glSecondaryColor3sv := SDL_GL_GetProcAddress('glSecondaryColor3sv'); - if not Assigned(glSecondaryColor3sv) then Exit; - glSecondaryColor3ub := SDL_GL_GetProcAddress('glSecondaryColor3ub'); - if not Assigned(glSecondaryColor3ub) then Exit; - glSecondaryColor3ubv := SDL_GL_GetProcAddress('glSecondaryColor3ubv'); - if not Assigned(glSecondaryColor3ubv) then Exit; - glSecondaryColor3ui := SDL_GL_GetProcAddress('glSecondaryColor3ui'); - if not Assigned(glSecondaryColor3ui) then Exit; - glSecondaryColor3uiv := SDL_GL_GetProcAddress('glSecondaryColor3uiv'); - if not Assigned(glSecondaryColor3uiv) then Exit; - glSecondaryColor3us := SDL_GL_GetProcAddress('glSecondaryColor3us'); - if not Assigned(glSecondaryColor3us) then Exit; - glSecondaryColor3usv := SDL_GL_GetProcAddress('glSecondaryColor3usv'); - if not Assigned(glSecondaryColor3usv) then Exit; - glSecondaryColorPointer := SDL_GL_GetProcAddress('glSecondaryColorPointer'); - if not Assigned(glSecondaryColorPointer) then Exit; - glWindowPos2d := SDL_GL_GetProcAddress('glWindowPos2d'); - if not Assigned(glWindowPos2d) then Exit; - glWindowPos2dv := SDL_GL_GetProcAddress('glWindowPos2dv'); - if not Assigned(glWindowPos2dv) then Exit; - glWindowPos2f := SDL_GL_GetProcAddress('glWindowPos2f'); - if not Assigned(glWindowPos2f) then Exit; - glWindowPos2fv := SDL_GL_GetProcAddress('glWindowPos2fv'); - if not Assigned(glWindowPos2fv) then Exit; - glWindowPos2i := SDL_GL_GetProcAddress('glWindowPos2i'); - if not Assigned(glWindowPos2i) then Exit; - glWindowPos2iv := SDL_GL_GetProcAddress('glWindowPos2iv'); - if not Assigned(glWindowPos2iv) then Exit; - glWindowPos2s := SDL_GL_GetProcAddress('glWindowPos2s'); - if not Assigned(glWindowPos2s) then Exit; - glWindowPos2sv := SDL_GL_GetProcAddress('glWindowPos2sv'); - if not Assigned(glWindowPos2sv) then Exit; - glWindowPos3d := SDL_GL_GetProcAddress('glWindowPos3d'); - if not Assigned(glWindowPos3d) then Exit; - glWindowPos3dv := SDL_GL_GetProcAddress('glWindowPos3dv'); - if not Assigned(glWindowPos3dv) then Exit; - glWindowPos3f := SDL_GL_GetProcAddress('glWindowPos3f'); - if not Assigned(glWindowPos3f) then Exit; - glWindowPos3fv := SDL_GL_GetProcAddress('glWindowPos3fv'); - if not Assigned(glWindowPos3fv) then Exit; - glWindowPos3i := SDL_GL_GetProcAddress('glWindowPos3i'); - if not Assigned(glWindowPos3i) then Exit; - glWindowPos3iv := SDL_GL_GetProcAddress('glWindowPos3iv'); - if not Assigned(glWindowPos3iv) then Exit; - glWindowPos3s := SDL_GL_GetProcAddress('glWindowPos3s'); - if not Assigned(glWindowPos3s) then Exit; - glWindowPos3sv := SDL_GL_GetProcAddress('glWindowPos3sv'); - if not Assigned(glWindowPos3sv) then Exit; - Result := TRUE; - -end; - -function Load_GL_version_1_5: Boolean; -var - extstring: String; -begin - - Result := FALSE; - extstring := String(PChar(glGetString(GL_EXTENSIONS))); - - glGenQueries := SDL_GL_GetProcAddress('glGenQueries'); - if not Assigned(glGenQueries) then Exit; - glDeleteQueries := SDL_GL_GetProcAddress('glDeleteQueries'); - if not Assigned(glDeleteQueries) then Exit; - glIsQuery := SDL_GL_GetProcAddress('glIsQuery'); - if not Assigned(glIsQuery) then Exit; - glBeginQuery := SDL_GL_GetProcAddress('glBeginQuery'); - if not Assigned(glBeginQuery) then Exit; - glEndQuery := SDL_GL_GetProcAddress('glEndQuery'); - if not Assigned(glEndQuery) then Exit; - glGetQueryiv := SDL_GL_GetProcAddress('glGetQueryiv'); - if not Assigned(glGetQueryiv) then Exit; - glGetQueryObjectiv := SDL_GL_GetProcAddress('glGetQueryObjectiv'); - if not Assigned(glGetQueryObjectiv) then Exit; - glGetQueryObjectuiv := SDL_GL_GetProcAddress('glGetQueryObjectuiv'); - if not Assigned(glGetQueryObjectuiv) then Exit; - glBindBuffer := SDL_GL_GetProcAddress('glBindBuffer'); - if not Assigned(glBindBuffer) then Exit; - glDeleteBuffers := SDL_GL_GetProcAddress('glDeleteBuffers'); - if not Assigned(glDeleteBuffers) then Exit; - glGenBuffers := SDL_GL_GetProcAddress('glGenBuffers'); - if not Assigned(glGenBuffers) then Exit; - glIsBuffer := SDL_GL_GetProcAddress('glIsBuffer'); - if not Assigned(glIsBuffer) then Exit; - glBufferData := SDL_GL_GetProcAddress('glBufferData'); - if not Assigned(glBufferData) then Exit; - glBufferSubData := SDL_GL_GetProcAddress('glBufferSubData'); - if not Assigned(glBufferSubData) then Exit; - glGetBufferSubData := SDL_GL_GetProcAddress('glGetBufferSubData'); - if not Assigned(glGetBufferSubData) then Exit; - glMapBuffer := SDL_GL_GetProcAddress('glMapBuffer'); - if not Assigned(glMapBuffer) then Exit; - glUnmapBuffer := SDL_GL_GetProcAddress('glUnmapBuffer'); - if not Assigned(glUnmapBuffer) then Exit; - glGetBufferParameteriv := SDL_GL_GetProcAddress('glGetBufferParameteriv'); - if not Assigned(glGetBufferParameteriv) then Exit; - glGetBufferPointerv := SDL_GL_GetProcAddress('glGetBufferPointerv'); - if not Assigned(glGetBufferPointerv) then Exit; - Result := TRUE; - -end; - -function Load_GL_version_2_0: Boolean; -var - extstring: String; -begin - - Result := FALSE; - extstring := String(PChar(glGetString(GL_EXTENSIONS))); - - glBlendEquationSeparate := SDL_GL_GetProcAddress('glBlendEquationSeparate'); - if not Assigned(glBlendEquationSeparate) then Exit; - glDrawBuffers := SDL_GL_GetProcAddress('glDrawBuffers'); - if not Assigned(glDrawBuffers) then Exit; - glStencilOpSeparate := SDL_GL_GetProcAddress('glStencilOpSeparate'); - if not Assigned(glStencilOpSeparate) then Exit; - glStencilFuncSeparate := SDL_GL_GetProcAddress('glStencilFuncSeparate'); - if not Assigned(glStencilFuncSeparate) then Exit; - glStencilMaskSeparate := SDL_GL_GetProcAddress('glStencilMaskSeparate'); - if not Assigned(glStencilMaskSeparate) then Exit; - glAttachShader := SDL_GL_GetProcAddress('glAttachShader'); - if not Assigned(glAttachShader) then Exit; - glBindAttribLocation := SDL_GL_GetProcAddress('glBindAttribLocation'); - if not Assigned(glBindAttribLocation) then Exit; - glCompileShader := SDL_GL_GetProcAddress('glCompileShader'); - if not Assigned(glCompileShader) then Exit; - glCreateProgram := SDL_GL_GetProcAddress('glCreateProgram'); - if not Assigned(glCreateProgram) then Exit; - glCreateShader := SDL_GL_GetProcAddress('glCreateShader'); - if not Assigned(glCreateShader) then Exit; - glDeleteProgram := SDL_GL_GetProcAddress('glDeleteProgram'); - if not Assigned(glDeleteProgram) then Exit; - glDeleteShader := SDL_GL_GetProcAddress('glDeleteShader'); - if not Assigned(glDeleteShader) then Exit; - glDetachShader := SDL_GL_GetProcAddress('glDetachShader'); - if not Assigned(glDetachShader) then Exit; - glDisableVertexAttribArray := SDL_GL_GetProcAddress('glDisableVertexAttribArray'); - if not Assigned(glDisableVertexAttribArray) then Exit; - glEnableVertexAttribArray := SDL_GL_GetProcAddress('glEnableVertexAttribArray'); - if not Assigned(glEnableVertexAttribArray) then Exit; - glGetActiveAttrib := SDL_GL_GetProcAddress('glGetActiveAttrib'); - if not Assigned(glGetActiveAttrib) then Exit; - glGetActiveUniform := SDL_GL_GetProcAddress('glGetActiveUniform'); - if not Assigned(glGetActiveUniform) then Exit; - glGetAttachedShaders := SDL_GL_GetProcAddress('glGetAttachedShaders'); - if not Assigned(glGetAttachedShaders) then Exit; - glGetAttribLocation := SDL_GL_GetProcAddress('glGetAttribLocation'); - if not Assigned(glGetAttribLocation) then Exit; - glGetProgramiv := SDL_GL_GetProcAddress('glGetProgramiv'); - if not Assigned(glGetProgramiv) then Exit; - glGetProgramInfoLog := SDL_GL_GetProcAddress('glGetProgramInfoLog'); - if not Assigned(glGetProgramInfoLog) then Exit; - glGetShaderiv := SDL_GL_GetProcAddress('glGetShaderiv'); - if not Assigned(glGetShaderiv) then Exit; - glGetShaderInfoLog := SDL_GL_GetProcAddress('glGetShaderInfoLog'); - if not Assigned(glGetShaderInfoLog) then Exit; - glGetShaderSource := SDL_GL_GetProcAddress('glGetShaderSource'); - if not Assigned(glGetShaderSource) then Exit; - glGetUniformLocation := SDL_GL_GetProcAddress('glGetUniformLocation'); - if not Assigned(glGetUniformLocation) then Exit; - glGetUniformfv := SDL_GL_GetProcAddress('glGetUniformfv'); - if not Assigned(glGetUniformfv) then Exit; - glGetUniformiv := SDL_GL_GetProcAddress('glGetUniformiv'); - if not Assigned(glGetUniformiv) then Exit; - glGetVertexAttribdv := SDL_GL_GetProcAddress('glGetVertexAttribdv'); - if not Assigned(glGetVertexAttribdv) then Exit; - glGetVertexAttribfv := SDL_GL_GetProcAddress('glGetVertexAttribfv'); - if not Assigned(glGetVertexAttribfv) then Exit; - glGetVertexAttribiv := SDL_GL_GetProcAddress('glGetVertexAttribiv'); - if not Assigned(glGetVertexAttribiv) then Exit; - glGetVertexAttribPointerv := SDL_GL_GetProcAddress('glGetVertexAttribPointerv'); - if not Assigned(glGetVertexAttribPointerv) then Exit; - glIsProgram := SDL_GL_GetProcAddress('glIsProgram'); - if not Assigned(glIsProgram) then Exit; - glIsShader := SDL_GL_GetProcAddress('glIsShader'); - if not Assigned(glIsShader) then Exit; - glLinkProgram := SDL_GL_GetProcAddress('glLinkProgram'); - if not Assigned(glLinkProgram) then Exit; - glShaderSource := SDL_GL_GetProcAddress('glShaderSource'); - if not Assigned(glShaderSource) then Exit; - glUseProgram := SDL_GL_GetProcAddress('glUseProgram'); - if not Assigned(glUseProgram) then Exit; - glUniform1f := SDL_GL_GetProcAddress('glUniform1f'); - if not Assigned(glUniform1f) then Exit; - glUniform2f := SDL_GL_GetProcAddress('glUniform2f'); - if not Assigned(glUniform2f) then Exit; - glUniform3f := SDL_GL_GetProcAddress('glUniform3f'); - if not Assigned(glUniform3f) then Exit; - glUniform4f := SDL_GL_GetProcAddress('glUniform4f'); - if not Assigned(glUniform4f) then Exit; - glUniform1i := SDL_GL_GetProcAddress('glUniform1i'); - if not Assigned(glUniform1i) then Exit; - glUniform2i := SDL_GL_GetProcAddress('glUniform2i'); - if not Assigned(glUniform2i) then Exit; - glUniform3i := SDL_GL_GetProcAddress('glUniform3i'); - if not Assigned(glUniform3i) then Exit; - glUniform4i := SDL_GL_GetProcAddress('glUniform4i'); - if not Assigned(glUniform4i) then Exit; - glUniform1fv := SDL_GL_GetProcAddress('glUniform1fv'); - if not Assigned(glUniform1fv) then Exit; - glUniform2fv := SDL_GL_GetProcAddress('glUniform2fv'); - if not Assigned(glUniform2fv) then Exit; - glUniform3fv := SDL_GL_GetProcAddress('glUniform3fv'); - if not Assigned(glUniform3fv) then Exit; - glUniform4fv := SDL_GL_GetProcAddress('glUniform4fv'); - if not Assigned(glUniform4fv) then Exit; - glUniform1iv := SDL_GL_GetProcAddress('glUniform1iv'); - if not Assigned(glUniform1iv) then Exit; - glUniform2iv := SDL_GL_GetProcAddress('glUniform2iv'); - if not Assigned(glUniform2iv) then Exit; - glUniform3iv := SDL_GL_GetProcAddress('glUniform3iv'); - if not Assigned(glUniform3iv) then Exit; - glUniform4iv := SDL_GL_GetProcAddress('glUniform4iv'); - if not Assigned(glUniform4iv) then Exit; - glUniformMatrix2fv := SDL_GL_GetProcAddress('glUniformMatrix2fv'); - if not Assigned(glUniformMatrix2fv) then Exit; - glUniformMatrix3fv := SDL_GL_GetProcAddress('glUniformMatrix3fv'); - if not Assigned(glUniformMatrix3fv) then Exit; - glUniformMatrix4fv := SDL_GL_GetProcAddress('glUniformMatrix4fv'); - if not Assigned(glUniformMatrix4fv) then Exit; - glValidateProgram := SDL_GL_GetProcAddress('glValidateProgram'); - if not Assigned(glValidateProgram) then Exit; - glVertexAttrib1d := SDL_GL_GetProcAddress('glVertexAttrib1d'); - if not Assigned(glVertexAttrib1d) then Exit; - glVertexAttrib1dv := SDL_GL_GetProcAddress('glVertexAttrib1dv'); - if not Assigned(glVertexAttrib1dv) then Exit; - glVertexAttrib1f := SDL_GL_GetProcAddress('glVertexAttrib1f'); - if not Assigned(glVertexAttrib1f) then Exit; - glVertexAttrib1fv := SDL_GL_GetProcAddress('glVertexAttrib1fv'); - if not Assigned(glVertexAttrib1fv) then Exit; - glVertexAttrib1s := SDL_GL_GetProcAddress('glVertexAttrib1s'); - if not Assigned(glVertexAttrib1s) then Exit; - glVertexAttrib1sv := SDL_GL_GetProcAddress('glVertexAttrib1sv'); - if not Assigned(glVertexAttrib1sv) then Exit; - glVertexAttrib2d := SDL_GL_GetProcAddress('glVertexAttrib2d'); - if not Assigned(glVertexAttrib2d) then Exit; - glVertexAttrib2dv := SDL_GL_GetProcAddress('glVertexAttrib2dv'); - if not Assigned(glVertexAttrib2dv) then Exit; - glVertexAttrib2f := SDL_GL_GetProcAddress('glVertexAttrib2f'); - if not Assigned(glVertexAttrib2f) then Exit; - glVertexAttrib2fv := SDL_GL_GetProcAddress('glVertexAttrib2fv'); - if not Assigned(glVertexAttrib2fv) then Exit; - glVertexAttrib2s := SDL_GL_GetProcAddress('glVertexAttrib2s'); - if not Assigned(glVertexAttrib2s) then Exit; - glVertexAttrib2sv := SDL_GL_GetProcAddress('glVertexAttrib2sv'); - if not Assigned(glVertexAttrib2sv) then Exit; - glVertexAttrib3d := SDL_GL_GetProcAddress('glVertexAttrib3d'); - if not Assigned(glVertexAttrib3d) then Exit; - glVertexAttrib3dv := SDL_GL_GetProcAddress('glVertexAttrib3dv'); - if not Assigned(glVertexAttrib3dv) then Exit; - glVertexAttrib3f := SDL_GL_GetProcAddress('glVertexAttrib3f'); - if not Assigned(glVertexAttrib3f) then Exit; - glVertexAttrib3fv := SDL_GL_GetProcAddress('glVertexAttrib3fv'); - if not Assigned(glVertexAttrib3fv) then Exit; - glVertexAttrib3s := SDL_GL_GetProcAddress('glVertexAttrib3s'); - if not Assigned(glVertexAttrib3s) then Exit; - glVertexAttrib3sv := SDL_GL_GetProcAddress('glVertexAttrib3sv'); - if not Assigned(glVertexAttrib3sv) then Exit; - glVertexAttrib4Nbv := SDL_GL_GetProcAddress('glVertexAttrib4Nbv'); - if not Assigned(glVertexAttrib4Nbv) then Exit; - glVertexAttrib4Niv := SDL_GL_GetProcAddress('glVertexAttrib4Niv'); - if not Assigned(glVertexAttrib4Niv) then Exit; - glVertexAttrib4Nsv := SDL_GL_GetProcAddress('glVertexAttrib4Nsv'); - if not Assigned(glVertexAttrib4Nsv) then Exit; - glVertexAttrib4Nub := SDL_GL_GetProcAddress('glVertexAttrib4Nub'); - if not Assigned(glVertexAttrib4Nub) then Exit; - glVertexAttrib4Nubv := SDL_GL_GetProcAddress('glVertexAttrib4Nubv'); - if not Assigned(glVertexAttrib4Nubv) then Exit; - glVertexAttrib4Nuiv := SDL_GL_GetProcAddress('glVertexAttrib4Nuiv'); - if not Assigned(glVertexAttrib4Nuiv) then Exit; - glVertexAttrib4Nusv := SDL_GL_GetProcAddress('glVertexAttrib4Nusv'); - if not Assigned(glVertexAttrib4Nusv) then Exit; - glVertexAttrib4bv := SDL_GL_GetProcAddress('glVertexAttrib4bv'); - if not Assigned(glVertexAttrib4bv) then Exit; - glVertexAttrib4d := SDL_GL_GetProcAddress('glVertexAttrib4d'); - if not Assigned(glVertexAttrib4d) then Exit; - glVertexAttrib4dv := SDL_GL_GetProcAddress('glVertexAttrib4dv'); - if not Assigned(glVertexAttrib4dv) then Exit; - glVertexAttrib4f := SDL_GL_GetProcAddress('glVertexAttrib4f'); - if not Assigned(glVertexAttrib4f) then Exit; - glVertexAttrib4fv := SDL_GL_GetProcAddress('glVertexAttrib4fv'); - if not Assigned(glVertexAttrib4fv) then Exit; - glVertexAttrib4iv := SDL_GL_GetProcAddress('glVertexAttrib4iv'); - if not Assigned(glVertexAttrib4iv) then Exit; - glVertexAttrib4s := SDL_GL_GetProcAddress('glVertexAttrib4s'); - if not Assigned(glVertexAttrib4s) then Exit; - glVertexAttrib4sv := SDL_GL_GetProcAddress('glVertexAttrib4sv'); - if not Assigned(glVertexAttrib4sv) then Exit; - glVertexAttrib4ubv := SDL_GL_GetProcAddress('glVertexAttrib4ubv'); - if not Assigned(glVertexAttrib4ubv) then Exit; - glVertexAttrib4uiv := SDL_GL_GetProcAddress('glVertexAttrib4uiv'); - if not Assigned(glVertexAttrib4uiv) then Exit; - glVertexAttrib4usv := SDL_GL_GetProcAddress('glVertexAttrib4usv'); - if not Assigned(glVertexAttrib4usv) then Exit; - glVertexAttribPointer := SDL_GL_GetProcAddress('glVertexAttribPointer'); - if not Assigned(glVertexAttribPointer) then Exit; - Result := TRUE; - -end; - -function glext_LoadExtension(ext: String): Boolean; -begin - - Result := FALSE; - - if ext = 'GL_version_1_2' then Result := Load_GL_version_1_2 - else if ext = 'GL_ARB_imaging' then Result := Load_GL_ARB_imaging - else if ext = 'GL_version_1_3' then Result := Load_GL_version_1_3 - else if ext = 'GL_ARB_multitexture' then Result := Load_GL_ARB_multitexture - else if ext = 'GL_ARB_transpose_matrix' then Result := Load_GL_ARB_transpose_matrix - else if ext = 'GL_ARB_multisample' then Result := Load_GL_ARB_multisample - else if ext = 'GL_ARB_texture_env_add' then Result := Load_GL_ARB_texture_env_add - {$IFDEF WINDOWS} - else if ext = 'WGL_ARB_extensions_string' then Result := Load_WGL_ARB_extensions_string - else if ext = 'WGL_ARB_buffer_region' then Result := Load_WGL_ARB_buffer_region - {$ENDIF} - else if ext = 'GL_ARB_texture_cube_map' then Result := Load_GL_ARB_texture_cube_map - else if ext = 'GL_ARB_depth_texture' then Result := Load_GL_ARB_depth_texture - else if ext = 'GL_ARB_point_parameters' then Result := Load_GL_ARB_point_parameters - else if ext = 'GL_ARB_shadow' then Result := Load_GL_ARB_shadow - else if ext = 'GL_ARB_shadow_ambient' then Result := Load_GL_ARB_shadow_ambient - else if ext = 'GL_ARB_texture_border_clamp' then Result := Load_GL_ARB_texture_border_clamp - else if ext = 'GL_ARB_texture_compression' then Result := Load_GL_ARB_texture_compression - else if ext = 'GL_ARB_texture_env_combine' then Result := Load_GL_ARB_texture_env_combine - else if ext = 'GL_ARB_texture_env_crossbar' then Result := Load_GL_ARB_texture_env_crossbar - else if ext = 'GL_ARB_texture_env_dot3' then Result := Load_GL_ARB_texture_env_dot3 - else if ext = 'GL_ARB_texture_mirrored_repeat' then Result := Load_GL_ARB_texture_mirrored_repeat - else if ext = 'GL_ARB_vertex_blend' then Result := Load_GL_ARB_vertex_blend - else if ext = 'GL_ARB_vertex_program' then Result := Load_GL_ARB_vertex_program - else if ext = 'GL_ARB_window_pos' then Result := Load_GL_ARB_window_pos - else if ext = 'GL_EXT_422_pixels' then Result := Load_GL_EXT_422_pixels - else if ext = 'GL_EXT_abgr' then Result := Load_GL_EXT_abgr - else if ext = 'GL_EXT_bgra' then Result := Load_GL_EXT_bgra - else if ext = 'GL_EXT_blend_color' then Result := Load_GL_EXT_blend_color - else if ext = 'GL_EXT_blend_func_separate' then Result := Load_GL_EXT_blend_func_separate - else if ext = 'GL_EXT_blend_logic_op' then Result := Load_GL_EXT_blend_logic_op - else if ext = 'GL_EXT_blend_minmax' then Result := Load_GL_EXT_blend_minmax - else if ext = 'GL_EXT_blend_subtract' then Result := Load_GL_EXT_blend_subtract - else if ext = 'GL_EXT_clip_volume_hint' then Result := Load_GL_EXT_clip_volume_hint - else if ext = 'GL_EXT_color_subtable' then Result := Load_GL_EXT_color_subtable - else if ext = 'GL_EXT_compiled_vertex_array' then Result := Load_GL_EXT_compiled_vertex_array - else if ext = 'GL_EXT_convolution' then Result := Load_GL_EXT_convolution - else if ext = 'GL_EXT_histogram' then Result := Load_GL_EXT_histogram - else if ext = 'GL_EXT_multi_draw_arrays' then Result := Load_GL_EXT_multi_draw_arrays - else if ext = 'GL_EXT_packed_pixels' then Result := Load_GL_EXT_packed_pixels - else if ext = 'GL_EXT_paletted_texture' then Result := Load_GL_EXT_paletted_texture - else if ext = 'GL_EXT_point_parameters' then Result := Load_GL_EXT_point_parameters - else if ext = 'GL_EXT_polygon_offset' then Result := Load_GL_EXT_polygon_offset - else if ext = 'GL_EXT_separate_specular_color' then Result := Load_GL_EXT_separate_specular_color - else if ext = 'GL_EXT_shadow_funcs' then Result := Load_GL_EXT_shadow_funcs - else if ext = 'GL_EXT_shared_texture_palette' then Result := Load_GL_EXT_shared_texture_palette - else if ext = 'GL_EXT_stencil_two_side' then Result := Load_GL_EXT_stencil_two_side - else if ext = 'GL_EXT_stencil_wrap' then Result := Load_GL_EXT_stencil_wrap - else if ext = 'GL_EXT_subtexture' then Result := Load_GL_EXT_subtexture - else if ext = 'GL_EXT_texture3D' then Result := Load_GL_EXT_texture3D - else if ext = 'GL_EXT_texture_compression_s3tc' then Result := Load_GL_EXT_texture_compression_s3tc - else if ext = 'GL_EXT_texture_env_add' then Result := Load_GL_EXT_texture_env_add - else if ext = 'GL_EXT_texture_env_combine' then Result := Load_GL_EXT_texture_env_combine - else if ext = 'GL_EXT_texture_env_dot3' then Result := Load_GL_EXT_texture_env_dot3 - else if ext = 'GL_EXT_texture_filter_anisotropic' then Result := Load_GL_EXT_texture_filter_anisotropic - else if ext = 'GL_EXT_texture_lod_bias' then Result := Load_GL_EXT_texture_lod_bias - else if ext = 'GL_EXT_texture_object' then Result := Load_GL_EXT_texture_object - else if ext = 'GL_EXT_vertex_array' then Result := Load_GL_EXT_vertex_array - else if ext = 'GL_EXT_vertex_shader' then Result := Load_GL_EXT_vertex_shader - else if ext = 'GL_EXT_vertex_weighting' then Result := Load_GL_EXT_vertex_weighting - else if ext = 'GL_HP_occlusion_test' then Result := Load_GL_HP_occlusion_test - else if ext = 'GL_NV_blend_square' then Result := Load_GL_NV_blend_square - else if ext = 'GL_NV_copy_depth_to_color' then Result := Load_GL_NV_copy_depth_to_color - else if ext = 'GL_NV_depth_clamp' then Result := Load_GL_NV_depth_clamp - else if ext = 'GL_NV_evaluators' then Result := Load_GL_NV_evaluators - else if ext = 'GL_NV_fence' then Result := Load_GL_NV_fence - else if ext = 'GL_NV_fog_distance' then Result := Load_GL_NV_fog_distance - else if ext = 'GL_NV_light_max_exponent' then Result := Load_GL_NV_light_max_exponent - else if ext = 'GL_NV_multisample_filter_hint' then Result := Load_GL_NV_multisample_filter_hint - else if ext = 'GL_NV_occlusion_query' then Result := Load_GL_NV_occlusion_query - else if ext = 'GL_NV_packed_depth_stencil' then Result := Load_GL_NV_packed_depth_stencil - else if ext = 'GL_NV_point_sprite' then Result := Load_GL_NV_point_sprite - else if ext = 'GL_NV_register_combiners' then Result := Load_GL_NV_register_combiners - else if ext = 'GL_NV_register_combiners2' then Result := Load_GL_NV_register_combiners2 - else if ext = 'GL_NV_texgen_emboss' then Result := Load_GL_NV_texgen_emboss - else if ext = 'GL_NV_texgen_reflection' then Result := Load_GL_NV_texgen_reflection - else if ext = 'GL_NV_texture_compression_vtc' then Result := Load_GL_NV_texture_compression_vtc - else if ext = 'GL_NV_texture_env_combine4' then Result := Load_GL_NV_texture_env_combine4 - else if ext = 'GL_NV_texture_rectangle' then Result := Load_GL_NV_texture_rectangle - else if ext = 'GL_NV_texture_shader' then Result := Load_GL_NV_texture_shader - else if ext = 'GL_NV_texture_shader2' then Result := Load_GL_NV_texture_shader2 - else if ext = 'GL_NV_texture_shader3' then Result := Load_GL_NV_texture_shader3 - else if ext = 'GL_NV_vertex_array_range' then Result := Load_GL_NV_vertex_array_range - else if ext = 'GL_NV_vertex_array_range2' then Result := Load_GL_NV_vertex_array_range2 - else if ext = 'GL_NV_vertex_program' then Result := Load_GL_NV_vertex_program - else if ext = 'GL_NV_vertex_program1_1' then Result := Load_GL_NV_vertex_program1_1 - else if ext = 'GL_ATI_element_array' then Result := Load_GL_ATI_element_array - else if ext = 'GL_ATI_envmap_bumpmap' then Result := Load_GL_ATI_envmap_bumpmap - else if ext = 'GL_ATI_fragment_shader' then Result := Load_GL_ATI_fragment_shader - else if ext = 'GL_ATI_pn_triangles' then Result := Load_GL_ATI_pn_triangles - else if ext = 'GL_ATI_texture_mirror_once' then Result := Load_GL_ATI_texture_mirror_once - else if ext = 'GL_ATI_vertex_array_object' then Result := Load_GL_ATI_vertex_array_object - else if ext = 'GL_ATI_vertex_streams' then Result := Load_GL_ATI_vertex_streams - {$IFDEF WINDOWS} - else if ext = 'WGL_I3D_image_buffer' then Result := Load_WGL_I3D_image_buffer - else if ext = 'WGL_I3D_swap_frame_lock' then Result := Load_WGL_I3D_swap_frame_lock - else if ext = 'WGL_I3D_swap_frame_usage' then Result := Load_WGL_I3D_swap_frame_usage - {$ENDIF} - else if ext = 'GL_3DFX_texture_compression_FXT1' then Result := Load_GL_3DFX_texture_compression_FXT1 - else if ext = 'GL_IBM_cull_vertex' then Result := Load_GL_IBM_cull_vertex - else if ext = 'GL_IBM_multimode_draw_arrays' then Result := Load_GL_IBM_multimode_draw_arrays - else if ext = 'GL_IBM_raster_pos_clip' then Result := Load_GL_IBM_raster_pos_clip - else if ext = 'GL_IBM_texture_mirrored_repeat' then Result := Load_GL_IBM_texture_mirrored_repeat - else if ext = 'GL_IBM_vertex_array_lists' then Result := Load_GL_IBM_vertex_array_lists - else if ext = 'GL_MESA_resize_buffers' then Result := Load_GL_MESA_resize_buffers - else if ext = 'GL_MESA_window_pos' then Result := Load_GL_MESA_window_pos - else if ext = 'GL_OML_interlace' then Result := Load_GL_OML_interlace - else if ext = 'GL_OML_resample' then Result := Load_GL_OML_resample - else if ext = 'GL_OML_subsample' then Result := Load_GL_OML_subsample - else if ext = 'GL_SGIS_generate_mipmap' then Result := Load_GL_SGIS_generate_mipmap - else if ext = 'GL_SGIS_multisample' then Result := Load_GL_SGIS_multisample - else if ext = 'GL_SGIS_pixel_texture' then Result := Load_GL_SGIS_pixel_texture - else if ext = 'GL_SGIS_texture_border_clamp' then Result := Load_GL_SGIS_texture_border_clamp - else if ext = 'GL_SGIS_texture_color_mask' then Result := Load_GL_SGIS_texture_color_mask - else if ext = 'GL_SGIS_texture_edge_clamp' then Result := Load_GL_SGIS_texture_edge_clamp - else if ext = 'GL_SGIS_texture_lod' then Result := Load_GL_SGIS_texture_lod - else if ext = 'GL_SGIS_depth_texture' then Result := Load_GL_SGIS_depth_texture - else if ext = 'GL_SGIX_fog_offset' then Result := Load_GL_SGIX_fog_offset - else if ext = 'GL_SGIX_interlace' then Result := Load_GL_SGIX_interlace - else if ext = 'GL_SGIX_shadow_ambient' then Result := Load_GL_SGIX_shadow_ambient - else if ext = 'GL_SGI_color_matrix' then Result := Load_GL_SGI_color_matrix - else if ext = 'GL_SGI_color_table' then Result := Load_GL_SGI_color_table - else if ext = 'GL_SGI_texture_color_table' then Result := Load_GL_SGI_texture_color_table - else if ext = 'GL_SUN_vertex' then Result := Load_GL_SUN_vertex - else if ext = 'GL_ARB_fragment_program' then Result := Load_GL_ARB_fragment_program - else if ext = 'GL_ATI_text_fragment_shader' then Result := Load_GL_ATI_text_fragment_shader - else if ext = 'GL_APPLE_client_storage' then Result := Load_GL_APPLE_client_storage - else if ext = 'GL_APPLE_element_array' then Result := Load_GL_APPLE_element_array - else if ext = 'GL_APPLE_fence' then Result := Load_GL_APPLE_fence - else if ext = 'GL_APPLE_vertex_array_object' then Result := Load_GL_APPLE_vertex_array_object - else if ext = 'GL_APPLE_vertex_array_range' then Result := Load_GL_APPLE_vertex_array_range - {$IFDEF WINDOWS} - else if ext = 'WGL_ARB_pixel_format' then Result := Load_WGL_ARB_pixel_format - else if ext = 'WGL_ARB_make_current_read' then Result := Load_WGL_ARB_make_current_read - else if ext = 'WGL_ARB_pbuffer' then Result := Load_WGL_ARB_pbuffer - else if ext = 'WGL_EXT_swap_control' then Result := Load_WGL_EXT_swap_control - else if ext = 'WGL_ARB_render_texture' then Result := Load_WGL_ARB_render_texture - else if ext = 'WGL_EXT_extensions_string' then Result := Load_WGL_EXT_extensions_string - else if ext = 'WGL_EXT_make_current_read' then Result := Load_WGL_EXT_make_current_read - else if ext = 'WGL_EXT_pbuffer' then Result := Load_WGL_EXT_pbuffer - else if ext = 'WGL_EXT_pixel_format' then Result := Load_WGL_EXT_pixel_format - else if ext = 'WGL_I3D_digital_video_control' then Result := Load_WGL_I3D_digital_video_control - else if ext = 'WGL_I3D_gamma' then Result := Load_WGL_I3D_gamma - else if ext = 'WGL_I3D_genlock' then Result := Load_WGL_I3D_genlock - {$ENDIF} - else if ext = 'GL_ARB_matrix_palette' then Result := Load_GL_ARB_matrix_palette - else if ext = 'GL_NV_element_array' then Result := Load_GL_NV_element_array - else if ext = 'GL_NV_float_buffer' then Result := Load_GL_NV_float_buffer - else if ext = 'GL_NV_fragment_program' then Result := Load_GL_NV_fragment_program - else if ext = 'GL_NV_primitive_restart' then Result := Load_GL_NV_primitive_restart - else if ext = 'GL_NV_vertex_program2' then Result := Load_GL_NV_vertex_program2 - {$IFDEF WINDOWS} - else if ext = 'WGL_NV_render_texture_rectangle' then Result := Load_WGL_NV_render_texture_rectangle - {$ENDIF} - else if ext = 'GL_NV_pixel_data_range' then Result := Load_GL_NV_pixel_data_range - else if ext = 'GL_EXT_texture_rectangle' then Result := Load_GL_EXT_texture_rectangle - else if ext = 'GL_S3_s3tc' then Result := Load_GL_S3_s3tc - else if ext = 'GL_ATI_draw_buffers' then Result := Load_GL_ATI_draw_buffers - {$IFDEF WINDOWS} - else if ext = 'WGL_ATI_pixel_format_float' then Result := Load_WGL_ATI_pixel_format_float - {$ENDIF} - else if ext = 'GL_ATI_texture_env_combine3' then Result := Load_GL_ATI_texture_env_combine3 - else if ext = 'GL_ATI_texture_float' then Result := Load_GL_ATI_texture_float - else if ext = 'GL_NV_texture_expand_normal' then Result := Load_GL_NV_texture_expand_normal - else if ext = 'GL_NV_half_float' then Result := Load_GL_NV_half_float - else if ext = 'GL_ATI_map_object_buffer' then Result := Load_GL_ATI_map_object_buffer - else if ext = 'GL_ATI_separate_stencil' then Result := Load_GL_ATI_separate_stencil - else if ext = 'GL_ATI_vertex_attrib_array_object' then Result := Load_GL_ATI_vertex_attrib_array_object - else if ext = 'GL_ARB_vertex_buffer_object' then Result := Load_GL_ARB_vertex_buffer_object - else if ext = 'GL_ARB_occlusion_query' then Result := Load_GL_ARB_occlusion_query - else if ext = 'GL_ARB_shader_objects' then Result := Load_GL_ARB_shader_objects - else if ext = 'GL_ARB_vertex_shader' then Result := Load_GL_ARB_vertex_shader - else if ext = 'GL_ARB_fragment_shader' then Result := Load_GL_ARB_fragment_shader - else if ext = 'GL_ARB_shading_language_100' then Result := Load_GL_ARB_shading_language_100 - else if ext = 'GL_ARB_texture_non_power_of_two' then Result := Load_GL_ARB_texture_non_power_of_two - else if ext = 'GL_ARB_point_sprite' then Result := Load_GL_ARB_point_sprite - else if ext = 'GL_EXT_depth_bounds_test' then Result := Load_GL_EXT_depth_bounds_test - else if ext = 'GL_EXT_secondary_color' then Result := Load_GL_EXT_secondary_color - else if ext = 'GL_EXT_texture_mirror_clamp' then Result := Load_GL_EXT_texture_mirror_clamp - else if ext = 'GL_EXT_blend_equation_separate' then Result := Load_GL_EXT_blend_equation_separate - else if ext = 'GL_MESA_pack_invert' then Result := Load_GL_MESA_pack_invert - else if ext = 'GL_MESA_ycbcr_texture' then Result := Load_GL_MESA_ycbcr_texture - else if ext = 'GL_ARB_fragment_program_shadow' then Result := Load_GL_ARB_fragment_program_shadow - else if ext = 'GL_EXT_fog_coord' then Result := Load_GL_EXT_fog_coord - else if ext = 'GL_NV_fragment_program_option' then Result := Load_GL_NV_fragment_program_option - else if ext = 'GL_EXT_pixel_buffer_object' then Result := Load_GL_EXT_pixel_buffer_object - else if ext = 'GL_NV_fragment_program2' then Result := Load_GL_NV_fragment_program2 - else if ext = 'GL_NV_vertex_program2_option' then Result := Load_GL_NV_vertex_program2_option - else if ext = 'GL_NV_vertex_program3' then Result := Load_GL_NV_vertex_program3 - else if ext = 'GL_ARB_draw_buffers' then Result := Load_GL_ARB_draw_buffers - else if ext = 'GL_ARB_texture_rectangle' then Result := Load_GL_ARB_texture_rectangle - else if ext = 'GL_ARB_color_buffer_float' then Result := Load_GL_ARB_color_buffer_float - else if ext = 'GL_ARB_half_float_pixel' then Result := Load_GL_ARB_half_float_pixel - else if ext = 'GL_ARB_texture_float' then Result := Load_GL_ARB_texture_float - else if ext = 'GL_EXT_texture_compression_dxt1' then Result := Load_GL_EXT_texture_compression_dxt1 - else if ext = 'GL_ARB_pixel_buffer_object' then Result := Load_GL_ARB_pixel_buffer_object - else if ext = 'GL_EXT_framebuffer_object' then Result := Load_GL_EXT_framebuffer_object - else if ext = 'GL_version_1_4' then Result := Load_GL_version_1_4 - else if ext = 'GL_version_1_5' then Result := Load_GL_version_1_5 - else if ext = 'GL_version_2_0' then Result := Load_GL_version_2_0 - -end; - -end. diff --git a/src/lib/JEDI-SDL/OpenGL/Pas/glu.pas b/src/lib/JEDI-SDL/OpenGL/Pas/glu.pas deleted file mode 100644 index 876270ff..00000000 --- a/src/lib/JEDI-SDL/OpenGL/Pas/glu.pas +++ /dev/null @@ -1,582 +0,0 @@ -unit glu; -{ - $Id: glu.pas,v 1.8 2007/05/20 20:28:31 savage Exp $ - - Adaption of the delphi3d.net OpenGL units to FreePascal - Sebastian Guenther (sg@freepascal.org) in 2002 - These units are free to use -} - -(*++ BUILD Version: 0004 // Increment this if a change has global effects - -Copyright (c) 1985-95, Microsoft Corporation - -Module Name: - - glu.h - -Abstract: - - Procedure declarations, constant definitions and macros for the OpenGL - Utility Library. - ---*) - -(* -** Copyright 1991-1993, Silicon Graphics, Inc. -** All Rights Reserved. -** -** This is UNPUBLISHED PROPRIETARY SOURCE CODE of Silicon Graphics, Inc.; -** the contents of this file may not be disclosed to third parties, copied or -** duplicated in any form, in whole or in part, without the prior written -** permission of Silicon Graphics, Inc. -** -** RESTRICTED RIGHTS LEGEND: -** Use, duplication or disclosure by the Government is subject to restrictions -** as set forth in subdivision (c)(1)(ii) of the Rights in Technical Data -** and Computer Software clause at DFARS 252.227-7013, and/or in similar or -** successor clauses in the FAR, DOD or NASA FAR Supplement. Unpublished - -** rights reserved under the Copyright Laws of the United States. -*) - -(* -** Return the error string associated with a particular error code. -** This will return 0 for an invalid error code. -** -** The generic function prototype that can be compiled for ANSI or Unicode -** is defined as follows: -** -** LPCTSTR APIENTRY gluErrorStringWIN (GLenum errCode); -*) - -{******************************************************************************} -{ } -{ Converted to Delphi by Tom Nuydens (tom@delphi3d.net) } -{ For the latest updates, visit Delphi3D: http://www.delphi3d.net } -{ } -{ Modified for Delphi/Kylix and FreePascal } -{ by Dominique Louis ( Dominique@Savagesoftware.com.au) } -{ For the latest updates, visit JEDI-SDL : http://www.sf.net/projects/jedi-sdl } -{ } -{******************************************************************************} - -{ - $Log: glu.pas,v $ - Revision 1.8 2007/05/20 20:28:31 savage - Initial Changes to Handle 64 Bits - - Revision 1.7 2006/11/26 16:35:49 savage - Messed up the last change to GLUtessCombineDataProc, had to reapply it. Thanks Michalis. - - Revision 1.6 2006/11/25 23:38:02 savage - Changes as proposed by Michalis Kamburelis for better FPC support - - Revision 1.5 2006/11/20 21:20:59 savage - Updated to work in MacOS X - - Revision 1.4 2005/05/22 18:52:09 savage - Changes as suggested by Michalis Kamburelis. Thanks again. - - Revision 1.3 2004/10/07 21:01:29 savage - Fix for FPC - - Revision 1.2 2004/08/14 22:54:30 savage - Updated so that Library name defines are correctly defined for MacOS X. - - Revision 1.1 2004/03/30 21:53:54 savage - Moved to it's own folder. - - Revision 1.4 2004/02/20 17:09:55 savage - Code tidied up in gl, glu and glut, while extensions in glext.pas are now loaded using SDL_GL_GetProcAddress, thus making it more cross-platform compatible, but now more tied to SDL. - - Revision 1.3 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.2 2004/02/14 00:09:19 savage - Changed uses to now make use of moduleloader.pas rather than dllfuncs.pas - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - Revision 1.4 2003/06/02 12:32:13 savage - Modified Sources to avoid warnings with Delphi by moving CVS Logging to the top of the header files. Hopefully CVS Logging still works. - - Revision 1.3 2003/05/29 22:55:00 savage - Make use of new DLLFunctions - - Revision 1.2 2003/05/27 09:39:53 savage - Added better Gnu Pascal support. - - Revision 1.1 2003/05/11 13:18:03 savage - Newest OpenGL Headers For Delphi, Kylix and FPC - - Revision 1.2 2002/10/13 14:36:47 sg - * Win32 fix: The OS symbol is called "Win32", not "Windows" - - Revision 1.1 2002/10/13 13:57:31 sg - * Finally, the new units are available: Match the C headers more closely; - support for OpenGL extensions, and much more. Based on the Delphi units - by Tom Nuydens of delphi3d.net - -} - -interface - -{$I jedi-sdl.inc} - -uses -{$IFDEF __GPC__} - gpc, -{$ENDIF} - moduleloader, - gl; - -const -{$IFDEF WINDOWS} - GLuLibName = 'glu32.dll'; -{$ENDIF} - -{$IFDEF UNIX} -{$IFDEF DARWIN} - GLuLibName = '/System/Library/Frameworks/OpenGL.framework/Libraries/libGLU.dylib'; -{$ELSE} - GLuLibName = 'libGLU.so.1'; -{$ENDIF} -{$ENDIF} - -type - TViewPortArray = array[ 0..3 ] of GLint; - T16dArray = array[ 0..15 ] of GLdouble; - TCallBack = procedure; - T3dArray = array[ 0..2 ] of GLdouble; - T4pArray = array[ 0..3 ] of Pointer; - T4fArray = array[ 0..3 ] of GLfloat; -{$IFNDEF __GPC__} - PPointer = ^Pointer; -{$ENDIF} - -var - gluErrorString : function( errCode : GLenum ) : PChar; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluErrorUnicodeStringEXT : function( errCode : GLenum ) : PWideChar; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluGetString : function( name : GLenum ) : PChar; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluOrtho2D : procedure( left, right, bottom, top : GLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluPerspective : procedure( fovy, aspect, zNear, zFar : GLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluPickMatrix : procedure( x, y, width, height : GLdouble; var viewport : TViewPortArray ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluLookAt : procedure( eyex, eyey, eyez, centerx, centery, centerz, upx, upy, upz : GLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluProject : function( objx, objy, objz : GLdouble; var modelMatrix, projMatrix : T16dArray; var viewport : TViewPortArray; winx, winy, winz : PGLdouble ) : Integer; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluUnProject : function( winx, winy, winz : GLdouble; var modelMatrix, projMatrix : T16dArray; var viewport : TViewPortArray; objx, objy, objz : PGLdouble ) : Integer; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluScaleImage : function( format : GLenum; widthin, heightin : GLint; typein : GLenum; const datain : Pointer; widthout, heightout : GLint; typeout : GLenum; dataout : Pointer ) : Integer; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluBuild1DMipmaps : function( target : GLenum; components, width : GLint; format, atype : GLenum; const data : Pointer ) : Integer; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluBuild2DMipmaps : function( target : GLenum; components, width, height : GLint; format, atype : GLenum; const data : Pointer ) : Integer; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - -type - GLUnurbs = record - end; PGLUnurbs = ^GLUnurbs; - GLUquadric = record - end; PGLUquadric = ^GLUquadric; - GLUtesselator = record - end; PGLUtesselator = ^GLUtesselator; - - // backwards compatibility: - GLUnurbsObj = GLUnurbs; PGLUnurbsObj = PGLUnurbs; - GLUquadricObj = GLUquadric; PGLUquadricObj = PGLUquadric; - GLUtesselatorObj = GLUtesselator; PGLUtesselatorObj = PGLUtesselator; - GLUtriangulatorObj = GLUtesselator; PGLUtriangulatorObj = PGLUtesselator; - -var - gluNewQuadric : function : PGLUquadric; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluDeleteQuadric : procedure( state : PGLUquadric ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluQuadricNormals : procedure( quadObject : PGLUquadric; normals : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluQuadricTexture : procedure( quadObject : PGLUquadric; textureCoords : GLboolean ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluQuadricOrientation : procedure( quadObject : PGLUquadric; orientation : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluQuadricDrawStyle : procedure( quadObject : PGLUquadric; drawStyle : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluCylinder : procedure( qobj : PGLUquadric; baseRadius, topRadius, height : GLdouble; slices, stacks : GLint ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluDisk : procedure( qobj : PGLUquadric; innerRadius, outerRadius : GLdouble; slices, loops : GLint ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluPartialDisk : procedure( qobj : PGLUquadric; innerRadius, outerRadius : GLdouble; slices, loops : GLint; startAngle, sweepAngle : GLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluSphere : procedure( qobj : PGLuquadric; radius : GLdouble; slices, stacks : GLint ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluQuadricCallback : procedure( qobj : PGLUquadric; which : GLenum; fn : TCallBack ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNewTess : function : PGLUtesselator; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluDeleteTess : procedure( tess : PGLUtesselator ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessBeginPolygon : procedure( tess : PGLUtesselator; polygon_data : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessBeginContour : procedure( tess : PGLUtesselator ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessVertex : procedure( tess : PGLUtesselator; var coords : T3dArray; data : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessEndContour : procedure( tess : PGLUtesselator ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessEndPolygon : procedure( tess : PGLUtesselator ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessProperty : procedure( tess : PGLUtesselator; which : GLenum; value : GLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessNormal : procedure( tess : PGLUtesselator; x, y, z : GLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluTessCallback : procedure( tess : PGLUtesselator; which : GLenum; fn : TCallBack ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluGetTessProperty : procedure( tess : PGLUtesselator; which : GLenum; value : PGLdouble ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNewNurbsRenderer : function : PGLUnurbs; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluDeleteNurbsRenderer : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluBeginSurface : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluBeginCurve : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluEndCurve : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluEndSurface : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluBeginTrim : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluEndTrim : procedure( nobj : PGLUnurbs ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluPwlCurve : procedure( nobj : PGLUnurbs; count : GLint; aarray : PGLfloat; stride : GLint; atype : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNurbsCurve : procedure( nobj : PGLUnurbs; nknots : GLint; knot : PGLfloat; stride : GLint; ctlarray : PGLfloat; order : GLint; atype : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNurbsSurface : procedure( nobj : PGLUnurbs; sknot_count : GLint; sknot : PGLfloat; tknot_count : GLint; tknot : PGLfloat; s_stride, t_stride : GLint; ctlarray : PGLfloat; sorder, torder : GLint; atype : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluLoadSamplingMatrices : procedure( nobj : PGLUnurbs; var modelMatrix, projMatrix : T16dArray; var viewport : TViewPortArray ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNurbsProperty : procedure( nobj : PGLUnurbs; aproperty : GLenum; value : GLfloat ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluGetNurbsProperty : procedure( nobj : PGLUnurbs; aproperty : GLenum; value : PGLfloat ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNurbsCallback : procedure( nobj : PGLUnurbs; which : GLenum; fn : TCallBack ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - -(**** Callback function prototypes ****) - -type - // gluQuadricCallback - GLUquadricErrorProc = procedure( p : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - - // gluTessCallback - GLUtessBeginProc = procedure( p : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessEdgeFlagProc = procedure( p : GLboolean ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessVertexProc = procedure( p : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessEndProc = procedure; {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessErrorProc = procedure( p : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessCombineProc = procedure( var p1 : T3dArray; p2 : T4pArray; p3 : T4fArray; p4 : PPointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessBeginDataProc = procedure( p1 : GLenum; p2 : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessEdgeFlagDataProc = procedure( p1 : GLboolean; p2 : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessVertexDataProc = procedure( p1, p2 : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessEndDataProc = procedure( p : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessErrorDataProc = procedure( p1 : GLenum; p2 : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - GLUtessCombineDataProc = procedure( var p1 : T3dArray; var p2 : T4pArray; var p3 : T4fArray; - p4 : PPointer; p5 : Pointer ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - - // gluNurbsCallback - GLUnurbsErrorProc = procedure( p : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - - -//*** Generic constants ****/ - -const - // Version - GLU_VERSION_1_1 = 1; - GLU_VERSION_1_2 = 1; - - // Errors: (return value 0 = no error) - GLU_INVALID_ENUM = 100900; - GLU_INVALID_VALUE = 100901; - GLU_OUT_OF_MEMORY = 100902; - GLU_INCOMPATIBLE_GL_VERSION = 100903; - - // StringName - GLU_VERSION = 100800; - GLU_EXTENSIONS = 100801; - - // Boolean - GLU_TRUE = GL_TRUE; - GLU_FALSE = GL_FALSE; - - - //*** Quadric constants ****/ - - // QuadricNormal - GLU_SMOOTH = 100000; - GLU_FLAT = 100001; - GLU_NONE = 100002; - - // QuadricDrawStyle - GLU_POINT = 100010; - GLU_LINE = 100011; - GLU_FILL = 100012; - GLU_SILHOUETTE = 100013; - - // QuadricOrientation - GLU_OUTSIDE = 100020; - GLU_INSIDE = 100021; - - // Callback types: - // GLU_ERROR = 100103; - - - //*** Tesselation constants ****/ - - GLU_TESS_MAX_COORD = 1.0E150; - - // TessProperty - GLU_TESS_WINDING_RULE = 100140; - GLU_TESS_BOUNDARY_ONLY = 100141; - GLU_TESS_TOLERANCE = 100142; - - // TessWinding - GLU_TESS_WINDING_ODD = 100130; - GLU_TESS_WINDING_NONZERO = 100131; - GLU_TESS_WINDING_POSITIVE = 100132; - GLU_TESS_WINDING_NEGATIVE = 100133; - GLU_TESS_WINDING_ABS_GEQ_TWO = 100134; - - // TessCallback - GLU_TESS_BEGIN = 100100; // void (CALLBACK*)(GLenum type) - GLU_TESS_VERTEX = 100101; // void (CALLBACK*)(void *data) - GLU_TESS_END = 100102; // void (CALLBACK*)(void) - GLU_TESS_ERROR = 100103; // void (CALLBACK*)(GLenum errno) - GLU_TESS_EDGE_FLAG = 100104; // void (CALLBACK*)(GLboolean boundaryEdge) - GLU_TESS_COMBINE = 100105; { void (CALLBACK*)(GLdouble coords[3], - void *data[4], - GLfloat weight[4], - void **dataOut) } - GLU_TESS_BEGIN_DATA = 100106; { void (CALLBACK*)(GLenum type, - void *polygon_data) } - GLU_TESS_VERTEX_DATA = 100107; { void (CALLBACK*)(void *data, - void *polygon_data) } - GLU_TESS_END_DATA = 100108; // void (CALLBACK*)(void *polygon_data) - GLU_TESS_ERROR_DATA = 100109; { void (CALLBACK*)(GLenum errno, - void *polygon_data) } - GLU_TESS_EDGE_FLAG_DATA = 100110; { void (CALLBACK*)(GLboolean boundaryEdge, - void *polygon_data) } - GLU_TESS_COMBINE_DATA = 100111; { void (CALLBACK*)(GLdouble coords[3], - void *data[4], - GLfloat weight[4], - void **dataOut, - void *polygon_data) } - - // TessError - GLU_TESS_ERROR1 = 100151; - GLU_TESS_ERROR2 = 100152; - GLU_TESS_ERROR3 = 100153; - GLU_TESS_ERROR4 = 100154; - GLU_TESS_ERROR5 = 100155; - GLU_TESS_ERROR6 = 100156; - GLU_TESS_ERROR7 = 100157; - GLU_TESS_ERROR8 = 100158; - - GLU_TESS_MISSING_BEGIN_POLYGON = GLU_TESS_ERROR1; - GLU_TESS_MISSING_BEGIN_CONTOUR = GLU_TESS_ERROR2; - GLU_TESS_MISSING_END_POLYGON = GLU_TESS_ERROR3; - GLU_TESS_MISSING_END_CONTOUR = GLU_TESS_ERROR4; - GLU_TESS_COORD_TOO_LARGE = GLU_TESS_ERROR5; - GLU_TESS_NEED_COMBINE_CALLBACK = GLU_TESS_ERROR6; - - //*** NURBS constants ****/ - - // NurbsProperty - GLU_AUTO_LOAD_MATRIX = 100200; - GLU_CULLING = 100201; - GLU_SAMPLING_TOLERANCE = 100203; - GLU_DISPLAY_MODE = 100204; - GLU_PARAMETRIC_TOLERANCE = 100202; - GLU_SAMPLING_METHOD = 100205; - GLU_U_STEP = 100206; - GLU_V_STEP = 100207; - - // NurbsSampling - GLU_PATH_LENGTH = 100215; - GLU_PARAMETRIC_ERROR = 100216; - GLU_DOMAIN_DISTANCE = 100217; - - - // NurbsTrim - GLU_MAP1_TRIM_2 = 100210; - GLU_MAP1_TRIM_3 = 100211; - - // NurbsDisplay - // GLU_FILL = 100012; - GLU_OUTLINE_POLYGON = 100240; - GLU_OUTLINE_PATCH = 100241; - - // NurbsCallback - // GLU_ERROR = 100103; - - // NurbsErrors - GLU_NURBS_ERROR1 = 100251; - GLU_NURBS_ERROR2 = 100252; - GLU_NURBS_ERROR3 = 100253; - GLU_NURBS_ERROR4 = 100254; - GLU_NURBS_ERROR5 = 100255; - GLU_NURBS_ERROR6 = 100256; - GLU_NURBS_ERROR7 = 100257; - GLU_NURBS_ERROR8 = 100258; - GLU_NURBS_ERROR9 = 100259; - GLU_NURBS_ERROR10 = 100260; - GLU_NURBS_ERROR11 = 100261; - GLU_NURBS_ERROR12 = 100262; - GLU_NURBS_ERROR13 = 100263; - GLU_NURBS_ERROR14 = 100264; - GLU_NURBS_ERROR15 = 100265; - GLU_NURBS_ERROR16 = 100266; - GLU_NURBS_ERROR17 = 100267; - GLU_NURBS_ERROR18 = 100268; - GLU_NURBS_ERROR19 = 100269; - GLU_NURBS_ERROR20 = 100270; - GLU_NURBS_ERROR21 = 100271; - GLU_NURBS_ERROR22 = 100272; - GLU_NURBS_ERROR23 = 100273; - GLU_NURBS_ERROR24 = 100274; - GLU_NURBS_ERROR25 = 100275; - GLU_NURBS_ERROR26 = 100276; - GLU_NURBS_ERROR27 = 100277; - GLU_NURBS_ERROR28 = 100278; - GLU_NURBS_ERROR29 = 100279; - GLU_NURBS_ERROR30 = 100280; - GLU_NURBS_ERROR31 = 100281; - GLU_NURBS_ERROR32 = 100282; - GLU_NURBS_ERROR33 = 100283; - GLU_NURBS_ERROR34 = 100284; - GLU_NURBS_ERROR35 = 100285; - GLU_NURBS_ERROR36 = 100286; - GLU_NURBS_ERROR37 = 100287; - -//*** Backwards compatibility for old tesselator ****/ - -var - gluBeginPolygon : procedure( tess : PGLUtesselator ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluNextContour : procedure( tess : PGLUtesselator; atype : GLenum ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - gluEndPolygon : procedure( tess : PGLUtesselator ); {$IFDEF WINDOWS}stdcall; {$ELSE}cdecl; {$ENDIF} - -const - // Contours types -- obsolete! - GLU_CW = 100120; - GLU_CCW = 100121; - GLU_INTERIOR = 100122; - GLU_EXTERIOR = 100123; - GLU_UNKNOWN = 100124; - - // Names without "TESS_" prefix - GLU_BEGIN = GLU_TESS_BEGIN; - GLU_VERTEX = GLU_TESS_VERTEX; - GLU_END = GLU_TESS_END; - GLU_ERROR = GLU_TESS_ERROR; - GLU_EDGE_FLAG = GLU_TESS_EDGE_FLAG; - -procedure LoadGLu( const dll : PChar ); -procedure FreeGLu; - -implementation - -var - LibGlu : TModuleHandle; - -procedure FreeGLu; -begin - - @gluErrorString := nil; - @gluErrorUnicodeStringEXT := nil; - @gluGetString := nil; - @gluOrtho2D := nil; - @gluPerspective := nil; - @gluPickMatrix := nil; - @gluLookAt := nil; - @gluProject := nil; - @gluUnProject := nil; - @gluScaleImage := nil; - @gluBuild1DMipmaps := nil; - @gluBuild2DMipmaps := nil; - @gluNewQuadric := nil; - @gluDeleteQuadric := nil; - @gluQuadricNormals := nil; - @gluQuadricTexture := nil; - @gluQuadricOrientation := nil; - @gluQuadricDrawStyle := nil; - @gluCylinder := nil; - @gluDisk := nil; - @gluPartialDisk := nil; - @gluSphere := nil; - @gluQuadricCallback := nil; - @gluNewTess := nil; - @gluDeleteTess := nil; - @gluTessBeginPolygon := nil; - @gluTessBeginContour := nil; - @gluTessVertex := nil; - @gluTessEndContour := nil; - @gluTessEndPolygon := nil; - @gluTessProperty := nil; - @gluTessNormal := nil; - @gluTessCallback := nil; - @gluGetTessProperty := nil; - @gluNewNurbsRenderer := nil; - @gluDeleteNurbsRenderer := nil; - @gluBeginSurface := nil; - @gluBeginCurve := nil; - @gluEndCurve := nil; - @gluEndSurface := nil; - @gluBeginTrim := nil; - @gluEndTrim := nil; - @gluPwlCurve := nil; - @gluNurbsCurve := nil; - @gluNurbsSurface := nil; - @gluLoadSamplingMatrices := nil; - @gluNurbsProperty := nil; - @gluGetNurbsProperty := nil; - @gluNurbsCallback := nil; - @gluBeginPolygon := nil; - @gluNextContour := nil; - @gluEndPolygon := nil; - - UnLoadModule( LibGlu ); - -end; - -procedure LoadGLu( const dll : PChar ); -begin - - FreeGLu; - - if LoadModule( LibGlu, dll ) then - begin - @gluErrorString := GetModuleSymbol( LibGlu, 'gluErrorString' ); - @gluErrorUnicodeStringEXT := GetModuleSymbol( LibGlu, 'gluErrorUnicodeStringEXT' ); - @gluGetString := GetModuleSymbol( LibGlu, 'gluGetString' ); - @gluOrtho2D := GetModuleSymbol( LibGlu, 'gluOrtho2D' ); - @gluPerspective := GetModuleSymbol( LibGlu, 'gluPerspective' ); - @gluPickMatrix := GetModuleSymbol( LibGlu, 'gluPickMatrix' ); - @gluLookAt := GetModuleSymbol( LibGlu, 'gluLookAt' ); - @gluProject := GetModuleSymbol( LibGlu, 'gluProject' ); - @gluUnProject := GetModuleSymbol( LibGlu, 'gluUnProject' ); - @gluScaleImage := GetModuleSymbol( LibGlu, 'gluScaleImage' ); - @gluBuild1DMipmaps := GetModuleSymbol( LibGlu, 'gluBuild1DMipmaps' ); - @gluBuild2DMipmaps := GetModuleSymbol( LibGlu, 'gluBuild2DMipmaps' ); - @gluNewQuadric := GetModuleSymbol( LibGlu, 'gluNewQuadric' ); - @gluDeleteQuadric := GetModuleSymbol( LibGlu, 'gluDeleteQuadric' ); - @gluQuadricNormals := GetModuleSymbol( LibGlu, 'gluQuadricNormals' ); - @gluQuadricTexture := GetModuleSymbol( LibGlu, 'gluQuadricTexture' ); - @gluQuadricOrientation := GetModuleSymbol( LibGlu, 'gluQuadricOrientation' ); - @gluQuadricDrawStyle := GetModuleSymbol( LibGlu, 'gluQuadricDrawStyle' ); - @gluCylinder := GetModuleSymbol( LibGlu, 'gluCylinder' ); - @gluDisk := GetModuleSymbol( LibGlu, 'gluDisk' ); - @gluPartialDisk := GetModuleSymbol( LibGlu, 'gluPartialDisk' ); - @gluSphere := GetModuleSymbol( LibGlu, 'gluSphere' ); - @gluQuadricCallback := GetModuleSymbol( LibGlu, 'gluQuadricCallback' ); - @gluNewTess := GetModuleSymbol( LibGlu, 'gluNewTess' ); - @gluDeleteTess := GetModuleSymbol( LibGlu, 'gluDeleteTess' ); - @gluTessBeginPolygon := GetModuleSymbol( LibGlu, 'gluTessBeginPolygon' ); - @gluTessBeginContour := GetModuleSymbol( LibGlu, 'gluTessBeginContour' ); - @gluTessVertex := GetModuleSymbol( LibGlu, 'gluTessVertex' ); - @gluTessEndContour := GetModuleSymbol( LibGlu, 'gluTessEndContour' ); - @gluTessEndPolygon := GetModuleSymbol( LibGlu, 'gluTessEndPolygon' ); - @gluTessProperty := GetModuleSymbol( LibGlu, 'gluTessProperty' ); - @gluTessNormal := GetModuleSymbol( LibGlu, 'gluTessNormal' ); - @gluTessCallback := GetModuleSymbol( LibGlu, 'gluTessCallback' ); - @gluGetTessProperty := GetModuleSymbol( LibGlu, 'gluGetTessProperty' ); - @gluNewNurbsRenderer := GetModuleSymbol( LibGlu, 'gluNewNurbsRenderer' ); - @gluDeleteNurbsRenderer := GetModuleSymbol( LibGlu, 'gluDeleteNurbsRenderer' ); - @gluBeginSurface := GetModuleSymbol( LibGlu, 'gluBeginSurface' ); - @gluBeginCurve := GetModuleSymbol( LibGlu, 'gluBeginCurve' ); - @gluEndCurve := GetModuleSymbol( LibGlu, 'gluEndCurve' ); - @gluEndSurface := GetModuleSymbol( LibGlu, 'gluEndSurface' ); - @gluBeginTrim := GetModuleSymbol( LibGlu, 'gluBeginTrim' ); - @gluEndTrim := GetModuleSymbol( LibGlu, 'gluEndTrim' ); - @gluPwlCurve := GetModuleSymbol( LibGlu, 'gluPwlCurve' ); - @gluNurbsCurve := GetModuleSymbol( LibGlu, 'gluNurbsCurve' ); - @gluNurbsSurface := GetModuleSymbol( LibGlu, 'gluNurbsSurface' ); - @gluLoadSamplingMatrices := GetModuleSymbol( LibGlu, 'gluLoadSamplingMatrices' ); - @gluNurbsProperty := GetModuleSymbol( LibGlu, 'gluNurbsProperty' ); - @gluGetNurbsProperty := GetModuleSymbol( LibGlu, 'gluGetNurbsProperty' ); - @gluNurbsCallback := GetModuleSymbol( LibGlu, 'gluNurbsCallback' ); - - @gluBeginPolygon := GetModuleSymbol( LibGlu, 'gluBeginPolygon' ); - @gluNextContour := GetModuleSymbol( LibGlu, 'gluNextContour' ); - @gluEndPolygon := GetModuleSymbol( LibGlu, 'gluEndPolygon' ); - end; -end; - -initialization - - LoadGLu( GLuLibName ); - -finalization - - FreeGLu; - -end. - diff --git a/src/lib/JEDI-SDL/OpenGL/Pas/glut.pas b/src/lib/JEDI-SDL/OpenGL/Pas/glut.pas deleted file mode 100644 index 04f69267..00000000 --- a/src/lib/JEDI-SDL/OpenGL/Pas/glut.pas +++ /dev/null @@ -1,688 +0,0 @@ -unit glut; -{ - $Id: glut.pas,v 1.4 2007/05/20 20:28:31 savage Exp $ - - Adaption of the delphi3d.net OpenGL units to FreePascal - Sebastian Guenther (sg@freepascal.org) in 2002 - These units are free to use -} - -// Copyright (c) Mark J. Kilgard, 1994, 1995, 1996. */ - -(* This program is freely distributable without licensing fees and is - provided without guarantee or warrantee expressed or implied. This - program is -not- in the public domain. *) - -{******************************************************************************} -{ } -{ Converted to Delphi by Tom Nuydens (tom@delphi3d.net) } -{ For the latest updates, visit Delphi3D: http://www.delphi3d.net } -{ } -{ Modified for Delphi/Kylix and FreePascal } -{ by Dominique Louis ( Dominique@Savagesoftware.com.au) } -{ For the latest updates, visit JEDI-SDL : http://www.sf.net/projects/jedi-sdl } -{ } -{******************************************************************************} - -{ - $Log: glut.pas,v $ - Revision 1.4 2007/05/20 20:28:31 savage - Initial Changes to Handle 64 Bits - - Revision 1.3 2006/11/20 21:20:59 savage - Updated to work in MacOS X - - Revision 1.2 2004/08/14 22:54:30 savage - Updated so that Library name defines are correctly defined for MacOS X. - - Revision 1.1 2004/03/30 21:53:54 savage - Moved to it's own folder. - - Revision 1.5 2004/02/20 17:09:55 savage - Code tidied up in gl, glu and glut, while extensions in glext.pas are now loaded using SDL_GL_GetProcAddress, thus making it more cross-platform compatible, but now more tied to SDL. - - Revision 1.4 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.3 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.2 2004/02/14 00:09:19 savage - Changed uses to now make use of moduleloader.pas rather than dllfuncs.pas - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - Revision 1.4 2003/06/02 12:32:13 savage - Modified Sources to avoid warnings with Delphi by moving CVS Logging to the top of the header files. Hopefully CVS Logging still works. - -} - -interface - -{$I jedi-sdl.inc} - -uses -{$IFDEF __GPC__} - system, - gpc, -{$ENDIF} - -{$IFDEF WINDOWS} - Windows, -{$ENDIF} - moduleloader, - gl; - -type - {$IFNDEF __GPC__} - PInteger = ^Integer; - PPChar = ^PChar; - {$ENDIF} - TGlutVoidCallback = procedure; {$IFNDEF __GPC__}{$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}{$ENDIF} - TGlut1IntCallback = procedure(value: Integer); {$IFNDEF __GPC__}{$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}{$ENDIF} - TGlut2IntCallback = procedure(v1, v2: Integer); {$IFNDEF __GPC__}{$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}{$ENDIF} - TGlut3IntCallback = procedure(v1, v2, v3: Integer); {$IFNDEF __GPC__}{$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}{$ENDIF} - TGlut4IntCallback = procedure(v1, v2, v3, v4: Integer); {$IFNDEF __GPC__}{$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}{$ENDIF} - TGlut1Char2IntCallback = procedure(c: Byte; v1, v2: Integer); {$IFNDEF __GPC__}{$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF}{$ENDIF} - -const -{$IFDEF WINDOWS} - GlutLibName = 'glut32.dll'; -{$ENDIF} - -{$IFDEF UNIX} -{$IFDEF DARWIN} - GlutLibName = '/System/Library/Frameworks/GLUT.framework/Libraries/libglut.dylib'; -{$ELSE} - GlutLibName = 'libglut.so'; -{$ENDIF} -{$ENDIF} - - GLUT_API_VERSION = 3; - GLUT_XLIB_IMPLEMENTATION = 12; - // Display mode bit masks. - GLUT_RGB = 0; - GLUT_RGBA = GLUT_RGB; - GLUT_INDEX = 1; - GLUT_SINGLE = 0; - GLUT_DOUBLE = 2; - GLUT_ACCUM = 4; - GLUT_ALPHA = 8; - GLUT_DEPTH = 16; - GLUT_STENCIL = 32; - GLUT_MULTISAMPLE = 128; - GLUT_STEREO = 256; - GLUT_LUMINANCE = 512; - - // Mouse buttons. - GLUT_LEFT_BUTTON = 0; - GLUT_MIDDLE_BUTTON = 1; - GLUT_RIGHT_BUTTON = 2; - - // Mouse button state. - GLUT_DOWN = 0; - GLUT_UP = 1; - - // function keys - GLUT_KEY_F1 = 1; - GLUT_KEY_F2 = 2; - GLUT_KEY_F3 = 3; - GLUT_KEY_F4 = 4; - GLUT_KEY_F5 = 5; - GLUT_KEY_F6 = 6; - GLUT_KEY_F7 = 7; - GLUT_KEY_F8 = 8; - GLUT_KEY_F9 = 9; - GLUT_KEY_F10 = 10; - GLUT_KEY_F11 = 11; - GLUT_KEY_F12 = 12; - // directional keys - GLUT_KEY_LEFT = 100; - GLUT_KEY_UP = 101; - GLUT_KEY_RIGHT = 102; - GLUT_KEY_DOWN = 103; - GLUT_KEY_PAGE_UP = 104; - GLUT_KEY_PAGE_DOWN = 105; - GLUT_KEY_HOME = 106; - GLUT_KEY_END = 107; - GLUT_KEY_INSERT = 108; - - // Entry/exit state. - GLUT_LEFT = 0; - GLUT_ENTERED = 1; - - // Menu usage state. - GLUT_MENU_NOT_IN_USE = 0; - GLUT_MENU_IN_USE = 1; - - // Visibility state. - GLUT_NOT_VISIBLE = 0; - GLUT_VISIBLE = 1; - - // Window status state. - GLUT_HIDDEN = 0; - GLUT_FULLY_RETAINED = 1; - GLUT_PARTIALLY_RETAINED = 2; - GLUT_FULLY_COVERED = 3; - - // Color index component selection values. - GLUT_RED = 0; - GLUT_GREEN = 1; - GLUT_BLUE = 2; - - // Layers for use. - GLUT_NORMAL = 0; - GLUT_OVERLAY = 1; - - // Stroke font constants (use these in GLUT program). - GLUT_STROKE_ROMAN = Pointer(0); - GLUT_STROKE_MONO_ROMAN = Pointer(1); - - // Bitmap font constants (use these in GLUT program). - GLUT_BITMAP_9_BY_15 = Pointer(2); - GLUT_BITMAP_8_BY_13 = Pointer(3); - GLUT_BITMAP_TIMES_ROMAN_10 = Pointer(4); - GLUT_BITMAP_TIMES_ROMAN_24 = Pointer(5); - GLUT_BITMAP_HELVETICA_10 = Pointer(6); - GLUT_BITMAP_HELVETICA_12 = Pointer(7); - GLUT_BITMAP_HELVETICA_18 = Pointer(8); - - // glutGet parameters. - GLUT_WINDOW_X = 100; - GLUT_WINDOW_Y = 101; - GLUT_WINDOW_WIDTH = 102; - GLUT_WINDOW_HEIGHT = 103; - GLUT_WINDOW_BUFFER_SIZE = 104; - GLUT_WINDOW_STENCIL_SIZE = 105; - GLUT_WINDOW_DEPTH_SIZE = 106; - GLUT_WINDOW_RED_SIZE = 107; - GLUT_WINDOW_GREEN_SIZE = 108; - GLUT_WINDOW_BLUE_SIZE = 109; - GLUT_WINDOW_ALPHA_SIZE = 110; - GLUT_WINDOW_ACCUM_RED_SIZE = 111; - GLUT_WINDOW_ACCUM_GREEN_SIZE = 112; - GLUT_WINDOW_ACCUM_BLUE_SIZE = 113; - GLUT_WINDOW_ACCUM_ALPHA_SIZE = 114; - GLUT_WINDOW_DOUBLEBUFFER = 115; - GLUT_WINDOW_RGBA = 116; - GLUT_WINDOW_PARENT = 117; - GLUT_WINDOW_NUM_CHILDREN = 118; - GLUT_WINDOW_COLORMAP_SIZE = 119; - GLUT_WINDOW_NUM_SAMPLES = 120; - GLUT_WINDOW_STEREO = 121; - GLUT_WINDOW_CURSOR = 122; - GLUT_SCREEN_WIDTH = 200; - GLUT_SCREEN_HEIGHT = 201; - GLUT_SCREEN_WIDTH_MM = 202; - GLUT_SCREEN_HEIGHT_MM = 203; - GLUT_MENU_NUM_ITEMS = 300; - GLUT_DISPLAY_MODE_POSSIBLE = 400; - GLUT_INIT_WINDOW_X = 500; - GLUT_INIT_WINDOW_Y = 501; - GLUT_INIT_WINDOW_WIDTH = 502; - GLUT_INIT_WINDOW_HEIGHT = 503; - GLUT_INIT_DISPLAY_MODE = 504; - GLUT_ELAPSED_TIME = 700; - - // glutDeviceGet parameters. - GLUT_HAS_KEYBOARD = 600; - GLUT_HAS_MOUSE = 601; - GLUT_HAS_SPACEBALL = 602; - GLUT_HAS_DIAL_AND_BUTTON_BOX = 603; - GLUT_HAS_TABLET = 604; - GLUT_NUM_MOUSE_BUTTONS = 605; - GLUT_NUM_SPACEBALL_BUTTONS = 606; - GLUT_NUM_BUTTON_BOX_BUTTONS = 607; - GLUT_NUM_DIALS = 608; - GLUT_NUM_TABLET_BUTTONS = 609; - - // glutLayerGet parameters. - GLUT_OVERLAY_POSSIBLE = 800; - GLUT_LAYER_IN_USE = 801; - GLUT_HAS_OVERLAY = 802; - GLUT_TRANSPARENT_INDEX = 803; - GLUT_NORMAL_DAMAGED = 804; - GLUT_OVERLAY_DAMAGED = 805; - - // glutVideoResizeGet parameters. - GLUT_VIDEO_RESIZE_POSSIBLE = 900; - GLUT_VIDEO_RESIZE_IN_USE = 901; - GLUT_VIDEO_RESIZE_X_DELTA = 902; - GLUT_VIDEO_RESIZE_Y_DELTA = 903; - GLUT_VIDEO_RESIZE_WIDTH_DELTA = 904; - GLUT_VIDEO_RESIZE_HEIGHT_DELTA = 905; - GLUT_VIDEO_RESIZE_X = 906; - GLUT_VIDEO_RESIZE_Y = 907; - GLUT_VIDEO_RESIZE_WIDTH = 908; - GLUT_VIDEO_RESIZE_HEIGHT = 909; - - // glutGetModifiers return mask. - GLUT_ACTIVE_SHIFT = 1; - GLUT_ACTIVE_CTRL = 2; - GLUT_ACTIVE_ALT = 4; - - // glutSetCursor parameters. - // Basic arrows. - GLUT_CURSOR_RIGHT_ARROW = 0; - GLUT_CURSOR_LEFT_ARROW = 1; - // Symbolic cursor shapes. - GLUT_CURSOR_INFO = 2; - GLUT_CURSOR_DESTROY = 3; - GLUT_CURSOR_HELP = 4; - GLUT_CURSOR_CYCLE = 5; - GLUT_CURSOR_SPRAY = 6; - GLUT_CURSOR_WAIT = 7; - GLUT_CURSOR_TEXT = 8; - GLUT_CURSOR_CROSSHAIR = 9; - // Directional cursors. - GLUT_CURSOR_UP_DOWN = 10; - GLUT_CURSOR_LEFT_RIGHT = 11; - // Sizing cursors. - GLUT_CURSOR_TOP_SIDE = 12; - GLUT_CURSOR_BOTTOM_SIDE = 13; - GLUT_CURSOR_LEFT_SIDE = 14; - GLUT_CURSOR_RIGHT_SIDE = 15; - GLUT_CURSOR_TOP_LEFT_CORNER = 16; - GLUT_CURSOR_TOP_RIGHT_CORNER = 17; - GLUT_CURSOR_BOTTOM_RIGHT_CORNER = 18; - GLUT_CURSOR_BOTTOM_LEFT_CORNER = 19; - // Inherit from parent window. - GLUT_CURSOR_INHERIT = 100; - // Blank cursor. - GLUT_CURSOR_NONE = 101; - // Fullscreen crosshair (if available). - GLUT_CURSOR_FULL_CROSSHAIR = 102; - - // GLUT game mode sub-API. - // glutGameModeGet. - GLUT_GAME_MODE_ACTIVE = 0; - GLUT_GAME_MODE_POSSIBLE = 1; - GLUT_GAME_MODE_WIDTH = 2; - GLUT_GAME_MODE_HEIGHT = 3; - GLUT_GAME_MODE_PIXEL_DEPTH = 4; - GLUT_GAME_MODE_REFRESH_RATE = 5; - GLUT_GAME_MODE_DISPLAY_CHANGED = 6; - -var -// GLUT initialization sub-API. - glutInit: procedure(argcp: PInteger; argv: PPChar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutInitDisplayMode: procedure(mode: Word); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutInitDisplayString: procedure(const str: PChar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutInitWindowPosition: procedure(x, y: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutInitWindowSize: procedure(width, height: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutMainLoop: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT window sub-API. - glutCreateWindow: function(const title: PChar): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutCreateSubWindow: function(win, x, y, width, height: Integer): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutDestroyWindow: procedure(win: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPostRedisplay: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPostWindowRedisplay: procedure(win: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSwapBuffers: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutGetWindow: function: Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSetWindow: procedure(win: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSetWindowTitle: procedure(const title: PChar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSetIconTitle: procedure(const title: PChar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPositionWindow: procedure(x, y: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutReshapeWindow: procedure(width, height: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPopWindow: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPushWindow: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutIconifyWindow: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutShowWindow: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutHideWindow: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutFullScreen: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSetCursor: procedure(cursor: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWarpPointer: procedure(x, y: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT overlay sub-API. - glutEstablishOverlay: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutRemoveOverlay: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutUseLayer: procedure(layer: GLenum); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPostOverlayRedisplay: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPostWindowOverlayRedisplay: procedure(win: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutShowOverlay: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutHideOverlay: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT menu sub-API. - glutCreateMenu: function(callback: TGlut1IntCallback): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutDestroyMenu: procedure(menu: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutGetMenu: function: Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSetMenu: procedure(menu: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutAddMenuEntry: procedure(const caption: PChar; value: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutAddSubMenu: procedure(const caption: PChar; submenu: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutChangeToMenuEntry: procedure(item: Integer; const caption: PChar; value: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutChangeToSubMenu: procedure(item: Integer; const caption: PChar; submenu: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutRemoveMenuItem: procedure(item: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutAttachMenu: procedure(button: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutDetachMenu: procedure(button: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUTsub-API. - glutDisplayFunc: procedure(f: TGlutVoidCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutReshapeFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutKeyboardFunc: procedure(f: TGlut1Char2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutMouseFunc: procedure(f: TGlut4IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutMotionFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutPassiveMotionFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutEntryFunc: procedure(f: TGlut1IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutVisibilityFunc: procedure(f: TGlut1IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutIdleFunc: procedure(f: TGlutVoidCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutTimerFunc: procedure(millis: Word; f: TGlut1IntCallback; value: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutMenuStateFunc: procedure(f: TGlut1IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSpecialFunc: procedure(f: TGlut3IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSpaceballMotionFunc: procedure(f: TGlut3IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSpaceballRotateFunc: procedure(f: TGlut3IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSpaceballButtonFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutButtonBoxFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutDialsFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutTabletMotionFunc: procedure(f: TGlut2IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutTabletButtonFunc: procedure(f: TGlut4IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutMenuStatusFunc: procedure(f: TGlut3IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutOverlayDisplayFunc: procedure(f:TGlutVoidCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWindowStatusFunc: procedure(f: TGlut1IntCallback); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT color index sub-API. - glutSetColor: procedure(cell: Integer; red, green, blue: GLfloat); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutGetColor: function(ndx, component: Integer): GLfloat; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutCopyColormap: procedure(win: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT state retrieval sub-API. - glutGet: function(t: GLenum): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutDeviceGet: function(t: GLenum): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT extension support sub-API - glutExtensionSupported: function(const name: PChar): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutGetModifiers: function: Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutLayerGet: function(t: GLenum): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT font sub-API - glutBitmapCharacter: procedure(font : pointer; character: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutBitmapWidth: function(font : pointer; character: Integer): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutStrokeCharacter: procedure(font : pointer; character: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutStrokeWidth: function(font : pointer; character: Integer): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutBitmapLength: function(font: pointer; const str: PChar): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutStrokeLength: function(font: pointer; const str: PChar): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT pre-built models sub-API - glutWireSphere: procedure(radius: GLdouble; slices, stacks: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidSphere: procedure(radius: GLdouble; slices, stacks: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireCone: procedure(base, height: GLdouble; slices, stacks: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidCone: procedure(base, height: GLdouble; slices, stacks: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireCube: procedure(size: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidCube: procedure(size: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireTorus: procedure(innerRadius, outerRadius: GLdouble; sides, rings: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidTorus: procedure(innerRadius, outerRadius: GLdouble; sides, rings: GLint); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireDodecahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidDodecahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireTeapot: procedure(size: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidTeapot: procedure(size: GLdouble); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireOctahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidOctahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireTetrahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidTetrahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutWireIcosahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSolidIcosahedron: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT video resize sub-API. - glutVideoResizeGet: function(param: GLenum): Integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutSetupVideoResizing: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutStopVideoResizing: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutVideoResize: procedure(x, y, width, height: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutVideoPan: procedure(x, y, width, height: Integer); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -// GLUT debugging sub-API. - glutReportErrors: procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -var - //example glutGameModeString('1280x1024:32@75'); - glutGameModeString : procedure (const AString : PChar); {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutEnterGameMode : function : integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutLeaveGameMode : procedure; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - glutGameModeGet : function (mode : GLenum) : integer; {$IFDEF WINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} - -procedure LoadGlut(const dll: PChar); -procedure FreeGlut; - -implementation - -var - LibGLUT : TModuleHandle; - -procedure FreeGlut; -begin - - UnLoadModule( LibGLUT ); - - @glutInit := nil; - @glutInitDisplayMode := nil; - @glutInitDisplayString := nil; - @glutInitWindowPosition := nil; - @glutInitWindowSize := nil; - @glutMainLoop := nil; - @glutCreateWindow := nil; - @glutCreateSubWindow := nil; - @glutDestroyWindow := nil; - @glutPostRedisplay := nil; - @glutPostWindowRedisplay := nil; - @glutSwapBuffers := nil; - @glutGetWindow := nil; - @glutSetWindow := nil; - @glutSetWindowTitle := nil; - @glutSetIconTitle := nil; - @glutPositionWindow := nil; - @glutReshapeWindow := nil; - @glutPopWindow := nil; - @glutPushWindow := nil; - @glutIconifyWindow := nil; - @glutShowWindow := nil; - @glutHideWindow := nil; - @glutFullScreen := nil; - @glutSetCursor := nil; - @glutWarpPointer := nil; - @glutEstablishOverlay := nil; - @glutRemoveOverlay := nil; - @glutUseLayer := nil; - @glutPostOverlayRedisplay := nil; - @glutPostWindowOverlayRedisplay := nil; - @glutShowOverlay := nil; - @glutHideOverlay := nil; - @glutCreateMenu := nil; - @glutDestroyMenu := nil; - @glutGetMenu := nil; - @glutSetMenu := nil; - @glutAddMenuEntry := nil; - @glutAddSubMenu := nil; - @glutChangeToMenuEntry := nil; - @glutChangeToSubMenu := nil; - @glutRemoveMenuItem := nil; - @glutAttachMenu := nil; - @glutDetachMenu := nil; - @glutDisplayFunc := nil; - @glutReshapeFunc := nil; - @glutKeyboardFunc := nil; - @glutMouseFunc := nil; - @glutMotionFunc := nil; - @glutPassiveMotionFunc := nil; - @glutEntryFunc := nil; - @glutVisibilityFunc := nil; - @glutIdleFunc := nil; - @glutTimerFunc := nil; - @glutMenuStateFunc := nil; - @glutSpecialFunc := nil; - @glutSpaceballMotionFunc := nil; - @glutSpaceballRotateFunc := nil; - @glutSpaceballButtonFunc := nil; - @glutButtonBoxFunc := nil; - @glutDialsFunc := nil; - @glutTabletMotionFunc := nil; - @glutTabletButtonFunc := nil; - @glutMenuStatusFunc := nil; - @glutOverlayDisplayFunc := nil; - @glutWindowStatusFunc := nil; - @glutSetColor := nil; - @glutGetColor := nil; - @glutCopyColormap := nil; - @glutGet := nil; - @glutDeviceGet := nil; - @glutExtensionSupported := nil; - @glutGetModifiers := nil; - @glutLayerGet := nil; - @glutBitmapCharacter := nil; - @glutBitmapWidth := nil; - @glutStrokeCharacter := nil; - @glutStrokeWidth := nil; - @glutBitmapLength := nil; - @glutStrokeLength := nil; - @glutWireSphere := nil; - @glutSolidSphere := nil; - @glutWireCone := nil; - @glutSolidCone := nil; - @glutWireCube := nil; - @glutSolidCube := nil; - @glutWireTorus := nil; - @glutSolidTorus := nil; - @glutWireDodecahedron := nil; - @glutSolidDodecahedron := nil; - @glutWireTeapot := nil; - @glutSolidTeapot := nil; - @glutWireOctahedron := nil; - @glutSolidOctahedron := nil; - @glutWireTetrahedron := nil; - @glutSolidTetrahedron := nil; - @glutWireIcosahedron := nil; - @glutSolidIcosahedron := nil; - @glutVideoResizeGet := nil; - @glutSetupVideoResizing := nil; - @glutStopVideoResizing := nil; - @glutVideoResize := nil; - @glutVideoPan := nil; - @glutReportErrors := nil; - -end; - -procedure LoadGlut(const dll: PChar); -begin - - FreeGlut; - - if LoadModule( LibGLUT, dll ) then - begin - @glutInit := GetModuleSymbol(LibGLUT, 'glutInit'); - @glutInitDisplayMode := GetModuleSymbol(LibGLUT, 'glutInitDisplayMode'); - @glutInitDisplayString := GetModuleSymbol(LibGLUT, 'glutInitDisplayString'); - @glutInitWindowPosition := GetModuleSymbol(LibGLUT, 'glutInitWindowPosition'); - @glutInitWindowSize := GetModuleSymbol(LibGLUT, 'glutInitWindowSize'); - @glutMainLoop := GetModuleSymbol(LibGLUT, 'glutMainLoop'); - @glutCreateWindow := GetModuleSymbol(LibGLUT, 'glutCreateWindow'); - @glutCreateSubWindow := GetModuleSymbol(LibGLUT, 'glutCreateSubWindow'); - @glutDestroyWindow := GetModuleSymbol(LibGLUT, 'glutDestroyWindow'); - @glutPostRedisplay := GetModuleSymbol(LibGLUT, 'glutPostRedisplay'); - @glutPostWindowRedisplay := GetModuleSymbol(LibGLUT, 'glutPostWindowRedisplay'); - @glutSwapBuffers := GetModuleSymbol(LibGLUT, 'glutSwapBuffers'); - @glutGetWindow := GetModuleSymbol(LibGLUT, 'glutGetWindow'); - @glutSetWindow := GetModuleSymbol(LibGLUT, 'glutSetWindow'); - @glutSetWindowTitle := GetModuleSymbol(LibGLUT, 'glutSetWindowTitle'); - @glutSetIconTitle := GetModuleSymbol(LibGLUT, 'glutSetIconTitle'); - @glutPositionWindow := GetModuleSymbol(LibGLUT, 'glutPositionWindow'); - @glutReshapeWindow := GetModuleSymbol(LibGLUT, 'glutReshapeWindow'); - @glutPopWindow := GetModuleSymbol(LibGLUT, 'glutPopWindow'); - @glutPushWindow := GetModuleSymbol(LibGLUT, 'glutPushWindow'); - @glutIconifyWindow := GetModuleSymbol(LibGLUT, 'glutIconifyWindow'); - @glutShowWindow := GetModuleSymbol(LibGLUT, 'glutShowWindow'); - @glutHideWindow := GetModuleSymbol(LibGLUT, 'glutHideWindow'); - @glutFullScreen := GetModuleSymbol(LibGLUT, 'glutFullScreen'); - @glutSetCursor := GetModuleSymbol(LibGLUT, 'glutSetCursor'); - @glutWarpPointer := GetModuleSymbol(LibGLUT, 'glutWarpPointer'); - @glutEstablishOverlay := GetModuleSymbol(LibGLUT, 'glutEstablishOverlay'); - @glutRemoveOverlay := GetModuleSymbol(LibGLUT, 'glutRemoveOverlay'); - @glutUseLayer := GetModuleSymbol(LibGLUT, 'glutUseLayer'); - @glutPostOverlayRedisplay := GetModuleSymbol(LibGLUT, 'glutPostOverlayRedisplay'); - @glutPostWindowOverlayRedisplay := GetModuleSymbol(LibGLUT, 'glutPostWindowOverlayRedisplay'); - @glutShowOverlay := GetModuleSymbol(LibGLUT, 'glutShowOverlay'); - @glutHideOverlay := GetModuleSymbol(LibGLUT, 'glutHideOverlay'); - @glutCreateMenu := GetModuleSymbol(LibGLUT, 'glutCreateMenu'); - @glutDestroyMenu := GetModuleSymbol(LibGLUT, 'glutDestroyMenu'); - @glutGetMenu := GetModuleSymbol(LibGLUT, 'glutGetMenu'); - @glutSetMenu := GetModuleSymbol(LibGLUT, 'glutSetMenu'); - @glutAddMenuEntry := GetModuleSymbol(LibGLUT, 'glutAddMenuEntry'); - @glutAddSubMenu := GetModuleSymbol(LibGLUT, 'glutAddSubMenu'); - @glutChangeToMenuEntry := GetModuleSymbol(LibGLUT, 'glutChangeToMenuEntry'); - @glutChangeToSubMenu := GetModuleSymbol(LibGLUT, 'glutChangeToSubMenu'); - @glutRemoveMenuItem := GetModuleSymbol(LibGLUT, 'glutRemoveMenuItem'); - @glutAttachMenu := GetModuleSymbol(LibGLUT, 'glutAttachMenu'); - @glutDetachMenu := GetModuleSymbol(LibGLUT, 'glutDetachMenu'); - @glutDisplayFunc := GetModuleSymbol(LibGLUT, 'glutDisplayFunc'); - @glutReshapeFunc := GetModuleSymbol(LibGLUT, 'glutReshapeFunc'); - @glutKeyboardFunc := GetModuleSymbol(LibGLUT, 'glutKeyboardFunc'); - @glutMouseFunc := GetModuleSymbol(LibGLUT, 'glutMouseFunc'); - @glutMotionFunc := GetModuleSymbol(LibGLUT, 'glutMotionFunc'); - @glutPassiveMotionFunc := GetModuleSymbol(LibGLUT, 'glutPassiveMotionFunc'); - @glutEntryFunc := GetModuleSymbol(LibGLUT, 'glutEntryFunc'); - @glutVisibilityFunc := GetModuleSymbol(LibGLUT, 'glutVisibilityFunc'); - @glutIdleFunc := GetModuleSymbol(LibGLUT, 'glutIdleFunc'); - @glutTimerFunc := GetModuleSymbol(LibGLUT, 'glutTimerFunc'); - @glutMenuStateFunc := GetModuleSymbol(LibGLUT, 'glutMenuStateFunc'); - @glutSpecialFunc := GetModuleSymbol(LibGLUT, 'glutSpecialFunc'); - @glutSpaceballMotionFunc := GetModuleSymbol(LibGLUT, 'glutSpaceballMotionFunc'); - @glutSpaceballRotateFunc := GetModuleSymbol(LibGLUT, 'glutSpaceballRotateFunc'); - @glutSpaceballButtonFunc := GetModuleSymbol(LibGLUT, 'glutSpaceballButtonFunc'); - @glutButtonBoxFunc := GetModuleSymbol(LibGLUT, 'glutButtonBoxFunc'); - @glutDialsFunc := GetModuleSymbol(LibGLUT, 'glutDialsFunc'); - @glutTabletMotionFunc := GetModuleSymbol(LibGLUT, 'glutTabletMotionFunc'); - @glutTabletButtonFunc := GetModuleSymbol(LibGLUT, 'glutTabletButtonFunc'); - @glutMenuStatusFunc := GetModuleSymbol(LibGLUT, 'glutMenuStatusFunc'); - @glutOverlayDisplayFunc := GetModuleSymbol(LibGLUT, 'glutOverlayDisplayFunc'); - @glutWindowStatusFunc := GetModuleSymbol(LibGLUT, 'glutWindowStatusFunc'); - @glutSetColor := GetModuleSymbol(LibGLUT, 'glutSetColor'); - @glutGetColor := GetModuleSymbol(LibGLUT, 'glutGetColor'); - @glutCopyColormap := GetModuleSymbol(LibGLUT, 'glutCopyColormap'); - @glutGet := GetModuleSymbol(LibGLUT, 'glutGet'); - @glutDeviceGet := GetModuleSymbol(LibGLUT, 'glutDeviceGet'); - @glutExtensionSupported := GetModuleSymbol(LibGLUT, 'glutExtensionSupported'); - @glutGetModifiers := GetModuleSymbol(LibGLUT, 'glutGetModifiers'); - @glutLayerGet := GetModuleSymbol(LibGLUT, 'glutLayerGet'); - @glutBitmapCharacter := GetModuleSymbol(LibGLUT, 'glutBitmapCharacter'); - @glutBitmapWidth := GetModuleSymbol(LibGLUT, 'glutBitmapWidth'); - @glutStrokeCharacter := GetModuleSymbol(LibGLUT, 'glutStrokeCharacter'); - @glutStrokeWidth := GetModuleSymbol(LibGLUT, 'glutStrokeWidth'); - @glutBitmapLength := GetModuleSymbol(LibGLUT, 'glutBitmapLength'); - @glutStrokeLength := GetModuleSymbol(LibGLUT, 'glutStrokeLength'); - @glutWireSphere := GetModuleSymbol(LibGLUT, 'glutWireSphere'); - @glutSolidSphere := GetModuleSymbol(LibGLUT, 'glutSolidSphere'); - @glutWireCone := GetModuleSymbol(LibGLUT, 'glutWireCone'); - @glutSolidCone := GetModuleSymbol(LibGLUT, 'glutSolidCone'); - @glutWireCube := GetModuleSymbol(LibGLUT, 'glutWireCube'); - @glutSolidCube := GetModuleSymbol(LibGLUT, 'glutSolidCube'); - @glutWireTorus := GetModuleSymbol(LibGLUT, 'glutWireTorus'); - @glutSolidTorus := GetModuleSymbol(LibGLUT, 'glutSolidTorus'); - @glutWireDodecahedron := GetModuleSymbol(LibGLUT, 'glutWireDodecahedron'); - @glutSolidDodecahedron := GetModuleSymbol(LibGLUT, 'glutSolidDodecahedron'); - @glutWireTeapot := GetModuleSymbol(LibGLUT, 'glutWireTeapot'); - @glutSolidTeapot := GetModuleSymbol(LibGLUT, 'glutSolidTeapot'); - @glutWireOctahedron := GetModuleSymbol(LibGLUT, 'glutWireOctahedron'); - @glutSolidOctahedron := GetModuleSymbol(LibGLUT, 'glutSolidOctahedron'); - @glutWireTetrahedron := GetModuleSymbol(LibGLUT, 'glutWireTetrahedron'); - @glutSolidTetrahedron := GetModuleSymbol(LibGLUT, 'glutSolidTetrahedron'); - @glutWireIcosahedron := GetModuleSymbol(LibGLUT, 'glutWireIcosahedron'); - @glutSolidIcosahedron := GetModuleSymbol(LibGLUT, 'glutSolidIcosahedron'); - @glutVideoResizeGet := GetModuleSymbol(LibGLUT, 'glutVideoResizeGet'); - @glutSetupVideoResizing := GetModuleSymbol(LibGLUT, 'glutSetupVideoResizing'); - @glutStopVideoResizing := GetModuleSymbol(LibGLUT, 'glutStopVideoResizing'); - @glutVideoResize := GetModuleSymbol(LibGLUT, 'glutVideoResize'); - @glutVideoPan := GetModuleSymbol(LibGLUT, 'glutVideoPan'); - @glutReportErrors := GetModuleSymbol(LibGLUT, 'glutReportErrors'); - @glutGameModeString := GetModuleSymbol(LibGLUT, 'glutGameModeString'); - @glutEnterGameMode := GetModuleSymbol(LibGLUT, 'glutEnterGameMode'); - @glutLeaveGameMode := GetModuleSymbol(LibGLUT, 'glutLeaveGameMode'); - @glutGameModeGet := GetModuleSymbol(LibGLUT, 'glutGameModeGet'); - end; -end; - -initialization - LoadGlut( GlutLibName ); - -finalization - FreeGlut; - -end. diff --git a/src/lib/JEDI-SDL/OpenGL/Pas/glx.pas b/src/lib/JEDI-SDL/OpenGL/Pas/glx.pas deleted file mode 100644 index 9f36d2b5..00000000 --- a/src/lib/JEDI-SDL/OpenGL/Pas/glx.pas +++ /dev/null @@ -1,279 +0,0 @@ -unit glx; -{ - $Id: glx.pas,v 1.3 2006/11/20 21:20:59 savage Exp $ - - Translation of the Mesa GLX headers for FreePascal - Copyright (C) 1999 Sebastian Guenther - - - Mesa 3-D graphics library - Version: 3.0 - Copyright (C) 1995-1998 Brian Paul - - This library is free software; you can redistribute it and/or - modify it under the terms of the GNU Library General Public - License as published by the Free Software Foundation; either - version 2 of the License, or (at your option) any later version. - - This library is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - Library General Public License for more details. - - You should have received a copy of the GNU Library General Public - License along with this library; if not, write to the Free - Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -} - -// {$MODE delphi} // objfpc would not work because of direct proc var assignments - -{You have to enable Macros (compiler switch "-Sm") for compiling this unit! - This is necessary for supporting different platforms with different calling - conventions via a single unit.} - -{ - $Log: glx.pas,v $ - Revision 1.3 2006/11/20 21:20:59 savage - Updated to work in MacOS X - - Revision 1.2 2006/04/18 18:38:33 savage - fixed boolean test - thanks grudzio - - Revision 1.1 2004/03/30 21:53:55 savage - Moved to it's own folder. - - Revision 1.5 2004/02/15 22:48:35 savage - More FPC and FreeBSD support changes. - - Revision 1.4 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.3 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.2 2004/02/14 00:09:19 savage - Changed uses to now make use of moduleloader.pas rather than dllfuncs.pas - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - Revision 1.1 2003/05/11 13:18:03 savage - Newest OpenGL Headers For Delphi, Kylix and FPC - - Revision 1.1 2002/10/13 13:57:31 sg - * Finally, the new units are available: Match the C headers more closely; - support for OpenGL extensions, and much more. Based on the Delphi units - by Tom Nuydens of delphi3d.net - -} - -interface - -{$I jedi-sdl.inc} - -{$IFDEF UNIX} - uses - {$IFDEF FPC} - x, - xlib, - xutil; - {$ELSE} - xlib; - {$ENDIF} - {$DEFINE HasGLX} // Activate GLX stuff -{$ELSE} - {$MESSAGE Unsupported platform.} -{$ENDIF} - -{$IFNDEF HasGLX} - {$MESSAGE GLX not present on this platform.} -{$ENDIF} - - -// ======================================================= -// Unit specific extensions -// ======================================================= - -// Note: Requires that the GL library has already been initialized -function InitGLX: Boolean; - -var - GLXDumpUnresolvedFunctions, - GLXInitialized: Boolean; - - -// ======================================================= -// GLX consts, types and functions -// ======================================================= - -// Tokens for glXChooseVisual and glXGetConfig: -const - GLX_USE_GL = 1; - GLX_BUFFER_SIZE = 2; - GLX_LEVEL = 3; - GLX_RGBA = 4; - GLX_DOUBLEBUFFER = 5; - GLX_STEREO = 6; - GLX_AUX_BUFFERS = 7; - GLX_RED_SIZE = 8; - GLX_GREEN_SIZE = 9; - GLX_BLUE_SIZE = 10; - GLX_ALPHA_SIZE = 11; - GLX_DEPTH_SIZE = 12; - GLX_STENCIL_SIZE = 13; - GLX_ACCUM_RED_SIZE = 14; - GLX_ACCUM_GREEN_SIZE = 15; - GLX_ACCUM_BLUE_SIZE = 16; - GLX_ACCUM_ALPHA_SIZE = 17; - - // GLX_EXT_visual_info extension - GLX_X_VISUAL_TYPE_EXT = $22; - GLX_TRANSPARENT_TYPE_EXT = $23; - GLX_TRANSPARENT_INDEX_VALUE_EXT = $24; - GLX_TRANSPARENT_RED_VALUE_EXT = $25; - GLX_TRANSPARENT_GREEN_VALUE_EXT = $26; - GLX_TRANSPARENT_BLUE_VALUE_EXT = $27; - GLX_TRANSPARENT_ALPHA_VALUE_EXT = $28; - - - // Error codes returned by glXGetConfig: - GLX_BAD_SCREEN = 1; - GLX_BAD_ATTRIBUTE = 2; - GLX_NO_EXTENSION = 3; - GLX_BAD_VISUAL = 4; - GLX_BAD_CONTEXT = 5; - GLX_BAD_VALUE = 6; - GLX_BAD_ENUM = 7; - - // GLX 1.1 and later: - GLX_VENDOR = 1; - GLX_VERSION = 2; - GLX_EXTENSIONS = 3; - - // GLX_visual_info extension - GLX_TRUE_COLOR_EXT = $8002; - GLX_DIRECT_COLOR_EXT = $8003; - GLX_PSEUDO_COLOR_EXT = $8004; - GLX_STATIC_COLOR_EXT = $8005; - GLX_GRAY_SCALE_EXT = $8006; - GLX_STATIC_GRAY_EXT = $8007; - GLX_NONE_EXT = $8000; - GLX_TRANSPARENT_RGB_EXT = $8008; - GLX_TRANSPARENT_INDEX_EXT = $8009; - -type - // From XLib: - {$IFNDEF FPC} - TXID = XID; - {$ENDIF} - XPixmap = TXID; - XFont = TXID; - XColormap = TXID; - - GLXContext = Pointer; - GLXPixmap = TXID; - GLXDrawable = TXID; - GLXContextID = TXID; - -var - glXChooseVisual: function(dpy: PDisplay; screen: Integer; var attribList: Integer): PXVisualInfo; cdecl; - glXCreateContext: function(dpy: PDisplay; vis: PXVisualInfo; shareList: GLXContext; direct: Boolean): GLXContext; cdecl; - glXDestroyContext: procedure(dpy: PDisplay; ctx: GLXContext); cdecl; - glXMakeCurrent: function(dpy: PDisplay; drawable: GLXDrawable; ctx: GLXContext): Boolean; cdecl; - glXCopyContext: procedure(dpy: PDisplay; src, dst: GLXContext; mask: LongWord); cdecl; - glXSwapBuffers: procedure(dpy: PDisplay; drawable: GLXDrawable); cdecl; - glXCreateGLXPixmap: function(dpy: PDisplay; visual: PXVisualInfo; pixmap: XPixmap): GLXPixmap; cdecl; - glXDestroyGLXPixmap: procedure(dpy: PDisplay; pixmap: GLXPixmap); cdecl; - glXQueryExtension: function(dpy: PDisplay; var errorb, event: Integer): Boolean; cdecl; - glXQueryVersion: function(dpy: PDisplay; var maj, min: Integer): Boolean; cdecl; - glXIsDirect: function(dpy: PDisplay; ctx: GLXContext): Boolean; cdecl; - glXGetConfig: function(dpy: PDisplay; visual: PXVisualInfo; attrib: Integer; var value: Integer): Integer; cdecl; - glXGetCurrentContext: function: GLXContext; cdecl; - glXGetCurrentDrawable: function: GLXDrawable; cdecl; - glXWaitGL: procedure; cdecl; - glXWaitX: procedure; cdecl; - glXUseXFont: procedure(font: XFont; first, count, list: Integer); cdecl; - - // GLX 1.1 and later - glXQueryExtensionsString: function(dpy: PDisplay; screen: Integer): PChar; cdecl; - glXQueryServerString: function(dpy: PDisplay; screen, name: Integer): PChar; cdecl; - glXGetClientString: function(dpy: PDisplay; name: Integer): PChar; cdecl; - - // Mesa GLX Extensions - glXCreateGLXPixmapMESA: function(dpy: PDisplay; visual: PXVisualInfo; pixmap: XPixmap; cmap: XColormap): GLXPixmap; cdecl; - glXReleaseBufferMESA: function(dpy: PDisplay; d: GLXDrawable): Boolean; cdecl; - glXCopySubBufferMESA: procedure(dpy: PDisplay; drawbale: GLXDrawable; x, y, width, height: Integer); cdecl; - glXGetVideoSyncSGI: function(var counter: LongWord): Integer; cdecl; - glXWaitVideoSyncSGI: function(divisor, remainder: Integer; var count: LongWord): Integer; cdecl; - - -// ======================================================= -// -// ======================================================= - -implementation - -uses - {$IFNDEF __GPC__} - SysUtils, - {$ENDIF} - moduleloader; - -(* {$LINKLIB m} *) - -var - libGLX: TModuleHandle; - -function InitGLXFromLibrary( dll : PChar ): Boolean; -begin - Result := False; - - if not LoadModule( libGLX, dll ) then - exit; - - glXChooseVisual := GetModuleSymbol(libglx, 'glXChooseVisual'); - glXCreateContext := GetModuleSymbol(libglx, 'glXCreateContext'); - glXDestroyContext := GetModuleSymbol(libglx, 'glXDestroyContext'); - glXMakeCurrent := GetModuleSymbol(libglx, 'glXMakeCurrent'); - glXCopyContext := GetModuleSymbol(libglx, 'glXCopyContext'); - glXSwapBuffers := GetModuleSymbol(libglx, 'glXSwapBuffers'); - glXCreateGLXPixmap := GetModuleSymbol(libglx, 'glXCreateGLXPixmap'); - glXDestroyGLXPixmap := GetModuleSymbol(libglx, 'glXDestroyGLXPixmap'); - glXQueryExtension := GetModuleSymbol(libglx, 'glXQueryExtension'); - glXQueryVersion := GetModuleSymbol(libglx, 'glXQueryVersion'); - glXIsDirect := GetModuleSymbol(libglx, 'glXIsDirect'); - glXGetConfig := GetModuleSymbol(libglx, 'glXGetConfig'); - glXGetCurrentContext := GetModuleSymbol(libglx, 'glXGetCurrentContext'); - glXGetCurrentDrawable := GetModuleSymbol(libglx, 'glXGetCurrentDrawable'); - glXWaitGL := GetModuleSymbol(libglx, 'glXWaitGL'); - glXWaitX := GetModuleSymbol(libglx, 'glXWaitX'); - glXUseXFont := GetModuleSymbol(libglx, 'glXUseXFont'); - // GLX 1.1 and later - glXQueryExtensionsString := GetModuleSymbol(libglx, 'glXQueryExtensionsString'); - glXQueryServerString := GetModuleSymbol(libglx, 'glXQueryServerString'); - glXGetClientString := GetModuleSymbol(libglx, 'glXGetClientString'); - // Mesa GLX Extensions - glXCreateGLXPixmapMESA := GetModuleSymbol(libglx, 'glXCreateGLXPixmapMESA'); - glXReleaseBufferMESA := GetModuleSymbol(libglx, 'glXReleaseBufferMESA'); - glXCopySubBufferMESA := GetModuleSymbol(libglx, 'glXCopySubBufferMESA'); - glXGetVideoSyncSGI := GetModuleSymbol(libglx, 'glXGetVideoSyncSGI'); - glXWaitVideoSyncSGI := GetModuleSymbol(libglx, 'glXWaitVideoSyncSGI'); - - GLXInitialized := True; - Result := True; -end; - -function InitGLX: Boolean; -begin - Result := InitGLXFromLibrary('libGL.so.1') or - InitGLXFromLibrary('libMesaGL.so') or - InitGLXFromLibrary('libMesaGL.so.3'); -end; - - -initialization - InitGLX; -finalization - UnloadModule(libGLX); -end. diff --git a/src/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas b/src/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas deleted file mode 100644 index 63e7b7fb..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/libxmlparser.pas +++ /dev/null @@ -1,2688 +0,0 @@ -(** -=============================================================================================== -Name : LibXmlParser -=============================================================================================== -Project : All Projects -=============================================================================================== -Subject : Progressive XML Parser for all types of XML Files -=============================================================================================== -Author : Stefan Heymann - Eschenweg 3 - 72076 Tübingen - GERMANY - -E-Mail: stefan@destructor.de -URL: www.destructor.de -=============================================================================================== -Source, Legals ("Licence") --------------------------- -The official site to get this parser is http://www.destructor.de/ - -Usage and Distribution of this Source Code is ruled by the -"Destructor.de Source code Licence" (DSL) which comes with this file or -can be downloaded at http://www.destructor.de/ - -IN SHORT: Usage and distribution of this source code is free. - You use it completely on your own risk. - -Postcardware ------------- -If you like this code, please send a postcard of your city to my above address. -=============================================================================================== -!!! All parts of this code which are not finished or not conforming exactly to - the XmlSpec are marked with three exclamation marks - --!- Parts where the parser may be able to detect errors in the document's syntax are - marked with the dash-exlamation mark-dash sequence. -=============================================================================================== -Terminology: ------------- -- Start: Start of a buffer part -- Final: End (last character) of a buffer part -- DTD: Document Type Definition -- DTDc: Document Type Declaration -- XMLSpec: The current W3C XML Recommendation (version 1.0 as of 1998-02-10), Chapter No. -- Cur*: Fields concerning the "Current" part passed back by the "Scan" method -=============================================================================================== -Scanning the XML document -------------------------- -- Create TXmlParser Instance MyXml := TXmlParser.Create; -- Load XML Document MyXml.LoadFromFile (Filename); -- Start Scanning MyXml.StartScan; -- Scan Loop WHILE MyXml.Scan DO -- Test for Part Type CASE MyXml.CurPartType OF -- Handle Parts ... : ;;; -- Handle Parts ... : ;;; -- Handle Parts ... : ;;; - END; -- Destroy MyXml.Free; -=============================================================================================== -Loading the XML document ------------------------- -You can load the XML document from a file with the "LoadFromFile" method. -It is beyond the scope of this parser to perform HTTP or FTP accesses. If you want your -application to handle such requests (URLs), you can load the XML via HTTP or FTP or whatever -protocol and hand over the data buffer using the "LoadFromBuffer" or "SetBuffer" method. -"LoadFromBuffer" loads the internal buffer of TXmlParser with the given null-terminated -string, thereby creating a copy of that buffer. -"SetBuffer" just takes the pointer to another buffer, which means that the given -buffer pointer must be valid while the document is accessed via TXmlParser. -=============================================================================================== -Encodings: ----------- -This XML parser kind of "understands" the following encodings: -- UTF-8 -- ISO-8859-1 -- Windows-1252 - -Any flavor of multi-byte characters (and this includes UTF-16) is not supported. Sorry. - -Every string which has to be passed to the application passes the virtual method -"TranslateEncoding" which translates the string from the current encoding (stored in -"CurEncoding") into the encoding the application wishes to receive. -The "TranslateEncoding" method that is built into TXmlParser assumes that the application -wants to receive Windows ANSI (Windows-1252, about the same as ISO-8859-1) and is able -to convert UTF-8 and ISO-8859-1 encodings. -For other source and target encodings, you will have to override "TranslateEncoding". -=============================================================================================== -Buffer Handling ---------------- -- The document must be loaded completely into a piece of RAM -- All character positions are referenced by PChar pointers -- The TXmlParser instance can either "own" the buffer itself (then, FBufferSize is > 0) - or reference the buffer of another instance or object (then, FBuffersize is 0 and - FBuffer is not NIL) -- The Property DocBuffer passes back a pointer to the first byte of the document. If there - is no document stored (FBuffer is NIL), the DocBuffer returns a pointer to a NULL character. -=============================================================================================== -Whitespace Handling -------------------- -The TXmlParser property "PackSpaces" determines how Whitespace is returned in Text Content: -While PackSpaces is true, all leading and trailing whitespace characters are trimmed of, all -Whitespace is converted to Space #x20 characters and contiguous Whitespace characters are -compressed to one. -If the "Scan" method reports a ptContent part, the application can get the original text -with all whitespace characters by extracting the characters from "CurStart" to "CurFinal". -If the application detects an xml:space attribute, it can set "PackSpaces" accordingly or -use CurStart/CurFinal. -Please note that TXmlParser does _not_ normalize Line Breaks to single LineFeed characters -as the XmlSpec requires (XmlSpec 2.11). -The xml:space attribute is not handled by TXmlParser. This is on behalf of the application. -=============================================================================================== -Non-XML-Conforming ------------------- -TXmlParser does not conform 100 % exactly to the XmlSpec: -- UTF-16 is not supported (XmlSpec 2.2) - (Workaround: Convert UTF-16 to UTF-8 and hand the buffer over to TXmlParser) -- As the parser only works with single byte strings, all Unicode characters > 255 - can currently not be handled correctly. -- Line breaks are not normalized to single Linefeed #x0A characters (XmlSpec 2.11) - (Workaround: The Application can access the text contents on its own [CurStart, CurFinal], - thereby applying every normalization it wishes to) -- The attribute value normalization does not work exactly as defined in the - Second Edition of the XML 1.0 specification. -- See also the code parts marked with three consecutive exclamation marks. These are - parts which are not finished in the current code release. - -This list may be incomplete, so it may grow if I get to know any other points. -As work on the parser proceeds, this list may also shrink. -=============================================================================================== -Things Todo ------------ -- Introduce a new event/callback which is called when there is an unresolvable - entity or character reference -- Support Unicode -- Use Streams instead of reading the whole XML into memory -=============================================================================================== -Change History, Version numbers -------------------------------- -The Date is given in ISO Year-Month-Day (YYYY-MM-DD) order. -Versions are counted from 1.0.0 beginning with the version from 2000-03-16. -Unreleased versions don't get a version number. - -Date Author Version Changes ------------------------------------------------------------------------------------------------ -2000-03-16 HeySt 1.0.0 Start -2000-03-28 HeySt 1.0.1 Initial Publishing of TXmlParser on the destructor.de Web Site -2000-03-30 HeySt 1.0.2 TXmlParser.AnalyzeCData: Call "TranslateEncoding" for CurContent -2000-03-31 HeySt 1.0.3 Deleted the StrPosE function (was not needed anyway) -2000-04-04 HeySt 1.0.4 TDtdElementRec modified: Start/Final for all Elements; - Should be backwards compatible. - AnalyzeDtdc: Set CurPartType to ptDtdc -2000-04-23 HeySt 1.0.5 New class TObjectList. Eliminated reference to the Delphi 5 - "Contnrs" unit so LibXmlParser is Delphi 4 compatible. -2000-07-03 HeySt 1.0.6 TNvpNode: Added Constructor -2000-07-11 HeySt 1.0.7 Removed "Windows" from USES clause - Added three-exclamation-mark comments for Utf8ToAnsi/AnsiToUtf8 - Added three-exclamation-mark comments for CHR function calls -2000-07-23 HeySt 1.0.8 TXmlParser.Clear: CurAttr.Clear; EntityStack.Clear; - (This was not a bug; just defensive programming) -2000-07-29 HeySt 1.0.9 TNvpList: Added methods: Node(Index), Value(Index), Name(Index); -2000-10-07 HeySt Introduced Conditional Defines - Uses Contnrs unit and its TObjectList class again for - Delphi 5 and newer versions -2001-01-30 HeySt Introduced Version Numbering - Made LoadFromFile and LoadFromBuffer BOOLEAN functions - Introduced FileMode parameter for LoadFromFile - BugFix: TAttrList.Analyze: Must add CWhitespace to ExtractName call - Comments worked over -2001-02-28 HeySt 1.0.10 Completely worked over and tested the UTF-8 functions - Fixed a bug in TXmlParser.Scan which caused it to start over when it - was called after the end of scanning, resulting in an endless loop - TEntityStack is now a TObjectList instead of TList -2001-07-03 HeySt 1.0.11 Updated Compiler Version IFDEFs for Kylix -2001-07-11 HeySt 1.0.12 New TCustomXmlScanner component (taken over from LibXmlComps.pas) -2001-07-14 HeySt 1.0.13 Bugfix TCustomXmlScanner.FOnTranslateEncoding -2001-10-22 HeySt Don't clear CurName anymore when the parser finds a CDATA section. -2001-12-03 HeySt 1.0.14 TObjectList.Clear: Make call to INHERITED method (fixes a memory leak) -2001-12-05 HeySt 1.0.15 TObjectList.Clear: removed call to INHERITED method - TObjectList.Destroy: Inserted SetCapacity call. - Reduces need for frequent re-allocation of pointer buffer - Dedicated to my father, Theodor Heymann -2002-06-26 HeySt 1.0.16 TXmlParser.Scan: Fixed a bug with PIs whose name is beginning - with 'xml'. Thanks to Uwe Kamm for submitting this bug. - The CurEncoding property is now always in uppercase letters (the XML - spec wants it to be treated case independently so when it's uppercase - comparisons are faster) -2002-03-04 HeySt 1.0.17 Included an IFDEF for Delphi 7 (VER150) and Kylix - There is a new symbol HAS_CONTNRS_UNIT which is used now to - distinguish between IDEs which come with the Contnrs unit and - those that don't. -*) - -UNIT libxmlparser; - -{$I jedi-sdl.inc} - -INTERFACE - -USES - SysUtils, Classes, - (*$IFDEF HAS_CONTNRS_UNIT *) // The Contnrs Unit was introduced in Delphi 5 - Contnrs, - (*$ENDIF*) - Math; - -CONST - CVersion = '1.0.17'; // This variable will be updated for every release - // (I hope, I won't forget to do it everytime ...) - -TYPE - TPartType = // --- Document Part Types - (ptNone, // Nothing - ptXmlProlog, // XML Prolog XmlSpec 2.8 / 4.3.1 - ptComment, // Comment XmlSpec 2.5 - ptPI, // Processing Instruction XmlSpec 2.6 - ptDtdc, // Document Type Declaration XmlSpec 2.8 - ptStartTag, // Start Tag XmlSpec 3.1 - ptEmptyTag, // Empty-Element Tag XmlSpec 3.1 - ptEndTag, // End Tag XmlSpec 3.1 - ptContent, // Text Content between Tags - ptCData); // CDATA Section XmlSpec 2.7 - - TDtdElemType = // --- DTD Elements - (deElement, // !ELEMENT declaration - deAttList, // !ATTLIST declaration - deEntity, // !ENTITY declaration - deNotation, // !NOTATION declaration - dePI, // PI in DTD - deComment, // Comment in DTD - deError); // Error found in the DTD - -TYPE - TAttrList = CLASS; - TEntityStack = CLASS; - TNvpList = CLASS; - TElemDef = CLASS; - TElemList = CLASS; - TEntityDef = CLASS; - TNotationDef = CLASS; - - TDtdElementRec = RECORD // --- This Record is returned by the DTD parser callback function - Start, Final : PChar; // Start/End of the Element's Declaration - CASE ElementType : TDtdElemType OF // Type of the Element - deElement, // - deAttList : (ElemDef : TElemDef); // - deEntity : (EntityDef : TEntityDef); // - deNotation : (NotationDef : TNotationDef); // - dePI : (Target : PChar; // - Content : PChar; - AttrList : TAttrList); - deError : (Pos : PChar); // Error - // deComment : ((No additional fields here)); // - END; - - TXmlParser = CLASS // --- Internal Properties and Methods - PROTECTED - FBuffer : PChar; // NIL if there is no buffer available - FBufferSize : INTEGER; // 0 if the buffer is not owned by the Document instance - FSource : STRING; // Name of Source of document. Filename for Documents loaded with LoadFromFile - - FXmlVersion : STRING; // XML version from Document header. Default is '1.0' - FEncoding : STRING; // Encoding from Document header. Default is 'UTF-8' - FStandalone : BOOLEAN; // Standalone declaration from Document header. Default is 'yes' - FRootName : STRING; // Name of the Root Element (= DTD name) - FDtdcFinal : PChar; // Pointer to the '>' character terminating the DTD declaration - - FNormalize : BOOLEAN; // If true: Pack Whitespace and don't return empty contents - EntityStack : TEntityStack; // Entity Stack for Parameter and General Entities - FCurEncoding : STRING; // Current Encoding during parsing (always uppercase) - - PROCEDURE AnalyzeProlog; // Analyze XML Prolog or Text Declaration - PROCEDURE AnalyzeComment (Start : PChar; VAR Final : PChar); // Analyze Comments - PROCEDURE AnalyzePI (Start : PChar; VAR Final : PChar); // Analyze Processing Instructions (PI) - PROCEDURE AnalyzeDtdc; // Analyze Document Type Declaration - PROCEDURE AnalyzeDtdElements (Start : PChar; VAR Final : PChar); // Analyze DTD declarations - PROCEDURE AnalyzeTag; // Analyze Start/End/Empty-Element Tags - PROCEDURE AnalyzeCData; // Analyze CDATA Sections - PROCEDURE AnalyzeText (VAR IsDone : BOOLEAN); // Analyze Text Content between Tags - PROCEDURE AnalyzeElementDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); - - PROCEDURE PushPE (VAR Start : PChar); - PROCEDURE ReplaceCharacterEntities (VAR Str : STRING); - PROCEDURE ReplaceParameterEntities (VAR Str : STRING); - PROCEDURE ReplaceGeneralEntities (VAR Str : STRING); - - FUNCTION GetDocBuffer : PChar; // Returns FBuffer or a pointer to a NUL char if Buffer is empty - - PUBLIC // --- Document Properties - PROPERTY XmlVersion : STRING READ FXmlVersion; // XML version from the Document Prolog - PROPERTY Encoding : STRING READ FEncoding; // Document Encoding from Prolog - PROPERTY Standalone : BOOLEAN READ FStandalone; // Standalone Declaration from Prolog - PROPERTY RootName : STRING READ FRootName; // Name of the Root Element - PROPERTY Normalize : BOOLEAN READ FNormalize WRITE FNormalize; // True if Content is to be normalized - PROPERTY Source : STRING READ FSource; // Name of Document Source (Filename) - PROPERTY DocBuffer : PChar READ GetDocBuffer; // Returns document buffer - PUBLIC // --- DTD Objects - Elements : TElemList; // Elements: List of TElemDef (contains Attribute Definitions) - Entities : TNvpList; // General Entities: List of TEntityDef - ParEntities : TNvpList; // Parameter Entities: List of TEntityDef - Notations : TNvpList; // Notations: List of TNotationDef - PUBLIC - CONSTRUCTOR Create; - DESTRUCTOR Destroy; OVERRIDE; - - // --- Document Handling - FUNCTION LoadFromFile (Filename : STRING; - FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; - // Loads Document from given file - FUNCTION LoadFromBuffer (Buffer : PChar) : BOOLEAN; // Loads Document from another buffer - PROCEDURE SetBuffer (Buffer : PChar); // References another buffer - PROCEDURE Clear; // Clear Document - - PUBLIC - // --- Scanning through the document - CurPartType : TPartType; // Current Type - CurName : STRING; // Current Name - CurContent : STRING; // Current Normalized Content - CurStart : PChar; // Current First character - CurFinal : PChar; // Current Last character - CurAttr : TAttrList; // Current Attribute List - PROPERTY CurEncoding : STRING READ FCurEncoding; // Current Encoding - PROCEDURE StartScan; - FUNCTION Scan : BOOLEAN; - - // --- Events / Callbacks - FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : STRING) : TXmlParser; VIRTUAL; - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; VIRTUAL; - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); VIRTUAL; - END; - - TValueType = // --- Attribute Value Type - (vtNormal, // Normal specified Attribute - vtImplied, // #IMPLIED attribute value - vtFixed, // #FIXED attribute value - vtDefault); // Attribute value from default value in !ATTLIST declaration - - TAttrDefault = // --- Attribute Default Type - (adDefault, // Normal default value - adRequired, // #REQUIRED attribute - adImplied, // #IMPLIED attribute - adFixed); // #FIXED attribute - - TAttrType = // --- Type of attribute - (atUnknown, // Unknown type - atCData, // Character data only - atID, // ID - atIdRef, // ID Reference - atIdRefs, // Several ID References, separated by Whitespace - atEntity, // Name of an unparsed Entity - atEntities, // Several unparsed Entity names, separated by Whitespace - atNmToken, // Name Token - atNmTokens, // Several Name Tokens, separated by Whitespace - atNotation, // A selection of Notation names (Unparsed Entity) - atEnumeration); // Enumeration - - TElemType = // --- Element content type - (etEmpty, // Element is always empty - etAny, // Element can have any mixture of PCDATA and any elements - etChildren, // Element must contain only elements - etMixed); // Mixed PCDATA and elements - - (*$IFDEF HAS_CONTNRS_UNIT *) - TObjectList = Contnrs.TObjectList; // Re-Export this identifier - (*$ELSE *) - TObjectList = CLASS (TList) - DESTRUCTOR Destroy; OVERRIDE; - PROCEDURE Delete (Index : INTEGER); - PROCEDURE Clear; OVERRIDE; - END; - (*$ENDIF *) - - TNvpNode = CLASS // Name-Value Pair Node - Name : STRING; - Value : STRING; - CONSTRUCTOR Create (TheName : STRING = ''; TheValue : STRING = ''); - END; - - TNvpList = CLASS (TObjectList) // Name-Value Pair List - PROCEDURE Add (Node : TNvpNode); - FUNCTION Node (Name : STRING) : TNvpNode; OVERLOAD; - FUNCTION Node (Index : INTEGER) : TNvpNode; OVERLOAD; - FUNCTION Value (Name : STRING) : STRING; OVERLOAD; - FUNCTION Value (Index : INTEGER) : STRING; OVERLOAD; - FUNCTION Name (Index : INTEGER) : STRING; - END; - - TAttr = CLASS (TNvpNode) // Attribute of a Start-Tag or Empty-Element-Tag - ValueType : TValueType; - AttrType : TAttrType; - END; - - TAttrList = CLASS (TNvpList) // List of Attributes - PROCEDURE Analyze (Start : PChar; VAR Final : PChar); - END; - - TEntityStack = CLASS (TObjectList) // Stack where current position is stored before parsing entities - PROTECTED - Owner : TXmlParser; - PUBLIC - CONSTRUCTOR Create (TheOwner : TXmlParser); - PROCEDURE Push (LastPos : PChar); OVERLOAD; - PROCEDURE Push (Instance : TObject; LastPos : PChar); OVERLOAD; - FUNCTION Pop : PChar; // Returns next char or NIL if EOF is reached. Frees Instance. - END; - - TAttrDef = CLASS (TNvpNode) // Represents a '; - - // --- Name Constants for the above enumeration types - CPartType_Name : ARRAY [TPartType] OF STRING = - ('', 'XML Prolog', 'Comment', 'PI', - 'DTD Declaration', 'Start Tag', 'Empty Tag', 'End Tag', - 'Text', 'CDATA'); - CValueType_Name : ARRAY [TValueType] OF STRING = ('Normal', 'Implied', 'Fixed', 'Default'); - CAttrDefault_Name : ARRAY [TAttrDefault] OF STRING = ('Default', 'Required', 'Implied', 'Fixed'); - CElemType_Name : ARRAY [TElemType] OF STRING = ('Empty', 'Any', 'Childs only', 'Mixed'); - CAttrType_Name : ARRAY [TAttrType] OF STRING = ('Unknown', 'CDATA', - 'ID', 'IDREF', 'IDREFS', - 'ENTITY', 'ENTITIES', - 'NMTOKEN', 'NMTOKENS', - 'Notation', 'Enumeration'); - -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; // Convert WS to spaces #x20 -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); // SetString by Start/Final of buffer -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; // Convert buffer part to Pascal string -FUNCTION TrimWs (Source : STRING) : STRING; // Trim Whitespace - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; // Convert Win-1252 to UTF-8 -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; // Convert UTF-8 to Win-1252 - - -(* -=============================================================================================== -TCustomXmlScanner event based component wrapper for TXmlParser -=============================================================================================== -*) - -TYPE - TCustomXmlScanner = CLASS; - TXmlPrologEvent = PROCEDURE (Sender : TObject; XmlVersion, Encoding: STRING; Standalone : BOOLEAN) OF OBJECT; - TCommentEvent = PROCEDURE (Sender : TObject; Comment : STRING) OF OBJECT; - TPIEvent = PROCEDURE (Sender : TObject; Target, Content: STRING; Attributes : TAttrList) OF OBJECT; - TDtdEvent = PROCEDURE (Sender : TObject; RootElementName : STRING) OF OBJECT; - TStartTagEvent = PROCEDURE (Sender : TObject; TagName : STRING; Attributes : TAttrList) OF OBJECT; - TEndTagEvent = PROCEDURE (Sender : TObject; TagName : STRING) OF OBJECT; - TContentEvent = PROCEDURE (Sender : TObject; Content : STRING) OF OBJECT; - TElementEvent = PROCEDURE (Sender : TObject; ElemDef : TElemDef) OF OBJECT; - TEntityEvent = PROCEDURE (Sender : TObject; EntityDef : TEntityDef) OF OBJECT; - TNotationEvent = PROCEDURE (Sender : TObject; NotationDef : TNotationDef) OF OBJECT; - TErrorEvent = PROCEDURE (Sender : TObject; ErrorPos : PChar) OF OBJECT; - TExternalEvent = PROCEDURE (Sender : TObject; SystemId, PublicId, NotationId : STRING; - VAR Result : TXmlParser) OF OBJECT; - TEncodingEvent = FUNCTION (Sender : TObject; CurrentEncoding, Source : STRING) : STRING OF OBJECT; - - - TCustomXmlScanner = CLASS (TComponent) - PROTECTED - FXmlParser : TXmlParser; - FOnXmlProlog : TXmlPrologEvent; - FOnComment : TCommentEvent; - FOnPI : TPIEvent; - FOnDtdRead : TDtdEvent; - FOnStartTag : TStartTagEvent; - FOnEmptyTag : TStartTagEvent; - FOnEndTag : TEndTagEvent; - FOnContent : TContentEvent; - FOnCData : TContentEvent; - FOnElement : TElementEvent; - FOnAttList : TElementEvent; - FOnEntity : TEntityEvent; - FOnNotation : TNotationEvent; - FOnDtdError : TErrorEvent; - FOnLoadExternal : TExternalEvent; - FOnTranslateEncoding : TEncodingEvent; - FStopParser : BOOLEAN; - FUNCTION GetNormalize : BOOLEAN; - PROCEDURE SetNormalize (Value : BOOLEAN); - - PROCEDURE WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); VIRTUAL; - PROCEDURE WhenComment (Comment : STRING); VIRTUAL; - PROCEDURE WhenPI (Target, Content: STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenDtdRead (RootElementName : STRING); VIRTUAL; - PROCEDURE WhenStartTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenEmptyTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenEndTag (TagName : STRING); VIRTUAL; - PROCEDURE WhenContent (Content : STRING); VIRTUAL; - PROCEDURE WhenCData (Content : STRING); VIRTUAL; - PROCEDURE WhenElement (ElemDef : TElemDef); VIRTUAL; - PROCEDURE WhenAttList (ElemDef : TElemDef); VIRTUAL; - PROCEDURE WhenEntity (EntityDef : TEntityDef); VIRTUAL; - PROCEDURE WhenNotation (NotationDef : TNotationDef); VIRTUAL; - PROCEDURE WhenDtdError (ErrorPos : PChar); VIRTUAL; - - PUBLIC - CONSTRUCTOR Create (AOwner: TComponent); OVERRIDE; - DESTRUCTOR Destroy; OVERRIDE; - - PROCEDURE LoadFromFile (Filename : TFilename); // Load XML Document from file - PROCEDURE LoadFromBuffer (Buffer : PChar); // Load XML Document from buffer - PROCEDURE SetBuffer (Buffer : PChar); // Refer to Buffer - FUNCTION GetFilename : TFilename; - - PROCEDURE Execute; // Perform scanning - - PROTECTED - PROPERTY XmlParser : TXmlParser READ FXmlParser; - PROPERTY StopParser : BOOLEAN READ FStopParser WRITE FStopParser; - PROPERTY Filename : TFilename READ GetFilename WRITE LoadFromFile; - PROPERTY Normalize : BOOLEAN READ GetNormalize WRITE SetNormalize; - PROPERTY OnXmlProlog : TXmlPrologEvent READ FOnXmlProlog WRITE FOnXmlProlog; - PROPERTY OnComment : TCommentEvent READ FOnComment WRITE FOnComment; - PROPERTY OnPI : TPIEvent READ FOnPI WRITE FOnPI; - PROPERTY OnDtdRead : TDtdEvent READ FOnDtdRead WRITE FOnDtdRead; - PROPERTY OnStartTag : TStartTagEvent READ FOnStartTag WRITE FOnStartTag; - PROPERTY OnEmptyTag : TStartTagEvent READ FOnEmptyTag WRITE FOnEmptyTag; - PROPERTY OnEndTag : TEndTagEvent READ FOnEndTag WRITE FOnEndTag; - PROPERTY OnContent : TContentEvent READ FOnContent WRITE FOnContent; - PROPERTY OnCData : TContentEvent READ FOnCData WRITE FOnCData; - PROPERTY OnElement : TElementEvent READ FOnElement WRITE FOnElement; - PROPERTY OnAttList : TElementEvent READ FOnAttList WRITE FOnAttList; - PROPERTY OnEntity : TEntityEvent READ FOnEntity WRITE FOnEntity; - PROPERTY OnNotation : TNotationEvent READ FOnNotation WRITE FOnNotation; - PROPERTY OnDtdError : TErrorEvent READ FOnDtdError WRITE FOnDtdError; - PROPERTY OnLoadExternal : TExternalEvent READ FOnLoadExternal WRITE FOnLoadExternal; - PROPERTY OnTranslateEncoding : TEncodingEvent READ FOnTranslateEncoding WRITE FOnTranslateEncoding; - END; - -(* -=============================================================================================== -IMPLEMENTATION -=============================================================================================== -*) - -IMPLEMENTATION - - -(* -=============================================================================================== -Unicode and UTF-8 stuff -=============================================================================================== -*) - -CONST - // --- Character Translation Table for Unicode <-> Win-1252 - WIN1252_UNICODE : ARRAY [$00..$FF] OF WORD = ( - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, - - $20AC, $0081, $201A, $0192, $201E, $2026, $2020, $2021, $02C6, $2030, - $0160, $2039, $0152, $008D, $017D, $008F, $0090, $2018, $2019, $201C, - $201D, $2022, $2013, $2014, $02DC, $2122, $0161, $203A, $0153, $009D, - $017E, $0178, $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, $00B0, $00B1, - $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, $00B8, $00B9, $00BA, $00BB, - $00BC, $00BD, $00BE, $00BF, $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, - $00C6, $00C7, $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, $00D8, $00D9, - $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, $00E0, $00E1, $00E2, $00E3, - $00E4, $00E5, $00E6, $00E7, $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, - $00EE, $00EF, $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF); - -(* UTF-8 (somewhat simplified) - ----- - Character Range Byte sequence - --------------- -------------------------- (x=Bits from original character) - $0000..$007F 0xxxxxxx - $0080..$07FF 110xxxxx 10xxxxxx - $8000..$FFFF 1110xxxx 10xxxxxx 10xxxxxx - - Example - -------- - Transforming the Unicode character U+00E4 LATIN SMALL LETTER A WITH DIAERESIS ("ä"): - - ISO-8859-1, Decimal 228 - Win1252, Hex $E4 - ANSI Bin 1110 0100 - abcd efgh - - UTF-8 Binary 1100xxab 10cdefgh - Binary 11000011 10100100 - Hex $C3 $A4 - Decimal 195 164 - ANSI Ã ¤ *) - - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; - (* Converts the given Windows ANSI (Win1252) String to UTF-8. *) -VAR - I : INTEGER; // Loop counter - U : WORD; // Current Unicode value - Len : INTEGER; // Current real length of "Result" string -BEGIN - SetLength (Result, Length (Source) * 3); // Worst case - Len := 0; - FOR I := 1 TO Length (Source) DO BEGIN - U := WIN1252_UNICODE [ORD (Source [I])]; - CASE U OF - $0000..$007F : BEGIN - INC (Len); - Result [Len] := CHR (U); - END; - $0080..$07FF : BEGIN - INC (Len); - Result [Len] := CHR ($C0 OR (U SHR 6)); - INC (Len); - Result [Len] := CHR ($80 OR (U AND $3F)); - END; - $0800..$FFFF : BEGIN - INC (Len); - Result [Len] := CHR ($E0 OR (U SHR 12)); - INC (Len); - Result [Len] := CHR ($80 OR ((U SHR 6) AND $3F)); - INC (Len); - Result [Len] := CHR ($80 OR (U AND $3F)); - END; - END; - END; - SetLength (Result, Len); -END; - - -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; - (* Converts the given UTF-8 String to Windows ANSI (Win-1252). - If a character can not be converted, the "UnknownChar" is inserted. *) -VAR - SourceLen : INTEGER; // Length of Source string - I, K : INTEGER; - A : BYTE; // Current ANSI character value - U : WORD; - Ch : CHAR; // Dest char - Len : INTEGER; // Current real length of "Result" string -BEGIN - SourceLen := Length (Source); - SetLength (Result, SourceLen); // Enough room to live - Len := 0; - I := 1; - WHILE I <= SourceLen DO BEGIN - A := ORD (Source [I]); - IF A < $80 THEN BEGIN // Range $0000..$007F - INC (Len); - Result [Len] := Source [I]; - INC (I); - END - ELSE BEGIN // Determine U, Inc I - IF (A AND $E0 = $C0) AND (I < SourceLen) THEN BEGIN // Range $0080..$07FF - U := (WORD (A AND $1F) SHL 6) OR (ORD (Source [I+1]) AND $3F); - INC (I, 2); - END - ELSE IF (A AND $F0 = $E0) AND (I < SourceLen-1) THEN BEGIN // Range $0800..$FFFF - U := (WORD (A AND $0F) SHL 12) OR - (WORD (ORD (Source [I+1]) AND $3F) SHL 6) OR - ( ORD (Source [I+2]) AND $3F); - INC (I, 3); - END - ELSE BEGIN // Unknown/unsupported - INC (I); - FOR K := 7 DOWNTO 0 DO - IF A AND (1 SHL K) = 0 THEN BEGIN - INC (I, (A SHR (K+1))-1); - BREAK; - END; - U := WIN1252_UNICODE [ORD (UnknownChar)]; - END; - Ch := UnknownChar; // Retrieve ANSI char - FOR A := $00 TO $FF DO - IF WIN1252_UNICODE [A] = U THEN BEGIN - Ch := CHR (A); - BREAK; - END; - INC (Len); - Result [Len] := Ch; - END; - END; - SetLength (Result, Len); -END; - - -(* -=============================================================================================== -"Special" Helper Functions - -Don't ask me why. But including these functions makes the parser *DRAMATICALLY* faster -on my K6-233 machine. You can test it yourself just by commenting them out. -They do exactly the same as the Assembler routines defined in SysUtils. -(This is where you can see how great the Delphi compiler really is. The compiled code is -faster than hand-coded assembler!) -=============================================================================================== ---> Just move this line below the StrScan function --> *) - - -FUNCTION StrPos (CONST Str, SearchStr : PChar) : PChar; - // Same functionality as SysUtils.StrPos -VAR - First : CHAR; - Len : INTEGER; -BEGIN - First := SearchStr^; - Len := StrLen (SearchStr); - Result := Str; - REPEAT - IF Result^ = First THEN - IF StrLComp (Result, SearchStr, Len) = 0 THEN BREAK; - IF Result^ = #0 THEN BEGIN - Result := NIL; - BREAK; - END; - INC (Result); - UNTIL FALSE; -END; - - -FUNCTION StrScan (CONST Start : PChar; CONST Ch : CHAR) : PChar; - // Same functionality as SysUtils.StrScan -BEGIN - Result := Start; - WHILE Result^ <> Ch DO BEGIN - IF Result^ = #0 THEN BEGIN - Result := NIL; - EXIT; - END; - INC (Result); - END; -END; - - -(* -=============================================================================================== -Helper Functions -=============================================================================================== -*) - -FUNCTION DelChars (Source : STRING; CharsToDelete : TCharset) : STRING; - // Delete all "CharsToDelete" from the string -VAR - I : INTEGER; -BEGIN - Result := Source; - FOR I := Length (Result) DOWNTO 1 DO - IF Result [I] IN CharsToDelete THEN - Delete (Result, I, 1); -END; - - -FUNCTION TrimWs (Source : STRING) : STRING; - // Trimms off Whitespace characters from both ends of the string -VAR - I : INTEGER; -BEGIN - // --- Trim Left - I := 1; - WHILE (I <= Length (Source)) AND (Source [I] IN CWhitespace) DO - INC (I); - Result := Copy (Source, I, MaxInt); - - // --- Trim Right - I := Length (Result); - WHILE (I > 1) AND (Result [I] IN CWhitespace) DO - DEC (I); - Delete (Result, I+1, Length (Result)-I); -END; - - -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; - // Converts all Whitespace characters to the Space #x20 character - // If "PackWs" is true, contiguous Whitespace characters are packed to one -VAR - I : INTEGER; -BEGIN - Result := Source; - FOR I := Length (Result) DOWNTO 1 DO - IF (Result [I] IN CWhitespace) THEN - IF PackWs AND (I > 1) AND (Result [I-1] IN CWhitespace) - THEN Delete (Result, I, 1) - ELSE Result [I] := #32; -END; - - -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); -BEGIN - SetString (S, BufferStart, BufferFinal-BufferStart+1); -END; - - -FUNCTION StrLPas (Start : PChar; Len : INTEGER) : STRING; -BEGIN - SetString (Result, Start, Len); -END; - - -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; -BEGIN - SetString (Result, Start, Finish-Start+1); -END; - - -FUNCTION StrScanE (CONST Source : PChar; CONST CharToScanFor : CHAR) : PChar; - // If "CharToScanFor" is not found, StrScanE returns the last char of the - // buffer instead of NIL -BEGIN - Result := StrScan (Source, CharToScanFor); - IF Result = NIL THEN - Result := StrEnd (Source)-1; -END; - - -PROCEDURE ExtractName (Start : PChar; Terminators : TCharset; VAR Final : PChar); - (* Extracts the complete Name beginning at "Start". - It is assumed that the name is contained in Markup, so the '>' character is - always a Termination. - Start: IN Pointer to first char of name. Is always considered to be valid - Terminators: IN Characters which terminate the name - Final: OUT Pointer to last char of name *) -BEGIN - Final := Start+1; - Include (Terminators, #0); - Include (Terminators, '>'); - WHILE NOT (Final^ IN Terminators) DO - INC (Final); - DEC (Final); -END; - - -PROCEDURE ExtractQuote (Start : PChar; VAR Content : STRING; VAR Final : PChar); - (* Extract a string which is contained in single or double Quotes. - Start: IN Pointer to opening quote - Content: OUT The quoted string - Final: OUT Pointer to closing quote *) -BEGIN - Final := StrScan (Start+1, Start^); - IF Final = NIL THEN BEGIN - Final := StrEnd (Start+1)-1; - SetString (Content, Start+1, Final-Start); - END - ELSE - SetString (Content, Start+1, Final-1-Start); -END; - - -(* -=============================================================================================== -TEntityStackNode -This Node is pushed to the "Entity Stack" whenever the parser parses entity replacement text. -The "Instance" field holds the Instance pointer of an External Entity buffer. When it is -popped, the Instance is freed. -The "Encoding" field holds the name of the Encoding. External Parsed Entities may have -another encoding as the document entity (XmlSpec 4.3.3). So when there is an " 0 THEN BEGIN - ESN := TEntityStackNode (Items [Count-1]); - Result := ESN.LastPos; - IF ESN.Instance <> NIL THEN - ESN.Instance.Free; - IF ESN.Encoding <> '' THEN - Owner.FCurEncoding := ESN.Encoding; // Restore current Encoding - Delete (Count-1); - END - ELSE - Result := NIL; -END; - - -(* -=============================================================================================== -TExternalID ------------ -XmlSpec 4.2.2: ExternalID ::= 'SYSTEM' S SystemLiteral | - 'PUBLIC' S PubidLiteral S SystemLiteral -XmlSpec 4.7: PublicID ::= 'PUBLIC' S PubidLiteral -SystemLiteral and PubidLiteral are quoted -=============================================================================================== -*) - -TYPE - TExternalID = CLASS - PublicId : STRING; - SystemId : STRING; - Final : PChar; - CONSTRUCTOR Create (Start : PChar); - END; - -CONSTRUCTOR TExternalID.Create (Start : PChar); -BEGIN - INHERITED Create; - Final := Start; - IF StrLComp (Start, 'SYSTEM', 6) = 0 THEN BEGIN - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, SystemID, Final); - END - ELSE IF StrLComp (Start, 'PUBLIC', 6) = 0 THEN BEGIN - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, PublicID, Final); - INC (Final); - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, SystemID, Final); - END; -END; - - -(* -=============================================================================================== -TXmlParser -=============================================================================================== -*) - -CONSTRUCTOR TXmlParser.Create; -BEGIN - INHERITED Create; - FBuffer := NIL; - FBufferSize := 0; - Elements := TElemList.Create; - Entities := TNvpList.Create; - ParEntities := TNvpList.Create; - Notations := TNvpList.Create; - CurAttr := TAttrList.Create; - EntityStack := TEntityStack.Create (Self); - Clear; -END; - - -DESTRUCTOR TXmlParser.Destroy; -BEGIN - Clear; - Elements.Free; - Entities.Free; - ParEntities.Free; - Notations.Free; - CurAttr.Free; - EntityStack.Free; - INHERITED Destroy; -END; - - -PROCEDURE TXmlParser.Clear; - // Free Buffer and clear all object attributes -BEGIN - IF (FBufferSize > 0) AND (FBuffer <> NIL) THEN - FreeMem (FBuffer); - FBuffer := NIL; - FBufferSize := 0; - FSource := ''; - FXmlVersion := ''; - FEncoding := ''; - FStandalone := FALSE; - FRootName := ''; - FDtdcFinal := NIL; - FNormalize := TRUE; - Elements.Clear; - Entities.Clear; - ParEntities.Clear; - Notations.Clear; - CurAttr.Clear; - EntityStack.Clear; -END; - - -FUNCTION TXmlParser.LoadFromFile (Filename : STRING; FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; - // Loads Document from given file - // Returns TRUE if successful -VAR - f : FILE; - ReadIn : INTEGER; - OldFileMode : INTEGER; -BEGIN - Result := FALSE; - Clear; - - // --- Open File - OldFileMode := SYSTEM.FileMode; - TRY - SYSTEM.FileMode := FileMode; - TRY - AssignFile (f, Filename); - Reset (f, 1); - EXCEPT - EXIT; - END; - - TRY - // --- Allocate Memory - TRY - FBufferSize := Filesize (f) + 1; - GetMem (FBuffer, FBufferSize); - EXCEPT - Clear; - EXIT; - END; - - // --- Read File - TRY - BlockRead (f, FBuffer^, FBufferSize, ReadIn); - (FBuffer+ReadIn)^ := #0; // NULL termination - EXCEPT - Clear; - EXIT; - END; - FINALLY - CloseFile (f); - END; - - FSource := Filename; - Result := TRUE; - - FINALLY - SYSTEM.FileMode := OldFileMode; - END; -END; - - -FUNCTION TXmlParser.LoadFromBuffer (Buffer : PChar) : BOOLEAN; - // Loads Document from another buffer - // Returns TRUE if successful - // The "Source" property becomes '' if successful -BEGIN - Result := FALSE; - Clear; - FBufferSize := StrLen (Buffer) + 1; - TRY - GetMem (FBuffer, FBufferSize); - EXCEPT - Clear; - EXIT; - END; - StrCopy (FBuffer, Buffer); - FSource := ''; - Result := TRUE; -END; - - -PROCEDURE TXmlParser.SetBuffer (Buffer : PChar); // References another buffer -BEGIN - Clear; - FBuffer := Buffer; - FBufferSize := 0; - FSource := ''; -END; - - -//----------------------------------------------------------------------------------------------- -// Scanning through the document -//----------------------------------------------------------------------------------------------- - -PROCEDURE TXmlParser.StartScan; -BEGIN - CurPartType := ptNone; - CurName := ''; - CurContent := ''; - CurStart := NIL; - CurFinal := NIL; - CurAttr.Clear; - EntityStack.Clear; -END; - - -FUNCTION TXmlParser.Scan : BOOLEAN; - // Scans the next Part - // Returns TRUE if a part could be found, FALSE if there is no part any more - // - // "IsDone" can be set to FALSE by AnalyzeText in order to go to the next part - // if there is no Content due to normalization -VAR - IsDone : BOOLEAN; -BEGIN - REPEAT - IsDone := TRUE; - - // --- Start of next Part - IF CurStart = NIL - THEN CurStart := DocBuffer - ELSE CurStart := CurFinal+1; - CurFinal := CurStart; - - // --- End of Document of Pop off a new part from the Entity stack? - IF CurStart^ = #0 THEN - CurStart := EntityStack.Pop; - - // --- No Document or End Of Document: Terminate Scan - IF (CurStart = NIL) OR (CurStart^ = #0) THEN BEGIN - CurStart := StrEnd (DocBuffer); - CurFinal := CurStart-1; - EntityStack.Clear; - Result := FALSE; - EXIT; - END; - - IF (StrLComp (CurStart, ''); - IF CurFinal <> NIL - THEN INC (CurFinal) - ELSE CurFinal := StrEnd (CurStart)-1; - FCurEncoding := AnsiUpperCase (CurAttr.Value ('encoding')); - IF FCurEncoding = '' THEN - FCurEncoding := 'UTF-8'; // Default XML Encoding is UTF-8 - CurPartType := ptXmlProlog; - CurName := ''; - CurContent := ''; -END; - - -PROCEDURE TXmlParser.AnalyzeComment (Start : PChar; VAR Final : PChar); - // Analyze Comments -BEGIN - Final := StrPos (Start+4, '-->'); - IF Final = NIL - THEN Final := StrEnd (Start)-1 - ELSE INC (Final, 2); - CurPartType := ptComment; -END; - - -PROCEDURE TXmlParser.AnalyzePI (Start : PChar; VAR Final : PChar); - // Analyze Processing Instructions (PI) - // This is also called for Character -VAR - F : PChar; -BEGIN - CurPartType := ptPI; - Final := StrPos (Start+2, '?>'); - IF Final = NIL - THEN Final := StrEnd (Start)-1 - ELSE INC (Final); - ExtractName (Start+2, CWhitespace + ['?', '>'], F); - SetStringSF (CurName, Start+2, F); - SetStringSF (CurContent, F+1, Final-2); - CurAttr.Analyze (F+1, F); -END; - - -PROCEDURE TXmlParser.AnalyzeDtdc; - (* Analyze Document Type Declaration - doctypedecl ::= '' - markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment - PEReference ::= '%' Name ';' - - elementdecl ::= '' - AttlistDecl ::= '' - EntityDecl ::= '' | - '' - NotationDecl ::= '' - PI ::= '' Char* )))? '?>' - Comment ::= '' *) -TYPE - TPhase = (phName, phDtd, phInternal, phFinishing); -VAR - Phase : TPhase; - F : PChar; - ExternalID : TExternalID; - ExternalDTD : TXmlParser; - DER : TDtdElementRec; -BEGIN - DER.Start := CurStart; - EntityStack.Clear; // Clear stack for Parameter Entities - CurPartType := ptDtdc; - - // --- Don't read DTDc twice - IF FDtdcFinal <> NIL THEN BEGIN - CurFinal := FDtdcFinal; - EXIT; - END; - - // --- Scan DTDc - CurFinal := CurStart + 9; // First char after '' : BREAK; - ELSE IF NOT (CurFinal^ IN CWhitespace) THEN BEGIN - CASE Phase OF - phName : IF (CurFinal^ IN CNameStart) THEN BEGIN - ExtractName (CurFinal, CWhitespace + ['[', '>'], F); - SetStringSF (FRootName, CurFinal, F); - CurFinal := F; - Phase := phDtd; - END; - phDtd : IF (StrLComp (CurFinal, 'SYSTEM', 6) = 0) OR - (StrLComp (CurFinal, 'PUBLIC', 6) = 0) THEN BEGIN - ExternalID := TExternalID.Create (CurFinal); - ExternalDTD := LoadExternalEntity (ExternalId.SystemId, ExternalID.PublicId, ''); - F := StrPos (ExternalDtd.DocBuffer, ' NIL THEN - AnalyzeDtdElements (F, F); - ExternalDTD.Free; - CurFinal := ExternalID.Final; - ExternalID.Free; - END; - ELSE BEGIN - DER.ElementType := deError; - DER.Pos := CurFinal; - DER.Final := CurFinal; - DtdElementFound (DER); - END; - END; - - END; - END; - INC (CurFinal); - UNTIL FALSE; - - CurPartType := ptDtdc; - CurName := ''; - CurContent := ''; - - // It is an error in the document if "EntityStack" is not empty now - IF EntityStack.Count > 0 THEN BEGIN - DER.ElementType := deError; - DER.Final := CurFinal; - DER.Pos := CurFinal; - DtdElementFound (DER); - END; - - EntityStack.Clear; // Clear stack for General Entities - FDtdcFinal := CurFinal; -END; - - -PROCEDURE TXmlParser.AnalyzeDtdElements (Start : PChar; VAR Final : PChar); - // Analyze the "Elements" of a DTD contained in the external or - // internal DTD subset. -VAR - DER : TDtdElementRec; -BEGIN - Final := Start; - REPEAT - CASE Final^ OF - '%' : BEGIN - PushPE (Final); - CONTINUE; - END; - #0 : IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurFinal := EntityStack.Pop; - CONTINUE; - END; - ']', - '>' : BREAK; - '<' : IF StrLComp (Final, ''); - - // --- Set Default Attribute values for nonexistent attributes - IF (CurPartType = ptStartTag) OR (CurPartType = ptEmptyTag) THEN BEGIN - ElemDef := Elements.Node (CurName); - IF ElemDef <> NIL THEN BEGIN - FOR I := 0 TO ElemDef.Count-1 DO BEGIN - AttrDef := TAttrDef (ElemDef [I]); - Attr := TAttr (CurAttr.Node (AttrDef.Name)); - IF (Attr = NIL) AND (AttrDef.Value <> '') THEN BEGIN - Attr := TAttr.Create (AttrDef.Name, AttrDef.Value); - Attr.ValueType := vtDefault; - CurAttr.Add (Attr); - END; - IF Attr <> NIL THEN BEGIN - CASE AttrDef.DefaultType OF - adDefault : ; - adRequired : ; // -!- It is an error in the document if "Attr.Value" is an empty string - adImplied : Attr.ValueType := vtImplied; - adFixed : BEGIN - Attr.ValueType := vtFixed; - Attr.Value := AttrDef.Value; - END; - END; - Attr.AttrType := AttrDef.AttrType; - END; - END; - END; - - // --- Normalize Attribute Values. XmlSpec: - // - a character reference is processed by appending the referenced character to the attribute value - // - an entity reference is processed by recursively processing the replacement text of the entity - // - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20 to the normalized value, - // except that only a single #x20 is appended for a "#xD#xA" sequence that is part of an external - // parsed entity or the literal entity value of an internal parsed entity - // - other characters are processed by appending them to the normalized value - // If the declared value is not CDATA, then the XML processor must further process the - // normalized attribute value by discarding any leading and trailing space (#x20) characters, - // and by replacing sequences of space (#x20) characters by a single space (#x20) character. - // All attributes for which no declaration has been read should be treated by a - // non-validating parser as if declared CDATA. - // !!! The XML 1.0 SE specification is somewhat different here - // This code does not conform exactly to this specification - FOR I := 0 TO CurAttr.Count-1 DO - WITH TAttr (CurAttr [I]) DO BEGIN - ReplaceGeneralEntities (Value); - ReplaceCharacterEntities (Value); - IF (AttrType <> atCData) AND (AttrType <> atUnknown) - THEN Value := TranslateEncoding (TrimWs (ConvertWs (Value, TRUE))) - ELSE Value := TranslateEncoding (ConvertWs (Value, FALSE)); - END; - END; -END; - - -PROCEDURE TXmlParser.AnalyzeCData; - // Analyze CDATA Sections -BEGIN - CurPartType := ptCData; - CurFinal := StrPos (CurStart, CDEnd); - IF CurFinal = NIL THEN BEGIN - CurFinal := StrEnd (CurStart)-1; - CurContent := TranslateEncoding (StrPas (CurStart+Length (CDStart))); - END - ELSE BEGIN - SetStringSF (CurContent, CurStart+Length (CDStart), CurFinal-1); - INC (CurFinal, Length (CDEnd)-1); - CurContent := TranslateEncoding (CurContent); - END; -END; - - -PROCEDURE TXmlParser.AnalyzeText (VAR IsDone : BOOLEAN); - (* Analyzes Text Content between Tags. CurFinal will point to the last content character. - Content ends at a '<' character or at the end of the document. - Entity References and Character Entity references are resolved. - If PackSpaces is TRUE, contiguous Whitespace Characters will be compressed to - one Space #x20 character, Whitespace at the beginning and end of content will - be trimmed off and content which is or becomes empty is not returned to - the application (in this case, "IsDone" is set to FALSE which causes the - Scan method to proceed directly to the next part. *) - - PROCEDURE ProcessEntity; - (* Is called if there is an ampsersand '&' character found in the document. - IN "CurFinal" points to the ampersand - OUT "CurFinal" points to the first character after the semi-colon ';' *) - VAR - P : PChar; - Name : STRING; - EntityDef : TEntityDef; - ExternalEntity : TXmlParser; - BEGIN - P := StrScan (CurFinal , ';'); - IF P <> NIL THEN BEGIN - SetStringSF (Name, CurFinal+1, P-1); - - // Is it a Character Entity? - IF (CurFinal+1)^ = '#' THEN BEGIN - IF UpCase ((CurFinal+2)^) = 'X' // !!! Can't use "CHR" for Unicode characters > 255: - THEN CurContent := CurContent + CHR (StrToIntDef ('$'+Copy (Name, 3, MaxInt), 32)) - ELSE CurContent := CurContent + CHR (StrToIntDef (Copy (Name, 2, MaxInt), 32)); - CurFinal := P+1; - EXIT; - END - - // Is it a Predefined Entity? - ELSE IF Name = 'lt' THEN BEGIN CurContent := CurContent + '<'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'gt' THEN BEGIN CurContent := CurContent + '>'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'amp' THEN BEGIN CurContent := CurContent + '&'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'apos' THEN BEGIN CurContent := CurContent + ''''; CurFinal := P+1; EXIT; END - ELSE IF Name = 'quot' THEN BEGIN CurContent := CurContent + '"'; CurFinal := P+1; EXIT; END; - - // Replace with Entity from DTD - EntityDef := TEntityDef (Entities.Node (Name)); - IF EntityDef <> NIL THEN BEGIN - IF EntityDef.Value <> '' THEN BEGIN - EntityStack.Push (P+1); - CurFinal := PChar (EntityDef.Value); - END - ELSE BEGIN - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); - EntityStack.Push (ExternalEntity, P+1); - CurFinal := ExternalEntity.DocBuffer; - END; - END - ELSE BEGIN - CurContent := CurContent + Name; - CurFinal := P+1; - END; - END - ELSE BEGIN - INC (CurFinal); - END; - END; - -VAR - C : INTEGER; -BEGIN - CurFinal := CurStart; - CurPartType := ptContent; - CurContent := ''; - C := 0; - REPEAT - CASE CurFinal^ OF - '&' : BEGIN - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - C := 0; - ProcessEntity; - CONTINUE; - END; - #0 : BEGIN - IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - C := 0; - CurFinal := EntityStack.Pop; - CONTINUE; - END; - END; - '<' : BREAK; - ELSE INC (C); - END; - INC (CurFinal); - UNTIL FALSE; - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - DEC (CurFinal); - - IF FNormalize THEN BEGIN - CurContent := ConvertWs (TrimWs (CurContent), TRUE); - IsDone := CurContent <> ''; // IsDone will only get FALSE if PackSpaces is TRUE - END; -END; - - -PROCEDURE TXmlParser.AnalyzeElementDecl (Start : PChar; VAR Final : PChar); - (* Parse ' character - XmlSpec 3.2: - elementdecl ::= '' - contentspec ::= 'EMPTY' | 'ANY' | Mixed | children - Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' | - '(' S? '#PCDATA' S? ')' - children ::= (choice | seq) ('?' | '*' | '+')? - choice ::= '(' S? cp ( S? '|' S? cp )* S? ')' - cp ::= (Name | choice | seq) ('?' | '*' | '+')? - seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' - - More simply: - contentspec ::= EMPTY - ANY - '(#PCDATA)' - '(#PCDATA | A | B)*' - '(A, B, C)' - '(A | B | C)' - '(A?, B*, C+), - '(A, (B | C | D)* )' *) -VAR - Element : TElemDef; - Elem2 : TElemDef; - F : PChar; - DER : TDtdElementRec; -BEGIN - Element := TElemDef.Create; - Final := Start + 9; - DER.Start := Start; - REPEAT - IF Final^ = '>' THEN BREAK; - IF (Final^ IN CNameStart) AND (Element.Name = '') THEN BEGIN - ExtractName (Final, CWhitespace, F); - SetStringSF (Element.Name, Final, F); - Final := F; - F := StrScan (Final+1, '>'); - IF F = NIL THEN BEGIN - Element.Definition := STRING (Final); - Final := StrEnd (Final); - BREAK; - END - ELSE BEGIN - SetStringSF (Element.Definition, Final+1, F-1); - Final := F; - BREAK; - END; - END; - INC (Final); - UNTIL FALSE; - Element.Definition := DelChars (Element.Definition, CWhitespace); - ReplaceParameterEntities (Element.Definition); - IF Element.Definition = 'EMPTY' THEN Element.ElemType := etEmpty - ELSE IF Element.Definition = 'ANY' THEN Element.ElemType := etAny - ELSE IF Copy (Element.Definition, 1, 8) = '(#PCDATA' THEN Element.ElemType := etMixed - ELSE IF Copy (Element.Definition, 1, 1) = '(' THEN Element.ElemType := etChildren - ELSE Element.ElemType := etAny; - - Elem2 := Elements.Node (Element.Name); - IF Elem2 <> NIL THEN - Elements.Delete (Elements.IndexOf (Elem2)); - Elements.Add (Element); - Final := StrScanE (Final, '>'); - DER.ElementType := deElement; - DER.ElemDef := Element; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); - (* Parse ' character - XmlSpec 3.3: - AttlistDecl ::= '' - AttDef ::= S Name S AttType S DefaultDecl - AttType ::= StringType | TokenizedType | EnumeratedType - StringType ::= 'CDATA' - TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' - EnumeratedType ::= NotationType | Enumeration - NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' - Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' - DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) - AttValue ::= '"' ([^<&"] | Reference)* '"' | "'" ([^<&'] | Reference)* "'" - Examples: - *) -TYPE - TPhase = (phElementName, phName, phType, phNotationContent, phDefault); -VAR - Phase : TPhase; - F : PChar; - ElementName : STRING; - ElemDef : TElemDef; - AttrDef : TAttrDef; - AttrDef2 : TAttrDef; - Strg : STRING; - DER : TDtdElementRec; -BEGIN - Final := Start + 9; // The character after ' : BREAK; - ELSE CASE Phase OF - phElementName : BEGIN - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); - SetStringSF (ElementName, Final, F); - Final := F; - ElemDef := Elements.Node (ElementName); - IF ElemDef = NIL THEN BEGIN - ElemDef := TElemDef.Create; - ElemDef.Name := ElementName; - ElemDef.Definition := 'ANY'; - ElemDef.ElemType := etAny; - Elements.Add (ElemDef); - END; - Phase := phName; - END; - phName : BEGIN - AttrDef := TAttrDef.Create; - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); - SetStringSF (AttrDef.Name, Final, F); - Final := F; - AttrDef2 := TAttrDef (ElemDef.Node (AttrDef.Name)); - IF AttrDef2 <> NIL THEN - ElemDef.Delete (ElemDef.IndexOf (AttrDef2)); - ElemDef.Add (AttrDef); - Phase := phType; - END; - phType : BEGIN - IF Final^ = '(' THEN BEGIN - F := StrScan (Final+1, ')'); - IF F <> NIL - THEN SetStringSF (AttrDef.TypeDef, Final+1, F-1) - ELSE AttrDef.TypeDef := STRING (Final+1); - AttrDef.TypeDef := DelChars (AttrDef.TypeDef, CWhitespace); - AttrDef.AttrType := atEnumeration; - ReplaceParameterEntities (AttrDef.TypeDef); - ReplaceCharacterEntities (AttrDef.TypeDef); - Phase := phDefault; - END - ELSE IF StrLComp (Final, 'NOTATION', 8) = 0 THEN BEGIN - INC (Final, 8); - AttrDef.AttrType := atNotation; - Phase := phNotationContent; - END - ELSE BEGIN - ExtractName (Final, CWhitespace+CQuoteChar+['#'], F); - SetStringSF (AttrDef.TypeDef, Final, F); - IF AttrDef.TypeDef = 'CDATA' THEN AttrDef.AttrType := atCData - ELSE IF AttrDef.TypeDef = 'ID' THEN AttrDef.AttrType := atId - ELSE IF AttrDef.TypeDef = 'IDREF' THEN AttrDef.AttrType := atIdRef - ELSE IF AttrDef.TypeDef = 'IDREFS' THEN AttrDef.AttrType := atIdRefs - ELSE IF AttrDef.TypeDef = 'ENTITY' THEN AttrDef.AttrType := atEntity - ELSE IF AttrDef.TypeDef = 'ENTITIES' THEN AttrDef.AttrType := atEntities - ELSE IF AttrDef.TypeDef = 'NMTOKEN' THEN AttrDef.AttrType := atNmToken - ELSE IF AttrDef.TypeDef = 'NMTOKENS' THEN AttrDef.AttrType := atNmTokens; - Phase := phDefault; - END - END; - phNotationContent : BEGIN - F := StrScan (Final, ')'); - IF F <> NIL THEN - SetStringSF (AttrDef.Notations, Final+1, F-1) - ELSE BEGIN - AttrDef.Notations := STRING (Final+1); - Final := StrEnd (Final); - END; - ReplaceParameterEntities (AttrDef.Notations); - AttrDef.Notations := DelChars (AttrDef.Notations, CWhitespace); - Phase := phDefault; - END; - phDefault : BEGIN - IF Final^ = '#' THEN BEGIN - ExtractName (Final, CWhiteSpace + CQuoteChar, F); - SetStringSF (Strg, Final, F); - Final := F; - ReplaceParameterEntities (Strg); - IF Strg = '#REQUIRED' THEN BEGIN AttrDef.DefaultType := adRequired; Phase := phName; END - ELSE IF Strg = '#IMPLIED' THEN BEGIN AttrDef.DefaultType := adImplied; Phase := phName; END - ELSE IF Strg = '#FIXED' THEN AttrDef.DefaultType := adFixed; - END - ELSE IF (Final^ IN CQuoteChar) THEN BEGIN - ExtractQuote (Final, AttrDef.Value, Final); - ReplaceParameterEntities (AttrDef.Value); - ReplaceCharacterEntities (AttrDef.Value); - Phase := phName; - END; - IF Phase = phName THEN BEGIN - AttrDef := NIL; - END; - END; - - END; - END; - INC (Final); - UNTIL FALSE; - - Final := StrScan (Final, '>'); - - DER.ElementType := deAttList; - DER.ElemDef := ElemDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); - (* Parse ' character - XmlSpec 4.2: - EntityDecl ::= '' | - '' - EntityDef ::= EntityValue | (ExternalID NDataDecl?) - PEDef ::= EntityValue | ExternalID - NDataDecl ::= S 'NDATA' S Name - EntityValue ::= '"' ([^%&"] | PEReference | EntityRef | CharRef)* '"' | - "'" ([^%&'] | PEReference | EntityRef | CharRef)* "'" - PEReference ::= '%' Name ';' - - Examples - - - - "> - - - Dies ist ein Test-Absatz

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

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

-BEGIN - IF Assigned (FOnEndTag) THEN FOnEndTag (Self, TagName); -END; - - -PROCEDURE TCustomXmlScanner.WhenContent (Content : STRING); - // Is called when the parser has parsed an element's text content -BEGIN - IF Assigned (FOnContent) THEN FOnContent (Self, Content); -END; - - -PROCEDURE TCustomXmlScanner.WhenCData (Content : STRING); - // Is called when the parser has parsed a CDATA section -BEGIN - IF Assigned (FOnCData) THEN FOnCData (Self, Content); -END; - - -PROCEDURE TCustomXmlScanner.WhenElement (ElemDef : TElemDef); - // Is called when the parser has parsed an definition - // inside the DTD -BEGIN - IF Assigned (FOnElement) THEN FOnElement (Self, ElemDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenAttList (ElemDef : TElemDef); - // Is called when the parser has parsed an definition - // inside the DTD -BEGIN - IF Assigned (FOnAttList) THEN FOnAttList (Self, ElemDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenEntity (EntityDef : TEntityDef); - // Is called when the parser has parsed an definition - // inside the DTD -BEGIN - IF Assigned (FOnEntity) THEN FOnEntity (Self, EntityDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenNotation (NotationDef : TNotationDef); - // Is called when the parser has parsed a definition - // inside the DTD -BEGIN - IF Assigned (FOnNotation) THEN FOnNotation (Self, NotationDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : PChar); - // Is called when the parser has found an Error in the DTD -BEGIN - IF Assigned (FOnDtdError) THEN FOnDtdError (Self, ErrorPos); -END; - - -PROCEDURE TCustomXmlScanner.Execute; - // Perform scanning - // Scanning is done synchronously, i.e. you can expect events to be triggered - // in the order of the XML data stream. Execute will finish when the whole XML - // document has been scanned or when the StopParser property has been set to TRUE. -BEGIN - FStopParser := FALSE; - FXmlParser.StartScan; - WHILE FXmlParser.Scan AND (NOT FStopParser) DO - CASE FXmlParser.CurPartType OF - ptNone : ; - ptXmlProlog : WhenXmlProlog (FXmlParser.XmlVersion, FXmlParser.Encoding, FXmlParser.Standalone); - ptComment : WhenComment (StrSFPas (FXmlParser.CurStart, FXmlParser.CurFinal)); - ptPI : WhenPI (FXmlParser.CurName, FXmlParser.CurContent, FXmlParser.CurAttr); - ptDtdc : WhenDtdRead (FXmlParser.RootName); - ptStartTag : WhenStartTag (FXmlParser.CurName, FXmlParser.CurAttr); - ptEmptyTag : WhenEmptyTag (FXmlParser.CurName, FXmlParser.CurAttr); - ptEndTag : WhenEndTag (FXmlParser.CurName); - ptContent : WhenContent (FXmlParser.CurContent); - ptCData : WhenCData (FXmlParser.CurContent); - END; -END; - - -END. diff --git a/src/lib/JEDI-SDL/SDL/Pas/logger.pas b/src/lib/JEDI-SDL/SDL/Pas/logger.pas deleted file mode 100644 index ad9b24e6..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/logger.pas +++ /dev/null @@ -1,189 +0,0 @@ -unit logger; -{ - $Id: logger.pas,v 1.2 2006/11/26 16:58:04 savage Exp $ - -} -{******************************************************************************} -{ } -{ Error Logging Unit } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2000 - 2001 Dominique Louis. } -{ } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Logging functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2001 - DL : Initial creation } -{ 25/10/2001 - DRE : Added $M+ directive to allow published } -{ in classes. Added a compile directive } -{ around fmShareExclusive as this does not } -{ exist in Free Pascal } -{ } -{******************************************************************************} -{ - $Log: logger.pas,v $ - Revision 1.2 2006/11/26 16:58:04 savage - Modifed to create separate log files. Therefore each instance running from the same directory will have their own individual log file, prepended with a number. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -{$I jedi-sdl.inc} - -{$WEAKPACKAGEUNIT OFF} - -interface - -uses - Classes, - SysUtils; - -type - TLogger = class - private - FFileHandle : TextFile; - FApplicationName : string; - FApplicationPath : string; - protected - - public - constructor Create; - destructor Destroy; override; - function GetApplicationName: string; - function GetApplicationPath: string; - procedure LogError( ErrorMessage : string; Location : string ); - procedure LogWarning( WarningMessage : string; Location : string ); - procedure LogStatus( StatusMessage : string; Location : string ); - published - property ApplicationName : string read GetApplicationName; - property ApplicationPath : string read GetApplicationPath; - end; - -var - Log : TLogger; - -implementation - -{ TLogger } -constructor TLogger.Create; -var - FileName : string; - FileNo : integer; -begin - FApplicationName := ExtractFileName( ParamStr(0) ); - FApplicationPath := ExtractFilePath( ParamStr(0) ); - FileName := FApplicationPath + ChangeFileExt( FApplicationName, '.log' ); - FileNo := 0; - while FileExists( FileName ) do - begin - inc( FileNo ); - FileName := FApplicationPath + IntToStr( FileNo ) + ChangeFileExt( FApplicationName, '.log' ) - end; - AssignFile( FFileHandle, FileName ); - ReWrite( FFileHandle ); - (*inherited Create( FApplicationPath + ChangeFileExt( FApplicationName, '.log' ), - fmCreate {$IFNDEF FPC}or fmShareExclusive{$ENDIF} );*) -end; - -destructor TLogger.Destroy; -begin - CloseFile( FFileHandle ); - inherited; -end; - -function TLogger.GetApplicationName: string; -begin - result := FApplicationName; -end; - -function TLogger.GetApplicationPath: string; -begin - result := FApplicationPath; -end; - -procedure TLogger.LogError(ErrorMessage, Location: string); -var - S : string; -begin - S := '*** ERROR *** : @ ' + TimeToStr(Time) + ' MSG : ' + ErrorMessage + ' IN : ' + Location + #13#10; - WriteLn( FFileHandle, S ); - Flush( FFileHandle ); -end; - -procedure TLogger.LogStatus(StatusMessage, Location: string); -var - S : string; -begin - S := 'STATUS INFO : @ ' + TimeToStr(Time) + ' MSG : ' + StatusMessage + ' IN : ' + Location + #13#10; - WriteLn( FFileHandle, S ); - Flush( FFileHandle ); -end; - -procedure TLogger.LogWarning(WarningMessage, Location: string); -var - S : string; -begin - S := '=== WARNING === : @ ' + TimeToStr(Time) + ' MSG : ' + WarningMessage + ' IN : ' + Location + #13#10; - WriteLn( FFileHandle, S ); - Flush( FFileHandle ); -end; - -initialization -begin - Log := TLogger.Create; - Log.LogStatus( 'Starting Application', 'Initialization' ); -end; - -finalization -begin - Log.LogStatus( 'Terminating Application', 'Finalization' ); - Log.Free; - Log := nil; -end; - -end. - \ No newline at end of file diff --git a/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas b/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas deleted file mode 100644 index ea4f220c..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/moduleloader.pas +++ /dev/null @@ -1,320 +0,0 @@ -unit moduleloader; -{ - $Id: moduleloader.pas,v 1.4 2004/02/20 17:19:10 savage Exp $ - -} -{******************************************************************} -{ } -{ Project JEDI } -{ OS independent Dynamic Loading Helpers } -{ } -{ The initial developer of the this code is } -{ Robert Marquardt INVALID_MODULEHANDLE_VALUE; -end; - -// load the DLL file FileName -// LoadLibraryEx is used to get better control of the loading -// for the allowed values for flags see LoadLibraryEx documentation. - -function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; -begin - if Module = INVALID_MODULEHANDLE_VALUE then - Module := LoadLibraryEx( FileName, 0, Flags); - Result := Module <> INVALID_MODULEHANDLE_VALUE; -end; - -// unload a DLL loaded with LoadModule or LoadModuleEx -// The procedure will not try to unload a handle with -// value INVALID_MODULEHANDLE_VALUE and assigns this value -// to Module after unload. - -procedure UnloadModule(var Module: TModuleHandle); -begin - if Module <> INVALID_MODULEHANDLE_VALUE then - FreeLibrary(Module); - Module := INVALID_MODULEHANDLE_VALUE; -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the DLL Module -// nil is returned if the symbol is not available - -function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := GetProcAddress(Module, SymbolName ); -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the DLL Module -// nil is returned if the symbol is not available. -// as an extra the boolean variable Accu is updated -// by anding in the success of the function. -// This is very handy for rendering a global result -// when accessing a long list of symbols. - -function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := GetProcAddress(Module, SymbolName ); - Accu := Accu and (Result <> nil); -end; - -// get the value of variables exported from a DLL Module -// Delphi cannot access variables in a DLL directly, so -// this function allows to copy the data from the DLL. -// Beware! You are accessing the DLL memory image directly. -// Be sure to access a variable not a function and be sure -// to read the correct amount of data. - -function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Sym^, Buffer, Size); -end; - -// set the value of variables exported from a DLL Module -// Delphi cannot access variables in a DLL directly, so -// this function allows to copy the data to the DLL! -// BEWARE! You are accessing the DLL memory image directly. -// Be sure to access a variable not a function and be sure -// to write the correct amount of data. -// The changes are not persistent. They get lost when the -// DLL is unloaded. - -function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Buffer, Sym^, Size); -end; - -{$ENDIF} - -{$IFDEF Unix} -uses -{$ifdef FPC} - dl, - Types, - Baseunix, - Unix; -{$else} - Types, - Libc; -{$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/src/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas b/src/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas deleted file mode 100644 index 4a5d55f0..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/registryuserpreferences.pas +++ /dev/null @@ -1,229 +0,0 @@ -unit registryuserpreferences; -{ - $Id: registryuserpreferences.pas,v 1.1 2004/09/30 22:35:47 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Wrapper class for Windows Register and INI Files } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: registryuserpreferences.pas,v $ - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - {$IFDEF REG} - Registry, - {$ELSE} - IniFiles, - {$ENDIF} - Classes, - userpreferences; - -type - TRegistryUserPreferences = class( TUserPreferences ) - private - - protected - function GetSection( const Index : Integer ) : string; virtual; abstract; - function GetIdentifier( const Index : Integer ) : string; virtual; abstract; - function GetDefaultBoolean( const Index : Integer ) : Boolean; override; - function GetBoolean( const Index : Integer ) : Boolean; override; - procedure SetBoolean( const Index : Integer; const Value : Boolean ); override; - function GetDefaultDateTime( const Index : Integer ) : TDateTime; override; - function GetDateTime( const Index : Integer ) : TDateTime; override; - procedure SetDateTime( const Index : Integer; const Value : TDateTime ); override; - function GetDefaultInteger( const Index : Integer ) : Integer; override; - function GetInteger( const Index : Integer ) : Integer; override; - procedure SetInteger( const Index : Integer; const Value : Integer ); override; - function GetDefaultFloat( const Index : Integer ) : single; override; - function GetFloat( const Index : Integer ) : single; override; - procedure SetFloat( const Index : Integer; const Value : single ); override; - function GetDefaultString( const Index : Integer ) : string; override; - function GetString( const Index : Integer ) : string; override; - procedure SetString( const Index : Integer; const Value : string ); override; - public - Registry : {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}; - constructor Create( const FileName : string = '' ); reintroduce; - destructor Destroy; override; - procedure Update; override; - end; - -implementation - -uses - SysUtils; - -{ TRegistryUserPreferences } -constructor TRegistryUserPreferences.Create( const FileName : string ); -var - defFileName : string; -begin - inherited Create; - - if FileName <> '' then - defFileName := FileName - else - defFileName := ChangeFileExt( ParamStr( 0 ), '.ini' ); - - Registry := {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}.Create( defFileName ); -end; - -destructor TRegistryUserPreferences.Destroy; -begin - Update; - Registry.Free; - Registry := nil; - inherited; -end; - -function TRegistryUserPreferences.GetBoolean( const Index : Integer ) : Boolean; -begin - Result := Registry.ReadBool( GetSection( Index ), GetIdentifier( Index ), GetDefaultBoolean( Index ) ); -end; - -function TRegistryUserPreferences.GetDateTime( const Index : Integer ): TDateTime; -begin - Result := Registry.ReadDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultDateTime( Index ){$ENDIF} ); -end; - -function TRegistryUserPreferences.GetDefaultBoolean( const Index : Integer ) : Boolean; -begin - result := false; -end; - -function TRegistryUserPreferences.GetDefaultDateTime( const Index: Integer ) : TDateTime; -begin - result := Now; -end; - -function TRegistryUserPreferences.GetDefaultFloat( const Index: Integer ) : single; -begin - result := 0.0; -end; - -function TRegistryUserPreferences.GetDefaultInteger(const Index : Integer ) : Integer; -begin - result := 0; -end; - -function TRegistryUserPreferences.GetDefaultString( const Index : Integer ) : string; -begin - result := ''; -end; - -function TRegistryUserPreferences.GetFloat( const Index : Integer ): single; -begin - Result := Registry.ReadFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultFloat( Index ){$ENDIF} ); -end; - -function TRegistryUserPreferences.GetInteger( const Index : Integer ) : Integer; -begin - Result := Registry.ReadInteger( GetSection( Index ), GetIdentifier( Index ), GetDefaultInteger( Index ) ); -end; - -function TRegistryUserPreferences.GetString( const Index : Integer ): string; -begin - Result := Registry.ReadString( GetSection( Index ), GetIdentifier( Index ), GetDefaultString( Index ) ); -end; - -procedure TRegistryUserPreferences.SetBoolean( const Index : Integer; const Value : Boolean ); -begin - Registry.WriteBool( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetDateTime( const Index: Integer; const Value: TDateTime ); -begin - Registry.WriteDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetFloat(const Index: Integer; const Value: single); -begin - Registry.WriteFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetInteger( const Index, Value : Integer ); -begin - Registry.WriteInteger( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetString( const Index : Integer; const Value : string ); -begin - Registry.WriteString( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.Update; -begin - {$IFDEF REG} - Registry.CloseKey; - {$ELSE} - Registry.UpdateFile; - {$ENDIF} -end; - -end. diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdl.pas b/src/lib/JEDI-SDL/SDL/Pas/sdl.pas deleted file mode 100644 index 0d7e46af..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdl.pas +++ /dev/null @@ -1,4332 +0,0 @@ -unit sdl; -{ - $Id: sdl.pas,v 1.38 2008/01/26 10:09:32 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Conversion of the Simple DirectMedia Layer Headers } -{ } -{ Portions created by Sam Lantinga are } -{ Copyright (C) 1997-2004 Sam Lantinga } -{ 5635-34 Springhouse Dr. } -{ Pleasanton, CA 94588 (USA) } -{ } -{ All Rights Reserved. } -{ } -{ The original files are : SDL.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 : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2000 - 2004 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Tom Jones His Project inspired this conversion } -{ Matthias Thoma } -{ } -{ 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.38 2008/01/26 10:09:32 savage - Added SDL_BUTTON_X1 and SDL_BUTTON_X2 constants for extended mouse buttons. Now makes SDL v1.2.13 compliant. - - Revision 1.37 2007/12/20 22:36:56 savage - Added SKYOS support, thanks to Sebastian-Torsten Tillmann - - Revision 1.36 2007/12/05 22:52:04 savage - Better Mac OS X support for Frameworks. - - Revision 1.35 2007/12/02 22:41:13 savage - Change for Mac OS X to link to SDL Framework - - Revision 1.34 2007/08/26 23:50:53 savage - Jonas supplied another fix. - - Revision 1.33 2007/08/26 15:59:46 savage - Mac OS changes as suggested by Jonas Maebe - - Revision 1.32 2007/08/22 21:18:43 savage - Thanks to Dean for his MouseDelta patch. - - Revision 1.31 2007/05/29 21:30:48 savage - Changes as suggested by Almindor for 64bit compatibility. - - Revision 1.30 2007/05/29 19:31:03 savage - Fix to TSDL_Overlay structure - thanks David Pethes (aka imcold) - - Revision 1.29 2007/05/20 20:29:11 savage - Initial Changes to Handle 64 Bits - - Revision 1.26 2007/02/11 13:38:04 savage - Added Nintendo DS support - Thanks Dean. - - Revision 1.25 2006/12/02 00:12:52 savage - Updated to latest version - - Revision 1.24 2006/05/18 21:10:04 savage - Added 1.2.10 Changes - - Revision 1.23 2005/12/04 23:17:52 drellis - Added declaration of SInt8 and PSInt8 - - Revision 1.22 2005/05/24 21:59:03 savage - Re-arranged uses clause to work on Win32 and Linux, Thanks again Michalis. - - Revision 1.21 2005/05/22 18:42:31 savage - Changes as suggested by Michalis Kamburelis. Thanks again. - - Revision 1.20 2005/04/10 11:48:33 savage - Changes as suggested by Michalis, thanks. - - Revision 1.19 2005/01/05 01:47:06 savage - Changed LibName to reflect what MacOS X should have. ie libSDL*-1.2.0.dylib respectively. - - Revision 1.18 2005/01/04 23:14:41 savage - Changed LibName to reflect what most Linux distros will have. ie libSDL*-1.2.so.0 respectively. - - 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} - -interface - -uses -{$IFDEF __GPC__} - system, - {$IFDEF WINDOWS} - wintypes, - {$ELSE} - {$ENDIF} - gpc; -{$ENDIF} - -{$IFDEF HAS_TYPES} - Types{$IFNDEF NDS},{$ELSE};{$ENDIF} -{$ENDIF} - -{$IFDEF WINDOWS} - Windows; -{$ENDIF} - -{$IFDEF UNIX} - {$IFDEF FPC} - {$IFNDEF SKYOS} - pthreads, - {$ENDIF} - baseunix, - {$IFNDEF GP2X} - {$IFNDEF DARWIN} - {$IFNDEF SKYOS} - unix, - {$ELSE} - unix; - {$ENDIF} - {$ELSE} - unix; - {$ENDIF} - {$ELSE} - unix; - {$ENDIF} - {$IFNDEF GP2X} - {$IFNDEF DARWIN} - {$IFNDEF SKYOS} - x, - xlib; - {$ENDIF} - {$ENDIF} - {$ENDIF} - {$ELSE} - Libc, - Xlib; - {$ENDIF} -{$ENDIF} - -{$IFDEF __MACH__} - GPCMacOSAll; -{$ENDIF} - -{$ifndef FPC} -type - PtrInt = LongInt; - PtrUInt = LongWord; -{$endif} - -const -{$IFDEF WINDOWS} - SDLLibName = 'SDL.dll'; -{$ENDIF} - -{$IFDEF UNIX} -{$IFDEF DARWIN} - SDLLibName = 'libSDL-1.2.0.dylib'; - {$linklib libSDL-1.2.0} - {$linklib gcc} - {$linklib SDLmain} - {$linkframework Cocoa} - {$PASCALMAINNAME SDL_main} -{$ELSE} - {$IFDEF FPC} - SDLLibName = 'libSDL.so'; - {$ELSE} - SDLLibName = 'libSDL-1.2.so.0'; - {$ENDIF} -{$ENDIF} -{$ENDIF} - -{$IFDEF MACOS} - SDLLibName = 'SDL'; - {$linklib libSDL} -{$ENDIF} - -{$IFDEF NDS} - SDLLibName = 'libSDL.a'; - {$linklib libSDL.a} - {$linklib libnds9.a} - {$linklib libc.a} - {$linklib libgcc.a} - {$linklib libsysbase.a} -{$ENDIF} - - // 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 = 13; -{$EXTERNALSYM SDL_PATCHLEVEL} - - // 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< } - - { 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 WINDOWS} - 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} - {$IFNDEF GP2X} - {$IFNDEF DARWIN} - {$IFNDEF SKYOS} - event : TXEvent; - {$ENDIF} - {$ENDIF} - {$ENDIF} - {$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 WINDOWS} - 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} - {$IFNDEF GP2X} - {$IFNDEF DARWIN} - {$IFNDEF SKYOS} - 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; - {$ENDIF} - {$ENDIF} - {$ENDIF} - - PSDL_SysWMinfo = ^TSDL_SysWMinfo; - TSDL_SysWMinfo = record - version : TSDL_version ; - subsystem : TSDL_SysWm; - {$IFNDEF GP2X} - {$IFNDEF DARWIN} - {$IFNDEF SKYOS} - X11 : TX11; - {$ENDIF} - {$ENDIF} - {$ENDIF} - 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 WINDOWS} - {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 - current_w : SInt32; // Value: The current video mode width - current_h : SInt32; // Value: The current video mode height - 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: PPUInt8; - // An array of pointers to the 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, - SDL_GL_ACCELERATED_VISUAL, - SDL_GL_SWAP_CONTROL); - - - - 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 WINDOWS} - 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 NDS} - PSDL_mutex = ^TSDL_Mutex; - TSDL_Mutex = record - recursive: Integer; - Owner: UInt32; - sem: PSDL_sem; - 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 WINDOWS} - // WINDOWS 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 WINDOWS} - TSYS_ThreadHandle = THandle; -{$ENDIF} - -{$IFDEF Unix} - TSYS_ThreadHandle = pthread_t; -{$ENDIF} - -{$IFDEF NDS} - TSYS_ThreadHandle = Integer; -{$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; - {$IFDEF HAS_TYPES} - TPoint = Types.TPoint; - {$ELSE} - {$IFDEF WINDOWS} - {$IFDEF __GPC__} - TPoint = wintypes.TPoint; - {$ELSE} - TPoint = Windows.TPoint; - {$ENDIF} - {$ELSE} - //Can't define TPoint : neither Types nor Windows unit available. - {$ENDIF} - {$ENDIF} - - PRect = ^TRect; - {$IFDEF HAS_TYPES} - TRect = Types.TRect; - {$ELSE} - {$IFDEF WINDOWS} - {$IFDEF __GPC__} - TRect = wintypes.TRect; - {$ELSE} - TRect = Windows.TRect; - {$ENDIF} - {$ELSE} - //Can't define TRect: neither Types nor Windows unit available. - {$ENDIF} - {$ENDIF} - - { 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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_Init'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_Init} - -// This function initializes specific SDL subsystems -function SDL_InitSubSystem( flags : UInt32 ) : Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_InitSubSystem'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_InitSubSystem} - -// This function cleans up specific SDL subsystems -procedure SDL_QuitSubSystem( flags : UInt32 ); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_QuitSubSystem'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WasInit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_Quit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_Quit} - -{$IFDEF WINDOWS} -// This should be called from your WinMain() function, if any -function SDL_RegisterApp(name: PChar; style: UInt32; h_Inst: Pointer): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_RegisterApp'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_RegisterApp} -{$ENDIF} - -{$IFDEF __MACH__} -// This should be called from your main() function, if any -procedure SDL_InitQuickDraw( the_qd: QDGlobals ); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_InitQuickDraw'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetError'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetError} -procedure SDL_SetError(fmt: PChar); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetError'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_SetError} -procedure SDL_ClearError; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_ClearError'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_ClearError} - -{$IFNDEF WINDOWS} -procedure SDL_Error(Code: TSDL_errorcode); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_Error'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_RWFromFile'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_RWFromFile} -procedure SDL_FreeRW(area: PSDL_RWops); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_FreeRW'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_FreeRW} - -//fp is FILE *fp ??? -function SDL_RWFromFP(fp: Pointer; autoclose: Integer): PSDL_RWops; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_RWFromFP'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_RWFromFP} -function SDL_RWFromMem(mem: Pointer; size: Integer): PSDL_RWops; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_RWFromMem'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_RWFromMem} -function SDL_RWFromConstMem(const mem: Pointer; size: Integer) : PSDL_RWops; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_RWFromConstMem'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_RWFromConstMem} -function SDL_AllocRW: PSDL_RWops; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_AllocRW'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetTicks'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetTicks} - -// Wait a specified number of milliseconds before returning -procedure SDL_Delay(msec: UInt32); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_Delay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_AddTimer'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_RemoveTimer'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_RemoveTimer} - -function SDL_SetTimer(interval: UInt32; callback: TSDL_TimerCallback): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetTimer'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_AudioInit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_AudioInit} -procedure SDL_AudioQuit; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_AudioQuit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_AudioDriverName'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_OpenAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_OpenAudio} - -{ Get the current audio state: } -function SDL_GetAudioStatus: TSDL_Audiostatus; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetAudioStatus'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_PauseAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LoadWAV_RW'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_FreeWAV'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_BuildAudioCVT'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_ConvertAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_MixAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LockAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_LockAudio} -procedure SDL_UnlockAudio; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UnlockAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_UnlockAudio} - -{ This function shuts down audio processing and closes the audio device. } - -procedure SDL_CloseAudio; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CloseAudio'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDNumDrives'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDName'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDOpen'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDStatus'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDPlayTracks'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDPlay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CDPlay} - -// Pause play -- returns 0, or -1 on error -function SDL_CDPause(cdrom: PSDL_CD): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDPause'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CDPause} - -// Resume play -- returns 0, or -1 on error -function SDL_CDResume(cdrom: PSDL_CD): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDResume'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CDResume} - -// Stop play -- returns 0, or -1 on error -function SDL_CDStop(cdrom: PSDL_CD): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDStop'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CDStop} - -// Eject CD-ROM -- returns 0, or -1 on error -function SDL_CDEject(cdrom: PSDL_CD): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDEject'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CDEject} - -// Closes the handle for the CD-ROM drive -procedure SDL_CDClose(cdrom: PSDL_CD); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CDClose'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_NumJoysticks'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickName'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickOpen'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickOpened'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_JoystickOpened} - -{ Get the device index of an opened joystick. } -function SDL_JoystickIndex(joystick: PSDL_Joystick): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickIndex'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_JoystickIndex} - -{ Get the number of general axis controls on a joystick } -function SDL_JoystickNumAxes(joystick: PSDL_Joystick): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickNumAxes'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickNumBalls'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_JoystickNumBalls} - - -{ Get the number of POV hats on a joystick } -function SDL_JoystickNumHats(joystick: PSDL_Joystick): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickNumHats'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_JoystickNumHats} - -{ Get the number of buttons on a joystick } -function SDL_JoystickNumButtons(joystick: PSDL_Joystick): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickNumButtons'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickUpdate'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickEventState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickGetAxis'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_JoystickGetAxis} - -{ The hat indices start at index 0. } - -function SDL_JoystickGetHat(joystick: PSDL_Joystick; hat: Integer): UInt8; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickGetHat'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickGetBall'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickGetButton'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_JoystickGetButton} - -{ Close a joystick previously opened with SDL_JoystickOpen() } -procedure SDL_JoystickClose(joystick: PSDL_Joystick); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_JoystickClose'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_PumpEvents'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_PeepEvents'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_PollEvent'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WaitEvent'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_WaitEvent} - -function SDL_PushEvent( event : PSDL_Event ) : Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_PushEvent'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetEventFilter'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetEventFilter'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_EventState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_Linked_Version'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_VideoInit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_VideoInit} -procedure SDL_VideoQuit; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_VideoQuit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_VideoDriverName'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetVideoSurface'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetVideoInfo'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_VideoModeOK'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_ListModes'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetVideoMode'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UpdateRects'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_UpdateRects} -procedure SDL_UpdateRect(screen: PSDL_Surface; x, y: SInt32; w, h: UInt32); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UpdateRect'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_Flip'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetGamma'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetGammaRamp'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetGammaRamp'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetColors'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetPalette'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_MapRGB'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_MapRGBA'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetRGB'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetRGBA'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateRGBSurface'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CreateRGBSurface} - -function SDL_CreateRGBSurfaceFrom(pixels: Pointer; width, height, depth, pitch - : Integer; RMask, GMask, BMask, AMask: UInt32): PSDL_Surface; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateRGBSurfaceFrom'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CreateRGBSurfaceFrom} - -procedure SDL_FreeSurface(surface: PSDL_Surface); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_FreeSurface'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LockSurface'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_LockSurface} - -procedure SDL_UnlockSurface(surface: PSDL_Surface); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UnlockSurface'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LoadBMP_RW'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SaveBMP_RW'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetColorKey'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetAlpha'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetClipRect'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetClipRect'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_ConvertSurface'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UpperBlit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LowerBlit'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_FillRect'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_DisplayFormat'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_DisplayFormatAlpha'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LockYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_LockYUVOverlay} - -procedure SDL_UnlockYUVOverlay(Overlay: PSDL_Overlay); cdecl; -external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UnlockYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_DisplayYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_DisplayYUVOverlay} - -// Free a video overlay -procedure SDL_FreeYUVOverlay(Overlay: PSDL_Overlay); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_FreeYUVOverlay'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_LoadLibrary'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GL_LoadLibrary} - -{ Get the address of a GL function (for extension functions) } -function SDL_GL_GetProcAddress(procname: PChar) : Pointer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_GetProcAddress'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_SetAttribute'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_GetAttribute'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GL_GetAttribute} - -{ Swap the OpenGL buffers, if double-buffering is supported. } - -procedure SDL_GL_SwapBuffers; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_SwapBuffers'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_UpdateRects'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GL_UpdateRects} -procedure SDL_GL_Lock; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_Lock'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GL_Lock;} -procedure SDL_GL_Unlock; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GL_Unlock'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WM_GetCaption'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_WM_GetCaption} -procedure SDL_WM_SetCaption( const title : PChar; const icon : PChar); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WM_SetCaption'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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: PUInt8); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WM_SetIcon'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WM_IconifyWindow'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WM_ToggleFullScreen'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WM_GrabInput'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetMouseState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetRelativeMouseState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetRelativeMouseState} - -{ Set the position of the mouse cursor (generates a mouse motion event) } -procedure SDL_WarpMouse(x, y: UInt16); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WarpMouse'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateCursor'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetCursor'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_SetCursor} - -{ Returns the currently active cursor. } -function SDL_GetCursor: PSDL_Cursor; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetCursor'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetCursor} - -{ Deallocates a cursor created with SDL_CreateCursor(). } -procedure SDL_FreeCursor(cursor: PSDL_Cursor); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_FreeCursor'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_ShowCursor'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_EnableUNICODE'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_EnableUNICODE} - -{ If 'delay' is set to 0, keyboard repeat is disabled. } -function SDL_EnableKeyRepeat(delay: Integer; interval: Integer): Integer; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_EnableKeyRepeat'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_EnableKeyRepeat} - -procedure SDL_GetKeyRepeat(delay : PInteger; interval: PInteger); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetKeyRepeat'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetKeyRepeat} - -{ 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] ) ... is pressed } - -function SDL_GetKeyState(numkeys: PInt): PUInt8; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetKeyState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetKeyState} - -{ Get the current key modifier state } -function SDL_GetModState: TSDLMod; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetModState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SetModState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_SetModState} - -{ Get the name of an SDL virtual keysym } -function SDL_GetKeyName(key: TSDLKey): PChar; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetKeyName'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetAppState'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_GetAppState} - - -{ Mutex functions } - -{ Create a mutex, initialized unlocked } - -function SDL_CreateMutex: PSDL_Mutex; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateMutex'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CreateMutex} - -{ Lock the mutex (Returns 0, or -1 on error) } - - function SDL_mutexP(mutex: PSDL_mutex): Integer; - cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_mutexP'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{ $ 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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_mutexV'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_mutexV} - -function SDL_UnlockMutex(mutex: PSDL_mutex): Integer; -{$EXTERNALSYM SDL_UnlockMutex} - -{ Destroy a mutex } -procedure SDL_DestroyMutex(mutex: PSDL_mutex); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_DestroyMutex'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateSemaphore'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CreateSemaphore} - - -{ Destroy a semaphore } -procedure SDL_DestroySemaphore(sem: PSDL_sem); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_DestroySemaphore'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SemWait'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SemTryWait'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SemWaitTimeout'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SemPost'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_SemTryWait} - -{ Returns the current count of the semaphore } - -function SDL_SemValue(sem: PSDL_sem): UInt32; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_SemValue'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_SemValue} - -{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * } -{ Condition variable functions } -{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * } -{ Create a condition variable } -function SDL_CreateCond: PSDL_Cond; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateCond'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CreateCond} - -{ Destroy a condition variable } -procedure SDL_DestroyCond(cond: PSDL_Cond); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_DestroyCond'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CondSignal'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CondBroadcast'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CondWait'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CondWaitTimeout'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CondWaitTimeout} - -{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * } -{ Condition variable functions } -{ * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * } - -{ Create a thread } -function SDL_CreateThread(fn: PInt; data: Pointer): PSDL_Thread; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_CreateThread'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_CreateThread} - -{ Get the 32-bit thread identifier for the current thread } -function SDL_ThreadID: UInt32; -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_ThreadID'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetThreadID'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_WaitThread'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_WaitThread} - -{ Forcefully kill a thread without worrying about its state } -procedure SDL_KillThread(thread: PSDL_Thread); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_KillThread'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_KillThread} - -{------------------------------------------------------------------------------} -{ Get Environment Routines } -{------------------------------------------------------------------------------} -{$IFDEF WINDOWS} -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 {$IFNDEF NDS}{$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 WINDOWS} -{$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 {$IFNDEF NDS}{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_GetWMInfo'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LoadObject'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_LoadFunction'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$EXTERNALSYM SDL_LoadFunction} - -{* Unload a shared object from memory *} -procedure SDL_UnloadObject( handle : Pointer ); -cdecl; external {$IFNDEF NDS}{$IFDEF __GPC__}name 'SDL_UnloadObject'{$ELSE} SDLLibName{$ENDIF __GPC__}{$ENDIF}; -{$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 WINDOWS} - 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 WINDOWS} -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 WINDOWS} - Result := _putenv(variable); - {$ENDIF} - - {$IFDEF UNIX} - {$IFDEF FPC} - Result := _putenv(variable); - {$ELSE} - Result := libc.putenv(variable); - {$ENDIF} - {$ENDIF} -end; - -{$IFDEF WINDOWS} -{$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 WINDOWS} - - {$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/src/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas b/src/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas deleted file mode 100644 index b09f19f9..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdl_cpuinfo.pas +++ /dev/null @@ -1,155 +0,0 @@ -unit sdl_cpuinfo; -{ - $Id: sdl_cpuinfo.pas,v 1.2 2004/02/18 22:52:53 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ Conversion of the Simple DirectMedia Layer Headers } -{ } -{ Portions created by Sam Lantinga are } -{ Copyright (C) 1997-2004 Sam Lantinga } -{ 5635-34 Springhouse Dr. } -{ Pleasanton, CA 94588 (USA) } -{ } -{ All Rights Reserved. } -{ } -{ The original files are : SDL_cpuinfo.h } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2004 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ - $Log: sdl_cpuinfo.pas,v $ - Revision 1.2 2004/02/18 22:52:53 savage - Forgot to add jedi-sdl.inc file. It's there now. - - Revision 1.1 2004/02/18 22:35:54 savage - Brought sdl.pas up to 1.2.7 compatability - Thus... - Added SDL_GL_STEREO, - SDL_GL_MULTISAMPLEBUFFERS, - SDL_GL_MULTISAMPLESAMPLES - - Add DLL/Shared object functions - function SDL_LoadObject( const sofile : PChar ) : Pointer; - - function SDL_LoadFunction( handle : Pointer; const name : PChar ) : Pointer; - - procedure SDL_UnloadObject( handle : Pointer ); - - Added function to create RWops from const memory: SDL_RWFromConstMem() - function SDL_RWFromConstMem(const mem: Pointer; size: Integer) : PSDL_RWops; - - Ported SDL_cpuinfo.h so Now you can test for Specific CPU types. - - -} -{******************************************************************************} - -interface - -{$I jedi-sdl.inc} - -uses - sdl; - -{* This function returns true if the CPU has the RDTSC instruction - *} -function SDL_HasRDTSC : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasRDTSC'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasRDTSC} - -{* This function returns true if the CPU has MMX features - *} -function SDL_HasMMX : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMX'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasMMX} - -{* This function returns true if the CPU has MMX Ext. features - *} -function SDL_HasMMXExt : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMXExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasMMXExt} - -{* This function returns true if the CPU has 3DNow features - *} -function SDL_Has3DNow : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNow'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_Has3DNow} - -{* This function returns true if the CPU has 3DNow! Ext. features - *} -function SDL_Has3DNowExt : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNowExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_Has3DNowExt} - -{* This function returns true if the CPU has SSE features - *} -function SDL_HasSSE : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasSSE} - -{* This function returns true if the CPU has SSE2 features - *} -function SDL_HasSSE2 : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE2'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasSSE2} - -{* This function returns true if the CPU has AltiVec features - *} -function SDL_HasAltiVec : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasAltiVec'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasAltiVec} - -implementation - -end. - \ No newline at end of file diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas b/src/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas deleted file mode 100644 index 9a58ff40..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdlgameinterface.pas +++ /dev/null @@ -1,202 +0,0 @@ -unit sdlgameinterface; -{ - $Id: sdlgameinterface.pas,v 1.4 2005/08/03 18:57:31 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Game Interface Base class } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: sdlgameinterface.pas,v $ - Revision 1.4 2005/08/03 18:57:31 savage - Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class - - Revision 1.3 2004/10/17 18:41:49 savage - Slight Change to allow Reseting of Input Event handlers - - Revision 1.2 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - sdl, - sdlwindow; - -type - TGameInterfaceClass = class of TGameInterface; - - TGameInterface = class( TObject ) - private - FNextGameInterface : TGameInterfaceClass; - protected - Dragging : Boolean; - Loaded : Boolean; - procedure FreeSurfaces; virtual; - procedure Render; virtual; abstract; - procedure Close; virtual; - procedure Update( aElapsedTime : single ); virtual; - procedure MouseDown( Button : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; - procedure MouseMove( Shift: TSDLMod; CurrentPos : TPoint; RelativePos : TPoint ); virtual; - procedure MouseUp( Button : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; - procedure MouseWheelScroll( WheelDelta : Integer; Shift: TSDLMod; MousePos : TPoint ); virtual; - procedure KeyDown( var Key: TSDLKey; Shift: TSDLMod; unicode : UInt16 ); virtual; - public - MainWindow : TSDLCustomWindow; - procedure ResetInputManager; - procedure LoadSurfaces; virtual; - function PointIsInRect( Point : TPoint; x, y, x1, y1 : integer ) : Boolean; - constructor Create( const aMainWindow : TSDLCustomWindow ); - destructor Destroy; override; - property NextGameInterface : TGameInterfaceClass read FNextGameInterface write FNextGameInterface; - end; - -implementation - -{ TGameInterface } -procedure TGameInterface.Close; -begin - FNextGameInterface := nil; -end; - -constructor TGameInterface.Create( const aMainWindow : TSDLCustomWindow ); -begin - inherited Create; - MainWindow := aMainWindow; - FNextGameInterface := TGameInterface; - ResetInputManager; -end; - -destructor TGameInterface.Destroy; -begin - if Loaded then - FreeSurfaces; - inherited; -end; - -procedure TGameInterface.FreeSurfaces; -begin - Loaded := False; -end; - -procedure TGameInterface.KeyDown(var Key: TSDLKey; Shift: TSDLMod; unicode: UInt16); -begin - -end; - -procedure TGameInterface.LoadSurfaces; -begin - Loaded := True; -end; - -procedure TGameInterface.MouseDown(Button: Integer; Shift: TSDLMod; MousePos: TPoint); -begin - Dragging := True; -end; - -procedure TGameInterface.MouseMove(Shift: TSDLMod; CurrentPos, RelativePos: TPoint); -begin - -end; - -procedure TGameInterface.MouseUp(Button: Integer; Shift: TSDLMod; MousePos: TPoint); -begin - Dragging := True; -end; - -procedure TGameInterface.MouseWheelScroll(WheelDelta: Integer; Shift: TSDLMod; MousePos: TPoint); -begin - -end; - -function TGameInterface.PointIsInRect( Point : TPoint; x, y, x1, y1: integer ): Boolean; -begin - if ( Point.x >= x ) - and ( Point.y >= y ) - and ( Point.x <= x1 ) - and ( Point.y <= y1 ) then - result := true - else - result := false; -end; - -procedure TGameInterface.ResetInputManager; -var - temp : TSDLNotifyEvent; -begin - MainWindow.InputManager.Mouse.OnMouseDown := MouseDown; - MainWindow.InputManager.Mouse.OnMouseMove := MouseMove; - MainWindow.InputManager.Mouse.OnMouseUp := MouseUp; - MainWindow.InputManager.Mouse.OnMouseWheel := MouseWheelScroll; - MainWindow.InputManager.KeyBoard.OnKeyDown := KeyDown; - temp := Render; - MainWindow.OnRender := temp; - temp := Close; - MainWindow.OnClose := temp; - MainWindow.OnUpdate := Update; -end; - -procedure TGameInterface.Update(aElapsedTime: single); -begin - -end; - -end. diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas b/src/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas deleted file mode 100644 index 4de4ebee..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdli386utils.pas +++ /dev/null @@ -1,5236 +0,0 @@ -unit sdli386utils; -{ - $Id: sdli386utils.pas,v 1.5 2004/06/02 19:38:53 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ SDL Utility functions } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Tom Jones } -{ } -{ Portions created by Tom Jones are } -{ Copyright (C) 2000 - 2001 Tom Jones. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ Róbert Kisnémeth } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Helper functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2000 - TJ : Initial creation } -{ } -{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } -{ } -{ Sept 14 2001 - RK : Added flipping routines. } -{ } -{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } -{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } -{ Added PSDLRect() } -{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} -{ Also removed by poor attempt or a dialog box } -{ } -{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } -{ SubSurface, MonoSurface & TexturedSurface } -{ } -{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } -{ types rather that Windows types. This makes it more} -{ portable to Linix. } -{ } -{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } -{ } -{ Oct 27 2001 - JF : Added ScrollY function } -{ } -{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } -{ } -{ Mar 28 2002 - JF : Added SDL_RotateSurface } -{ } -{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } -{ } -{ May 27 2002 - YS : GradientFillRect function } -{ } -{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } -{ & SDL_50Scanline2xBlit } -{ } -{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } -{ } -{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } -{ } -{ November 9 2002 - JF : Added Jason's boolean Surface functions } -{ } -{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } -{ } -{******************************************************************************} -{ - $Log: sdli386utils.pas,v $ - Revision 1.5 2004/06/02 19:38:53 savage - Changes to SDL_GradientFillRect as suggested by - Ángel Eduardo García Hernández. Many thanks. - - Revision 1.4 2004/05/29 23:11:53 savage - Changes to SDL_ScaleSurfaceRect as suggested by - Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. - - Revision 1.3 2004/02/20 22:04:11 savage - Added Changes as mentioned by Rodrigo "Rui" R. (1/2 RRC2Soft) to facilitate FPC compilation and it also works in Delphi. Also syncronized the funcitons so that they are identical to sdlutils.pas, when no assembly version is available. - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -interface - -{$i jedi-sdl.inc} - -uses -{$IFDEF UNIX} - Types, - Xlib, -{$ENDIF} - SysUtils, - sdl; - -type - TGradientStyle = ( gsHorizontal, gsVertical ); - - // Pixel procedures -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; - -procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -// Line procedures -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal );overload; - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ; DashLength, DashSpace : byte ); overload; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -// Surface procedures -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); - -// Flip procedures -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; - -function SDLRect( aRect : TRect ) : TSDL_Rect; overload; - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; - -// Fill Rect routine -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); - -// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : -PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : -boolean; - -// Jason's boolean Surface functions -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; - -implementation - -uses - Math; - -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1, Mod2 : cardinal; - Addr1, Addr2 : cardinal; - BPP : cardinal; - Pitch1, Pitch2 : cardinal; - TransparentColor1, TransparentColor2 : cardinal; - tx, ty : cardinal; - StartTick : cardinal; - Color1, Color2 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - if SrcRect2 = nil then - begin - with Src_Rect2 do - begin - x := 0; - y := 0; - w := SrcSurface2.w; - h := SrcSurface2.h; - end; - end - else - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := cardinal( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - with SrcSurface2^ do - begin - TransparentColor2 := format.colorkey; - Pitch2 := Pitch; - Addr2 := cardinal( Pixels ); - inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); - end; - Mod1 := Pitch1 - ( ScanWidth * BPP ); - Mod2 := Pitch2 - ( ScanWidth * BPP ); - inc( Addr1, BPP * Scan1Start ); - inc( Addr2, BPP * Scan2Start ); - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - inc( Addr2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - inc( Addr2, 2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - Color2 := PLongWord( Addr2 )^ and $00FFFFFF; - if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - inc( Addr2, 3 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - inc( Addr2, 4 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - end; -end; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; -var - bpp : UInt32; - p : PInteger; -begin - bpp := SrcSurface.format.BytesPerPixel; - // Here p is the address to the pixel we want to retrieve - p := Pointer( Uint32( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * - bpp ); - case bpp of - 1 : result := PUint8( p )^; - 2 : result := PUint16( p )^; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] - else - result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] shl 16; - 4 : result := PUint32( p )^; - else - result := 0; // shouldn't happen, but avoids warnings - end; -end; - -procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - Addr, Pitch, BPP : cardinal; -begin - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - BPP := SrcSurface.format.BytesPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - mov ecx, Color - cmp BPP, 1 - jne @Not1BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov [eax], cl - jmp @Quit - @Not1BPP: - cmp BPP, 2 - jne @Not2BPP - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov [eax], cx - jmp @Quit - @Not2BPP: - cmp BPP, 3 - jne @Not3BPP - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov edx, [eax] - and edx, $ff000000 - or edx, ecx - mov [eax], edx - jmp @Quit - @Not3BPP: - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov [eax], ecx - @Quit: - end; -end; - -procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - SrcColor, FinalColor : cardinal; - Addr, Pitch, Bits : cardinal; -begin - if Color = 0 then - exit; - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - Bits := SrcSurface.format.BitsPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - cmp Bits, 8 - jne @Not8bit - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov cl, [eax] - movzx ecx, cl - mov SrcColor, ecx - mov edx, Color - and ecx, 3 - and edx, 3 - add ecx, edx - cmp ecx, 3 - jbe @Skip1_8bit - mov ecx, 3 - @Skip1_8bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $1c - and edx, $1c - add ecx, edx - cmp ecx, $1c - jbe @Skip2_8bit - mov ecx, $1c - @Skip2_8bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $e0 - and edx, $e0 - add ecx, edx - cmp ecx, $e0 - jbe @Skip3_8bit - mov ecx, $e0 - @Skip3_8bit: - or ecx, FinalColor - mov [eax], cl - jmp @Quit - @Not8bit: - cmp Bits, 15 - jne @Not15bit - shl eax, 1 - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - and ecx, $00007fff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - add ecx, edx - cmp ecx, $1f - jbe @Skip1_15bit - mov ecx, $1f - @Skip1_15bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $03e0 - and edx, $03e0 - add ecx, edx - cmp ecx, $03e0 - jbe @Skip2_15bit - mov ecx, $03e0 - @Skip2_15bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $7c00 - and edx, $7c00 - add ecx, edx - cmp ecx, $7c00 - jbe @Skip3_15bit - mov ecx, $7c00 - @Skip3_15bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not15Bit: - cmp Bits, 16 - jne @Not16bit - shl eax, 1 - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - and ecx, $0000ffff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - add ecx, edx - cmp ecx, $1f - jbe @Skip1_16bit - mov ecx, $1f - @Skip1_16bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $07e0 - and edx, $07e0 - add ecx, edx - cmp ecx, $07e0 - jbe @Skip2_16bit - mov ecx, $07e0 - @Skip2_16bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $f800 - and edx, $f800 - add ecx, edx - cmp ecx, $f800 - jbe @Skip3_16bit - mov ecx, $f800 - @Skip3_16bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not16Bit: - cmp Bits, 24 - jne @Not24bit - mov ecx, 0 - add ecx, eax - shl ecx, 1 - add ecx, eax - mov eax, ecx - jmp @32bit - @Not24bit: - shl eax, 2 - @32bit: - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - mov FinalColor, ecx - and FinalColor, $ff000000 - and ecx, $00ffffff - mov SrcColor, ecx - mov edx, Color - and ecx, $000000ff - and edx, $000000ff - add ecx, edx - cmp ecx, $000000ff - jbe @Skip1_32bit - mov ecx, $000000ff - @Skip1_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $0000ff00 - and edx, $0000ff00 - add ecx, edx - cmp ecx, $0000ff00 - jbe @Skip2_32bit - mov ecx, $0000ff00 - @Skip2_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $00ff0000 - and edx, $00ff0000 - add ecx, edx - cmp ecx, $00ff0000 - jbe @Skip3_32bit - mov ecx, $00ff0000 - @Skip3_32bit: - or ecx, FinalColor - mov [eax], ecx - @Quit: - end; -end; - -procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - SrcColor, FinalColor : cardinal; - Addr, Pitch, Bits : cardinal; -begin - if Color = 0 then - exit; - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - Bits := SrcSurface.format.BitsPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - cmp Bits, 8 - jne @Not8bit - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov cl, [eax] - movzx ecx, cl - mov SrcColor, ecx - mov edx, Color - and ecx, 3 - and edx, 3 - sub ecx, edx - jns @Skip1_8bit - mov ecx, 0 - @Skip1_8bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $1c - and edx, $1c - sub ecx, edx - jns @Skip2_8bit - mov ecx, 0 - @Skip2_8bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $e0 - and edx, $e0 - sub ecx, edx - jns @Skip3_8bit - mov ecx, 0 - @Skip3_8bit: - or ecx, FinalColor - mov [eax], cl - jmp @Quit - @Not8bit: - cmp Bits, 15 - jne @Not15bit - shl eax, 1 - add eax, Addr - mov ecx, [eax] - and ecx, $00007fff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - sub ecx, edx - jns @Skip1_15bit - mov ecx, 0 - @Skip1_15bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $03e0 - and edx, $03e0 - sub ecx, edx - jns @Skip2_15bit - mov ecx, 0 - @Skip2_15bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $7c00 - and edx, $7c00 - sub ecx, edx - jns @Skip3_15bit - mov ecx, 0 - @Skip3_15bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not15Bit: - cmp Bits, 16 - jne @Not16bit - shl eax, 1 - add eax, Addr - mov ecx, [eax] - and ecx, $0000ffff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - sub ecx, edx - jns @Skip1_16bit - mov ecx, 0 - @Skip1_16bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $07e0 - and edx, $07e0 - sub ecx, edx - jns @Skip2_16bit - mov ecx, 0 - @Skip2_16bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $f800 - and edx, $f800 - sub ecx, edx - jns @Skip3_16bit - mov ecx, 0 - @Skip3_16bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not16Bit: - cmp Bits, 24 - jne @Not24bit - mov ecx, 0 - add ecx, eax - shl ecx, 1 - add ecx, eax - mov eax, ecx - jmp @32bit - @Not24bit: - shl eax, 2 - @32bit: - add eax, Addr - mov ecx, [eax] - mov FinalColor, ecx - and FinalColor, $ff000000 - and ecx, $00ffffff - mov SrcColor, ecx - mov edx, Color - and ecx, $000000ff - and edx, $000000ff - sub ecx, edx - jns @Skip1_32bit - mov ecx, 0 - @Skip1_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $0000ff00 - and edx, $0000ff00 - sub ecx, edx - jns @Skip2_32bit - mov ecx, 0 - @Skip2_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $00ff0000 - and edx, $00ff0000 - sub ecx, edx - jns @Skip3_32bit - mov ecx, 0 - @Skip3_32bit: - or ecx, FinalColor - mov [eax], ecx - @Quit: - end; -end; - -// Draw a line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// Draw a dashed line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ; DashLength, DashSpace : byte ); overload; -var - dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; -begin - counter := 0; - drawdash := true; //begin line drawing with dash - - //Avoid invalid user-passed dash parameters - if (DashLength < 1) - then DashLength := 1; - if (DashSpace < 1) - then DashSpace := 0; - - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc(counter); - if (counter > DashLength-1) and (DashSpace > 0) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc(counter); - if counter > DashSpace-1 then - begin - drawdash := true; - counter := 0; - end; - end; - - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc(counter); - if (counter > DashLength-1) and (DashSpace > 0) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc(counter); - if counter > DashSpace-1 then - begin - drawdash := true; - counter := 0; - end; - end; - - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. -// In 8 bit color depth mode the procedure works with the default packed -// palette (RRRGGGBB). It handles all clipping. -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - // TransparentColor := format.ColorKey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - mov esp, eax // ESP - source color - mov bl, [edi] // BL := destination color - mov dl, bl // DL := destination color - and ax, $03 // Adding BLUE - and bl, $03 - add al, bl - cmp al, $03 - jbe @Skip1 - mov al, $03 - @Skip1: - mov cl, al - mov eax, esp // Adding GREEN - mov bl, dl - and al, $1c - and bl, $1c - add al, bl - cmp al, $1c - jbe @Skip2 - mov al, $1c - @Skip2: - or cl, al - mov eax, esp // Adding RED - mov bl, dl - and ax, $e0 - and bx, $e0 - add ax, bx - cmp ax, $e0 - jbe @Skip3 - mov al, $e0 - @Skip3: - or cl, al - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $001F // Adding BLUE - and bx, $001F - add ax, bx - cmp ax, $001F - jbe @Skip1 - mov ax, $001F - @Skip1: - mov cx, ax - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $3E0 - and bx, $3E0 - add ax, bx - cmp ax, $3E0 - jbe @Skip2 - mov ax, $3E0 - @Skip2: - or cx, ax - mov eax, esp // Adding RED - mov bx, dx - and ax, $7C00 - and bx, $7C00 - add ax, bx - cmp ax, $7C00 - jbe @Skip3 - mov ax, $7C00 - @Skip3: - or cx, ax - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $1F // Adding BLUE - and bx, $1F - add ax, bx - cmp ax, $1F - jbe @Skip1 - mov ax, $1F - @Skip1: - mov cx, ax - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $7E0 - and bx, $7E0 - add ax, bx - cmp ax, $7E0 - jbe @Skip2 - mov ax, $7E0 - @Skip2: - or cx, ax - mov eax, esp // Adding RED - mov bx, dx - and eax, $F800 - and ebx, $F800 - add eax, ebx - cmp eax, $F800 - jbe @Skip3 - mov ax, $F800 - @Skip3: - or cx, ax - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - add bx, ax - cmp bx, $00ff - jb @Skip - mov bl, $ff - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - add bx, ax - cmp bx, $00ff - jb @Skip - mov bl, $ff - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 then skip everything - mov esp, eax // ESP - source color - mov bl, [edi] // BL := destination color - mov dl, bl // DL := destination color - and al, $03 // Subtract BLUE - and bl, $03 - sub bl, al - jns @Skip1 - mov bl, 0 - @Skip1: - mov cl, bl - mov eax, esp // Subtract GREEN - mov bl, dl - and al, $1c - and bl, $1c - sub bl, al - jns @Skip2 - mov bl, 0 - @Skip2: - or cl, bl - mov eax, esp // Subtract RED - mov bl, dl - and ax, $e0 - and bx, $e0 - sub bx, ax - jns @Skip3 - mov bl, 0 - @Skip3: - or cl, bl - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $001F // Subtract BLUE - and bx, $001F - sub bx, ax - jns @Skip1 - mov bx, 0 - @Skip1: - mov cx, bx - mov eax, esp // Subtract GREEN - mov bx, dx - and ax, $3E0 - and bx, $3E0 - sub bx, ax - jns @Skip2 - mov bx, 0 - @Skip2: - or cx, bx - mov eax, esp // Subtract RED - mov bx, dx - and ax, $7C00 - and bx, $7C00 - sub bx, ax - jns @Skip3 - mov bx, 0 - @Skip3: - or cx, bx - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $1F // Subtracting BLUE - and bx, $1F - sub bx, ax - jns @Skip1 - mov bx, 0 - @Skip1: - mov cx, bx - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $7E0 - and bx, $7E0 - sub bx, ax - jns @Skip2 - mov bx, 0 - @Skip2: - or cx, bx - mov eax, esp // Adding RED - mov bx, dx - and eax, $F800 - and ebx, $F800 - sub ebx, eax - jns @Skip3 - mov bx, 0 - @Skip3: - or cx, bx - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - sub bx, ax - jns @Skip - mov bl, 0 - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - sub bx, ax - jns @Skip - mov bl, 0 - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - SrcTransparentColor : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - SrcTransparentColor := format.colorkey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - movzx eax, al - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 15, 16 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - movzx eax, ax - cmp eax, SrcTransparentColor - je @SkipColor // if AX=Transparent color then skip everything - mov [edi], cx - @SkipColor: - inc esi - inc esi - inc edi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 24 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - and ecx, $00ffffff - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // EAX := source color - and eax, $00ffffff - cmp eax, SrcTransparentColor - je @SkipColor // if EAX=Transparent color then skip everything - mov ebx, [edi] - and ebx, $ff000000 - or ebx, ecx - mov [edi], ecx - @SkipColor: - add esi, 3 - add edi, 3 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp, _esp - mov edi, _edi - mov esi, _esi - mov ebx, _ebx - end; - 32 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // EAX := source color - cmp eax, SrcTransparentColor - je @SkipColor // if EAX=Transparent color then skip everything - mov [edi], ecx - @SkipColor: - add esi, 4 - add edi, 4 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp, _esp - mov edi, _edi - mov esi, _esi - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; -// TextureRect.w and TextureRect.h are not used. -// The TextureSurface's size MUST larger than the drawing rectangle!!! - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TextAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod, TextMod : cardinal; - SrcTransparentColor : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - SrcTransparentColor := format.colorkey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - with Texture^ do - begin - TextAddr := cardinal( Pixels ) + UInt32( TextureRect.y ) * Pitch + - UInt32( TextureRect.x ) * Format.BytesPerPixel; - TextMod := Pitch - Src.w * Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - SDL_LockSurface( Texture ); - case bits of - 8 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ebx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - movzx eax, al - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov al, [ebx] - mov [edi], al - @SkipColor: - inc esi - inc edi - inc ebx - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ebx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx, _ebx - end; - 15, 16 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ecx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AL := source color - movzx eax, ax - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov ax, [ecx] - mov [edi], ax - @SkipColor: - inc esi - inc esi - inc edi - inc edi - inc ecx - inc ecx - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ecx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 24 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ebx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // AL := source color - and eax, $00ffffff - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov eax, [ebx] - and eax, $00ffffff - mov ecx, [edi] - and ecx, $ff000000 - or ecx, eax - mov [edi], eax - @SkipColor: - add esi, 3 - add edi, 3 - add ebx, 3 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ebx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx, _ebx - end; - 32 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ecx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // AL := source color - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov eax, [ecx] - mov [edi], eax - @SkipColor: - add esi, 4 - add edi, 4 - add ecx, 4 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ecx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); - SDL_UnlockSurface( Texture ); -end; - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); -var - xc, yc : cardinal; - rx, wx, ry, wy, ry16 : cardinal; - color : cardinal; - modx, mody : cardinal; -begin - // Warning! No checks for surface pointers!!! - if srcrect = nil then - srcrect := @SrcSurface.clip_rect; - if dstrect = nil then - dstrect := @DstSurface.clip_rect; - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); - mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); - //rx := srcrect.x * 65536; - ry := srcrect.y * 65536; - wy := dstrect.y; - for yc := 0 to dstrect.h - 1 do - begin - rx := srcrect.x * 65536; - wx := dstrect.x; - ry16 := ry shr 16; - for xc := 0 to dstrect.w - 1 do - begin - color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); - SDL_PutPixel( DstSurface, wx, wy, color ); - rx := rx + modx; - inc( wx ); - end; - ry := ry + mody; - inc( wy ); - end; - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; -// Re-map a rectangular area into an area defined by four vertices -// Converted from C to Pascal by KiCHY - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); -const - SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) - THRESH = 1 shl SHIFTS; // Threshold for pixel size value - procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); - var - tm, lm, rm, bm, m : TPoint; - mx, my : cardinal; - cr : cardinal; - begin - // Does the destination area specify a single pixel? - if ( ( abs( ul.x - ur.x ) < THRESH ) and - ( abs( ul.x - lr.x ) < THRESH ) and - ( abs( ul.x - ll.x ) < THRESH ) and - ( abs( ul.y - ur.y ) < THRESH ) and - ( abs( ul.y - lr.y ) < THRESH ) and - ( abs( ul.y - ll.y ) < THRESH ) ) then - begin // Yes - cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); - SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); - end - else - begin // No - // Quarter the source and the destination, and then recurse - tm.x := ( ul.x + ur.x ) shr 1; - tm.y := ( ul.y + ur.y ) shr 1; - bm.x := ( ll.x + lr.x ) shr 1; - bm.y := ( ll.y + lr.y ) shr 1; - lm.x := ( ul.x + ll.x ) shr 1; - lm.y := ( ul.y + ll.y ) shr 1; - rm.x := ( ur.x + lr.x ) shr 1; - rm.y := ( ur.y + lr.y ) shr 1; - m.x := ( tm.x + bm.x ) shr 1; - m.y := ( tm.y + bm.y ) shr 1; - mx := ( x1 + x2 ) shr 1; - my := ( y1 + y2 ) shr 1; - CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); - CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); - CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); - CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); - end; - end; -var - _UL, _UR, _LR, _LL : TPoint; - Rect_x, Rect_y, Rect_w, Rect_h : integer; -begin - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - if SrcRect = nil then - begin - Rect_x := 0; - Rect_y := 0; - Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; - Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; - end - else - begin - Rect_x := SrcRect.x; - Rect_y := SrcRect.y; - Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; - Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; - end; - // Shift all values to help reduce round-off error. - _ul.x := ul.x shl SHIFTS; - _ul.y := ul.y shl SHIFTS; - _ur.x := ur.x shl SHIFTS; - _ur.y := ur.y shl SHIFTS; - _lr.x := lr.x shl SHIFTS; - _lr.y := lr.y shl SHIFTS; - _ll.x := ll.x shl SHIFTS; - _ll.y := ll.y shl SHIFTS; - CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; - -// flips a rectangle vertically on given surface -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -var - TmpRect : TSDL_Rect; - Locked : boolean; - y, FlipLength, RowLength : integer; - Row1, Row2 : Pointer; - OneRow : TByteArray; // Optimize it if you wish -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin // if Rect=nil then we flip the whole surface - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.h shr 1 - 1; - RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - Row1 := pointer( cardinal( DstSurface^.Pixels ) + UInt32( Rect^.y ) * - DstSurface^.Pitch ); - Row2 := pointer( cardinal( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) - * DstSurface^.Pitch ); - for y := 0 to FlipLength do - begin - Move( Row1^, OneRow, RowLength ); - Move( Row2^, Row1^, RowLength ); - Move( OneRow, Row2^, RowLength ); - inc( cardinal( Row1 ), DstSurface^.Pitch ); - dec( cardinal( Row2 ), DstSurface^.Pitch ); - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// flips a rectangle horizontally on given surface -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -type - T24bit = packed array[ 0..2 ] of byte; - T24bitArray = packed array[ 0..8191 ] of T24bit; - P24bitArray = ^T24bitArray; - TLongWordArray = array[ 0..8191 ] of LongWord; - PLongWordArray = ^TLongWordArray; -var - TmpRect : TSDL_Rect; - Row8bit : PByteArray; - Row16bit : PWordArray; - Row24bit : P24bitArray; - Row32bit : PLongWordArray; - y, x, RightSide, FlipLength : integer; - Pixel : cardinal; - Pixel24 : T24bit; - Locked : boolean; -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.w shr 1 - 1; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - case DstSurface^.format.BytesPerPixel of - 1 : - begin - Row8Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row8Bit^[ x ]; - Row8Bit^[ x ] := Row8Bit^[ RightSide ]; - Row8Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row8Bit ), DstSurface^.pitch ); - end; - end; - 2 : - begin - Row16Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row16Bit^[ x ]; - Row16Bit^[ x ] := Row16Bit^[ RightSide ]; - Row16Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row16Bit ), DstSurface^.pitch ); - end; - end; - 3 : - begin - Row24Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel24 := Row24Bit^[ x ]; - Row24Bit^[ x ] := Row24Bit^[ RightSide ]; - Row24Bit^[ RightSide ] := Pixel24; - dec( RightSide ); - end; - inc( cardinal( Row24Bit ), DstSurface^.pitch ); - end; - end; - 4 : - begin - Row32Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row32Bit^[ x ]; - Row32Bit^[ x ] := Row32Bit^[ RightSide ]; - Row32Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row32Bit ), DstSurface^.pitch ); - end; - end; - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. -// But you MUST free it after you don't need it anymore!!! -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; -var - Rect : PSDL_Rect; -begin - New( Rect ); - with Rect^ do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; - Result := Rect; -end; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; -begin - with result do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; -end; - -function SDLRect( aRect : TRect ) : TSDL_Rect; -begin - with aRect do - result := SDLRect( Left, Top, Right - Left, Bottom - Top ); -end; - -procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, - depth : integer ); -var - dx, dy, e, d, dx2 : integer; - src_pitch, dst_pitch : uint16; - src_pixels, dst_pixels : PUint8; -begin - if ( yw >= dst_surface^.h ) then - exit; - dx := ( x2 - x1 ); - dy := ( y2 - y1 ); - dy := dy shl 1; - e := dy - dx; - dx2 := dx shl 1; - src_pitch := Surface^.pitch; - dst_pitch := dst_surface^.pitch; - src_pixels := PUint8( integer( Surface^.pixels ) + yr * src_pitch + y1 * depth ); - dst_pixels := PUint8( integer( dst_surface^.pixels ) + yw * dst_pitch + x1 * - depth ); - for d := 0 to dx - 1 do - begin - move( src_pixels^, dst_pixels^, depth ); - while ( e >= 0 ) do - begin - inc( src_pixels, depth ); - e := e - dx2; - end; - inc( dst_pixels, depth ); - e := e + dy; - end; -end; - -function sign( x : integer ) : integer; -begin - if x > 0 then - result := 1 - else - result := -1; -end; - -// Stretches a part of a surface -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; -var - dst_surface : PSDL_Surface; - dx, dy, e, d, dx2, srcx2, srcy2 : integer; - destx1, desty1 : integer; -begin - srcx2 := srcx1 + SrcW; - srcy2 := srcy1 + SrcH; - result := nil; - destx1 := 0; - desty1 := 0; - dx := abs( integer( Height - desty1 ) ); - dy := abs( integer( SrcY2 - SrcY1 ) ); - e := ( dy shl 1 ) - dx; - dx2 := dx shl 1; - dy := dy shl 1; - dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - - desty1, - SrcSurface^.Format^.BitsPerPixel, - SrcSurface^.Format^.RMask, - SrcSurface^.Format^.GMask, - SrcSurface^.Format^.BMask, - SrcSurface^.Format^.AMask ); - if ( dst_surface^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); - if ( SDL_MustLock( dst_surface ) ) then - if ( SDL_LockSurface( dst_surface ) < 0 ) then - exit; - for d := 0 to dx - 1 do - begin - SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, - SrcSurface^.format^.BytesPerPixel ); - while e >= 0 do - begin - inc( SrcY1 ); - e := e - dx2; - end; - inc( desty1 ); - e := e + dy; - end; - if SDL_MUSTLOCK( dst_surface ) then - SDL_UnlockSurface( dst_surface ); - result := dst_surface; -end; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); -var - r1, r2 : TSDL_Rect; - //buffer: PSDL_Surface; - YPos : Integer; -begin - if ( DstSurface <> nil ) and ( DifY <> 0 ) then - begin - //if DifY > 0 then // going up - //begin - ypos := 0; - r1.x := 0; - r2.x := 0; - r1.w := DstSurface.w; - r2.w := DstSurface.w; - r1.h := DifY; - r2.h := DifY; - while ypos < DstSurface.h do - begin - r1.y := ypos; - r2.y := ypos + DifY; - SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); - ypos := ypos + DifY; - end; - //end - //else - //begin // Going Down - //end; - end; -end; - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); -var - r1, r2 : TSDL_Rect; - buffer : PSDL_Surface; -begin - if ( DstSurface <> nil ) and ( DifX <> 0 ) then - begin - buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, - DstSurface^.h * 2, - DstSurface^.Format^.BitsPerPixel, - DstSurface^.Format^.RMask, - DstSurface^.Format^.GMask, - DstSurface^.Format^.BMask, - DstSurface^.Format^.AMask ); - if buffer <> nil then - begin - if ( buffer^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); - r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); - SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); - SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); - SDL_FreeSurface( buffer ); - end; - end; -end; - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); -var - aSin, aCos : Single; - MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; - Colour, TempTransparentColour : UInt32; - MAXX, MAXY : Integer; -begin - // Rotate the surface to the target surface. - TempTransparentColour := SrcSurface.format.colorkey; - if srcRect.w > srcRect.h then - begin - Width := srcRect.w; - Height := srcRect.w; - end - else - begin - Width := srcRect.h; - Height := srcRect.h; - end; - - maxx := DstSurface.w; - maxy := DstSurface.h; - aCos := cos( Angle ); - aSin := sin( Angle ); - - Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); - Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); - - OX := Width div 2; - OY := Height div 2; ; - MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; - MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; - ROX := ( -( srcRect.w div 2 ) ) + Offsetx; - ROY := ( -( srcRect.h div 2 ) ) + OffsetY; - Tx := ox + round( ROX * aSin - ROY * aCos ); - Ty := oy + round( ROY * aSin + ROX * aCos ); - SX := 0; - for DX := DestX - TX to DestX - TX + ( width ) do - begin - Inc( SX ); - SY := 0; - for DY := DestY - TY to DestY - TY + ( Height ) do - begin - RX := SX - OX; - RY := SY - OY; - NX := round( mx + RX * aSin + RY * aCos ); // - NY := round( my + RY * aSin - RX * aCos ); // - // Used for testing only - //SDL_PutPixel(DstSurface.SDLSurfacePointer,DX,DY,0); - if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then - begin - if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then - begin - if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then - begin - Colour := SDL_GetPixel( SrcSurface, NX, NY ); - if Colour <> TempTransparentColour then - begin - SDL_PutPixel( DstSurface, DX, DY, Colour ); - end; - end; - end; - end; - inc( SY ); - end; - end; -end; - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); -begin - SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); -end; - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; -var - RealRect : TSDL_Rect; - OutOfRange : Boolean; -begin - OutOfRange := false; - if dstrect = nil then - begin - RealRect.x := 0; - RealRect.y := 0; - RealRect.w := DstSurface.w; - RealRect.h := DstSurface.h; - end - else - begin - if dstrect.x < DstSurface.w then - begin - RealRect.x := dstrect.x; - end - else if dstrect.x < 0 then - begin - realrect.x := 0; - end - else - begin - OutOfRange := True; - end; - if dstrect.y < DstSurface.h then - begin - RealRect.y := dstrect.y; - end - else if dstrect.y < 0 then - begin - realrect.y := 0; - end - else - begin - OutOfRange := True; - end; - if OutOfRange = False then - begin - if realrect.x + dstrect.w <= DstSurface.w then - begin - RealRect.w := dstrect.w; - end - else - begin - RealRect.w := dstrect.w - realrect.x; - end; - if realrect.y + dstrect.h <= DstSurface.h then - begin - RealRect.h := dstrect.h; - end - else - begin - RealRect.h := dstrect.h - realrect.y; - end; - end; - end; - if OutOfRange = False then - begin - result := realrect; - end - else - begin - realrect.w := 0; - realrect.h := 0; - realrect.x := 0; - realrect.y := 0; - result := realrect; - end; -end; - -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); -var - FBC : array[ 0..255 ] of Cardinal; - // temp vars - i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; - - TempStepV, TempStepH : Single; - TempLeft, TempTop, TempHeight, TempWidth : integer; - TempRect : TSDL_Rect; - -begin - // calc FBC - YR := StartColor.r; - YG := StartColor.g; - YB := StartColor.b; - SR := YR; - SG := YG; - SB := YB; - DR := EndColor.r - SR; - DG := EndColor.g - SG; - DB := EndColor.b - SB; - - for i := 0 to 255 do - begin - FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); - YR := SR + round( DR / 255 * i ); - YG := SG + round( DG / 255 * i ); - YB := SB + round( DB / 255 * i ); - end; - - // if aStyle = 1 then begin - TempStepH := Rect.w / 255; - TempStepV := Rect.h / 255; - TempHeight := Trunc( TempStepV + 1 ); - TempWidth := Trunc( TempStepH + 1 ); - TempTop := 0; - TempLeft := 0; - TempRect.x := Rect.x; - TempRect.y := Rect.y; - TempRect.h := Rect.h; - TempRect.w := Rect.w; - - case Style of - gsHorizontal : - begin - TempRect.h := TempHeight; - for i := 0 to 255 do - begin - TempRect.y := Rect.y + TempTop; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempTop := Trunc( TempStepV * i ); - end; - end; - gsVertical : - begin - TempRect.w := TempWidth; - for i := 0 to 255 do - begin - TempRect.x := Rect.x + TempLeft; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempLeft := Trunc( TempStepH * i ); - end; - end; - end; -end; - -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BytesPerPixel of - 1 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; - mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 2 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 3 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx], eax - and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 4 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; - mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BytesPerPixel of - 1 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 2 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], eax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 3 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 4 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BitsPerPixel of - 8 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - shr al, 1 - and al, $6d - mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; - mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 15 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - shr ax, 1 - and ax, $3def - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 16 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - shr ax, 1 - and ax, $7bef - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 24 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - shr eax, 1 - and eax, $007f7f7f - and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx], eax - and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 32 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - shr eax, 1 - and eax, $7f7f7f7f - mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; - mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : -boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1: cardinal; - Addr1 : cardinal; - BPP : cardinal; - Pitch1 : cardinal; - TransparentColor1 : cardinal; - tx, ty : cardinal; - StartTick : cardinal; - Color1 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( -Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := cardinal( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - - Mod1 := Pitch1 - ( ScanWidth * BPP ); - - inc( Addr1, BPP * Scan1Start ); - - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - - end; - inc( Addr1, Mod1 ); - - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - - end; - inc( Addr1, Mod1 ); - - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - - if ( Color1 <> TransparentColor1 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - - end; - inc( Addr1, Mod1 ); - - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - - end; - inc( Addr1, Mod1 ); - - end; - end; -end; - -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TransparentColor : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - cmp al, byte ptr TransparentColor - je @SkipColor - or al, [edi] - mov [edi], al - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - or ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - or ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov al, [esi] // AL := source color - or al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov al, [esi] // AL := source color - or al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TransparentColor : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - cmp al, byte ptr TransparentColor - je @SkipColor - and al, [edi] - mov [edi], al - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - and ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - and ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov al, [esi] // AL := source color - and al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov al, [esi] // AL := source color - and al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 > Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; - if Pixel2 and $1C > Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; - if Pixel2 and $03 > Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 > Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; - if Pixel2 and $03E0 > Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; - if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 > Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; - if Pixel2 and $07E0 > Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; - if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 < Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; - if Pixel2 and $1C < Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; - if Pixel2 and $03 < Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 < Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; - if Pixel2 and $03E0 < Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; - if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 < Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; - if Pixel2 and $07E0 < Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; - if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; -var tflag, flag1, flag2: word; - txy, xedge, yedge: Integer; - slope: single; - - function ClipCode(x,y: Integer): word; - begin - Result := 0; - if x < ClipRect.x then Result := 1; - if x >= ClipRect.w + ClipRect.x then Result := Result or 2; - if y < ClipRect.y then Result := Result or 4; - if y >= ClipRect.h + ClipRect.y then Result := Result or 8; - end; - -begin - flag1 := ClipCode(x1,y1); - flag2 := ClipCode(x2,y2); - result := true; - - while true do - begin - if (flag1 or flag2) = 0 then Exit; // all in - - if (flag1 and flag2) <> 0 then - begin - result := false; - Exit; // all out - end; - - if flag2 = 0 then - begin - txy := x1; x1 := x2; x2 := txy; - txy := y1; y1 := y2; y2 := txy; - tflag := flag1; flag1 := flag2; flag2 := tflag; - end; - - if (flag2 and 3) <> 0 then - begin - if (flag2 and 1) <> 0 then - xedge := ClipRect.x - else - xedge := ClipRect.w + ClipRect.x -1; // back 1 pixel otherwise we end up in a loop - - slope := (y2 - y1) / (x2 - x1); - y2 := y1 + Round(slope * (xedge - x1)); - x2 := xedge; - end - else - begin - if (flag2 and 4) <> 0 then - yedge := ClipRect.y - else - yedge := ClipRect.h + ClipRect.y -1; // up 1 pixel otherwise we end up in a loop - - slope := (x2 - x1) / (y2 - y1); - x2 := x1 + Round(slope * (yedge - y1)); - y2 := yedge; - end; - - flag2 := ClipCode(x2, y2); - end; -end; - -end. - - diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdlinput.pas b/src/lib/JEDI-SDL/SDL/Pas/sdlinput.pas deleted file mode 100644 index 094f4e0f..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdlinput.pas +++ /dev/null @@ -1,923 +0,0 @@ -unit sdlinput; -{ - $Id: sdlinput.pas,v 1.9 2007/08/22 21:18:43 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ SDL Input Wrapper } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2003 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ SDL Mouse, Keyboard and Joystick wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ March 12 2003 - DL : Initial creation } -{ } -{ February 02 2004 - DL : Added Custom Cursor Support to the Mouse class } -{ - $Log: sdlinput.pas,v $ - Revision 1.9 2007/08/22 21:18:43 savage - Thanks to Dean for his MouseDelta patch. - - Revision 1.8 2005/08/03 18:57:32 savage - Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class - - Revision 1.7 2004/09/30 22:32:04 savage - Updated with slightly different header comments - - Revision 1.6 2004/09/12 21:52:58 savage - Slight changes to fix some issues with the sdl classes. - - Revision 1.5 2004/05/10 21:11:49 savage - changes required to help get SoAoS off the ground. - - Revision 1.4 2004/05/03 22:38:40 savage - Added the ability to enable or disable certain inputs @ runtime. Basically it just does not call UpdateInput if Enabled = false. - Can also disable and enable input devices via the InputManager. - - Revision 1.3 2004/04/28 21:27:01 savage - Updated Joystick code and event handlers. Needs testing... - - Revision 1.2 2004/02/14 22:36:29 savage - Fixed inconsistencies of using LoadLibrary and LoadModule. - Now all units make use of LoadModule rather than LoadLibrary and other dynamic proc procedures. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} -{******************************************************************************} - -interface - -{$i jedi-sdl.inc} - -uses - Classes, - sdl; - -type - TSDLInputType = ( itJoystick , itKeyBoard, itMouse ); - TSDLInputTypes = set of TSDLInputType; - - TSDLCustomInput = class( TObject ) - private - FEnabled: Boolean; - public - constructor Create; - function UpdateInput( event: TSDL_EVENT ) : Boolean; virtual; abstract; - property Enabled : Boolean read FEnabled write FEnabled; - end; - - TSDLJoyAxisMoveEvent = procedure ( Which: UInt8; Axis: UInt8; Value: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLJoyBallMoveEvent = procedure ( Which: UInt8; Ball: UInt8; RelativePos: TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLJoyHatMoveEvent = procedure ( Which: UInt8; Hat: UInt8; Value: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLJoyButtonEvent = procedure ( Which: UInt8; Button: UInt8; State: SInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - - TSDLJoyStick = class( TSDLCustomInput ) - private - FJoystick : PSDL_Joystick; - FJoystickIndex : Integer; - FJoyAxisMoveEvent : TSDLJoyAxisMoveEvent; - FJoyBallMoveEvent : TSDLJoyBallMoveEvent; - FJoyHatMoveEvent : TSDLJoyHatMoveEvent; - FJoyButtonDownEvent : TSDLJoyButtonEvent; - FJoyButtonUpEvent : TSDLJoyButtonEvent; - procedure DoAxisMove( Event : TSDL_Event ); - procedure DoBallMove( Event : TSDL_Event ); - procedure DoHatMove( Event : TSDL_Event ); - procedure DoButtonDown( Event : TSDL_Event ); - procedure DoButtonUp( Event : TSDL_Event ); - function GetName: PChar; - function GetNumAxes: integer; - function GetNumBalls: integer; - function GetNumButtons: integer; - function GetNumHats: integer; - public - constructor Create( Index : Integer ); - destructor Destroy; override; - procedure Open; - procedure Close; - function UpdateInput( Event: TSDL_EVENT ) : Boolean; override; - property Name : PChar read GetName; - property NumAxes : integer read GetNumAxes; - property NumBalls : integer read GetNumBalls; - property NumButtons : integer read GetNumButtons; - property NumHats : integer read GetNumHats; - property OnAxisMove : TSDLJoyAxisMoveEvent read FJoyAxisMoveEvent write FJoyAxisMoveEvent; - property OnBallMove : TSDLJoyBallMoveEvent read FJoyBallMoveEvent write FJoyBallMoveEvent; - property OnHatMove : TSDLJoyHatMoveEvent read FJoyHatMoveEvent write FJoyHatMoveEvent; - property OnButtonDown : TSDLJoyButtonEvent read FJoyButtonDownEvent write FJoyButtonDownEvent; - property OnButtonUp : TSDLJoyButtonEvent read FJoyButtonUpEvent write FJoyButtonUpEvent; - end; - - TSDLJoySticks = class( TObject ) - private - FNumOfJoySticks: Integer; - FJoyStickList : TList; - function GetJoyStick(Index: integer): TSDLJoyStick; - procedure SetJoyStick(Index: integer; const Value: TSDLJoyStick); - public - constructor Create; - destructor Destroy; override; - function UpdateInput( event: TSDL_EVENT ) : Boolean; - property NumOfJoySticks : Integer read FNumOfJoySticks write FNumOfJoySticks; - property JoySticks[ Index : integer ] : TSDLJoyStick read GetJoyStick write SetJoyStick; - end; - - TSDLKeyBoardEvent = procedure ( var Key: TSDLKey; Shift: TSDLMod; unicode : UInt16 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - TSDLKeyBoard = class( TSDLCustomInput ) - private - FKeys : PKeyStateArr; - FOnKeyUp: TSDLKeyBoardEvent; - FOnKeyDown: TSDLKeyBoardEvent; - procedure DoKeyDown( keysym : PSDL_keysym ); - procedure DoKeyUp( keysym : PSDL_keysym ); - public - function IsKeyDown( Key : TSDLKey ) : Boolean; - function IsKeyUp( Key : TSDLKey ) : Boolean; - function UpdateInput( event: TSDL_EVENT ) : Boolean; override; - property Keys : PKeyStateArr read FKeys write FKeys; - property OnKeyDown : TSDLKeyBoardEvent read FOnKeyDown write FOnKeyDown; - property OnKeyUp : TSDLKeyBoardEvent read FOnKeyUp write FOnKeyUp; - end; - - TSDLMouseButtonEvent = procedure ( Button : Integer; Shift: TSDLMod; MousePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLMouseMoveEvent = procedure ( Shift: TSDLMod; CurrentPos : TPoint; RelativePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLMouseWheelEvent = procedure ( WheelDelta : Integer; Shift: TSDLMod; MousePos : TPoint ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - TSDLCustomCursor = class( TObject ) - private - FFileName : string; - FHotPoint: TPoint; - procedure SetFileName(const aValue: string ); - function ScanForChar( str : string; ch : Char; startPos : Integer; lookFor : Boolean ) : Integer; - public - constructor Create( const aFileName : string; aHotPoint: TPoint ); - procedure LoadFromFile( const aFileName : string ); virtual; abstract; - procedure LoadFromStream( aStream : TStream ); virtual; abstract; - procedure Show; virtual; abstract; - property FileName : string read FFileName write SetFileName; - property HotPoint : TPoint read FHotPoint write FHotPoint; - end; - - TSDLXPMCursor = class( TSDLCustomCursor ) - private - FCursor : PSDL_Cursor; - procedure FreeCursor; - public - destructor Destroy; override; - procedure LoadFromFile( const aFileName : string ); override; - procedure LoadFromStream( aStream : TStream ); override; - procedure Show; override; - end; - - TSDLCursorList = class( TStringList ) - protected - function GetObject( aIndex : Integer ): TSDLCustomCursor; reintroduce; - procedure PutObject( aIndex : Integer; AObject : TSDLCustomCursor); reintroduce; - public - constructor Create; - function AddCursor(const aName : string; aObject : TSDLCustomCursor): Integer; virtual; - end; - - TSDLMouse = class( TSDLCustomInput ) - private - FDragging : Boolean; - FMousePos : TPoint; - FOnMouseUp: TSDLMouseButtonEvent; - FOnMouseDown: TSDLMouseButtonEvent; - FOnMouseMove: TSDLMouseMoveEvent; - FOnMouseWheel: TSDLMouseWheelEvent; - FCursorList : TSDLCursorList; // Cursor Pointer - procedure DoMouseMove( Event: TSDL_Event ); - procedure DoMouseDown( Event: TSDL_Event ); - procedure DoMouseUp( Event: TSDL_Event ); - procedure DoMouseWheelScroll( Event: TSDL_Event ); - function GetMousePosition: TPoint; - procedure SetMousePosition(const Value: TPoint); - function GetMouseDelta: TPoint; - public - destructor Destroy; override; - function UpdateInput( event: TSDL_EVENT ) : Boolean; override; - function MouseIsDown( Button : Integer ) : Boolean; - function MouseIsUp( Button : Integer ) : Boolean; - procedure ShowCursor; - procedure HideCursor; - property OnMouseDown : TSDLMouseButtonEvent read FOnMouseDown write FOnMouseDown; - property OnMouseUp : TSDLMouseButtonEvent read FOnMouseUp write FOnMouseUp; - property OnMouseMove : TSDLMouseMoveEvent read FOnMouseMove write FOnMouseMove; - property OnMouseWheel : TSDLMouseWheelEvent read FOnMouseWheel write FOnMouseWheel; - property MousePosition : TPoint read GetMousePosition write SetMousePosition; - property MouseDelta: TPoint read GetMouseDelta; - property Cursors : TSDLCursorList read FCursorList write FCursorList; - end; - - TSDLInputManager = class( TObject ) - private - FKeyBoard : TSDLKeyBoard; - FMouse : TSDLMouse; - FJoystick : TSDLJoysticks; - public - constructor Create( InitInputs : TSDLInputTypes ); - destructor Destroy; override; - procedure Disable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer = 0 ); - procedure Enable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer = 0 ); - function UpdateInputs( event: TSDL_EVENT ) : Boolean; - property KeyBoard : TSDLKeyBoard read FKeyBoard write FKeyBoard; - property Mouse : TSDLMouse read FMouse write FMouse; - property JoyStick : TSDLJoysticks read FJoyStick write FJoyStick; - end; - -implementation - -uses - SysUtils; - -{ TSDLCustomInput } -constructor TSDLCustomInput.Create; -begin - inherited; - FEnabled := true; -end; - -{ TSDLJoysticks } -constructor TSDLJoysticks.Create; -var - i : integer; -begin - inherited; - if ( SDL_WasInit( SDL_INIT_JOYSTICK ) = 0 ) then - SDL_InitSubSystem( SDL_INIT_JOYSTICK ); - FNumOfJoySticks := SDL_NumJoysticks; - FJoyStickList := TList.Create; - for i := 0 to FNumOfJoySticks - 1 do - begin - FJoyStickList.Add( TSDLJoyStick.Create( i ) ); - end; -end; - -destructor TSDLJoysticks.Destroy; -var - i : integer; -begin - if FJoyStickList.Count > 0 then - begin - for i := 0 to FJoyStickList.Count - 1 do - begin - TSDLJoyStick( FJoyStickList.Items[i] ).Free; - end; - end; - SDL_QuitSubSystem( SDL_INIT_JOYSTICK ); - inherited; -end; - -function TSDLJoySticks.GetJoyStick(Index: integer): TSDLJoyStick; -begin - Result := TSDLJoyStick( FJoyStickList[ Index ] ); -end; - -procedure TSDLJoySticks.SetJoyStick(Index: integer; - const Value: TSDLJoyStick); -begin - FJoyStickList[ Index ] := @Value; -end; - -function TSDLJoysticks.UpdateInput(event: TSDL_EVENT): Boolean; -var - i : integer; -begin - result := false; - if FJoyStickList.Count > 0 then - begin - for i := 0 to FJoyStickList.Count - 1 do - begin - TSDLJoyStick( FJoyStickList.Items[i] ).UpdateInput( event ); - end; - end; -end; - -{ TSDLKeyBoard } -procedure TSDLKeyBoard.DoKeyDown(keysym: PSDL_keysym); -begin - if Assigned( FOnKeyDown ) then - FOnKeyDown( keysym.sym , keysym.modifier, keysym.unicode ); -end; - -procedure TSDLKeyBoard.DoKeyUp(keysym: PSDL_keysym); -begin - if Assigned( FOnKeyUp ) then - FOnKeyUp( keysym.sym , keysym.modifier, keysym.unicode ); -end; - -function TSDLKeyBoard.IsKeyDown( Key: TSDLKey ): Boolean; -begin - SDL_PumpEvents; - - // Populate Keys array - FKeys := PKeyStateArr( SDL_GetKeyState( nil ) ); - Result := ( FKeys[Key] = SDL_PRESSED ); -end; - -function TSDLKeyBoard.IsKeyUp( Key: TSDLKey ): Boolean; -begin - SDL_PumpEvents; - - // Populate Keys array - FKeys := PKeyStateArr( SDL_GetKeyState( nil ) ); - Result := ( FKeys[Key] = SDL_RELEASED ); -end; - -function TSDLKeyBoard.UpdateInput(event: TSDL_EVENT): Boolean; -begin - result := false; - if ( FEnabled ) then - begin - case event.type_ of - SDL_KEYDOWN : - begin - // handle key presses - DoKeyDown( @event.key.keysym ); - result := true; - end; - - SDL_KEYUP : - begin - // handle key releases - DoKeyUp( @event.key.keysym ); - result := true; - end; - end; - end; -end; - -{ TSDLMouse } -destructor TSDLMouse.Destroy; -begin - - inherited; -end; - -procedure TSDLMouse.DoMouseDown( Event: TSDL_Event ); -var - CurrentPos : TPoint; -begin - FDragging := true; - if Assigned( FOnMouseDown ) then - begin - CurrentPos.x := event.button.x; - CurrentPos.y := event.button.y; - FOnMouseDown( event.button.button, SDL_GetModState, CurrentPos ); - end; -end; - -procedure TSDLMouse.DoMouseMove( Event: TSDL_Event ); -var - CurrentPos, RelativePos : TPoint; -begin - if Assigned( FOnMouseMove ) then - begin - CurrentPos.x := event.motion.x; - CurrentPos.y := event.motion.y; - RelativePos.x := event.motion.xrel; - RelativePos.y := event.motion.yrel; - FOnMouseMove( SDL_GetModState, CurrentPos, RelativePos ); - end; -end; - -procedure TSDLMouse.DoMouseUp( event: TSDL_EVENT ); -var - Point : TPoint; -begin - FDragging := false; - if Assigned( FOnMouseUp ) then - begin - Point.x := event.button.x; - Point.y := event.button.y; - FOnMouseUp( event.button.button, SDL_GetModState, Point ); - end; -end; - -procedure TSDLMouse.DoMouseWheelScroll( event: TSDL_EVENT ); -var - Point : TPoint; -begin - if Assigned( FOnMouseWheel ) then - begin - Point.x := event.button.x; - Point.y := event.button.y; - if ( event.button.button = SDL_BUTTON_WHEELUP ) then - FOnMouseWheel( SDL_BUTTON_WHEELUP, SDL_GetModState, Point ) - else - FOnMouseWheel( SDL_BUTTON_WHEELDOWN, SDL_GetModState, Point ); - end; -end; - -function TSDLMouse.GetMouseDelta: TPoint; -begin - SDL_PumpEvents; - - SDL_GetRelativeMouseState( Result.X, Result.Y ); -end; - -function TSDLMouse.GetMousePosition: TPoint; -begin - SDL_PumpEvents; - - SDL_GetMouseState( FMousePos.X, FMousePos.Y ); - Result := FMousePos; -end; - -procedure TSDLMouse.HideCursor; -begin - SDL_ShowCursor( SDL_DISABLE ); -end; - -function TSDLMouse.MouseIsDown(Button: Integer): Boolean; -begin - SDL_PumpEvents; - - Result := ( SDL_GetMouseState( FMousePos.X, FMousePos.Y ) and SDL_BUTTON( Button ) = 0 ); -end; - -function TSDLMouse.MouseIsUp(Button: Integer): Boolean; -begin - SDL_PumpEvents; - - Result := not ( SDL_GetMouseState( FMousePos.X, FMousePos.Y ) and SDL_BUTTON( Button ) = 0 ); -end; - -procedure TSDLMouse.SetMousePosition(const Value: TPoint); -begin - SDL_WarpMouse( Value.x, Value.y ); -end; - -procedure TSDLMouse.ShowCursor; -begin - SDL_ShowCursor( SDL_ENABLE ); -end; - -function TSDLMouse.UpdateInput(event: TSDL_EVENT): Boolean; -begin - result := false; - if ( FEnabled ) then - begin - case event.type_ of - SDL_MOUSEMOTION : - begin - // handle Mouse Move - DoMouseMove( event ); - end; - - SDL_MOUSEBUTTONDOWN : - begin - // handle Mouse Down - if ( event.button.button = SDL_BUTTON_WHEELUP ) - or ( event.button.button = SDL_BUTTON_WHEELDOWN ) then - DoMouseWheelScroll( event ) - else - DoMouseDown( event ); - end; - - SDL_MOUSEBUTTONUP : - begin - // handle Mouse Up - if ( event.button.button = SDL_BUTTON_WHEELUP ) - or ( event.button.button = SDL_BUTTON_WHEELDOWN ) then - DoMouseWheelScroll( event ) - else - DoMouseUp( event ); - end; - end; - end; -end; - -{ TSDLInputManager } -constructor TSDLInputManager.Create(InitInputs: TSDLInputTypes); -begin - inherited Create; - if itJoystick in InitInputs then - FJoystick := TSDLJoysticks.Create; - - if itKeyBoard in InitInputs then - FKeyBoard := TSDLKeyBoard.Create; - - if itMouse in InitInputs then - FMouse := TSDLMouse.Create; -end; - -destructor TSDLInputManager.Destroy; -begin - if FJoystick <> nil then - FreeAndNil( FJoystick ); - if FKeyBoard <> nil then - FreeAndNil( FKeyBoard ); - if FMouse <> nil then - FreeAndNil( FMouse ); - inherited; -end; - -procedure TSDLInputManager.Disable( InitInputs : TSDLInputTypes; JoyStickNumber : Integer ); -begin - if itJoystick in InitInputs then - FJoystick.JoySticks[ JoyStickNumber ].Enabled := false; - - if itKeyBoard in InitInputs then - FKeyBoard.Enabled := false; - - if itMouse in InitInputs then - FMouse.Enabled := false; -end; - -procedure TSDLInputManager.Enable( InitInputs: TSDLInputTypes; JoyStickNumber: Integer ); -begin - if itJoystick in InitInputs then - FJoystick.JoySticks[ JoyStickNumber ].Enabled := true; - - if itKeyBoard in InitInputs then - FKeyBoard.Enabled := true; - - if itMouse in InitInputs then - FMouse.Enabled := true; -end; - -function TSDLInputManager.UpdateInputs( event: TSDL_EVENT ): Boolean; -begin - Result := false; - if ( FJoystick <> nil ) then - Result := FJoystick.UpdateInput( event ); - if ( FKeyBoard <> nil ) then - Result := FKeyBoard.UpdateInput( event ); - if ( FMouse <> nil ) then - Result := FMouse.UpdateInput( event ); -end; - -{ TSDLJoyStick } -procedure TSDLJoyStick.Close; -begin - SDL_JoystickClose( @FJoystick ); -end; - -constructor TSDLJoyStick.Create( Index : Integer ); -begin - inherited Create; - FJoystick := nil; - FJoystickIndex := Index; -end; - -destructor TSDLJoyStick.Destroy; -begin - if FJoystick <> nil then - Close; - inherited; -end; - -procedure TSDLJoyStick.DoAxisMove(Event: TSDL_Event); -begin - if Assigned( FJoyAxisMoveEvent ) then - begin - FJoyAxisMoveEvent( Event.jaxis.which, Event.jaxis.axis, Event.jaxis.value ); - end -end; - -procedure TSDLJoyStick.DoBallMove(Event: TSDL_Event); -var - BallPoint : TPoint; -begin - if Assigned( FJoyBallMoveEvent ) then - begin - BallPoint.x := Event.jball.xrel; - BallPoint.y := Event.jball.yrel; - FJoyBallMoveEvent( Event.jball.which, Event.jball.ball, BallPoint ); - end; -end; - -procedure TSDLJoyStick.DoButtonDown(Event: TSDL_Event); -begin - if Assigned( FJoyButtonDownEvent ) then - begin - if ( Event.jbutton.state = SDL_PRESSED ) then - FJoyButtonDownEvent( Event.jbutton.which, Event.jbutton.button, Event.jbutton.state ); - end; -end; - -procedure TSDLJoyStick.DoButtonUp(Event: TSDL_Event); -begin - if Assigned( FJoyButtonUpEvent ) then - begin - if ( Event.jbutton.state = SDL_RELEASED ) then - FJoyButtonUpEvent( Event.jbutton.which, Event.jbutton.button, Event.jbutton.state ); - end -end; - -procedure TSDLJoyStick.DoHatMove(Event: TSDL_Event); -begin - if Assigned( FJoyHatMoveEvent ) then - begin - FJoyHatMoveEvent( Event.jhat.which, Event.jhat.hat, Event.jhat.value ); - end; -end; - -function TSDLJoyStick.GetName: PChar; -begin - result := FJoystick.name; -end; - -function TSDLJoyStick.GetNumAxes: integer; -begin - result := FJoystick.naxes; -end; - -function TSDLJoyStick.GetNumBalls: integer; -begin - result := FJoystick.nballs; -end; - -function TSDLJoyStick.GetNumButtons: integer; -begin - result := FJoystick.nbuttons; -end; - -function TSDLJoyStick.GetNumHats: integer; -begin - result := FJoystick.nhats; -end; - -procedure TSDLJoyStick.Open; -begin - FJoystick := SDL_JoyStickOpen( FJoystickIndex ); -end; - -function TSDLJoyStick.UpdateInput(Event: TSDL_EVENT): Boolean; -begin - Result := false; - - if ( FEnabled ) then - begin - case event.type_ of - SDL_JOYAXISMOTION : - begin - DoAxisMove( Event ); - end; - - SDL_JOYBALLMOTION : - begin - DoBallMove( Event ); - end; - - SDL_JOYHATMOTION : - begin - DoHatMove( Event ); - end; - - SDL_JOYBUTTONDOWN : - begin - DoButtonDown( Event ); - end; - - SDL_JOYBUTTONUP : - begin - DoButtonUp( Event ); - end; - end; - end; -end; - -{ TSDLCustomCursor } - -constructor TSDLCustomCursor.Create(const aFileName: string; aHotPoint: TPoint); -begin - inherited Create; - FHotPoint := aHotPoint; - LoadFromFile( aFileName ); -end; - -function TSDLCustomCursor.ScanForChar(str: string; ch: Char; - startPos: Integer; lookFor: Boolean): Integer; -begin - Result := -1; - while ( ( ( str[ startPos ] = ch ) <> lookFor ) and ( startPos < Length( str ) ) ) do - inc( startPos ); - if startPos <> Length( str ) then - Result := startPos; -end; - -procedure TSDLCustomCursor.SetFileName(const aValue: string); -begin - LoadFromFile( aValue ); -end; - -{ TSDLXPMCursor } - -destructor TSDLXPMCursor.Destroy; -begin - FreeCursor; - inherited; -end; - -procedure TSDLXPMCursor.FreeCursor; -begin - if FCursor <> nil then - begin - SDL_FreeCursor( FCursor ); - FFileName := ''; - end; -end; - -procedure TSDLXPMCursor.LoadFromFile(const aFileName: string); -var - xpmFile : Textfile; - step : Integer; - holdPos : Integer; - counter : Integer; - dimensions : array[ 1..3 ] of Integer; - clr, clrNone, clrBlack, clrWhite : Char; - data, mask : array of UInt8; - i, col : Integer; - LineString : string; -begin - FreeCursor; - AssignFile( xpmFile, aFileName ); - Reset( xpmFile ); - step := 0; - i := -1; - clrBlack := 'X'; - clrWhite := ','; - clrNone := ' '; - counter := 0; - while not ( eof( xpmFile ) ) do - begin - Readln( xpmFile, LineString ); - // scan for strings - if LineString[ 1 ] = '"' then - begin - case step of - 0 : // Get dimensions (should be width height number-of-colors ???) - begin - HoldPos := 2; - counter := ScanForChar( LineString, ' ', HoldPos, False ); - counter := ScanForChar( LineString, ' ', counter, True ); - dimensions[ 1 ] := StrToInt( Copy( LineString, HoldPos, counter - HoldPos ) ); - counter := ScanForChar( LineString, ' ', counter, False ); - holdPos := counter; - counter := ScanForChar( LineString, ' ', counter, True ); - dimensions[ 2 ] := StrToInt( Copy( LineString, holdPos, counter - HoldPos ) ); - counter := ScanForChar( LineString, ' ', counter, False ); - holdPos := counter; - counter := ScanForChar( LineString, ' ', counter, True ); - dimensions[ 3 ] := StrToInt( Copy( LineString, holdPos, counter - HoldPos ) ); - step := 1; - SetLength( data, ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ); - SetLength( mask, ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ); - //Log.LogStatus( 'Length = ' + IntToStr( ( dimensions[ 1 ] * dimensions[ 2 ] ) div 8 ), 'LoadCursorFromFile' ); - end; - 1 : // get the symbols for transparent, black and white - begin - // get the symbol for the color - clr := LineString[ 2 ]; - // look for the 'c' symbol - counter := ScanForChar( LineString, 'c', 3, True ); - inc( counter ); - counter := ScanForChar( LineString, ' ', counter, False ); - if LowerCase( Copy( LineString, counter, 4 ) ) = 'none' then - begin - clrNone := clr; - end; - if LowerCase( Copy( LineString, counter, 7 ) ) = '#ffffff' then - begin - clrWhite := clr; - end; - if LowerCase( Copy( LineString, counter, 7 ) ) = '#000000' then - begin - clrBlack := clr; - end; - dec( dimensions[ 3 ] ); - if dimensions[ 3 ] = 0 then - begin - step := 2; - counter := 0; - end; - end; - 2 : // get cursor information -- modified from the SDL - // documentation of SDL_CreateCursor. - begin - for col := 1 to dimensions[1] do - begin - if ( ( col mod 8 ) <> 1 ) then - begin - data[ i ] := data[ i ] shl 1; - mask[ i ] := mask[ i ] shl 1; - end - else - begin - inc( i ); - data[ i ] := 0; - mask[ i ] := 0; - end; - if LineString[ col ] = clrWhite then - begin - mask[ i ] := mask[ i ] or $01; - end - else if LineString[ col ] = clrBlack then - begin - data[ i ] := data[ i ] or $01; - mask[ i ] := mask[ i ] or $01; - end - else if LineString[ col + 1 ] = clrNone then - begin - // - end; - end; - inc(counter); - if counter = dimensions[2] then - step := 4; - end; - end; - end; - end; - CloseFile( xpmFile ); - FCursor := SDL_CreateCursor( PUInt8( data ), PUInt8( mask ), dimensions[ 1 ], dimensions[ 2 ], FHotPoint.x, FHotPoint.y ); -end; - -procedure TSDLXPMCursor.LoadFromStream(aStream: TStream); -begin - inherited; - -end; - -procedure TSDLXPMCursor.Show; -begin - inherited; - SDL_SetCursor( FCursor ); -end; - -{ TSDLCursorList } -function TSDLCursorList.AddCursor(const aName : string; aObject : TSDLCustomCursor): Integer; -begin - result := inherited AddObject( aName, aObject ); -end; - -constructor TSDLCursorList.Create; -begin - inherited; - Duplicates := dupIgnore; -end; - -function TSDLCursorList.GetObject(aIndex: Integer): TSDLCustomCursor; -begin - result := TSDLCustomCursor( inherited GetObject( aIndex ) ); -end; - -procedure TSDLCursorList.PutObject(aIndex: Integer; aObject: TSDLCustomCursor); -begin - inherited PutObject( aIndex, aObject ); -end; - -end. diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas b/src/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas deleted file mode 100644 index 8ba3946f..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdlstreams.pas +++ /dev/null @@ -1,216 +0,0 @@ -unit sdlstreams; -{ - $Id: sdlstreams.pas,v 1.1 2004/02/05 00:08:20 savage Exp $ - -} -{******************************************************************} -{ } -{ SDL - Simple DirectMedia Layer } -{ Copyright (C) 1997, 1998, 1999, 2000, 2001 Sam Lantinga } -{ } -{ Portions created by Chris Bruner are } -{ Copyright (C) 2002 Chris Bruner. } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/NPL/NPL-1_1Final.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Shows how to use OpenGL to do 2D and 3D with the SDL libraries } -{ } -{ } -{ Requires } -{ -------- } -{ SDL runtime libary somewhere in your path } -{ The Latest SDL runtime can be found on http://www.libsdl.org } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ January 11 2002 - CB : Software embraced and extended by } -{ Chris Bruner of Crystal Software } -{ (Canada) Inc. } -{ } -{ February 11 2002 - DL : Added FreePascal support as suggested } -{ by "QuePasha Pepe" } -{ } -{******************************************************************} -{ - $Log: sdlstreams.pas,v $ - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -{$i jedi-sdl.inc} - -interface - -uses - Classes, - SysUtils, - sdl, - sdlutils; - -{$IFDEF FPC} -type - EinvalidContainer=class(Exception); - {$ENDIF} - -function LoadSDLBMPFromStream( Stream : TStream ) : PSDL_Surface; -procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); -function SDL_Swap16( D : UInt16 ) : Uint16; -function SDL_Swap32( D : UInt32 ) : Uint32; -function SDLStreamSetup( stream : TStream ) : PSDL_RWops; -// this only closes the SDL_RWops part of the stream, not the stream itself -procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); - -implementation - -function SDL_Swap16( D : UInt16 ) : Uint16; -begin - Result := ( D shl 8 ) or ( D shr 8 ); -end; - -function SDL_Swap32( D : UInt32 ) : Uint32; -begin - Result := ( ( D shl 24 ) or ( ( D shl 8 ) and $00FF0000 ) or ( ( D shr 8 ) and $0000FF00 ) or ( D shr 24 ) ); -end; - -(*function SDL_Swap64(D : UInt64) : Uint64; -var hi,lo : Uint32; -begin - // Separate into high and low 32-bit resultues and swap them - lo := Uint32(D and $0FFFFFFFF); // bloody pascal is too tight in it's type checking! - D := D shr 32; - hi = Uint32((D and $FFFFFFFF)); - result = SDL_Swap32(lo); - result := result shl 32; - result := result or SDL_Swap32(hi); -end; -*) - -function SdlStreamSeek( context : PSDL_RWops; offset : Integer; whence : Integer ) : integer; cdecl; -var - stream : TStream; - origin : Word; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamSeek on nil' ); - case whence of - 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0. - 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset. - 2 : origin := soFromEnd; - else - origin := soFromBeginning; // just in case - end; - Result := stream.Seek( offset, origin ); -end; - -function SDLStreamWrite( context : PSDL_RWops; Ptr : Pointer; - size : Integer; num : Integer ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamWrite on nil' ); - try - Result := stream.Write( Ptr^, Size * num ) div size; - except - Result := -1; - end; -end; - -function SdlStreamRead( context : PSDL_RWops; Ptr : Pointer; size : Integer; maxnum - : Integer ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamRead on nil' ); - try - Result := stream.read( Ptr^, Size * maxnum ) div size; - except - Result := -1; - end; -end; - -function SDLStreamClose( context : PSDL_RWops ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamClose on nil' ); - stream.Free; - Result := 1; -end; - -function SDLStreamSetup( stream : TStream ) : PSDL_RWops; -begin - result := SDL_AllocRW; - if ( result = nil ) then - raise EInvalidContainer.Create( 'could not create SDLStream on nil' ); - result.unknown := TUnknown( stream ); - result.seek := SDLStreamSeek; - result.read := SDLStreamRead; - result.write := SDLStreamWrite; - result.close := SDLStreamClose; - Result.type_ := 2; // TUnknown -end; - -// this only closes the SDL part of the stream, not the context - -procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); -begin - SDL_FreeRW( SDL_RWops ); -end; - -function LoadSDLBMPFromStream( stream : TStream ) : PSDL_Surface; -var - SDL_RWops : PSDL_RWops; -begin - SDL_RWops := SDLStreamSetup( stream ); - result := SDL_LoadBMP_RW( SDL_RWops, 0 ); - SDLStreamCloseRWops( SDL_RWops ); -end; - -procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); -var - SDL_RWops : PSDL_RWops; -begin - SDL_RWops := SDLStreamSetup( stream ); - SDL_SaveBMP_RW( SDL_Surface, SDL_RWops, 0 ); - SDLStreamCloseRWops( SDL_RWops ); -end; - -end. - diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdlticks.pas b/src/lib/JEDI-SDL/SDL/Pas/sdlticks.pas deleted file mode 100644 index a479b493..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdlticks.pas +++ /dev/null @@ -1,197 +0,0 @@ -unit sdlticks; -{ - $Id: sdlticks.pas,v 1.2 2006/11/08 08:22:48 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ SDL GetTicks Class Wrapper } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2004 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ SDL Window Wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: sdlticks.pas,v $ - Revision 1.2 2006/11/08 08:22:48 savage - updates tp sdlgameinterface and sdlticks functions. - - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - -} -{******************************************************************************} - -interface - -uses - sdl; - -type - TSDLTicks = class - private - FStartTime : UInt32; - FTicksPerSecond : UInt32; - FElapsedLastTime : UInt32; - FFPSLastTime : UInt32; - FLockFPSLastTime : UInt32; - public - constructor Create; - destructor Destroy; override; // destructor - - {***************************************************************************** - Init - If the hi-res timer is present, the tick rate is stored and the function - returns true. Otherwise, the function returns false, and the timer should - not be used. - *****************************************************************************} - function Init : boolean; - - {*************************************************************************** - GetGetElapsedSeconds - Returns the Elapsed time, since the function was last called. - ***************************************************************************} - function GetElapsedSeconds : Single; - - {*************************************************************************** - GetFPS - Returns the average frames per second. - If this is not called every frame, the client should track the number - of frames itself, and reset the value after this is called. - ***************************************************************************} - function GetFPS : single; - - {*************************************************************************** - LockFPS - Used to lock the frame rate to a set amount. This will block until enough - time has passed to ensure that the fps won't go over the requested amount. - Note that this can only keep the fps from going above the specified level; - it can still drop below it. It is assumed that if used, this function will - be called every frame. The value returned is the instantaneous fps, which - will be less than or equal to the targetFPS. - ***************************************************************************} - procedure LockFPS( targetFPS : Byte ); - end; - -implementation - -{ TSDLTicks } -constructor TSDLTicks.Create; -begin - inherited; - FTicksPerSecond := 1000; -end; - -destructor TSDLTicks.Destroy; -begin - inherited; -end; - -function TSDLTicks.GetElapsedSeconds : Single; -var - currentTime : Cardinal; -begin - currentTime := SDL_GetTicks; - - result := ( currentTime - FElapsedLastTime ) / FTicksPerSecond; - - // reset the timer - FElapsedLastTime := currentTime; -end; - -function TSDLTicks.GetFPS : Single; -var - currentTime, FrameTime : UInt32; - fps : single; -begin - currentTime := SDL_GetTicks; - - FrameTime := ( currentTime - FFPSLastTime ); - - if FrameTime = 0 then - FrameTime := 1; - - fps := FTicksPerSecond / FrameTime; - - // reset the timer - FFPSLastTime := currentTime; - result := fps; -end; - -function TSDLTicks.Init : boolean; -begin - FStartTime := SDL_GetTicks; - FElapsedLastTime := FStartTime; - FFPSLastTime := FStartTime; - FLockFPSLastTime := FStartTime; - result := true; -end; - -procedure TSDLTicks.LockFPS( targetFPS : Byte ); -var - currentTime : UInt32; - targetTime : single; -begin - if ( targetFPS = 0 ) then - targetFPS := 1; - - targetTime := FTicksPerSecond / targetFPS; - - // delay to maintain a constant frame rate - repeat - currentTime := SDL_GetTicks; - until ( ( currentTime - FLockFPSLastTime ) > targetTime ); - - // reset the timer - FLockFPSLastTime := currentTime; -end; - -end. - - \ No newline at end of file diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdlutils.pas b/src/lib/JEDI-SDL/SDL/Pas/sdlutils.pas deleted file mode 100644 index e01f3cdb..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdlutils.pas +++ /dev/null @@ -1,4363 +0,0 @@ -unit sdlutils; -{ - $Id: sdlutils.pas,v 1.5 2006/11/19 18:56:44 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL - Simple DirectMedia Layer } -{ SDL Utility functions } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Tom Jones } -{ } -{ Portions created by Tom Jones are } -{ Copyright (C) 2000 - 2001 Tom Jones. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ Róbert Kisnémeth } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Helper functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2000 - TJ : Initial creation } -{ } -{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } -{ } -{ Sept 14 2001 - RK : Added flipping routines. } -{ } -{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } -{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } -{ Added PSDLRect() } -{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} -{ Also removed by poor attempt or a dialog box } -{ } -{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } -{ SubSurface, MonoSurface & TexturedSurface } -{ } -{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } -{ types rather that Windows types. This makes it more} -{ portable to Linix. } -{ } -{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } -{ } -{ Oct 27 2001 - JF : Added ScrollY function } -{ } -{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } -{ } -{ Mar 28 2002 - JF : Added SDL_RotateSurface } -{ } -{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } -{ } -{ May 27 2002 - YS : GradientFillRect function } -{ } -{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } -{ & SDL_50Scanline2xBlit } -{ } -{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } -{ } -{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } -{ } -{ November 9 2002 - JF : Added Jason's boolean Surface functions } -{ } -{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } -{ } -{ April 26 2003 - SS : Incorporated JF's changes to SDL_ClipLine } -{ Fixed SDL_ClipLine bug for non-zero cliprect x, y } -{ Added overloaded SDL_DrawLine for dashed lines } -{ } -{******************************************************************************} -{ - $Log: sdlutils.pas,v $ - Revision 1.5 2006/11/19 18:56:44 savage - Removed Hints and Warnings. - - Revision 1.4 2004/06/02 19:38:53 savage - Changes to SDL_GradientFillRect as suggested by - Ángel Eduardo García Hernández. Many thanks. - - Revision 1.3 2004/05/29 23:11:54 savage - Changes to SDL_ScaleSurfaceRect as suggested by - Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -interface - -{$I jedi-sdl.inc} - -uses -{$IFDEF UNIX} - Types, -{$IFNDEF DARWIN} - Xlib, -{$ENDIF} -{$ENDIF} - SysUtils, - sdl; - -type - TGradientStyle = ( gsHorizontal, gsVertical ); - -// Pixel procedures -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : integer; y : integer ) : Uint32; - -procedure SDL_PutPixel( DstSurface : PSDL_Surface; x : integer; y : integer; pixel : - Uint32 ); - -procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); - -procedure SDL_SubPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); - -// Line procedures -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); overload; - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal; DashLength, DashSpace : byte ); overload; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -// Surface procedures -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); - -// Flip procedures -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; - -function SDLRect( aRect : TRect ) : TSDL_Rect; overload; - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; - -// Fill Rect routine -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); - -// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); - -// -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : - PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : - boolean; - -// Jason's boolean Surface functions -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -function SDL_ClipLine( var x1, y1, x2, y2 : Integer; ClipRect : PSDL_Rect ) : boolean; - -implementation - -uses - Math; - -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1, Mod2 : cardinal; - Addr1, Addr2 : PtrUInt; - BPP : cardinal; - Pitch1, Pitch2 : cardinal; - TransparentColor1, TransparentColor2 : cardinal; - tx, ty : cardinal; -// StartTick : cardinal; // Auto Removed, Unused Variable - Color1, Color2 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - if SrcRect2 = nil then - begin - with Src_Rect2 do - begin - x := 0; - y := 0; - w := SrcSurface2.w; - h := SrcSurface2.h; - end; - end - else - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := PtrUInt( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - with SrcSurface2^ do - begin - TransparentColor2 := format.colorkey; - Pitch2 := Pitch; - Addr2 := PtrUInt( Pixels ); - inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); - end; - Mod1 := Pitch1 - ( ScanWidth * BPP ); - Mod2 := Pitch2 - ( ScanWidth * BPP ); - inc( Addr1, BPP * Scan1Start ); - inc( Addr2, BPP * Scan2Start ); - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - inc( Addr2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - inc( Addr2, 2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - Color2 := PLongWord( Addr2 )^ and $00FFFFFF; - if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - inc( Addr2, 3 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - inc( Addr2, 4 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - end; -end; - -procedure SDL_AddPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); -var - SrcColor : cardinal; - Addr : PtrUInt; - R, G, B : cardinal; -begin - if Color = 0 then - exit; - with DstSurface^ do - begin - Addr := PtrUInt( Pixels ) + y * Pitch + x * format.BytesPerPixel; - SrcColor := PUInt32( Addr )^; - case format.BitsPerPixel of - 8 : - begin - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - end; - 15 : - begin - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - end; - 16 : - begin - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - end; - 24 : - begin - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - end; - 32 : - begin - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - end; - end; - end; -end; - -procedure SDL_SubPixel( DstSurface : PSDL_Surface; x : cardinal; y : cardinal; Color : - cardinal ); -var - SrcColor : cardinal; - Addr : PtrUInt; - R, G, B : cardinal; -begin - if Color = 0 then - exit; - with DstSurface^ do - begin - Addr := PtrUInt( Pixels ) + y * Pitch + x * format.BytesPerPixel; - SrcColor := PUInt32( Addr )^; - case format.BitsPerPixel of - 8 : - begin - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - end; - 15 : - begin - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - end; - 16 : - begin - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - end; - 24 : - begin - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - end; - 32 : - begin - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - end; - end; - end; -end; -// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. -// In 8 bit color depth mode the procedure works with the default packed -// palette (RRRGGGBB). It handles all clipping. - -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $E0 + Pixel2 and $E0; - G := Pixel1 and $1C + Pixel2 and $1C; - B := Pixel1 and $03 + Pixel2 and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $7C00 + Pixel2 and $7C00; - G := Pixel1 and $03E0 + Pixel2 and $03E0; - B := Pixel1 and $001F + Pixel2 and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $F800 + Pixel2 and $F800; - G := Pixel1 and $07E0 + Pixel2 and $07E0; - B := Pixel1 and $001F + Pixel2 and $001F; - if R > $F800 then - R := $F800; - if G > $07E0 then - G := $07E0; - if B > $001F then - B := $001F; - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - R := Pixel1 and $FF0000 + Pixel2 and $FF0000; - G := Pixel1 and $00FF00 + Pixel2 and $00FF00; - B := Pixel1 and $0000FF + Pixel2 and $0000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel1 and $FF0000 + Pixel2 and $FF0000; - G := Pixel1 and $00FF00 + Pixel2 and $00FF00; - B := Pixel1 and $0000FF + Pixel2 and $0000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; -//{*_ebx, *}{*_esi, *}{*_edi, _esp*} : cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DestSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $E0 - Pixel1 and $E0; - G := Pixel2 and $1C - Pixel1 and $1C; - B := Pixel2 and $03 - Pixel1 and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( DestAddr )^ := R or G or B; - end; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $7C00 - Pixel1 and $7C00; - G := Pixel2 and $03E0 - Pixel1 and $03E0; - B := Pixel2 and $001F - Pixel1 and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( DestAddr )^ := R or G or B; - end; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $F800 - Pixel1 and $F800; - G := Pixel2 and $07E0 - Pixel1 and $07E0; - B := Pixel2 and $001F - Pixel1 and $001F; - if R > $F800 then - R := 0; - if G > $07E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( DestAddr )^ := R or G or B; - end; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - R := Pixel2 and $FF0000 - Pixel1 and $FF0000; - G := Pixel2 and $00FF00 - Pixel1 and $00FF00; - B := Pixel2 and $0000FF - Pixel1 and $0000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - R := Pixel2 and $FF0000 - Pixel1 and $FF0000; - G := Pixel2 and $00FF00 - Pixel1 and $00FF00; - B := Pixel2 and $0000FF - Pixel1 and $0000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel2; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; -//{*_ebx, *}{*_esi, *}{*_edi, _esp*} : cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - TransparentColor, SrcColor : cardinal; - BPP : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - BPP := DestSurface.Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case BPP of - 1 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt8( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt8( DestAddr )^ := SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 2 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt16( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt16( DestAddr )^ := SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 3 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^ and $FFFFFF; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := ( PUInt32( DestAddr )^ and $FFFFFF ) or SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 4 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := SrcColor; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; -// TextureRect.w and TextureRect.h are not used. -// The TextureSurface's size MUST larger than the drawing rectangle!!! - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TextAddr : PtrUInt; -//{*_ebx, *}{*_esi, *}{*_edi, _esp*}: cardinal; // Auto Removed, Unused Variable (_ebx) // Auto Removed, Unused Variable (_esi) // Auto Removed, Unused Variable (_edi) - WorkX, WorkY : word; - SrcMod, DestMod, TextMod : cardinal; -SrcColor, TransparentColor{*, TextureColor*} : cardinal; // Auto Removed, Unused Variable (TextureColor) - BPP : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - BPP := DestSurface.Format.BitsPerPixel; - end; - with Texture^ do - begin - TextAddr := PtrUInt( Pixels ) + UInt32( TextureRect.y ) * Pitch + - UInt32( TextureRect.x ) * Format.BytesPerPixel; - TextMod := Pitch - Src.w * Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - SDL_LockSurface( Texture ); - WorkY := Src.h; - case BPP of - 1 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt8( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt8( DestAddr )^ := PUint8( TextAddr )^; - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - 2 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt16( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt16( DestAddr )^ := PUInt16( TextAddr )^; - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - 3 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^ and $FFFFFF; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := ( PUInt32( DestAddr )^ and $FFFFFF ) or ( PUInt32( TextAddr )^ and $FFFFFF ); - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - 4 : - begin - repeat - WorkX := Src.w; - repeat - SrcColor := PUInt32( SrcAddr )^; - if SrcColor <> TransparentColor then - PUInt32( DestAddr )^ := PUInt32( TextAddr )^; - inc( SrcAddr ); - inc( DestAddr ); - inc( TextAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - inc( TextAddr, TextMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); - SDL_UnlockSurface( Texture ); -end; - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); -var - xc, yc : cardinal; - rx, wx, ry, wy, ry16 : cardinal; - color : cardinal; - modx, mody : cardinal; -begin - // Warning! No checks for surface pointers!!! - if srcrect = nil then - srcrect := @SrcSurface.clip_rect; - if dstrect = nil then - dstrect := @DstSurface.clip_rect; - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); - mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); - //rx := srcrect.x * 65536; - ry := srcrect.y * 65536; - wy := dstrect.y; - for yc := 0 to dstrect.h - 1 do - begin - rx := srcrect.x * 65536; - wx := dstrect.x; - ry16 := ry shr 16; - for xc := 0 to dstrect.w - 1 do - begin - color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); - SDL_PutPixel( DstSurface, wx, wy, color ); - rx := rx + modx; - inc( wx ); - end; - ry := ry + mody; - inc( wy ); - end; - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; -// Re-map a rectangular area into an area defined by four vertices -// Converted from C to Pascal by KiCHY - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); -const - SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) - THRESH = 1 shl SHIFTS; // Threshold for pixel size value - procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); - var - tm, lm, rm, bm, m : TPoint; - mx, my : cardinal; - cr : cardinal; - begin - // Does the destination area specify a single pixel? - if ( ( abs( ul.x - ur.x ) < THRESH ) and - ( abs( ul.x - lr.x ) < THRESH ) and - ( abs( ul.x - ll.x ) < THRESH ) and - ( abs( ul.y - ur.y ) < THRESH ) and - ( abs( ul.y - lr.y ) < THRESH ) and - ( abs( ul.y - ll.y ) < THRESH ) ) then - begin // Yes - cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); - SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); - end - else - begin // No - // Quarter the source and the destination, and then recurse - tm.x := ( ul.x + ur.x ) shr 1; - tm.y := ( ul.y + ur.y ) shr 1; - bm.x := ( ll.x + lr.x ) shr 1; - bm.y := ( ll.y + lr.y ) shr 1; - lm.x := ( ul.x + ll.x ) shr 1; - lm.y := ( ul.y + ll.y ) shr 1; - rm.x := ( ur.x + lr.x ) shr 1; - rm.y := ( ur.y + lr.y ) shr 1; - m.x := ( tm.x + bm.x ) shr 1; - m.y := ( tm.y + bm.y ) shr 1; - mx := ( x1 + x2 ) shr 1; - my := ( y1 + y2 ) shr 1; - CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); - CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); - CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); - CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); - end; - end; -var - _UL, _UR, _LR, _LL : TPoint; - Rect_x, Rect_y, Rect_w, Rect_h : integer; -begin - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - if SrcRect = nil then - begin - Rect_x := 0; - Rect_y := 0; - Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; - Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; - end - else - begin - Rect_x := SrcRect.x; - Rect_y := SrcRect.y; - Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; - Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; - end; - // Shift all values to help reduce round-off error. - _ul.x := ul.x shl SHIFTS; - _ul.y := ul.y shl SHIFTS; - _ur.x := ur.x shl SHIFTS; - _ur.y := ur.y shl SHIFTS; - _lr.x := lr.x shl SHIFTS; - _lr.y := lr.y shl SHIFTS; - _ll.x := ll.x shl SHIFTS; - _ll.y := ll.y shl SHIFTS; - CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; - -// Draw a line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// Draw a dashed line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal; DashLength, DashSpace : byte ); overload; -var - dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; -begin - counter := 0; - drawdash := true; //begin line drawing with dash - - //Avoid invalid user-passed dash parameters - if ( DashLength < 1 ) - then - DashLength := 1; - if ( DashSpace < 1 ) - then - DashSpace := 0; - - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc( counter ); - if ( counter > DashLength - 1 ) and ( DashSpace > 0 ) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc( counter ); - if counter > DashSpace - 1 then - begin - drawdash := true; - counter := 0; - end; - end; - - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc( counter ); - if ( counter > DashLength - 1 ) and ( DashSpace > 0 ) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc( counter ); - if counter > DashSpace - 1 then - begin - drawdash := true; - counter := 0; - end; - end; - - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// flips a rectangle vertically on given surface - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -var - TmpRect : TSDL_Rect; - Locked : boolean; - y, FlipLength, RowLength : integer; - Row1, Row2 : Pointer; - OneRow : TByteArray; // Optimize it if you wish -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin // if Rect=nil then we flip the whole surface - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.h shr 1 - 1; - RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - Row1 := pointer( PtrUInt( DstSurface^.Pixels ) + UInt32( Rect^.y ) * - DstSurface^.Pitch ); - Row2 := pointer( PtrUInt( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) - * DstSurface^.Pitch ); - for y := 0 to FlipLength do - begin - Move( Row1^, OneRow, RowLength ); - Move( Row2^, Row1^, RowLength ); - Move( OneRow, Row2^, RowLength ); - inc( PtrUInt( Row1 ), DstSurface^.Pitch ); - dec( PtrUInt( Row2 ), DstSurface^.Pitch ); - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// flips a rectangle horizontally on given surface - -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -type - T24bit = packed array[ 0..2 ] of byte; - T24bitArray = packed array[ 0..8191 ] of T24bit; - P24bitArray = ^T24bitArray; - TLongWordArray = array[ 0..8191 ] of LongWord; - PLongWordArray = ^TLongWordArray; -var - TmpRect : TSDL_Rect; - Row8bit : PByteArray; - Row16bit : PWordArray; - Row24bit : P24bitArray; - Row32bit : PLongWordArray; - y, x, RightSide, FlipLength : integer; - Pixel : cardinal; - Pixel24 : T24bit; - Locked : boolean; -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.w shr 1 - 1; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - case DstSurface^.format.BytesPerPixel of - 1 : - begin - Row8Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row8Bit^[ x ]; - Row8Bit^[ x ] := Row8Bit^[ RightSide ]; - Row8Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( PtrUInt( Row8Bit ), DstSurface^.pitch ); - end; - end; - 2 : - begin - Row16Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row16Bit^[ x ]; - Row16Bit^[ x ] := Row16Bit^[ RightSide ]; - Row16Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( PtrUInt( Row16Bit ), DstSurface^.pitch ); - end; - end; - 3 : - begin - Row24Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel24 := Row24Bit^[ x ]; - Row24Bit^[ x ] := Row24Bit^[ RightSide ]; - Row24Bit^[ RightSide ] := Pixel24; - dec( RightSide ); - end; - inc( PtrUInt( Row24Bit ), DstSurface^.pitch ); - end; - end; - 4 : - begin - Row32Bit := pointer( PtrUInt( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row32Bit^[ x ]; - Row32Bit^[ x ] := Row32Bit^[ RightSide ]; - Row32Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( PtrUInt( Row32Bit ), DstSurface^.pitch ); - end; - end; - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. -// But you MUST free it after you don't need it anymore!!! - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; -var - Rect : PSDL_Rect; -begin - New( Rect ); - with Rect^ do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; - Result := Rect; -end; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; -begin - with result do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; -end; - -function SDLRect( aRect : TRect ) : TSDL_Rect; -begin - with aRect do - result := SDLRect( Left, Top, Right - Left, Bottom - Top ); -end; - -procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, - depth : integer ); -var - dx, dy, e, d, dx2 : integer; - src_pitch, dst_pitch : uint16; - src_pixels, dst_pixels : PUint8; -begin - if ( yw >= dst_surface^.h ) then - exit; - dx := ( x2 - x1 ); - dy := ( y2 - y1 ); - dy := dy shl 1; - e := dy - dx; - dx2 := dx shl 1; - src_pitch := Surface^.pitch; - dst_pitch := dst_surface^.pitch; - src_pixels := PUint8( PtrUInt( Surface^.pixels ) + yr * src_pitch + y1 * depth ); - dst_pixels := PUint8( PtrUInt( dst_surface^.pixels ) + yw * dst_pitch + x1 * - depth ); - for d := 0 to dx - 1 do - begin - move( src_pixels^, dst_pixels^, depth ); - while ( e >= 0 ) do - begin - inc( src_pixels, depth ); - e := e - dx2; - end; - inc( dst_pixels, depth ); - e := e + dy; - end; -end; - -function sign( x : integer ) : integer; -begin - if x > 0 then - result := 1 - else - result := -1; -end; - -// Stretches a part of a surface - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; -var - dst_surface : PSDL_Surface; - dx, dy, e, d, dx2, srcx2, srcy2 : integer; - destx1, desty1 : integer; -begin - srcx2 := srcx1 + SrcW; - srcy2 := srcy1 + SrcH; - result := nil; - destx1 := 0; - desty1 := 0; - dx := abs( integer( Height - desty1 ) ); - dy := abs( integer( SrcY2 - SrcY1 ) ); - e := ( dy shl 1 ) - dx; - dx2 := dx shl 1; - dy := dy shl 1; - dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - - desty1, - SrcSurface^.Format^.BitsPerPixel, - SrcSurface^.Format^.RMask, - SrcSurface^.Format^.GMask, - SrcSurface^.Format^.BMask, - SrcSurface^.Format^.AMask ); - if ( dst_surface^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); - if ( SDL_MustLock( dst_surface ) ) then - if ( SDL_LockSurface( dst_surface ) < 0 ) then - exit; - for d := 0 to dx - 1 do - begin - SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, - SrcSurface^.format^.BytesPerPixel ); - while e >= 0 do - begin - inc( SrcY1 ); - e := e - dx2; - end; - inc( desty1 ); - e := e + dy; - end; - if SDL_MUSTLOCK( dst_surface ) then - SDL_UnlockSurface( dst_surface ); - result := dst_surface; -end; - -procedure SDL_MoveLine( Surface : PSDL_Surface; x1, x2, y1, xofs, depth : integer ); -var - src_pixels, dst_pixels : PUint8; - i : integer; -begin - src_pixels := PUint8( PtrUInt( Surface^.pixels ) + Surface^.w * y1 * depth + x2 * - depth ); - dst_pixels := PUint8( PtrUInt( Surface^.pixels ) + Surface^.w * y1 * depth + ( x2 - + xofs ) * depth ); - for i := x2 downto x1 do - begin - move( src_pixels^, dst_pixels^, depth ); - dec( src_pixels ); - dec( dst_pixels ); - end; -end; -{ Return the pixel value at (x, y) -NOTE: The surface must be locked before calling this! } - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : integer; y : integer ) : Uint32; -var - bpp : UInt32; - p : PInteger; -begin - bpp := SrcSurface.format.BytesPerPixel; - // Here p is the address to the pixel we want to retrieve - p := Pointer( PtrUInt( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * - bpp ); - case bpp of - 1 : result := PUint8( p )^; - 2 : result := PUint16( p )^; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] - else - result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] shl 16; - 4 : result := PUint32( p )^; - else - result := 0; // shouldn't happen, but avoids warnings - end; -end; -{ Set the pixel at (x, y) to the given value - NOTE: The surface must be locked before calling this! } - -procedure SDL_PutPixel( DstSurface : PSDL_Surface; x : integer; y : integer; pixel : - Uint32 ); -var - bpp : UInt32; - p : PInteger; -begin - bpp := DstSurface.format.BytesPerPixel; - p := Pointer( PtrUInt( DstSurface.pixels ) + UInt32( y ) * DstSurface.pitch + UInt32( x ) - * bpp ); - case bpp of - 1 : PUint8( p )^ := pixel; - 2 : PUint16( p )^ := pixel; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - begin - PUInt8Array( p )[ 0 ] := ( pixel shr 16 ) and $FF; - PUInt8Array( p )[ 1 ] := ( pixel shr 8 ) and $FF; - PUInt8Array( p )[ 2 ] := pixel and $FF; - end - else - begin - PUInt8Array( p )[ 0 ] := pixel and $FF; - PUInt8Array( p )[ 1 ] := ( pixel shr 8 ) and $FF; - PUInt8Array( p )[ 2 ] := ( pixel shr 16 ) and $FF; - end; - 4 : - PUint32( p )^ := pixel; - end; -end; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); -var - r1, r2 : TSDL_Rect; - //buffer: PSDL_Surface; - YPos : Integer; -begin - if ( DstSurface <> nil ) and ( DifY <> 0 ) then - begin - //if DifY > 0 then // going up - //begin - ypos := 0; - r1.x := 0; - r2.x := 0; - r1.w := DstSurface.w; - r2.w := DstSurface.w; - r1.h := DifY; - r2.h := DifY; - while ypos < DstSurface.h do - begin - r1.y := ypos; - r2.y := ypos + DifY; - SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); - ypos := ypos + DifY; - end; - //end - //else - //begin // Going Down - //end; - end; -end; - -{procedure SDL_ScrollY(Surface: PSDL_Surface; DifY: integer); -var - r1, r2: TSDL_Rect; - buffer: PSDL_Surface; -begin - if (Surface <> nil) and (Dify <> 0) then - begin - buffer := SDL_CreateRGBSurface(SDL_HWSURFACE, (Surface^.w - DifY) * 2, - Surface^.h * 2, - Surface^.Format^.BitsPerPixel, 0, 0, 0, 0); - if buffer <> nil then - begin - if (buffer^.format^.BytesPerPixel = 1) then - SDL_SetColors(buffer, @Surface^.format^.palette^.colors^[0], 0, 256); - r1 := SDLRect(0, DifY, buffer^.w, buffer^.h); - r2 := SDLRect(0, 0, buffer^.w, buffer^.h); - SDL_BlitSurface(Surface, @r1, buffer, @r2); - SDL_BlitSurface(buffer, @r2, Surface, @r2); - SDL_FreeSurface(buffer); - end; - end; -end;} - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); -var - r1, r2 : TSDL_Rect; - buffer : PSDL_Surface; -begin - if ( DstSurface <> nil ) and ( DifX <> 0 ) then - begin - buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, - DstSurface^.h * 2, - DstSurface^.Format^.BitsPerPixel, - DstSurface^.Format^.RMask, - DstSurface^.Format^.GMask, - DstSurface^.Format^.BMask, - DstSurface^.Format^.AMask ); - if buffer <> nil then - begin - if ( buffer^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); - r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); - SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); - SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); - SDL_FreeSurface( buffer ); - end; - end; -end; - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); -var - aSin, aCos : Single; - MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; - Colour, TempTransparentColour : UInt32; - MAXX, MAXY : Integer; -begin - // Rotate the surface to the target surface. - TempTransparentColour := SrcSurface.format.colorkey; - {if srcRect.w > srcRect.h then - begin - Width := srcRect.w; - Height := srcRect.w; - end - else - begin - Width := srcRect.h; - Height := srcRect.h; - end; } - - maxx := DstSurface.w; - maxy := DstSurface.h; - aCos := cos( Angle ); - aSin := sin( Angle ); - - Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); - Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); - - OX := Width div 2; - OY := Height div 2; ; - MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; - MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; - ROX := ( -( srcRect.w div 2 ) ) + Offsetx; - ROY := ( -( srcRect.h div 2 ) ) + OffsetY; - Tx := ox + round( ROX * aSin - ROY * aCos ); - Ty := oy + round( ROY * aSin + ROX * aCos ); - SX := 0; - for DX := DestX - TX to DestX - TX + ( width ) do - begin - Inc( SX ); - SY := 0; - for DY := DestY - TY to DestY - TY + ( Height ) do - begin - RX := SX - OX; - RY := SY - OY; - NX := round( mx + RX * aSin + RY * aCos ); // - NY := round( my + RY * aSin - RX * aCos ); // - // Used for testing only - //SDL_PutPixel(DestSurface.SDLSurfacePointer,DX,DY,0); - if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then - begin - if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then - begin - if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then - begin - Colour := SDL_GetPixel( SrcSurface, NX, NY ); - if Colour <> TempTransparentColour then - begin - SDL_PutPixel( DstSurface, DX, DY, Colour ); - end; - end; - end; - end; - inc( SY ); - end; - end; -end; - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); -begin - SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); -end; - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; -var - RealRect : TSDL_Rect; - OutOfRange : Boolean; -begin - OutOfRange := false; - if dstrect = nil then - begin - RealRect.x := 0; - RealRect.y := 0; - RealRect.w := DstSurface.w; - RealRect.h := DstSurface.h; - end - else - begin - if dstrect.x < DstSurface.w then - begin - RealRect.x := dstrect.x; - end - else if dstrect.x < 0 then - begin - realrect.x := 0; - end - else - begin - OutOfRange := True; - end; - if dstrect.y < DstSurface.h then - begin - RealRect.y := dstrect.y; - end - else if dstrect.y < 0 then - begin - realrect.y := 0; - end - else - begin - OutOfRange := True; - end; - if OutOfRange = False then - begin - if realrect.x + dstrect.w <= DstSurface.w then - begin - RealRect.w := dstrect.w; - end - else - begin - RealRect.w := dstrect.w - realrect.x; - end; - if realrect.y + dstrect.h <= DstSurface.h then - begin - RealRect.h := dstrect.h; - end - else - begin - RealRect.h := dstrect.h - realrect.y; - end; - end; - end; - if OutOfRange = False then - begin - result := realrect; - end - else - begin - realrect.w := 0; - realrect.h := 0; - realrect.x := 0; - realrect.y := 0; - result := realrect; - end; -end; - -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( PtrUInt( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( PtrUInt( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - inc( PtrUInt( Addr ), BPP ); - end; - inc( PtrUInt( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); -var - FBC : array[ 0..255 ] of Cardinal; - // temp vars - i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; - - TempStepV, TempStepH : Single; - TempLeft, TempTop, TempHeight, TempWidth : integer; - TempRect : TSDL_Rect; - -begin - // calc FBC - YR := StartColor.r; - YG := StartColor.g; - YB := StartColor.b; - SR := YR; - SG := YG; - SB := YB; - DR := EndColor.r - SR; - DG := EndColor.g - SG; - DB := EndColor.b - SB; - - for i := 0 to 255 do - begin - FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); - YR := SR + round( DR / 255 * i ); - YG := SG + round( DG / 255 * i ); - YB := SB + round( DB / 255 * i ); - end; - - // if aStyle = 1 then begin - TempStepH := Rect.w / 255; - TempStepV := Rect.h / 255; - TempHeight := Trunc( TempStepV + 1 ); - TempWidth := Trunc( TempStepH + 1 ); - TempTop := 0; - TempLeft := 0; - TempRect.x := Rect.x; - TempRect.y := Rect.y; - TempRect.h := Rect.h; - TempRect.w := Rect.w; - - case Style of - gsHorizontal : - begin - TempRect.h := TempHeight; - for i := 0 to 255 do - begin - TempRect.y := Rect.y + TempTop; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempTop := Trunc( TempStepV * i ); - end; - end; - gsVertical : - begin - TempRect.w := TempWidth; - for i := 0 to 255 do - begin - TempRect.x := Rect.x + TempLeft; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempLeft := Trunc( TempStepH * i ); - end; - end; - end; -end; - -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; - SrcPitch, DestPitch, x, y : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := PtrUInt( Src.Pixels ); - WriteRow := PtrUInt( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - case Src.format.BytesPerPixel of - 1 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt8( WriteAddr )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + 1 )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + DestPitch )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + DestPitch + 1 )^ := PUInt8( ReadAddr )^; - inc( ReadAddr ); - inc( WriteAddr, 2 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 2 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt16( WriteAddr )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + 2 )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + DestPitch )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + DestPitch + 2 )^ := PUInt16( ReadAddr )^; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 3 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + 3 )^ := ( PUInt32( WriteAddr + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + DestPitch )^ := ( PUInt32( WriteAddr + DestPitch )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + DestPitch + 3 )^ := ( PUInt32( WriteAddr + DestPitch + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - inc( ReadAddr, 3 ); - inc( WriteAddr, 6 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 4 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + 4 )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + DestPitch )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + DestPitch + 4 )^ := PUInt32( ReadAddr )^; - inc( ReadAddr, 4 ); - inc( WriteAddr, 8 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; - SrcPitch, DestPitch, x, y : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := PtrUInt( Src.Pixels ); - WriteRow := PtrUInt( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - case Src.format.BytesPerPixel of - 1 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt8( WriteAddr )^ := PUInt8( ReadAddr )^; - PUInt8( WriteAddr + 1 )^ := PUInt8( ReadAddr )^; - inc( ReadAddr ); - inc( WriteAddr, 2 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 2 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt16( WriteAddr )^ := PUInt16( ReadAddr )^; - PUInt16( WriteAddr + 2 )^ := PUInt16( ReadAddr )^; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 3 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr + 3 )^ := ( PUInt32( WriteAddr + 3 )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - inc( ReadAddr, 3 ); - inc( WriteAddr, 6 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 4 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - PUInt32( WriteAddr )^ := PUInt32( ReadAddr )^; - PUInt32( WriteAddr + 4 )^ := PUInt32( ReadAddr )^; - inc( ReadAddr, 4 ); - inc( WriteAddr, 8 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : PtrUInt; - SrcPitch, DestPitch, x, y, Color : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := PtrUInt( Src.Pixels ); - WriteRow := PtrUInt( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - case Src.format.BitsPerPixel of - 8 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt8( ReadAddr )^; - PUInt8( WriteAddr )^ := Color; - PUInt8( WriteAddr + 1 )^ := Color; - Color := ( Color shr 1 ) and $6D; {%01101101} - PUInt8( WriteAddr + DestPitch )^ := Color; - PUInt8( WriteAddr + DestPitch + 1 )^ := Color; - inc( ReadAddr ); - inc( WriteAddr, 2 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 15 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt16( ReadAddr )^; - PUInt16( WriteAddr )^ := Color; - PUInt16( WriteAddr + 2 )^ := Color; - Color := ( Color shr 1 ) and $3DEF; {%0011110111101111} - PUInt16( WriteAddr + DestPitch )^ := Color; - PUInt16( WriteAddr + DestPitch + 2 )^ := Color; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 16 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt16( ReadAddr )^; - PUInt16( WriteAddr )^ := Color; - PUInt16( WriteAddr + 2 )^ := Color; - Color := ( Color shr 1 ) and $7BEF; {%0111101111101111} - PUInt16( WriteAddr + DestPitch )^ := Color; - PUInt16( WriteAddr + DestPitch + 2 )^ := Color; - inc( ReadAddr, 2 ); - inc( WriteAddr, 4 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 24 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := ( PUInt32( WriteAddr )^ and $FF000000 ) or ( PUInt32( ReadAddr )^ and $00FFFFFF ); - PUInt32( WriteAddr )^ := Color; - PUInt32( WriteAddr + 3 )^ := Color; - Color := ( Color shr 1 ) and $007F7F7F; {%011111110111111101111111} - PUInt32( WriteAddr + DestPitch )^ := Color; - PUInt32( WriteAddr + DestPitch + 3 )^ := Color; - inc( ReadAddr, 3 ); - inc( WriteAddr, 6 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - 32 : for y := 1 to Src.h do - begin - ReadAddr := ReadRow; - WriteAddr := WriteRow; - for x := 1 to Src.w do - begin - Color := PUInt32( ReadAddr )^; - PUInt32( WriteAddr )^ := Color; - PUInt32( WriteAddr + 4 )^ := Color; - Color := ( Color shr 1 ) and $7F7F7F7F; - PUInt32( WriteAddr + DestPitch )^ := Color; - PUInt32( WriteAddr + DestPitch + 4 )^ := Color; - inc( ReadAddr, 4 ); - inc( WriteAddr, 8 ); - end; - inc( PtrUInt( ReadRow ), SrcPitch ); - inc( PtrUInt( WriteRow ), DestPitch * 2 ); - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : - PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : - boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, {Scan2Start,} ScanWidth, ScanHeight : cardinal; - Mod1 : cardinal; - Addr1 : PtrUInt; - BPP : cardinal; - Pitch1 : cardinal; - TransparentColor1 : cardinal; - tx, ty : cardinal; -// StartTick : cardinal; // Auto Removed, Unused Variable - Color1 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - //Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - //Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := PtrUInt( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - - Mod1 := Pitch1 - ( ScanWidth * BPP ); - - inc( Addr1, BPP * Scan1Start ); - - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - - end; - inc( Addr1, Mod1 ); - - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - - end; - inc( Addr1, Mod1 ); - - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - - if ( Color1 <> TransparentColor1 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - - end; - inc( Addr1, Mod1 ); - - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - - end; - inc( Addr1, Mod1 ); - - end; - end; -end; - -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var -{*R, *}{*G, *}{*B, *}Pixel1, Pixel2, TransparentColor : cardinal; // Auto Removed, Unused Variable (R) // Auto Removed, Unused Variable (G) // Auto Removed, Unused Variable (B) - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - PUInt8( DestAddr )^ := Pixel2 or Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 or Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 or Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel2 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - - PUInt32( DestAddr )^ := Pixel2 or Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var -{*R, *}{*G, *}{*B, *}Pixel1, Pixel2, TransparentColor : cardinal; // Auto Removed, Unused Variable (R) // Auto Removed, Unused Variable (G) // Auto Removed, Unused Variable (B) - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - PUInt8( DestAddr )^ := Pixel2 and Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 and Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - - PUInt16( DestAddr )^ := Pixel2 and Pixel1; - - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel2 and Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - - PUInt32( DestAddr )^ := Pixel2 and Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 > Pixel1 and $E0 then - R := Pixel2 and $E0 - else - R := Pixel1 and $E0; - if Pixel2 and $1C > Pixel1 and $1C then - G := Pixel2 and $1C - else - G := Pixel1 and $1C; - if Pixel2 and $03 > Pixel1 and $03 then - B := Pixel2 and $03 - else - B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 > Pixel1 and $7C00 then - R := Pixel2 and $7C00 - else - R := Pixel1 and $7C00; - if Pixel2 and $03E0 > Pixel1 and $03E0 then - G := Pixel2 and $03E0 - else - G := Pixel1 and $03E0; - if Pixel2 and $001F > Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 > Pixel1 and $F800 then - R := Pixel2 and $F800 - else - R := Pixel1 and $F800; - if Pixel2 and $07E0 > Pixel1 and $07E0 then - G := Pixel2 and $07E0 - else - G := Pixel1 and $07E0; - if Pixel2 and $001F > Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : PtrUInt; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := PtrUInt( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := PtrUInt( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 < Pixel1 and $E0 then - R := Pixel2 and $E0 - else - R := Pixel1 and $E0; - if Pixel2 and $1C < Pixel1 and $1C then - G := Pixel2 and $1C - else - G := Pixel1 and $1C; - if Pixel2 and $03 < Pixel1 and $03 then - B := Pixel2 and $03 - else - B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 < Pixel1 and $7C00 then - R := Pixel2 and $7C00 - else - R := Pixel1 and $7C00; - if Pixel2 and $03E0 < Pixel1 and $03E0 then - G := Pixel2 and $03E0 - else - G := Pixel1 and $03E0; - if Pixel2 and $001F < Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 < Pixel1 and $F800 then - R := Pixel2 and $F800 - else - R := Pixel1 and $F800; - if Pixel2 and $07E0 < Pixel1 and $07E0 then - G := Pixel2 and $07E0 - else - G := Pixel1 and $07E0; - if Pixel2 and $001F < Pixel1 and $001F then - B := Pixel2 and $001F - else - B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then - R := Pixel2 and $FF0000 - else - R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then - G := Pixel2 and $00FF00 - else - G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then - B := Pixel2 and $0000FF - else - B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -// Will clip the x1,x2,y1,x2 params to the ClipRect provided - -function SDL_ClipLine( var x1, y1, x2, y2 : Integer; ClipRect : PSDL_Rect ) : boolean; -var - tflag, flag1, flag2 : word; - txy, xedge, yedge : Integer; - slope : single; - - function ClipCode( x, y : Integer ) : word; - begin - Result := 0; - if x < ClipRect.x then - Result := 1; - if x >= ClipRect.w + ClipRect.x then - Result := Result or 2; - if y < ClipRect.y then - Result := Result or 4; - if y >= ClipRect.h + ClipRect.y then - Result := Result or 8; - end; - -begin - flag1 := ClipCode( x1, y1 ); - flag2 := ClipCode( x2, y2 ); - result := true; - - while true do - begin - if ( flag1 or flag2 ) = 0 then - Exit; // all in - - if ( flag1 and flag2 ) <> 0 then - begin - result := false; - Exit; // all out - end; - - if flag2 = 0 then - begin - txy := x1; x1 := x2; x2 := txy; - txy := y1; y1 := y2; y2 := txy; - tflag := flag1; flag1 := flag2; flag2 := tflag; - end; - - if ( flag2 and 3 ) <> 0 then - begin - if ( flag2 and 1 ) <> 0 then - xedge := ClipRect.x - else - xedge := ClipRect.w + ClipRect.x - 1; // back 1 pixel otherwise we end up in a loop - - slope := ( y2 - y1 ) / ( x2 - x1 ); - y2 := y1 + Round( slope * ( xedge - x1 ) ); - x2 := xedge; - end - else - begin - if ( flag2 and 4 ) <> 0 then - yedge := ClipRect.y - else - yedge := ClipRect.h + ClipRect.y - 1; // up 1 pixel otherwise we end up in a loop - - slope := ( x2 - x1 ) / ( y2 - y1 ); - x2 := x1 + Round( slope * ( yedge - y1 ) ); - y2 := yedge; - end; - - flag2 := ClipCode( x2, y2 ); - end; -end; - -end. - diff --git a/src/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas b/src/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas deleted file mode 100644 index 99eea304..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/sdlwindow.pas +++ /dev/null @@ -1,566 +0,0 @@ -unit sdlwindow; -{ - $Id: sdlwindow.pas,v 1.9 2006/10/22 18:55:25 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ SDL Window Wrapper } -{ } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2004 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ SDL Window Wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ January 31 2003 - DL : Initial creation } -{ } -{ - $Log: sdlwindow.pas,v $ - Revision 1.9 2006/10/22 18:55:25 savage - Slight Change to handle OpenGL context - - Revision 1.8 2005/08/03 18:57:32 savage - Various updates and additions. Mainly to handle OpenGL 3D Window support and better cursor support for the mouse class - - Revision 1.7 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - Revision 1.6 2004/09/12 21:52:58 savage - Slight changes to fix some issues with the sdl classes. - - Revision 1.5 2004/05/10 21:11:49 savage - changes required to help get SoAoS off the ground. - - Revision 1.4 2004/05/01 14:59:27 savage - Updated code - - Revision 1.3 2004/04/23 10:45:28 savage - Changes made by Dean Ellis to work more modularly. - - Revision 1.2 2004/03/31 10:06:41 savage - Changed so that it now compiles, but is untested. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - -} -{******************************************************************************} - -interface - -{$i jedi-sdl.inc} - -uses - Classes, - sdl, - sdlinput, - sdlticks; - -type - TSDLNotifyEvent = procedure {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLUpdateEvent = procedure( aElapsedTime : single ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLResizeEvent = procedure( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLUserEvent = procedure( aType : UInt8; aCode : integer; aData1 : Pointer; aData2 : Pointer ) {$IFNDEF NOT_OO}of object{$ENDIF}; - TSDLActiveEvent = procedure( aGain: UInt8; aState: UInt8 ) {$IFNDEF NOT_OO}of object{$ENDIF}; - - TSDLBaseWindow = class( TObject ) - private - FDisplaySurface : PSDL_Surface; - FVideoFlags : Uint32; - FOnDestroy: TSDLNotifyEvent; - FOnCreate: TSDLNotifyEvent; - FOnShow: TSDLNotifyEvent; - FOnResize: TSDLResizeEvent; - FOnUpdate: TSDLUpdateEvent; - FOnRender: TSDLNotifyEvent; - FOnClose: TSDLNotifyEvent; - FLoaded: Boolean; - FRendering: Boolean; - FHeight: integer; - FBitDepth: integer; - FWidth: integer; - FInputManager: TSDLInputManager; - FCaptionText : PChar; - FIconName : PChar; - FOnActive: TSDLActiveEvent; - FOnQuit: TSDLNotifyEvent; - FOnExpose: TSDLNotifyEvent; - FOnUser: TSDLUserEvent; - FTimer : TSDLTicks; - protected - procedure DoActive( aGain: UInt8; aState: UInt8 ); - procedure DoCreate; - procedure DoClose; - procedure DoDestroy; - procedure DoUpdate( aElapsedTime : single ); - procedure DoQuit; - procedure DoRender; - procedure DoResize( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); - procedure DoShow; - procedure DoUser( aType : UInt8; aCode : integer; aData1 : Pointer; aData2 : Pointer ); - procedure DoExpose; - procedure Render; virtual; - procedure Update( aElapsedTime : single ); virtual; - procedure InitialiseObjects; virtual; - procedure RestoreObjects; virtual; - procedure DeleteObjects; virtual; - function Flip : integer; virtual; - property OnActive : TSDLActiveEvent read FOnActive write FOnActive; - property OnClose: TSDLNotifyEvent read FOnClose write FOnClose; - property OnDestroy : TSDLNotifyEvent read FOnDestroy write FOnDestroy; - property OnCreate : TSDLNotifyEvent read FOnCreate write FOnCreate; - property OnUpdate: TSDLUpdateEvent read FOnUpdate write FOnUpdate; - property OnQuit : TSDLNotifyEvent read FOnQuit write FOnQuit; - property OnResize : TSDLResizeEvent read FOnResize write FOnResize; - property OnRender: TSDLNotifyEvent read FOnRender write FOnRender; - property OnShow : TSDLNotifyEvent read FOnShow write FOnShow; - property OnUser : TSDLUserEvent read FOnUser write FOnUser; - property OnExpose : TSDLNotifyEvent read FOnExpose write FOnExpose; - property DisplaySurface: PSDL_Surface read FDisplaySurface; - public - property InputManager : TSDLInputManager read FInputManager; - property Loaded : Boolean read FLoaded; - property Width : integer read FWidth; - property Height : integer read FHeight; - property BitDepth : integer read FBitDepth; - property Rendering : Boolean read FRendering write FRendering; - procedure SetCaption( const aCaptionText : string; const aIconName : string ); - procedure GetCaption( var aCaptionText : string; var aIconName : string ); - procedure SetIcon( aIcon : PSDL_Surface; aMask: UInt8 ); - procedure ActivateVideoMode; - constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); virtual; - destructor Destroy; override; - procedure InitialiseEnvironment; - function Show : Boolean; virtual; - end; - - TSDLCustomWindow = class( TSDLBaseWindow ) - public - property OnCreate; - property OnDestroy; - property OnClose; - property OnShow; - property OnResize; - property OnRender; - property OnUpdate; - property DisplaySurface; - end; - - TSDL2DWindow = class( TSDLCustomWindow ) - public - constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 = SDL_DOUBLEBUF or SDL_SWSURFACE); override; - procedure Render; override; - procedure Update( aElapsedTime : single ); override; - procedure InitialiseObjects; override; - procedure RestoreObjects; override; - procedure DeleteObjects; override; - function Flip : integer; override; - end; - - TSDL3DWindow = class( TSDLCustomWindow ) - public - constructor Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 = SDL_OPENGL or SDL_DOUBLEBUF); override; - function Flip : integer; override; - procedure Render; override; - procedure Update( aElapsedTime : single ); override; - procedure InitialiseObjects; override; - procedure RestoreObjects; override; - procedure DeleteObjects; override; - end; - - - -implementation - -uses - logger, - SysUtils; - -{ TSDLBaseWindow } -procedure TSDLBaseWindow.ActivateVideoMode; -begin - FDisplaySurface := SDL_SetVideoMode( FWidth, FHeight, FBitDepth, FVideoFlags); - if (FDisplaySurface = nil) then - begin - Log.LogError( Format('Could not set video mode: %s', [SDL_GetError]), 'Main'); - exit; - end; - - SetCaption( 'Made with JEDI-SDL', 'JEDI-SDL Icon' ); -end; - -constructor TSDLBaseWindow.Create( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); -begin - inherited Create; - SDL_Init(SDL_INIT_EVERYTHING); - FInputManager := TSDLInputManager.Create( [ itJoystick, itKeyBoard, itMouse ]); - FTimer := TSDLTicks.Create; - - FWidth := aWidth; - FHeight := aHeight; - FBitDepth := aBitDepth; - FVideoFlags := aVideoFlags; - - DoCreate; -end; - -procedure TSDLBaseWindow.DeleteObjects; -begin - FLoaded := False; -end; - -destructor TSDLBaseWindow.Destroy; -begin - DoDestroy; - if FLoaded then - DeleteObjects; - if FInputManager <> nil then - FreeAndNil( FInputManager ); - if FTimer <> nil then - FreeAndNil( FTimer ); - if FDisplaySurface <> nil then - SDL_FreeSurface( FDisplaySurface ); - inherited Destroy; - SDL_Quit; -end; - -procedure TSDLBaseWindow.DoActive(aGain, aState: UInt8); -begin - if Assigned( FOnActive ) then - begin - FOnActive( aGain, aState ); - end; -end; - -procedure TSDLBaseWindow.DoClose; -begin - if Assigned( FOnClose ) then - begin - FOnClose; - end; -end; - -procedure TSDLBaseWindow.DoCreate; -begin - if Assigned( FOnCreate ) then - begin - FOnCreate; - end; -end; - -procedure TSDLBaseWindow.DoDestroy; -begin - if Assigned( FOnDestroy ) then - begin - FOnDestroy; - end; -end; - -procedure TSDLBaseWindow.DoExpose; -begin - if Assigned( FOnExpose ) then - begin - FOnExpose; - end; -end; - -procedure TSDLBaseWindow.DoUpdate( aElapsedTime : single ); -begin - if Assigned( FOnUpdate ) then - begin - FOnUpdate( aElapsedTime ); - end; -end; - -procedure TSDLBaseWindow.DoQuit; -begin - FRendering := false; - if Assigned( FOnQuit ) then - begin - FOnQuit; - end; -end; - -procedure TSDLBaseWindow.DoRender; -begin - if Assigned( FOnRender ) then - begin - FOnRender; - end; -end; - -procedure TSDLBaseWindow.DoResize( aWidth : integer; aHeight : integer; aBitDepth : integer; aVideoFlags : Uint32 ); -begin - // resize to the new size - SDL_FreeSurface(FDisplaySurface); - FWidth := aWidth; - FHeight := aHeight; - FBitDepth := aBitDepth; - FVideoFlags := aVideoFlags; - FDisplaySurface := SDL_SetVideoMode(aWidth, aHeight, aBitDepth, aVideoFlags); - if Assigned( FOnResize ) then - begin - FOnResize( aWidth, aHeight, aBitDepth, aVideoFlags ); - end; -end; - -procedure TSDLBaseWindow.DoShow; -begin - if Assigned( FOnShow ) then - begin - FOnShow; - end; -end; - -procedure TSDLBaseWindow.DoUser(aType: UInt8; aCode: integer; aData1, aData2: Pointer); -begin - if Assigned( FOnUser ) then - begin - FOnUser( aType, aCode, aData1, aData2 ); - end; -end; - -function TSDLBaseWindow.Flip : integer; -begin - result := 0; -end; - -procedure TSDLBaseWindow.GetCaption( var aCaptionText : string; var aIconName : string ); -begin - aCaptionText := string( FCaptionText ); - aIconName := string( FIconName ); -end; - -procedure TSDLBaseWindow.InitialiseEnvironment; -begin - InitialiseObjects; - RestoreObjects; -end; - -procedure TSDLBaseWindow.InitialiseObjects; -begin - FLoaded := True; -end; - -procedure TSDLBaseWindow.Update( aElapsedTime : single ); -begin - DoUpdate( aElapsedTime ); -end; - -procedure TSDLBaseWindow.Render; -begin - DoRender; -end; - -procedure TSDLBaseWindow.RestoreObjects; -begin - FLoaded := false; -end; - -procedure TSDLBaseWindow.SetCaption( const aCaptionText : string; const aIconName : string ); -begin - if FCaptionText <> aCaptionText then - begin - FCaptionText := PChar( aCaptionText ); - FIconName := PChar( aIconName ); - SDL_WM_SetCaption( FCaptionText, FIconName ); - end; -end; - -procedure TSDLBaseWindow.SetIcon(aIcon: PSDL_Surface; aMask: UInt8); -begin - SDL_WM_SetIcon( aIcon, aMask ); -end; - -function TSDLBaseWindow.Show : Boolean; -var - eBaseWindowEvent : TSDL_Event; -begin - DoShow; - - FTimer.Init; - - FRendering := true; - // repeat until we are told not to render - while FRendering do - begin - // wait for an event - while SDL_PollEvent( @eBaseWindowEvent ) > 0 do - begin - - // check for a quit event - case eBaseWindowEvent.type_ of - SDL_ACTIVEEVENT : - begin - DoActive( eBaseWindowEvent.active.gain, eBaseWindowEvent.active.state ); - end; - - SDL_QUITEV : - begin - DoQuit; - DoClose; - end; - - SDL_USEREVENT : - begin - DoUser( eBaseWindowEvent.user.type_, eBaseWindowEvent.user.code, eBaseWindowEvent.user.data1, eBaseWindowEvent.user.data2 ); - end; - - SDL_VIDEOEXPOSE : - begin - DoExpose; - end; - - SDL_VIDEORESIZE : - begin - DoResize( eBaseWindowEvent.resize.w, eBaseWindowEvent.resize.h, FDisplaySurface.format.BitsPerPixel, FVideoflags ); - end; - - - end; - InputManager.UpdateInputs( eBaseWindowEvent ); - end; - // Prepare the Next Frame - Update( FTimer.GetElapsedSeconds ); - // Display the Next Frame - Render; - // Flip the surfaces - Flip; - end; - - Result := FRendering; -end; - -{ TSDL2DWindow } - -constructor TSDL2DWindow.Create(aWidth, aHeight, aBitDepth: integer; aVideoFlags: Uint32); -begin - // make sure double buffer is always included in the video flags - inherited Create(aWidth,aHeight, aBitDepth, aVideoFlags or SDL_DOUBLEBUF); -end; - -procedure TSDL2DWindow.DeleteObjects; -begin - inherited; - -end; - -function TSDL2DWindow.Flip: integer; -begin - // let's show the back buffer - result := SDL_Flip( FDisplaySurface ); -end; - -procedure TSDL2DWindow.InitialiseObjects; -begin - inherited; - -end; - -procedure TSDL2DWindow.Update( aElapsedTime : single ); -begin - inherited; - -end; - -procedure TSDL2DWindow.Render; -begin - inherited; - -end; - -procedure TSDL2DWindow.RestoreObjects; -begin - inherited; - -end; - -{ TSDL3DWindow } - -constructor TSDL3DWindow.Create(aWidth, - aHeight, aBitDepth: integer; aVideoFlags: Uint32); -begin - // make sure opengl is always included in the video flags - inherited Create(aWidth,aHeight, aBitDepth, aVideoFlags or SDL_OPENGL or SDL_DOUBLEBUF); -end; - -procedure TSDL3DWindow.DeleteObjects; -begin - inherited; - -end; - -function TSDL3DWindow.Flip : integer; -begin - SDL_GL_SwapBuffers; - result := 0; -end; - -procedure TSDL3DWindow.InitialiseObjects; -begin - inherited; - -end; - -procedure TSDL3DWindow.Update( aElapsedTime : single ); -begin - inherited; - -end; - -procedure TSDL3DWindow.Render; -begin - inherited; - -end; - -procedure TSDL3DWindow.RestoreObjects; -begin - inherited; - -end; - -end. diff --git a/src/lib/JEDI-SDL/SDL/Pas/userpreferences.pas b/src/lib/JEDI-SDL/SDL/Pas/userpreferences.pas deleted file mode 100644 index aed326d1..00000000 --- a/src/lib/JEDI-SDL/SDL/Pas/userpreferences.pas +++ /dev/null @@ -1,159 +0,0 @@ -unit userpreferences; -{ - $Id: userpreferences.pas,v 1.1 2004/09/30 22:35:47 savage Exp $ - -} -{******************************************************************************} -{ } -{ JEDI-SDL : Pascal units for SDL - Simple DirectMedia Layer } -{ Base Class for User Preferences } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: userpreferences.pas,v $ - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - Classes; - -type - TUserPreferences = class - private - FAutoSave: Boolean; - procedure CheckAutoSave; - protected - function GetDefaultBoolean( const Index : Integer ) : Boolean; virtual; abstract; - function GetBoolean( const Index : Integer ) : Boolean; virtual; abstract; - procedure SetBoolean( const Index : Integer; const Value : Boolean ); virtual; - function GetDefaultDateTime( const Index : Integer ) : TDateTime; virtual; abstract; - function GetDateTime( const Index : Integer ) : TDateTime; virtual; abstract; - procedure SetDateTime( const Index : Integer; const Value : TDateTime ); virtual; - function GetDefaultInteger( const Index : Integer ) : Integer; virtual; abstract; - function GetInteger( const Index : Integer ) : Integer; virtual; abstract; - procedure SetInteger( const Index : Integer; const Value : Integer ); virtual; - function GetDefaultFloat( const Index : Integer ) : single; virtual; abstract; - function GetFloat( const Index : Integer ) : single; virtual; abstract; - procedure SetFloat( const Index : Integer; const Value : single ); virtual; - function GetDefaultString( const Index : Integer ) : string; virtual; abstract; - function GetString( const Index : Integer ) : string; virtual; abstract; - procedure SetString( const Index : Integer; const Value : string ); virtual; - function GetDefaultBinaryStream( const Index : Integer ) : TStream; virtual; abstract; - function GetBinaryStream( const Index : Integer ) : TStream; virtual; abstract; - procedure SetBinaryStream( const Index : Integer; const Value : TStream ); virtual; - public - procedure Update; virtual; abstract; - constructor Create; virtual; - destructor Destroy; override; - property AutoSave : Boolean read FAutoSave write FAutoSave; - end; - -implementation - -{ TUserPreferences } -procedure TUserPreferences.CheckAutoSave; -begin - if FAutoSave then - Update; -end; - -constructor TUserPreferences.Create; -begin - inherited; - FAutoSave := false; -end; - -destructor TUserPreferences.Destroy; -begin - - inherited; -end; - -procedure TUserPreferences.SetBinaryStream( const Index : Integer; const Value : TStream ); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetBoolean(const Index: Integer; const Value: Boolean); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetDateTime(const Index: Integer; const Value: TDateTime); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetFloat(const Index: Integer; const Value: single); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetInteger(const Index, Value: Integer); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetString(const Index: Integer; const Value: string); -begin - CheckAutoSave; -end; - -end. diff --git a/src/lib/JEDI-SDL/SDL_Image/Pas/sdl_image.pas b/src/lib/JEDI-SDL/SDL_Image/Pas/sdl_image.pas deleted file mode 100644 index 4468f036..00000000 --- a/src/lib/JEDI-SDL/SDL_Image/Pas/sdl_image.pas +++ /dev/null @@ -1,350 +0,0 @@ -unit sdl_image; -{ - $Id: sdl_image.pas,v 1.15 2007/12/05 22:52:23 savage Exp $ - -} -{******************************************************************************} -{ } -{ Borland Delphi SDL_Image - An example image loading library for use } -{ with SDL } -{ Conversion of the Simple DirectMedia Layer Image Headers } -{ } -{ Portions created by Sam Lantinga are } -{ Copyright (C) 1997, 1998, 1999, 2000, 2001 Sam Lantinga } -{ 5635-34 Springhouse Dr. } -{ Pleasanton, CA 94588 (USA) } -{ } -{ All Rights Reserved. } -{ } -{ The original files are : SDL_image.h } -{ } -{ The initial developer of this Pascal code was : } -{ Matthias Thoma } -{ } -{ Portions created by Matthias Thoma are } -{ Copyright (C) 2000 - 2001 Matthias Thoma. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ A simple library to load images of various formats as SDL surfaces } -{ } -{ Requires } -{ -------- } -{ SDL.pas in your search path. } -{ } -{ Programming Notes } -{ ----------------- } -{ See the Aliens Demo on how to make use of this libaray } -{ } -{ Revision History } -{ ---------------- } -{ April 02 2001 - MT : Initial Translation } -{ } -{ May 08 2001 - DL : Added ExternalSym derectives and copyright header } -{ } -{ 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_image.pas,v $ - Revision 1.15 2007/12/05 22:52:23 savage - Better Mac OS X support for Frameworks. - - Revision 1.14 2007/05/29 21:31:13 savage - Changes as suggested by Almindor for 64bit compatibility. - - Revision 1.13 2007/05/20 20:30:54 savage - Initial Changes to Handle 64 Bits - - Revision 1.12 2006/12/02 00:14:40 savage - Updated to latest version - - Revision 1.11 2005/04/10 18:22:59 savage - Changes as suggested by Michalis, thanks. - - Revision 1.10 2005/04/10 11:48:33 savage - Changes as suggested by Michalis, thanks. - - Revision 1.9 2005/01/05 01:47:07 savage - Changed LibName to reflect what MacOS X should have. ie libSDL*-1.2.0.dylib respectively. - - Revision 1.8 2005/01/04 23:14:44 savage - Changed LibName to reflect what most Linux distros will have. ie libSDL*-1.2.so.0 respectively. - - Revision 1.7 2005/01/01 02:03:12 savage - Updated to v1.2.4 - - Revision 1.6 2004/08/14 22:54:30 savage - Updated so that Library name defines are correctly defined for MacOS X. - - Revision 1.5 2004/05/10 14:10:04 savage - Initial MacOS X support. Fixed defines for MACOS ( Classic ) and DARWIN ( MacOS X ). - - Revision 1.4 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.3 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.2 2004/03/30 20:23:28 savage - Tidied up use of UNIX compiler directive. - - Revision 1.1 2004/02/14 23:35:42 savage - version 1 of sdl_image, sdl_mixer and smpeg. - - -} -{******************************************************************************} - -{$I jedi-sdl.inc} - -interface - -uses -{$IFDEF __GPC__} - gpc, -{$ENDIF} - sdl; - -const -{$IFDEF WINDOWS} - SDL_ImageLibName = 'SDL_Image.dll'; -{$ENDIF} - -{$IFDEF UNIX} -{$IFDEF DARWIN} - SDL_ImageLibName = 'libSDL_image-1.2.0.dylib'; - {$linklib libSDL_image} -{$ELSE} - {$IFDEF FPC} - SDL_ImageLibName = 'libSDL_image.so'; - {$ELSE} - SDL_ImageLibName = 'libSDL_image-1.2.so.0'; - {$ENDIF} -{$ENDIF} -{$ENDIF} - -{$IFDEF MACOS} - SDL_ImageLibName = 'SDL_image'; - {$linklib libSDL_image} -{$ENDIF} - - // Printable format: "%d.%d.%d", MAJOR, MINOR, PATCHLEVEL - SDL_IMAGE_MAJOR_VERSION = 1; -{$EXTERNALSYM SDL_IMAGE_MAJOR_VERSION} - SDL_IMAGE_MINOR_VERSION = 2; -{$EXTERNALSYM SDL_IMAGE_MINOR_VERSION} - SDL_IMAGE_PATCHLEVEL = 6; -{$EXTERNALSYM SDL_IMAGE_PATCHLEVEL} - -{ This macro can be used to fill a version structure with the compile-time - version of the SDL_image library. } -procedure SDL_IMAGE_VERSION( var X : TSDL_Version ); -{$EXTERNALSYM SDL_IMAGE_VERSION} - -{ This function gets the version of the dynamically linked SDL_image library. - it should NOT be used to fill a version structure, instead you should - use the SDL_IMAGE_VERSION() macro. - } -function IMG_Linked_Version : PSDL_version; -external {$IFDEF __GPC__}name 'IMG_Linked_Version'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_Linked_Version} - -{ Load an image from an SDL data source. - The 'type' may be one of: "BMP", "GIF", "PNG", etc. - - If the image format supports a transparent pixel, SDL will set the - colorkey for the surface. You can enable RLE acceleration on the - surface afterwards by calling: - SDL_SetColorKey(image, SDL_RLEACCEL, image.format.colorkey); -} -function IMG_LoadTyped_RW(src: PSDL_RWops; freesrc: Integer; _type: PChar): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadTyped_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadTyped_RW} -{ Convenience functions } -function IMG_Load(const _file: PChar): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_Load'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_Load} -function IMG_Load_RW(src: PSDL_RWops; freesrc: Integer): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_Load_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_Load_RW} - -{ Invert the alpha of a surface for use with OpenGL - This function is now a no-op, and only provided for backwards compatibility. } -function IMG_InvertAlpha(_on: Integer): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_InvertAlpha'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_InvertAlpha} - -{ Functions to detect a file type, given a seekable source } -function IMG_isBMP(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isBMP'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isBMP} - -function IMG_isGIF(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isGIF'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isGIF} - -function IMG_isJPG(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isJPG'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isJPG} - -function IMG_isLBM(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isLBM'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isLBM} - -function IMG_isPCX(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isPCX'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isPCX} - -function IMG_isPNG(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isPNG'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isPNG} - -function IMG_isPNM(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isPNM'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isPNM} - -function IMG_isTIF(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isTIF'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isTIF} - -function IMG_isXCF(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isXCF'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isXCF} - -function IMG_isXPM(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isXPM'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isXPM} - -function IMG_isXV(src: PSDL_RWops): Integer; -cdecl; external {$IFDEF __GPC__}name 'IMG_isXV'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_isXV} - - -{ Individual loading functions } -function IMG_LoadBMP_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadBMP_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadBMP_RW} - -function IMG_LoadGIF_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadGIF_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadGIF_RW} - -function IMG_LoadJPG_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadJPG_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadJPG_RW} - -function IMG_LoadLBM_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadLBM_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadLBM_RW} - -function IMG_LoadPCX_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadPCX_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadPCX_RW} - -function IMG_LoadPNM_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadPNM_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadPNM_RW} - -function IMG_LoadPNG_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadPNG_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadPNG_RW} - -function IMG_LoadTGA_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadTGA_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadTGA_RW} - -function IMG_LoadTIF_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadTIF_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadTIF_RW} - -function IMG_LoadXCF_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadXCF_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadXCF_RW} - -function IMG_LoadXPM_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadXPM_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadXPM_RW} - -function IMG_LoadXV_RW(src: PSDL_RWops): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_LoadXV_RW'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_LoadXV_RW} - -function IMG_ReadXPMFromArray( xpm : PPChar ): PSDL_Surface; -cdecl; external {$IFDEF __GPC__}name 'IMG_ReadXPMFromArray'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -{$EXTERNALSYM IMG_ReadXPMFromArray} - - - - -{ used internally, NOT an exported function } -//function IMG_string_equals( const str1 : PChar; const str2 : PChar ) : integer; -//cdecl; external {$IFDEF __GPC__}name 'IMG_string_equals'{$ELSE} SDL_ImageLibName{$ENDIF __GPC__}; -//{ $ EXTERNALSYM IMG_string_equals} - -{ Error Macros } -{ We'll use SDL for reporting errors } -procedure IMG_SetError( fmt : PChar ); - -function IMG_GetError : PChar; - -implementation - -{$IFDEF __GPC__} - {$L 'sdl_image'} { link sdl_image.dll.a or libsdl_image.so or libsdl_image.a } -{$ENDIF} - -procedure SDL_IMAGE_VERSION( var X : TSDL_Version ); -begin - X.major := SDL_IMAGE_MAJOR_VERSION; - X.minor := SDL_IMAGE_MINOR_VERSION; - X.patch := SDL_IMAGE_PATCHLEVEL; -end; - -procedure IMG_SetError( fmt : PChar ); -begin - SDL_SetError( fmt ); -end; - -function IMG_GetError : PChar; -begin - result := SDL_GetError; -end; - -end. diff --git a/src/lib/SQLite/SQLite3.pas b/src/lib/SQLite/SQLite3.pas deleted file mode 100644 index 7b7207c4..00000000 --- a/src/lib/SQLite/SQLite3.pas +++ /dev/null @@ -1,253 +0,0 @@ -unit SQLite3; - -{ - Simplified interface for SQLite. - Updated for Sqlite 3 by Tim Anderson (tim@itwriting.com) - Note: NOT COMPLETE for version 3, just minimal functionality - Adapted from file created by Pablo Pissanetzky (pablo@myhtpc.net) - which was based on SQLite.pas by Ben Hochstrasser (bhoc@surfeu.ch) -} - -{$IFDEF FPC} - {$MODE DELPHI} - {$H+} (* use long strings *) - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -interface - -const -{$IF Defined(MSWINDOWS)} - SQLiteDLL = 'sqlite3.dll'; -{$ELSEIF Defined(DARWIN)} - SQLiteDLL = 'libsqlite3.dylib'; - {$linklib libsqlite3} -{$ELSEIF Defined(UNIX)} - SQLiteDLL = 'sqlite3.so'; -{$IFEND} - -// Return values for sqlite3_exec() and sqlite3_step() - -const - SQLITE_OK = 0; // Successful result - (* beginning-of-error-codes *) - SQLITE_ERROR = 1; // SQL error or missing database - SQLITE_INTERNAL = 2; // An internal logic error in SQLite - SQLITE_PERM = 3; // Access permission denied - SQLITE_ABORT = 4; // Callback routine requested an abort - SQLITE_BUSY = 5; // The database file is locked - SQLITE_LOCKED = 6; // A table in the database is locked - SQLITE_NOMEM = 7; // A malloc() failed - SQLITE_READONLY = 8; // Attempt to write a readonly database - SQLITE_INTERRUPT = 9; // Operation terminated by sqlite3_interrupt() - SQLITE_IOERR = 10; // Some kind of disk I/O error occurred - SQLITE_CORRUPT = 11; // The database disk image is malformed - SQLITE_NOTFOUND = 12; // (Internal Only) Table or record not found - SQLITE_FULL = 13; // Insertion failed because database is full - SQLITE_CANTOPEN = 14; // Unable to open the database file - SQLITE_PROTOCOL = 15; // Database lock protocol error - SQLITE_EMPTY = 16; // Database is empty - SQLITE_SCHEMA = 17; // The database schema changed - SQLITE_TOOBIG = 18; // Too much data for one row of a table - SQLITE_CONSTRAINT = 19; // Abort due to contraint violation - SQLITE_MISMATCH = 20; // Data type mismatch - SQLITE_MISUSE = 21; // Library used incorrectly - SQLITE_NOLFS = 22; // Uses OS features not supported on host - SQLITE_AUTH = 23; // Authorization denied - SQLITE_FORMAT = 24; // Auxiliary database format error - SQLITE_RANGE = 25; // 2nd parameter to sqlite3_bind out of range - SQLITE_NOTADB = 26; // File opened that is not a database file - SQLITE_ROW = 100; // sqlite3_step() has another row ready - SQLITE_DONE = 101; // sqlite3_step() has finished executing - - SQLITE_INTEGER = 1; - SQLITE_FLOAT = 2; - SQLITE_TEXT = 3; - SQLITE_BLOB = 4; - SQLITE_NULL = 5; - - SQLITE_UTF8 = 1; - SQLITE_UTF16 = 2; - SQLITE_UTF16BE = 3; - SQLITE_UTF16LE = 4; - SQLITE_ANY = 5; - - SQLITE_STATIC {: TSQLite3Destructor} = Pointer(0); - SQLITE_TRANSIENT {: TSQLite3Destructor} = Pointer(-1); - -type - TSQLiteDB = Pointer; - TSQLiteResult = ^PAnsiChar; - TSQLiteStmt = Pointer; - -type - PPAnsiCharArray = ^TPAnsiCharArray; - TPAnsiCharArray = array[0 .. (MaxInt div SizeOf(PAnsiChar))-1] of PAnsiChar; - -type - TSQLiteExecCallback = function(UserData: Pointer; NumCols: integer; ColValues: - PPAnsiCharArray; ColNames: PPAnsiCharArray): integer; cdecl; - TSQLiteBusyHandlerCallback = function(UserData: Pointer; P2: integer): integer; cdecl; - - //function prototype for define own collate - TCollateXCompare = function(UserData: pointer; Buf1Len: integer; Buf1: pointer; - Buf2Len: integer; Buf2: pointer): integer; cdecl; - - -function SQLite3_Open(filename: PAnsiChar; out db: TSQLiteDB): integer; cdecl; external SQLiteDLL name 'sqlite3_open'; -function SQLite3_Close(db: TSQLiteDB): integer; cdecl; external SQLiteDLL name 'sqlite3_close'; -function SQLite3_Exec(db: TSQLiteDB; SQLStatement: PAnsiChar; CallbackPtr: TSQLiteExecCallback; UserData: Pointer; var ErrMsg: PAnsiChar): integer; cdecl; external SQLiteDLL name 'sqlite3_exec'; -function SQLite3_Version(): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_libversion'; -function SQLite3_ErrMsg(db: TSQLiteDB): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_errmsg'; -function SQLite3_ErrCode(db: TSQLiteDB): integer; cdecl; external SQLiteDLL name 'sqlite3_errcode'; -procedure SQlite3_Free(P: PAnsiChar); cdecl; external SQLiteDLL name 'sqlite3_free'; -function SQLite3_GetTable(db: TSQLiteDB; SQLStatement: PAnsiChar; var ResultPtr: TSQLiteResult; var RowCount: Cardinal; var ColCount: Cardinal; var ErrMsg: PAnsiChar): integer; cdecl; external SQLiteDLL name 'sqlite3_get_table'; -procedure SQLite3_FreeTable(Table: TSQLiteResult); cdecl; external SQLiteDLL name 'sqlite3_free_table'; -function SQLite3_Complete(P: PAnsiChar): boolean; cdecl; external SQLiteDLL name 'sqlite3_complete'; -function SQLite3_LastInsertRowID(db: TSQLiteDB): int64; cdecl; external SQLiteDLL name 'sqlite3_last_insert_rowid'; -procedure SQLite3_Interrupt(db: TSQLiteDB); cdecl; external SQLiteDLL name 'sqlite3_interrupt'; -procedure SQLite3_BusyHandler(db: TSQLiteDB; CallbackPtr: TSQLiteBusyHandlerCallback; UserData: Pointer); cdecl; external SQLiteDLL name 'sqlite3_busy_handler'; -procedure SQLite3_BusyTimeout(db: TSQLiteDB; TimeOut: integer); cdecl; external SQLiteDLL name 'sqlite3_busy_timeout'; -function SQLite3_Changes(db: TSQLiteDB): integer; cdecl; external SQLiteDLL name 'sqlite3_changes'; -function SQLite3_TotalChanges(db: TSQLiteDB): integer; cdecl; external SQLiteDLL name 'sqlite3_total_changes'; -function SQLite3_Prepare(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: integer; out hStmt: TSqliteStmt; out pzTail: PAnsiChar): integer; cdecl; external SQLiteDLL name 'sqlite3_prepare'; -function SQLite3_Prepare_v2(db: TSQLiteDB; SQLStatement: PAnsiChar; nBytes: integer; out hStmt: TSqliteStmt; out pzTail: PAnsiChar): integer; cdecl; external SQLiteDLL name 'sqlite3_prepare_v2'; -function SQLite3_ColumnCount(hStmt: TSqliteStmt): integer; cdecl; external SQLiteDLL name 'sqlite3_column_count'; -function SQLite3_ColumnName(hStmt: TSqliteStmt; ColNum: integer): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_column_name'; -function SQLite3_ColumnDeclType(hStmt: TSqliteStmt; ColNum: integer): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_column_decltype'; -function SQLite3_Step(hStmt: TSqliteStmt): integer; cdecl; external SQLiteDLL name 'sqlite3_step'; -function SQLite3_DataCount(hStmt: TSqliteStmt): integer; cdecl; external SQLiteDLL name 'sqlite3_data_count'; - -function SQLite3_ColumnBlob(hStmt: TSqliteStmt; ColNum: integer): pointer; cdecl; external SQLiteDLL name 'sqlite3_column_blob'; -function SQLite3_ColumnBytes(hStmt: TSqliteStmt; ColNum: integer): integer; cdecl; external SQLiteDLL name 'sqlite3_column_bytes'; -function SQLite3_ColumnDouble(hStmt: TSqliteStmt; ColNum: integer): double; cdecl; external SQLiteDLL name 'sqlite3_column_double'; -function SQLite3_ColumnInt(hStmt: TSqliteStmt; ColNum: integer): integer; cdecl; external SQLiteDLL name 'sqlite3_column_int'; -function SQLite3_ColumnText(hStmt: TSqliteStmt; ColNum: integer): PAnsiChar; cdecl; external SQLiteDLL name 'sqlite3_column_text'; -function SQLite3_ColumnType(hStmt: TSqliteStmt; ColNum: integer): integer; cdecl; external SQLiteDLL name 'sqlite3_column_type'; -function SQLite3_ColumnInt64(hStmt: TSqliteStmt; ColNum: integer): Int64; cdecl; external SQLiteDLL name 'sqlite3_column_int64'; -function SQLite3_Finalize(hStmt: TSqliteStmt): integer; cdecl; external SQLiteDLL name 'sqlite3_finalize'; -function SQLite3_Reset(hStmt: TSqliteStmt): integer; cdecl; external SQLiteDLL name 'sqlite3_reset'; - -// -// In the SQL strings input to sqlite3_prepare() and sqlite3_prepare16(), -// one or more literals can be replace by a wildcard "?" or ":N:" where -// N is an integer. These value of these wildcard literals can be set -// using the routines listed below. -// -// In every case, the first parameter is a pointer to the sqlite3_stmt -// structure returned from sqlite3_prepare(). The second parameter is the -// index of the wildcard. The first "?" has an index of 1. ":N:" wildcards -// use the index N. -// -// The fifth parameter to sqlite3_bind_blob(), sqlite3_bind_text(), and -//sqlite3_bind_text16() is a destructor used to dispose of the BLOB or -//text after SQLite has finished with it. If the fifth argument is the -// special value SQLITE_STATIC, then the library assumes that the information -// is in static, unmanaged space and does not need to be freed. If the -// fifth argument has the value SQLITE_TRANSIENT, then SQLite makes its -// own private copy of the data. -// -// The sqlite3_bind_* routine must be called before sqlite3_step() after -// an sqlite3_prepare() or sqlite3_reset(). Unbound wildcards are interpreted -// as NULL. -// - -type - TSQLite3Destructor = procedure(Ptr: Pointer); cdecl; - -function sqlite3_bind_blob(hStmt: TSqliteStmt; ParamNum: integer; - ptrData: pointer; numBytes: integer; ptrDestructor: TSQLite3Destructor): integer; -cdecl; external SQLiteDLL name 'sqlite3_bind_blob'; -function sqlite3_bind_text(hStmt: TSqliteStmt; ParamNum: integer; - Text: PAnsiChar; numBytes: integer; ptrDestructor: TSQLite3Destructor): integer; -cdecl; external SQLiteDLL name 'sqlite3_bind_text'; -function sqlite3_bind_double(hStmt: TSqliteStmt; ParamNum: integer; Data: Double): integer; - cdecl; external SQLiteDLL name 'sqlite3_bind_double'; -function sqlite3_bind_int(hStmt: TSqLiteStmt; ParamNum: integer; Data: integer): integer; - cdecl; external SQLiteDLL name 'sqlite3_bind_int'; -function sqlite3_bind_int64(hStmt: TSqliteStmt; ParamNum: integer; Data: int64): integer; - cdecl; external SQLiteDLL name 'sqlite3_bind_int64'; -function sqlite3_bind_null(hStmt: TSqliteStmt; ParamNum: integer): integer; - cdecl; external SQLiteDLL name 'sqlite3_bind_null'; - -function sqlite3_bind_parameter_index(hStmt: TSqliteStmt; zName: PAnsiChar): integer; - cdecl; external SQLiteDLL name 'sqlite3_bind_parameter_index'; - -function sqlite3_enable_shared_cache(Value: integer): integer; cdecl; external SQLiteDLL name 'sqlite3_enable_shared_cache'; - -//user collate definiton -function SQLite3_create_collation(db: TSQLiteDB; Name: PAnsiChar; eTextRep: integer; - UserData: pointer; xCompare: TCollateXCompare): integer; cdecl; external SQLiteDLL name 'sqlite3_create_collation'; - -function SQLiteFieldType(SQLiteFieldTypeCode: Integer): AnsiString; -function SQLiteErrorStr(SQLiteErrorCode: Integer): AnsiString; - -implementation - -uses - SysUtils; - -function SQLiteFieldType(SQLiteFieldTypeCode: Integer): AnsiString; -begin - case SQLiteFieldTypeCode of - SQLITE_INTEGER: Result := 'Integer'; - SQLITE_FLOAT: Result := 'Float'; - SQLITE_TEXT: Result := 'Text'; - SQLITE_BLOB: Result := 'Blob'; - SQLITE_NULL: Result := 'Null'; - else - Result := 'Unknown SQLite Field Type Code "' + IntToStr(SQLiteFieldTypeCode) + '"'; - end; -end; - -function SQLiteErrorStr(SQLiteErrorCode: Integer): AnsiString; -begin - case SQLiteErrorCode of - SQLITE_OK: Result := 'Successful result'; - SQLITE_ERROR: Result := 'SQL error or missing database'; - SQLITE_INTERNAL: Result := 'An internal logic error in SQLite'; - SQLITE_PERM: Result := 'Access permission denied'; - SQLITE_ABORT: Result := 'Callback routine requested an abort'; - SQLITE_BUSY: Result := 'The database file is locked'; - SQLITE_LOCKED: Result := 'A table in the database is locked'; - SQLITE_NOMEM: Result := 'A malloc() failed'; - SQLITE_READONLY: Result := 'Attempt to write a readonly database'; - SQLITE_INTERRUPT: Result := 'Operation terminated by sqlite3_interrupt()'; - SQLITE_IOERR: Result := 'Some kind of disk I/O error occurred'; - SQLITE_CORRUPT: Result := 'The database disk image is malformed'; - SQLITE_NOTFOUND: Result := '(Internal Only) Table or record not found'; - SQLITE_FULL: Result := 'Insertion failed because database is full'; - SQLITE_CANTOPEN: Result := 'Unable to open the database file'; - SQLITE_PROTOCOL: Result := 'Database lock protocol error'; - SQLITE_EMPTY: Result := 'Database is empty'; - SQLITE_SCHEMA: Result := 'The database schema changed'; - SQLITE_TOOBIG: Result := 'Too much data for one row of a table'; - SQLITE_CONSTRAINT: Result := 'Abort due to contraint violation'; - SQLITE_MISMATCH: Result := 'Data type mismatch'; - SQLITE_MISUSE: Result := 'Library used incorrectly'; - SQLITE_NOLFS: Result := 'Uses OS features not supported on host'; - SQLITE_AUTH: Result := 'Authorization denied'; - SQLITE_FORMAT: Result := 'Auxiliary database format error'; - SQLITE_RANGE: Result := '2nd parameter to sqlite3_bind out of range'; - SQLITE_NOTADB: Result := 'File opened that is not a database file'; - SQLITE_ROW: Result := 'sqlite3_step() has another row ready'; - SQLITE_DONE: Result := 'sqlite3_step() has finished executing'; - else - Result := 'Unknown SQLite Error Code "' + IntToStr(SQLiteErrorCode) + '"'; - end; -end; - -function ColValueToStr(Value: PAnsiChar): AnsiString; -begin - if (Value = nil) then - Result := 'NULL' - else - Result := Value; -end; - - -end. - diff --git a/src/lib/SQLite/SQLiteTable3.pas b/src/lib/SQLite/SQLiteTable3.pas deleted file mode 100644 index 3aed54a4..00000000 --- a/src/lib/SQLite/SQLiteTable3.pas +++ /dev/null @@ -1,1500 +0,0 @@ -unit SQLiteTable3; - -{ - Simple classes for using SQLite's exec and get_table. - - TSQLiteDatabase wraps the calls to open and close an SQLite database. - It also wraps SQLite_exec for queries that do not return a result set - - TSQLiteTable wraps execution of SQL query. - It run query and read all returned rows to internal buffer. - It allows accessing fields by name as well as index and can move through a - result set forward and backwards, or randomly to any row. - - TSQLiteUniTable wraps execution of SQL query. - It run query as TSQLiteTable, but reading just first row only! - You can step to next row (until not EOF) by 'Next' method. - You cannot step backwards! (So, it is called as UniDirectional result set.) - It not using any internal buffering, this class is very close to Sqlite API. - It allows accessing fields by name as well as index on actual row only. - Very good and fast for sequentional scanning of large result sets with minimal - memory footprint. - - Warning! Do not close TSQLiteDatabase before any TSQLiteUniTable, - because query is closed on TSQLiteUniTable destructor and database connection - is used during TSQLiteUniTable live! - - SQL parameter usage: - You can add named parameter values by call set of AddParam* methods. - Parameters will be used for first next SQL statement only. - Parameter name must be prefixed by ':', '$' or '@' and same prefix must be - used in SQL statement! - Sample: - table.AddParamText(':str', 'some value'); - s := table.GetTableString('SELECT value FROM sometable WHERE id=:str'); - - Notes from Andrew Retmanski on prepared queries - The changes are as follows: - - SQLiteTable3.pas - - Added new boolean property Synchronised (this controls the SYNCHRONOUS pragma as I found that turning this OFF increased the write performance in my application) - - Added new type TSQLiteQuery (this is just a simple record wrapper around the SQL string and a TSQLiteStmt pointer) - - Added PrepareSQL method to prepare SQL query - returns TSQLiteQuery - - Added ReleaseSQL method to release previously prepared query - - Added overloaded BindSQL methods for Integer and String types - these set new values for the prepared query parameters - - Added overloaded ExecSQL method to execute a prepared TSQLiteQuery - - Usage of the new methods should be self explanatory but the process is in essence: - - 1. Call PrepareSQL to return TSQLiteQuery 2. Call BindSQL for each parameter in the prepared query 3. Call ExecSQL to run the prepared query 4. Repeat steps 2 & 3 as required 5. Call ReleaseSQL to free SQLite resources - - One other point - the Synchronised property throws an error if used inside a transaction. - - Acknowledments - Adapted by Tim Anderson (tim@itwriting.com) - Originally created by Pablo Pissanetzky (pablo@myhtpc.net) - Modified and enhanced by Lukas Gebauer - Modified and enhanced by Tobias Gunkel -} - -interface - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -uses - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF} - SQLite3, Classes, SysUtils; - -const - - dtInt = 1; - dtNumeric = 2; - dtStr = 3; - dtBlob = 4; - dtNull = 5; - -type - - ESQLiteException = class(Exception) - end; - - TSQliteParam = class - public - name: string; - valuetype: integer; - valueinteger: int64; - valuefloat: double; - valuedata: string; - end; - - THookQuery = procedure(Sender: TObject; SQL: String) of object; - - TSQLiteQuery = record - SQL: String; - Statement: TSQLiteStmt; - end; - - TSQLiteTable = class; - TSQLiteUniTable = class; - - TSQLiteDatabase = class - private - fDB: TSQLiteDB; - fInTrans: boolean; - fSync: boolean; - fParams: TList; - FOnQuery: THookQuery; - procedure RaiseError(s: string; SQL: string); - procedure SetParams(Stmt: TSQLiteStmt); - procedure BindData(Stmt: TSQLiteStmt; const Bindings: array of const); - function GetRowsChanged: integer; - protected - procedure SetSynchronised(Value: boolean); - procedure DoQuery(value: string); - public - constructor Create(const FileName: string); - destructor Destroy; override; - function GetTable(const SQL: Ansistring): TSQLiteTable; overload; - function GetTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteTable; overload; - procedure ExecSQL(const SQL: Ansistring); overload; - procedure ExecSQL(const SQL: Ansistring; const Bindings: array of const); overload; - procedure ExecSQL(Query: TSQLiteQuery); overload; - function PrepareSQL(const SQL: Ansistring): TSQLiteQuery; - procedure BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: Integer); overload; - procedure BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: String); overload; - procedure ReleaseSQL(Query: TSQLiteQuery); - function GetUniTable(const SQL: Ansistring): TSQLiteUniTable; overload; - function GetUniTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteUniTable; overload; - function GetTableValue(const SQL: Ansistring): int64; overload; - function GetTableValue(const SQL: Ansistring; const Bindings: array of const): int64; overload; - function GetTableString(const SQL: Ansistring): string; overload; - function GetTableString(const SQL: Ansistring; const Bindings: array of const): string; overload; - procedure GetTableStrings(const SQL: Ansistring; const Value: TStrings); - procedure UpdateBlob(const SQL: Ansistring; BlobData: TStream); - procedure BeginTransaction; - procedure Commit; - procedure Rollback; - function TableExists(TableName: string): boolean; - function ContainsColumn(Table: String; Column: String) : boolean; - function GetLastInsertRowID: int64; - function GetLastChangedRows: int64; - procedure SetTimeout(Value: integer); - function Version: string; - procedure AddCustomCollate(name: string; xCompare: TCollateXCompare); - //adds collate named SYSTEM for correct data sorting by user's locale - Procedure AddSystemCollate; - procedure ParamsClear; - procedure AddParamInt(name: string; value: int64); - procedure AddParamFloat(name: string; value: double); - procedure AddParamText(name: string; value: string); - procedure AddParamNull(name: string); - property DB: TSQLiteDB read fDB; - published - property IsTransactionOpen: boolean read fInTrans; - //database rows that were changed (or inserted or deleted) by the most recent SQL statement - property RowsChanged : integer read getRowsChanged; - property Synchronised: boolean read FSync write SetSynchronised; - property OnQuery: THookQuery read FOnQuery write FOnQuery; - end; - - TSQLiteTable = class - private - fResults: TList; - fRowCount: cardinal; - fColCount: cardinal; - fCols: TStringList; - fColTypes: TList; - fRow: cardinal; - function GetFields(I: cardinal): string; - function GetEOF: boolean; - function GetBOF: boolean; - function GetColumns(I: integer): string; - function GetFieldByName(FieldName: string): string; - function GetFieldIndex(FieldName: string): integer; - function GetCount: integer; - function GetCountResult: integer; - public - constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring); overload; - constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); overload; - destructor Destroy; override; - function FieldAsInteger(I: cardinal): int64; - function FieldAsBlob(I: cardinal): TMemoryStream; - function FieldAsBlobText(I: cardinal): string; - function FieldIsNull(I: cardinal): boolean; - function FieldAsString(I: cardinal): string; - function FieldAsDouble(I: cardinal): double; - function Next: boolean; - function Previous: boolean; - property EOF: boolean read GetEOF; - property BOF: boolean read GetBOF; - property Fields[I: cardinal]: string read GetFields; - property FieldByName[FieldName: string]: string read GetFieldByName; - property FieldIndex[FieldName: string]: integer read GetFieldIndex; - property Columns[I: integer]: string read GetColumns; - property ColCount: cardinal read fColCount; - property RowCount: cardinal read fRowCount; - property Row: cardinal read fRow; - function MoveFirst: boolean; - function MoveLast: boolean; - function MoveTo(position: cardinal): boolean; - property Count: integer read GetCount; - // The property CountResult is used when you execute count(*) queries. - // It returns 0 if the result set is empty or the value of the - // first field as an integer. - property CountResult: integer read GetCountResult; - end; - - TSQLiteUniTable = class - private - fColCount: cardinal; - fCols: TStringList; - fRow: cardinal; - fEOF: boolean; - fStmt: TSQLiteStmt; - fDB: TSQLiteDatabase; - fSQL: string; - function GetFields(I: cardinal): string; - function GetColumns(I: integer): string; - function GetFieldByName(FieldName: string): string; - function GetFieldIndex(FieldName: string): integer; - public - constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring); overload; - constructor Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); overload; - destructor Destroy; override; - function FieldAsInteger(I: cardinal): int64; - function FieldAsBlob(I: cardinal): TMemoryStream; - function FieldAsBlobPtr(I: cardinal; out iNumBytes: integer): Pointer; - function FieldAsBlobText(I: cardinal): string; - function FieldIsNull(I: cardinal): boolean; - function FieldAsString(I: cardinal): string; - function FieldAsDouble(I: cardinal): double; - function Next: boolean; - property EOF: boolean read FEOF; - property Fields[I: cardinal]: string read GetFields; - property FieldByName[FieldName: string]: string read GetFieldByName; - property FieldIndex[FieldName: string]: integer read GetFieldIndex; - property Columns[I: integer]: string read GetColumns; - property ColCount: cardinal read fColCount; - property Row: cardinal read fRow; - end; - -procedure DisposePointer(ptr: pointer); cdecl; - -{$IFDEF MSWINDOWS} -function SystemCollate(Userdta: pointer; Buf1Len: integer; Buf1: pointer; - Buf2Len: integer; Buf2: pointer): integer; cdecl; -{$ENDIF} - -implementation - -procedure DisposePointer(ptr: pointer); cdecl; -begin - if assigned(ptr) then - freemem(ptr); -end; - -{$IFDEF MSWINDOWS} -function SystemCollate(Userdta: pointer; Buf1Len: integer; Buf1: pointer; - Buf2Len: integer; Buf2: pointer): integer; cdecl; -begin - Result := CompareStringW(LOCALE_USER_DEFAULT, 0, PWideChar(Buf1), Buf1Len, - PWideChar(Buf2), Buf2Len) - 2; -end; -{$ENDIF} - -//------------------------------------------------------------------------------ -// TSQLiteDatabase -//------------------------------------------------------------------------------ - -constructor TSQLiteDatabase.Create(const FileName: string); -var - Msg: PAnsiChar; - iResult: integer; - utf8FileName: UTF8string; -begin - inherited Create; - fParams := TList.Create; - - self.fInTrans := False; - - Msg := nil; - try - utf8FileName := UTF8String(FileName); - iResult := SQLite3_Open(PAnsiChar(utf8FileName), Fdb); - - if iResult <> SQLITE_OK then - if Assigned(Fdb) then - begin - Msg := Sqlite3_ErrMsg(Fdb); - raise ESqliteException.CreateFmt('Failed to open database "%s" : %s', - [FileName, Msg]); - end - else - raise ESqliteException.CreateFmt('Failed to open database "%s" : unknown error', - [FileName]); - -//set a few configs -//L.G. Do not call it here. Because busy handler is not setted here, -// any share violation causing exception! - -// self.ExecSQL('PRAGMA SYNCHRONOUS=NORMAL;'); -// self.ExecSQL('PRAGMA temp_store = MEMORY;'); - - finally - if Assigned(Msg) then - SQLite3_Free(Msg); - end; - -end; - -//.............................................................................. - -destructor TSQLiteDatabase.Destroy; -begin - if self.fInTrans then - self.Rollback; //assume rollback - if Assigned(fDB) then - SQLite3_Close(fDB); - ParamsClear; - fParams.Free; - inherited; -end; - -function TSQLiteDatabase.GetLastInsertRowID: int64; -begin - Result := Sqlite3_LastInsertRowID(self.fDB); -end; - -function TSQLiteDatabase.GetLastChangedRows: int64; -begin - Result := SQLite3_TotalChanges(self.fDB); -end; - -//.............................................................................. - -procedure TSQLiteDatabase.RaiseError(s: string; SQL: string); -//look up last error and raise an exception with an appropriate message -var - Msg: PAnsiChar; - ret : integer; -begin - - Msg := nil; - - ret := sqlite3_errcode(self.fDB); - if ret <> SQLITE_OK then - Msg := sqlite3_errmsg(self.fDB); - - if Msg <> nil then - raise ESqliteException.CreateFmt(s +'.'#13'Error [%d]: %s.'#13'"%s": %s', [ret, SQLiteErrorStr(ret),SQL, Msg]) - else - raise ESqliteException.CreateFmt(s, [SQL, 'No message']); - -end; - -procedure TSQLiteDatabase.SetSynchronised(Value: boolean); -begin - if Value <> fSync then - begin - if Value then - ExecSQL('PRAGMA synchronous = ON;') - else - ExecSQL('PRAGMA synchronous = OFF;'); - fSync := Value; - end; -end; - -procedure TSQLiteDatabase.BindData(Stmt: TSQLiteStmt; const Bindings: array of const); -var - BlobMemStream: TCustomMemoryStream; - BlobStdStream: TStream; - DataPtr: Pointer; - DataSize: integer; - AnsiStr: AnsiString; - AnsiStrPtr: PAnsiString; - I: integer; -begin - for I := 0 to High(Bindings) do - begin - case Bindings[I].VType of - vtString, - vtAnsiString, vtPChar, - vtWideString, vtPWideChar, - vtChar, vtWideChar: - begin - case Bindings[I].VType of - vtString: begin // ShortString - AnsiStr := Bindings[I].VString^; - DataPtr := PAnsiChar(AnsiStr); - DataSize := Length(AnsiStr)+1; - end; - vtPChar: begin - DataPtr := Bindings[I].VPChar; - DataSize := -1; - end; - vtAnsiString: begin - AnsiStrPtr := PAnsiString(@Bindings[I].VAnsiString); - DataPtr := PAnsiChar(AnsiStrPtr^); - DataSize := Length(AnsiStrPtr^)+1; - end; - vtPWideChar: begin - AnsiStr := UTF8Encode(WideString(Bindings[I].VPWideChar)); - DataPtr := PAnsiChar(AnsiStr); - DataSize := -1; - end; - vtWideString: begin - AnsiStr := UTF8Encode(PWideString(@Bindings[I].VWideString)^); - DataPtr := PAnsiChar(AnsiStr); - DataSize := -1; - end; - vtChar: begin - AnsiStr := AnsiString(Bindings[I].VChar); - DataPtr := PAnsiChar(AnsiStr); - DataSize := 2; - end; - vtWideChar: begin - AnsiStr := UTF8Encode(WideString(Bindings[I].VWideChar)); - DataPtr := PAnsiChar(AnsiStr); - DataSize := -1; - end; - else - raise ESqliteException.Create('Unknown string-type'); - end; - if (sqlite3_bind_text(Stmt, I+1, DataPtr, DataSize, SQLITE_STATIC) <> SQLITE_OK) then - RaiseError('Could not bind text', 'BindData'); - end; - vtInteger: - if (sqlite3_bind_int(Stmt, I+1, Bindings[I].VInteger) <> SQLITE_OK) then - RaiseError('Could not bind integer', 'BindData'); - vtInt64: - if (sqlite3_bind_int64(Stmt, I+1, Bindings[I].VInt64^) <> SQLITE_OK) then - RaiseError('Could not bind int64', 'BindData'); - vtExtended: - if (sqlite3_bind_double(Stmt, I+1, Bindings[I].VExtended^) <> SQLITE_OK) then - RaiseError('Could not bind extended', 'BindData'); - vtBoolean: - if (sqlite3_bind_int(Stmt, I+1, Integer(Bindings[I].VBoolean)) <> SQLITE_OK) then - RaiseError('Could not bind boolean', 'BindData'); - vtPointer: - begin - if (Bindings[I].VPointer = nil) then - begin - if (sqlite3_bind_null(Stmt, I+1) <> SQLITE_OK) then - RaiseError('Could not bind null', 'BindData'); - end - else - raise ESqliteException.Create('Unhandled pointer (<> nil)'); - end; - vtObject: - begin - if (Bindings[I].VObject is TCustomMemoryStream) then - begin - BlobMemStream := TCustomMemoryStream(Bindings[I].VObject); - if (sqlite3_bind_blob(Stmt, I+1, @PAnsiChar(BlobMemStream.Memory)[BlobMemStream.Position], - BlobMemStream.Size-BlobMemStream.Position, SQLITE_STATIC) <> SQLITE_OK) then - begin - RaiseError('Could not bind BLOB', 'BindData'); - end; - end - else if (Bindings[I].VObject is TStream) then - begin - BlobStdStream := TStream(Bindings[I].VObject); - DataSize := BlobStdStream.Size; - - GetMem(DataPtr, DataSize); - if (DataPtr = nil) then - raise ESqliteException.Create('Error getting memory to save blob'); - - BlobStdStream.Position := 0; - BlobStdStream.Read(DataPtr^, DataSize); - - if (sqlite3_bind_blob(stmt, I+1, DataPtr, DataSize, @DisposePointer) <> SQLITE_OK) then - RaiseError('Could not bind BLOB', 'BindData'); - end - else - raise ESqliteException.Create('Unhandled object-type in binding'); - end - else - begin - raise ESqliteException.Create('Unhandled binding'); - end; - end; - end; -end; - -procedure TSQLiteDatabase.ExecSQL(const SQL: Ansistring); -begin - ExecSQL(SQL, []); -end; - -procedure TSQLiteDatabase.ExecSQL(const SQL: Ansistring; const Bindings: array of const); -var - Stmt: TSQLiteStmt; - NextSQLStatement: PAnsiChar; - iStepResult: integer; -begin - try - if Sqlite3_Prepare_v2(self.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> - SQLITE_OK then - RaiseError('Error executing SQL', SQL); - if (Stmt = nil) then - RaiseError('Could not prepare SQL statement', SQL); - DoQuery(SQL); - SetParams(Stmt); - BindData(Stmt, Bindings); - - iStepResult := Sqlite3_step(Stmt); - if (iStepResult <> SQLITE_DONE) then - begin - SQLite3_reset(stmt); - RaiseError('Error executing SQL statement', SQL); - end; - finally - if Assigned(Stmt) then - Sqlite3_Finalize(stmt); - end; -end; - -procedure TSQLiteDatabase.ExecSQL(Query: TSQLiteQuery); -var - iStepResult: integer; -begin - if Assigned(Query.Statement) then - begin - iStepResult := Sqlite3_step(Query.Statement); - - if (iStepResult <> SQLITE_DONE) then - begin - SQLite3_reset(Query.Statement); - RaiseError('Error executing prepared SQL statement', Query.SQL); - end; - Sqlite3_Reset(Query.Statement); - end; -end; - -function TSQLiteDatabase.PrepareSQL(const SQL: Ansistring): TSQLiteQuery; -var - Stmt: TSQLiteStmt; - NextSQLStatement: PAnsiChar; -begin - Result.SQL := SQL; - Result.Statement := nil; - - if Sqlite3_Prepare(self.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> - SQLITE_OK then - RaiseError('Error executing SQL', SQL) - else - Result.Statement := Stmt; - - if (Result.Statement = nil) then - RaiseError('Could not prepare SQL statement', SQL); - DoQuery(SQL); -end; - -procedure TSQLiteDatabase.BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: Integer); -begin - if Assigned(Query.Statement) then - sqlite3_Bind_Int(Query.Statement, Index, Value) - else - RaiseError('Could not bind integer to prepared SQL statement', Query.SQL); -end; - -procedure TSQLiteDatabase.BindSQL(Query: TSQLiteQuery; const Index: Integer; const Value: String); -begin - if Assigned(Query.Statement) then - Sqlite3_Bind_Text(Query.Statement, Index, PAnsiChar(Value), Length(Value), Pointer(SQLITE_STATIC)) - else - RaiseError('Could not bind string to prepared SQL statement', Query.SQL); -end; - -procedure TSQLiteDatabase.ReleaseSQL(Query: TSQLiteQuery); -begin - if Assigned(Query.Statement) then - begin - Sqlite3_Finalize(Query.Statement); - Query.Statement := nil; - end - else - RaiseError('Could not release prepared SQL statement', Query.SQL); -end; - -procedure TSQLiteDatabase.UpdateBlob(const SQL: Ansistring; BlobData: TStream); -var - iSize: integer; - ptr: pointer; - Stmt: TSQLiteStmt; - Msg: PAnsiChar; - NextSQLStatement: PAnsiChar; - iStepResult: integer; - iBindResult: integer; -begin - //expects SQL of the form 'UPDATE MYTABLE SET MYFIELD = ? WHERE MYKEY = 1' - if pos('?', SQL) = 0 then - RaiseError('SQL must include a ? parameter', SQL); - - Msg := nil; - try - - if Sqlite3_Prepare_v2(self.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> - SQLITE_OK then - RaiseError('Could not prepare SQL statement', SQL); - - if (Stmt = nil) then - RaiseError('Could not prepare SQL statement', SQL); - DoQuery(SQL); - - //now bind the blob data - iSize := BlobData.size; - - GetMem(ptr, iSize); - - if (ptr = nil) then - raise ESqliteException.CreateFmt('Error getting memory to save blob', - [SQL, 'Error']); - - BlobData.position := 0; - BlobData.Read(ptr^, iSize); - - iBindResult := SQLite3_Bind_Blob(stmt, 1, ptr, iSize, @DisposePointer); - - if iBindResult <> SQLITE_OK then - RaiseError('Error binding blob to database', SQL); - - iStepResult := Sqlite3_step(Stmt); - - if (iStepResult <> SQLITE_DONE) then - begin - SQLite3_reset(stmt); - RaiseError('Error executing SQL statement', SQL); - end; - - finally - - if Assigned(Stmt) then - Sqlite3_Finalize(stmt); - - if Assigned(Msg) then - SQLite3_Free(Msg); - end; - -end; - -//.............................................................................. - -function TSQLiteDatabase.GetTable(const SQL: Ansistring): TSQLiteTable; -begin - Result := TSQLiteTable.Create(Self, SQL); -end; - -function TSQLiteDatabase.GetTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteTable; -begin - Result := TSQLiteTable.Create(Self, SQL, Bindings); -end; - -function TSQLiteDatabase.GetUniTable(const SQL: Ansistring): TSQLiteUniTable; -begin - Result := TSQLiteUniTable.Create(Self, SQL); -end; - -function TSQLiteDatabase.GetUniTable(const SQL: Ansistring; const Bindings: array of const): TSQLiteUniTable; -begin - Result := TSQLiteUniTable.Create(Self, SQL, Bindings); -end; - -function TSQLiteDatabase.GetTableValue(const SQL: Ansistring): int64; -begin - Result := GetTableValue(SQL, []); -end; - -function TSQLiteDatabase.GetTableValue(const SQL: Ansistring; const Bindings: array of const): int64; -var - Table: TSQLiteUniTable; -begin - Result := 0; - Table := self.GetUniTable(SQL, Bindings); - try - if not Table.EOF then - Result := Table.FieldAsInteger(0); - finally - Table.Free; - end; -end; - -function TSQLiteDatabase.GetTableString(const SQL: Ansistring): String; -begin - Result := GetTableString(SQL, []); -end; - -function TSQLiteDatabase.GetTableString(const SQL: Ansistring; const Bindings: array of const): String; -var - Table: TSQLiteUniTable; -begin - Result := ''; - Table := self.GetUniTable(SQL, Bindings); - try - if not Table.EOF then - Result := Table.FieldAsString(0); - finally - Table.Free; - end; -end; - -procedure TSQLiteDatabase.GetTableStrings(const SQL: Ansistring; - const Value: TStrings); -var - Table: TSQLiteUniTable; -begin - Value.Clear; - Table := self.GetUniTable(SQL); - try - while not table.EOF do - begin - Value.Add(Table.FieldAsString(0)); - table.Next; - end; - finally - Table.Free; - end; -end; - -procedure TSQLiteDatabase.BeginTransaction; -begin - if not self.fInTrans then - begin - self.ExecSQL('BEGIN TRANSACTION'); - self.fInTrans := True; - end - else - raise ESqliteException.Create('Transaction already open'); -end; - -procedure TSQLiteDatabase.Commit; -begin - self.ExecSQL('COMMIT'); - self.fInTrans := False; -end; - -procedure TSQLiteDatabase.Rollback; -begin - self.ExecSQL('ROLLBACK'); - self.fInTrans := False; -end; - -function TSQLiteDatabase.TableExists(TableName: string): boolean; -var - sql: string; - ds: TSqliteTable; -begin - //returns true if table exists in the database - sql := 'select [sql] from sqlite_master where [type] = ''table'' and lower(name) = ''' + - lowercase(TableName) + ''' '; - ds := self.GetTable(sql); - try - Result := (ds.Count > 0); - finally - ds.Free; - end; -end; - -function TSQLiteDatabase.ContainsColumn(Table: String; Column: String) : boolean; -var - sql: string; - ds: TSqliteTable; - i : integer; -begin - sql := 'PRAGMA TABLE_INFO('+Table+');'; - ds := self.GetTable(sql); - try - Result := false; - while (ds.Next() and not Result and not ds.EOF) do - begin - if ds.FieldAsString(1) = Column then - Result := true; - end; - finally - ds.Free; - end; -end; - -procedure TSQLiteDatabase.SetTimeout(Value: integer); -begin - SQLite3_BusyTimeout(self.fDB, Value); -end; - -function TSQLiteDatabase.Version: string; -begin - Result := SQLite3_Version; -end; - -procedure TSQLiteDatabase.AddCustomCollate(name: string; - xCompare: TCollateXCompare); -begin - sqlite3_create_collation(fdb, PAnsiChar(name), SQLITE_UTF8, nil, xCompare); -end; - -procedure TSQLiteDatabase.AddSystemCollate; -begin - {$IFDEF MSWINDOWS} - sqlite3_create_collation(fdb, 'SYSTEM', SQLITE_UTF16LE, nil, @SystemCollate); - {$ENDIF} -end; - -procedure TSQLiteDatabase.ParamsClear; -var - n: integer; -begin - for n := fParams.Count - 1 downto 0 do - TSQliteParam(fparams[n]).free; - fParams.Clear; -end; - -procedure TSQLiteDatabase.AddParamInt(name: string; value: int64); -var - par: TSQliteParam; -begin - par := TSQliteParam.Create; - par.name := name; - par.valuetype := SQLITE_INTEGER; - par.valueinteger := value; - fParams.Add(par); -end; - -procedure TSQLiteDatabase.AddParamFloat(name: string; value: double); -var - par: TSQliteParam; -begin - par := TSQliteParam.Create; - par.name := name; - par.valuetype := SQLITE_FLOAT; - par.valuefloat := value; - fParams.Add(par); -end; - -procedure TSQLiteDatabase.AddParamText(name: string; value: string); -var - par: TSQliteParam; -begin - par := TSQliteParam.Create; - par.name := name; - par.valuetype := SQLITE_TEXT; - par.valuedata := value; - fParams.Add(par); -end; - -procedure TSQLiteDatabase.AddParamNull(name: string); -var - par: TSQliteParam; -begin - par := TSQliteParam.Create; - par.name := name; - par.valuetype := SQLITE_NULL; - fParams.Add(par); -end; - -procedure TSQLiteDatabase.SetParams(Stmt: TSQLiteStmt); -var - n: integer; - i: integer; - par: TSQliteParam; -begin - try - for n := 0 to fParams.Count - 1 do - begin - par := TSQliteParam(fParams[n]); - i := sqlite3_bind_parameter_index(Stmt, PAnsiChar(par.name)); - if i > 0 then - begin - case par.valuetype of - SQLITE_INTEGER: - sqlite3_bind_int64(Stmt, i, par.valueinteger); - SQLITE_FLOAT: - sqlite3_bind_double(Stmt, i, par.valuefloat); - SQLITE_TEXT: - sqlite3_bind_text(Stmt, i, PAnsiChar(par.valuedata), - length(par.valuedata), SQLITE_TRANSIENT); - SQLITE_NULL: - sqlite3_bind_null(Stmt, i); - end; - end; - end; - finally - ParamsClear; - end; -end; - -//database rows that were changed (or inserted or deleted) by the most recent SQL statement -function TSQLiteDatabase.GetRowsChanged: integer; -begin - Result := SQLite3_Changes(self.fDB); -end; - -procedure TSQLiteDatabase.DoQuery(value: string); -begin - if assigned(OnQuery) then - OnQuery(Self, Value); -end; - -//------------------------------------------------------------------------------ -// TSQLiteTable -//------------------------------------------------------------------------------ - -constructor TSQLiteTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring); -begin - Create(DB, SQL, []); -end; - -constructor TSQLiteTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); -var - Stmt: TSQLiteStmt; - NextSQLStatement: PAnsiChar; - iStepResult: integer; - ptr: pointer; - iNumBytes: integer; - thisBlobValue: TMemoryStream; - thisStringValue: pstring; - thisDoubleValue: pDouble; - thisIntValue: pInt64; - thisColType: pInteger; - i: integer; - DeclaredColType: PAnsiChar; - ActualColType: integer; - ptrValue: PAnsiChar; -begin - inherited create; - try - self.fRowCount := 0; - self.fColCount := 0; - //if there are several SQL statements in SQL, NextSQLStatment points to the - //beginning of the next one. Prepare only prepares the first SQL statement. - if Sqlite3_Prepare_v2(DB.fDB, PAnsiChar(SQL), -1, Stmt, NextSQLStatement) <> SQLITE_OK then - DB.RaiseError('Error executing SQL', SQL); - if (Stmt = nil) then - DB.RaiseError('Could not prepare SQL statement', SQL); - DB.DoQuery(SQL); - DB.SetParams(Stmt); - DB.BindData(Stmt, Bindings); - - iStepResult := Sqlite3_step(Stmt); - while (iStepResult <> SQLITE_DONE) do - begin - case iStepResult of - SQLITE_ROW: - begin - Inc(fRowCount); - if (fRowCount = 1) then - begin - //get data types - fCols := TStringList.Create; - fColTypes := TList.Create; - fColCount := SQLite3_ColumnCount(stmt); - for i := 0 to Pred(fColCount) do - fCols.Add(AnsiUpperCase(Sqlite3_ColumnName(stmt, i))); - for i := 0 to Pred(fColCount) do - begin - new(thisColType); - DeclaredColType := Sqlite3_ColumnDeclType(stmt, i); - if DeclaredColType = nil then - thisColType^ := Sqlite3_ColumnType(stmt, i) //use the actual column type instead - //seems to be needed for last_insert_rowid - else - if (DeclaredColType = 'INTEGER') or (DeclaredColType = 'BOOLEAN') then - thisColType^ := dtInt - else - if (DeclaredColType = 'NUMERIC') or - (DeclaredColType = 'FLOAT') or - (DeclaredColType = 'DOUBLE') or - (DeclaredColType = 'REAL') then - thisColType^ := dtNumeric - else - if DeclaredColType = 'BLOB' then - thisColType^ := dtBlob - else - thisColType^ := dtStr; - fColTypes.Add(thiscoltype); - end; - fResults := TList.Create; - end; - - //get column values - for i := 0 to Pred(ColCount) do - begin - ActualColType := Sqlite3_ColumnType(stmt, i); - if (ActualColType = SQLITE_NULL) then - fResults.Add(nil) - else - if pInteger(fColTypes[i])^ = dtInt then - begin - new(thisintvalue); - thisintvalue^ := Sqlite3_ColumnInt64(stmt, i); - fResults.Add(thisintvalue); - end - else - if pInteger(fColTypes[i])^ = dtNumeric then - begin - new(thisdoublevalue); - thisdoublevalue^ := Sqlite3_ColumnDouble(stmt, i); - fResults.Add(thisdoublevalue); - end - else - if pInteger(fColTypes[i])^ = dtBlob then - begin - iNumBytes := Sqlite3_ColumnBytes(stmt, i); - if iNumBytes = 0 then - thisblobvalue := nil - else - begin - thisblobvalue := TMemoryStream.Create; - thisblobvalue.position := 0; - ptr := Sqlite3_ColumnBlob(stmt, i); - thisblobvalue.writebuffer(ptr^, iNumBytes); - end; - fResults.Add(thisblobvalue); - end - else - begin - new(thisstringvalue); - ptrValue := Sqlite3_ColumnText(stmt, i); - setstring(thisstringvalue^, ptrvalue, strlen(ptrvalue)); - fResults.Add(thisstringvalue); - end; - end; - end; - SQLITE_BUSY: - raise ESqliteException.CreateFmt('Could not prepare SQL statement', - [SQL, 'SQLite is Busy']); - else - begin - SQLite3_reset(stmt); - DB.RaiseError('Could not retrieve data', SQL); - end; - end; - iStepResult := Sqlite3_step(Stmt); - end; - fRow := 0; - finally - if Assigned(Stmt) then - Sqlite3_Finalize(stmt); - end; -end; - -//.............................................................................. - -destructor TSQLiteTable.Destroy; -var - i: cardinal; - iColNo: integer; -begin - if Assigned(fResults) then - begin - for i := 0 to fResults.Count - 1 do - begin - //check for blob type - iColNo := (i mod fColCount); - case pInteger(self.fColTypes[iColNo])^ of - dtBlob: - TMemoryStream(fResults[i]).Free; - dtStr: - if fResults[i] <> nil then - begin - setstring(string(fResults[i]^), nil, 0); - dispose(fResults[i]); - end; - else - dispose(fResults[i]); - end; - end; - fResults.Free; - end; - if Assigned(fCols) then - fCols.Free; - if Assigned(fColTypes) then - for i := 0 to fColTypes.Count - 1 do - dispose(fColTypes[i]); - fColTypes.Free; - inherited; -end; - -//.............................................................................. - -function TSQLiteTable.GetColumns(I: integer): string; -begin - Result := fCols[I]; -end; - -//.............................................................................. - -function TSQLiteTable.GetCountResult: integer; -begin - if not EOF then - Result := StrToInt(Fields[0]) - else - Result := 0; -end; - -function TSQLiteTable.GetCount: integer; -begin - Result := FRowCount; -end; - -//.............................................................................. - -function TSQLiteTable.GetEOF: boolean; -begin - Result := fRow >= fRowCount; -end; - -function TSQLiteTable.GetBOF: boolean; -begin - Result := fRow <= 0; -end; - -//.............................................................................. - -function TSQLiteTable.GetFieldByName(FieldName: string): string; -begin - Result := GetFields(self.GetFieldIndex(FieldName)); -end; - -function TSQLiteTable.GetFieldIndex(FieldName: string): integer; -begin - if (fCols = nil) then - begin - raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); - exit; - end; - - if (fCols.count = 0) then - begin - raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); - exit; - end; - - Result := fCols.IndexOf(AnsiUpperCase(FieldName)); - - if (result < 0) then - begin - raise ESqliteException.Create('Field not found in dataset: ' + fieldname) - end; -end; - -//.............................................................................. - -function TSQLiteTable.GetFields(I: cardinal): string; -var - thisvalue: pstring; - thistype: integer; -begin - Result := ''; - if EOF then - raise ESqliteException.Create('Table is at End of File'); - //integer types are not stored in the resultset - //as strings, so they should be retrieved using the type-specific - //methods - thistype := pInteger(self.fColTypes[I])^; - - case thistype of - dtStr: - begin - thisvalue := self.fResults[(self.frow * self.fColCount) + I]; - if (thisvalue <> nil) then - Result := thisvalue^ - else - Result := ''; - end; - dtInt: - Result := IntToStr(self.FieldAsInteger(I)); - dtNumeric: - Result := FloatToStr(self.FieldAsDouble(I)); - dtBlob: - Result := self.FieldAsBlobText(I); - else - Result := ''; - end; -end; - -function TSqliteTable.FieldAsBlob(I: cardinal): TMemoryStream; -begin - if EOF then - raise ESqliteException.Create('Table is at End of File'); - if (self.fResults[(self.frow * self.fColCount) + I] = nil) then - Result := nil - else - if pInteger(self.fColTypes[I])^ = dtBlob then - Result := TMemoryStream(self.fResults[(self.frow * self.fColCount) + I]) - else - raise ESqliteException.Create('Not a Blob field'); -end; - -function TSqliteTable.FieldAsBlobText(I: cardinal): string; -var - MemStream: TMemoryStream; - Buffer: PAnsiChar; -begin - Result := ''; - MemStream := self.FieldAsBlob(I); - if MemStream <> nil then - if MemStream.Size > 0 then - begin - MemStream.position := 0; - {$IFDEF UNICODE} - Buffer := AnsiStralloc(MemStream.Size + 1); - {$ELSE} - Buffer := Stralloc(MemStream.Size + 1); - {$ENDIF} - MemStream.readbuffer(Buffer[0], MemStream.Size); - (Buffer + MemStream.Size)^ := chr(0); - SetString(Result, Buffer, MemStream.size); - strdispose(Buffer); - end; - //do not free the TMemoryStream here; it is freed when - //TSqliteTable is destroyed - -end; - - -function TSqliteTable.FieldAsInteger(I: cardinal): int64; -begin - if EOF then - raise ESqliteException.Create('Table is at End of File'); - if (self.fResults[(self.frow * self.fColCount) + I] = nil) then - Result := 0 - else - if pInteger(self.fColTypes[I])^ = dtInt then - Result := pInt64(self.fResults[(self.frow * self.fColCount) + I])^ - else - if pInteger(self.fColTypes[I])^ = dtNumeric then - Result := trunc(strtofloat(pString(self.fResults[(self.frow * self.fColCount) + I])^)) - else - raise ESqliteException.Create('Not an integer or numeric field'); -end; - -function TSqliteTable.FieldAsDouble(I: cardinal): double; -begin - if EOF then - raise ESqliteException.Create('Table is at End of File'); - if (self.fResults[(self.frow * self.fColCount) + I] = nil) then - Result := 0 - else - if pInteger(self.fColTypes[I])^ = dtInt then - Result := pInt64(self.fResults[(self.frow * self.fColCount) + I])^ - else - if pInteger(self.fColTypes[I])^ = dtNumeric then - Result := pDouble(self.fResults[(self.frow * self.fColCount) + I])^ - else - raise ESqliteException.Create('Not an integer or numeric field'); -end; - -function TSqliteTable.FieldAsString(I: cardinal): string; -begin - if EOF then - raise ESqliteException.Create('Table is at End of File'); - if (self.fResults[(self.frow * self.fColCount) + I] = nil) then - Result := '' - else - Result := self.GetFields(I); -end; - -function TSqliteTable.FieldIsNull(I: cardinal): boolean; -var - thisvalue: pointer; -begin - if EOF then - raise ESqliteException.Create('Table is at End of File'); - thisvalue := self.fResults[(self.frow * self.fColCount) + I]; - Result := (thisvalue = nil); -end; - -//.............................................................................. - -function TSQLiteTable.Next: boolean; -begin - Result := False; - if not EOF then - begin - Inc(fRow); - Result := True; - end; -end; - -function TSQLiteTable.Previous: boolean; -begin - Result := False; - if not BOF then - begin - Dec(fRow); - Result := True; - end; -end; - -function TSQLiteTable.MoveFirst: boolean; -begin - Result := False; - if self.fRowCount > 0 then - begin - fRow := 0; - Result := True; - end; -end; - -function TSQLiteTable.MoveLast: boolean; -begin - Result := False; - if self.fRowCount > 0 then - begin - fRow := fRowCount - 1; - Result := True; - end; -end; - -function TSQLiteTable.MoveTo(position: cardinal): boolean; -begin - Result := False; - if (self.fRowCount > 0) and (self.fRowCount > position) then - begin - fRow := position; - Result := True; - end; -end; - - - -{ TSQLiteUniTable } - -constructor TSQLiteUniTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring); -begin - Create(DB, SQL, []); -end; - -constructor TSQLiteUniTable.Create(DB: TSQLiteDatabase; const SQL: Ansistring; const Bindings: array of const); -var - NextSQLStatement: PAnsiChar; - i: integer; -begin - inherited create; - self.fDB := db; - self.fEOF := false; - self.fRow := 0; - self.fColCount := 0; - self.fSQL := SQL; - if Sqlite3_Prepare_v2(DB.fDB, PAnsiChar(SQL), -1, fStmt, NextSQLStatement) <> SQLITE_OK then - DB.RaiseError('Error executing SQL', SQL); - if (fStmt = nil) then - DB.RaiseError('Could not prepare SQL statement', SQL); - DB.DoQuery(SQL); - DB.SetParams(fStmt); - DB.BindData(fStmt, Bindings); - - //get data types - fCols := TStringList.Create; - fColCount := SQLite3_ColumnCount(fstmt); - for i := 0 to Pred(fColCount) do - fCols.Add(AnsiUpperCase(Sqlite3_ColumnName(fstmt, i))); - - Next; -end; - -destructor TSQLiteUniTable.Destroy; -begin - if Assigned(fStmt) then - Sqlite3_Finalize(fstmt); - if Assigned(fCols) then - fCols.Free; - inherited; -end; - -function TSQLiteUniTable.FieldAsBlob(I: cardinal): TMemoryStream; -var - iNumBytes: integer; - ptr: pointer; -begin - Result := TMemoryStream.Create; - iNumBytes := Sqlite3_ColumnBytes(fstmt, i); - if iNumBytes > 0 then - begin - ptr := Sqlite3_ColumnBlob(fstmt, i); - Result.writebuffer(ptr^, iNumBytes); - Result.Position := 0; - end; -end; - -function TSQLiteUniTable.FieldAsBlobPtr(I: cardinal; out iNumBytes: integer): Pointer; -begin - iNumBytes := Sqlite3_ColumnBytes(fstmt, i); - Result := Sqlite3_ColumnBlob(fstmt, i); -end; - -function TSQLiteUniTable.FieldAsBlobText(I: cardinal): string; -var - MemStream: TMemoryStream; - Buffer: PAnsiChar; -begin - Result := ''; - MemStream := self.FieldAsBlob(I); - if MemStream <> nil then - try - if MemStream.Size > 0 then - begin - MemStream.position := 0; - {$IFDEF UNICODE} - Buffer := AnsiStralloc(MemStream.Size + 1); - {$ELSE} - Buffer := Stralloc(MemStream.Size + 1); - {$ENDIF} - MemStream.readbuffer(Buffer[0], MemStream.Size); - (Buffer + MemStream.Size)^ := chr(0); - SetString(Result, Buffer, MemStream.size); - strdispose(Buffer); - end; - finally - MemStream.Free; - end; -end; - -function TSQLiteUniTable.FieldAsDouble(I: cardinal): double; -begin - Result := Sqlite3_ColumnDouble(fstmt, i); -end; - -function TSQLiteUniTable.FieldAsInteger(I: cardinal): int64; -begin - Result := Sqlite3_ColumnInt64(fstmt, i); -end; - -function TSQLiteUniTable.FieldAsString(I: cardinal): string; -begin - Result := self.GetFields(I); -end; - -function TSQLiteUniTable.FieldIsNull(I: cardinal): boolean; -begin - Result := Sqlite3_ColumnText(fstmt, i) = nil; -end; - -function TSQLiteUniTable.GetColumns(I: integer): string; -begin - Result := fCols[I]; -end; - -function TSQLiteUniTable.GetFieldByName(FieldName: string): string; -begin - Result := GetFields(self.GetFieldIndex(FieldName)); -end; - -function TSQLiteUniTable.GetFieldIndex(FieldName: string): integer; -begin - if (fCols = nil) then - begin - raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); - exit; - end; - - if (fCols.count = 0) then - begin - raise ESqliteException.Create('Field ' + fieldname + ' Not found. Empty dataset'); - exit; - end; - - Result := fCols.IndexOf(AnsiUpperCase(FieldName)); - - if (result < 0) then - begin - raise ESqliteException.Create('Field not found in dataset: ' + fieldname) - end; -end; - -function TSQLiteUniTable.GetFields(I: cardinal): string; -begin - Result := Sqlite3_ColumnText(fstmt, i); -end; - -function TSQLiteUniTable.Next: boolean; -var - iStepResult: integer; -begin - fEOF := true; - iStepResult := Sqlite3_step(fStmt); - case iStepResult of - SQLITE_ROW: - begin - fEOF := false; - inc(fRow); - end; - SQLITE_DONE: - // we are on the end of dataset - // return EOF=true only - ; - else - begin - SQLite3_reset(fStmt); - fDB.RaiseError('Could not retrieve data', fSQL); - end; - end; - Result := not fEOF; -end; - -end. - diff --git a/src/lib/SQLite/example/uTestSqlite.pas b/src/lib/SQLite/example/uTestSqlite.pas deleted file mode 100644 index 484be71c..00000000 --- a/src/lib/SQLite/example/uTestSqlite.pas +++ /dev/null @@ -1,233 +0,0 @@ -unit uTestSqlite; - -interface - -uses - Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms, - Dialogs, StdCtrls,SQLiteTable3, ExtCtrls, jpeg; - -type - TForm1 = class(TForm) - btnTest: TButton; - memNotes: TMemo; - Label1: TLabel; - Label2: TLabel; - ebName: TEdit; - Label3: TLabel; - ebNumber: TEdit; - Label4: TLabel; - ebID: TEdit; - Image1: TImage; - btnLoadImage: TButton; - btnDisplayImage: TButton; - procedure btnTestClick(Sender: TObject); - procedure btnLoadImageClick(Sender: TObject); - procedure btnDisplayImageClick(Sender: TObject); - private - { Private declarations } - public - { Public declarations } - end; - -var - Form1: TForm1; - -implementation - -{$R *.dfm} - -procedure TForm1.btnTestClick(Sender: TObject); -var -slDBpath: string; -sldb: TSQLiteDatabase; -sltb: TSQLIteTable; -sSQL: String; -Notes: String; - -begin - -slDBPath := ExtractFilepath(application.exename) -+ 'test.db'; - -sldb := TSQLiteDatabase.Create(slDBPath); -try - -if sldb.TableExists('testTable') then begin -sSQL := 'DROP TABLE testtable'; -sldb.execsql(sSQL); -end; - -sSQL := 'CREATE TABLE testtable ([ID] INTEGER PRIMARY KEY,[OtherID] INTEGER NULL,'; -sSQL := sSQL + '[Name] VARCHAR (255),[Number] FLOAT, [notes] BLOB, [picture] BLOB COLLATE NOCASE);'; - -sldb.execsql(sSQL); - -sldb.execsql('CREATE INDEX TestTableName ON [testtable]([Name]);'); - -//begin a transaction -sldb.BeginTransaction; - -sSQL := 'INSERT INTO testtable(Name,OtherID,Number,Notes) VALUES ("Some Name",4,587.6594,"Here are some notes");'; -//do the insert -sldb.ExecSQL(sSQL); - -sSQL := 'INSERT INTO testtable(Name,OtherID,Number,Notes) VALUES ("Another Name",12,4758.3265,"More notes");'; -//do the insert -sldb.ExecSQL(sSQL); - -//end the transaction -sldb.Commit; - -//query the data -sltb := slDb.GetTable('SELECT * FROM testtable'); -try - -if sltb.Count > 0 then -begin -//display first row - -ebName.Text := sltb.FieldAsString(sltb.FieldIndex['Name']); -ebID.Text := inttostr(sltb.FieldAsInteger(sltb.FieldIndex['ID'])); -ebNumber.Text := floattostr( sltb.FieldAsDouble(sltb.FieldIndex['Number'])); -Notes := sltb.FieldAsBlobText(sltb.FieldIndex['Notes']); -memNotes.Text := notes; - -end; - -finally -sltb.Free; -end; - -finally -sldb.Free; - -end; - -end; - -procedure TForm1.btnLoadImageClick(Sender: TObject); -var -slDBpath: string; -sldb: TSQLiteDatabase; -sltb: TSQLIteTable; -iID: integer; -fs: TFileStream; - -begin - -slDBPath := ExtractFilepath(application.exename) -+ 'test.db'; - -if not FileExists(slDBPath) then begin -MessageDLg('Test.db does not exist. Click Test Sqlite 3 to create it.',mtInformation,[mbOK],0); -exit; -end; - -sldb := TSQLiteDatabase.Create(slDBPath); -try - -//get an ID -//query the data -sltb := slDb.GetTable('SELECT ID FROM testtable'); -try - -if sltb.Count = 0 then begin -MessageDLg('There are no rows in the database. Click Test Sqlite 3 to insert a row.',mtInformation,[mbOK],0); -exit; -end; - -iID := sltb.FieldAsInteger(sltb.FieldIndex['ID']); - -finally -sltb.Free; -end; - -//load an image -fs := TFileStream.Create(ExtractFileDir(application.ExeName) + '\sunset.jpg',fmOpenRead); -try - -//insert the image into the db -sldb.UpdateBlob('UPDATE testtable set picture = ? WHERE ID = ' + inttostr(iID),fs); - -finally -fs.Free; -end; - -finally -sldb.Free; - -end; - -end; - -procedure TForm1.btnDisplayImageClick(Sender: TObject); -var -slDBpath: string; -sldb: TSQLiteDatabase; -sltb: TSQLIteTable; -iID: integer; -ms: TMemoryStream; -pic: TJPegImage; - -begin - -slDBPath := ExtractFilepath(application.exename) -+ 'test.db'; - -if not FileExists(slDBPath) then begin -MessageDLg('Test.db does not exist. Click Test Sqlite 3 to create it, then Load image to load an image.',mtInformation,[mbOK],0); -exit; -end; - -sldb := TSQLiteDatabase.Create(slDBPath); -try - -//get an ID -//query the data -sltb := slDb.GetTable('SELECT ID FROM testtable'); -try - -if not sltb.Count = 0 then begin -MessageDLg('No rows in the test database. Click Test Sqlite 3 to insert a row, then Load image to load an image.',mtInformation,[mbOK],0); -exit; -end; - -iID := sltb.FieldAsInteger(sltb.FieldIndex['ID']); - -finally -sltb.Free; -end; - -sltb := sldb.GetTable('SELECT picture FROM testtable where ID = ' + inttostr(iID)); -try - -ms := sltb.FieldAsBlob(sltb.FieldIndex['picture']); -//note that the memory stream is freed when the TSqliteTable is destroyed. - -if (ms = nil) then begin -MessageDLg('No image in the test database. Click Load image to load an image.',mtInformation,[mbOK],0); -exit; -end; - -ms.Position := 0; - -pic := TJPEGImage.Create; -pic.LoadFromStream(ms); - -self.Image1.Picture.Graphic := pic; - -pic.Free; - -finally -sltb.Free; -end; - -finally -sldb.Free; - -end; - - -end; - -end. diff --git a/src/lib/TntUnicodeControls/TntClasses.pas b/src/lib/TntUnicodeControls/TntClasses.pas deleted file mode 100644 index be043421..00000000 --- a/src/lib/TntUnicodeControls/TntClasses.pas +++ /dev/null @@ -1,1799 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntClasses; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Consider: TTntRegIniFile, TTntMemIniFile (consider if UTF8 fits into this solution). } - -{***********************************************} -{ WideChar-streaming implemented by Maël Hörz } -{***********************************************} - -uses - Classes, SysUtils, Windows, - {$IFNDEF COMPILER_10_UP} - TntWideStrings, - {$ELSE} - WideStrings, - {$ENDIF} - ActiveX, Contnrs; - -// ......... introduced ......... -type - TTntStreamCharSet = (csAnsi, csUnicode, csUnicodeSwapped, csUtf8); - -function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; - -//--------------------------------------------------------------------------------------------- -// Tnt - Classes -//--------------------------------------------------------------------------------------------- - -{TNT-WARN ExtractStrings} -{TNT-WARN LineStart} -{TNT-WARN TStringStream} // TODO: Implement a TWideStringStream - -// A potential implementation of TWideStringStream can be found at: -// http://kdsxml.cvs.sourceforge.net/kdsxml/Global/KDSClasses.pas?revision=1.10&view=markup - -procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); - -type -{TNT-WARN TFileStream} - TTntFileStream = class(THandleStream) - public - constructor Create(const FileName: WideString; Mode: Word); - destructor Destroy; override; - end; - -{TNT-WARN TMemoryStream} - TTntMemoryStream = class(TMemoryStream{TNT-ALLOW TMemoryStream}) - public - procedure LoadFromFile(const FileName: WideString); - procedure SaveToFile(const FileName: WideString); - end; - -{TNT-WARN TResourceStream} - TTntResourceStream = class(TCustomMemoryStream) - private - HResInfo: HRSRC; - HGlobal: THandle; - procedure Initialize(Instance: THandle; Name, ResType: PWideChar); - public - constructor Create(Instance: THandle; const ResName: WideString; ResType: PWideChar); - constructor CreateFromID(Instance: THandle; ResID: Word; ResType: PWideChar); - destructor Destroy; override; - function Write(const Buffer; Count: Longint): Longint; override; - procedure SaveToFile(const FileName: WideString); - end; - - TTntStrings = class; - -{TNT-WARN TAnsiStrings} - TAnsiStrings{TNT-ALLOW TAnsiStrings} = class(TStrings{TNT-ALLOW TStrings}) - public - procedure LoadFromFile(const FileName: WideString); reintroduce; - procedure SaveToFile(const FileName: WideString); reintroduce; - procedure LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); - procedure SaveToFileEx(const FileName: WideString; CodePage: Cardinal); - procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; - procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); virtual; abstract; - end; - - TAnsiStringsForWideStringsAdapter = class(TAnsiStrings{TNT-ALLOW TAnsiStrings}) - private - FWideStrings: TTntStrings; - FAdapterCodePage: Cardinal; - protected - function Get(Index: Integer): AnsiString; override; - procedure Put(Index: Integer; const S: AnsiString); override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetUpdateState(Updating: Boolean); override; - function AdapterCodePage: Cardinal; dynamic; - public - constructor Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal = 0); - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Insert(Index: Integer; const S: AnsiString); override; - procedure LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); override; - procedure SaveToStreamEx(Stream: TStream; CodePage: Cardinal); override; - end; - -{TNT-WARN TStrings} - TTntStrings = class(TWideStrings) - private - FLastFileCharSet: TTntStreamCharSet; - FAnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings}; - procedure SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); - procedure ReadData(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure ReadDataUTF8(Reader: TReader); - procedure WriteDataUTF7(Writer: TWriter); - protected - procedure DefineProperties(Filer: TFiler); override; - public - constructor Create; - destructor Destroy; override; - - procedure LoadFromFile(const FileName: WideString); override; - procedure LoadFromStream(Stream: TStream); override; - procedure LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; - - procedure SaveToFile(const FileName: WideString); override; - procedure SaveToStream(Stream: TStream); override; - procedure SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); virtual; - - property LastFileCharSet: TTntStreamCharSet read FLastFileCharSet; - published - property AnsiStrings: TAnsiStrings{TNT-ALLOW TAnsiStrings} read FAnsiStrings write SetAnsiStrings stored False; - end; - -{ TTntStringList class } - - TTntStringList = class; - TWideStringListSortCompare = function(List: TTntStringList; Index1, Index2: Integer): Integer; - -{TNT-WARN TStringList} - TTntStringList = class(TTntStrings) - private - FUpdating: Boolean; - FList: PWideStringItemList; - FCount: Integer; - FCapacity: Integer; - FSorted: Boolean; - FDuplicates: TDuplicates; - FCaseSensitive: Boolean; - FOnChange: TNotifyEvent; - FOnChanging: TNotifyEvent; - procedure ExchangeItems(Index1, Index2: Integer); - procedure Grow; - procedure QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); - procedure SetSorted(Value: Boolean); - procedure SetCaseSensitive(const Value: Boolean); - protected - procedure Changed; virtual; - procedure Changing; virtual; - function Get(Index: Integer): WideString; override; - function GetCapacity: Integer; override; - function GetCount: Integer; override; - function GetObject(Index: Integer): TObject; override; - procedure Put(Index: Integer; const S: WideString); override; - procedure PutObject(Index: Integer; AObject: TObject); override; - procedure SetCapacity(NewCapacity: Integer); override; - procedure SetUpdateState(Updating: Boolean); override; - function CompareStrings(const S1, S2: WideString): Integer; override; - procedure InsertItem(Index: Integer; const S: WideString; AObject: TObject); virtual; - public - destructor Destroy; override; - function Add(const S: WideString): Integer; override; - function AddObject(const S: WideString; AObject: TObject): Integer; override; - procedure Clear; override; - procedure Delete(Index: Integer); override; - procedure Exchange(Index1, Index2: Integer); override; - function Find(const S: WideString; var Index: Integer): Boolean; virtual; - function IndexOf(const S: WideString): Integer; override; - function IndexOfName(const Name: WideString): Integer; override; - procedure Insert(Index: Integer; const S: WideString); override; - procedure InsertObject(Index: Integer; const S: WideString; - AObject: TObject); override; - procedure Sort; virtual; - procedure CustomSort(Compare: TWideStringListSortCompare); virtual; - property Duplicates: TDuplicates read FDuplicates write FDuplicates; - property Sorted: Boolean read FSorted write SetSorted; - property CaseSensitive: Boolean read FCaseSensitive write SetCaseSensitive; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnChanging: TNotifyEvent read FOnChanging write FOnChanging; - end; - -// ......... introduced ......... -type - TListTargetCompare = function (Item, Target: Pointer): Integer; - -function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; - Target: Pointer; var Index: Integer): Boolean; - -function ClassIsRegistered(const clsid: TCLSID): Boolean; - -var - RuntimeUTFStreaming: Boolean; - -type - TBufferedAnsiString = class(TObject) - private - FStringBuffer: AnsiString; - LastWriteIndex: Integer; - public - procedure Clear; - procedure AddChar(const wc: AnsiChar); - procedure AddString(const s: AnsiString); - procedure AddBuffer(Buff: PAnsiChar; Chars: Integer); - function Value: AnsiString; - function BuffPtr: PAnsiChar; - end; - - TBufferedWideString = class(TObject) - private - FStringBuffer: WideString; - LastWriteIndex: Integer; - public - procedure Clear; - procedure AddChar(const wc: WideChar); - procedure AddString(const s: WideString); - procedure AddBuffer(Buff: PWideChar; Chars: Integer); - function Value: WideString; - function BuffPtr: PWideChar; - end; - - TBufferedStreamReader = class(TStream) - private - FStream: TStream; - FStreamSize: Integer; - FBuffer: array of Byte; - FBufferSize: Integer; - FBufferStartPosition: Integer; - FVirtualPosition: Integer; - procedure UpdateBufferFromPosition(StartPos: Integer); - public - constructor Create(Stream: TStream; BufferSize: Integer = 1024); - function Read(var Buffer; Count: Longint): Longint; override; - function Write(const Buffer; Count: Longint): Longint; override; - function Seek(Offset: Longint; Origin: Word): Longint; override; - end; - -// "synced" wide string -type TSetAnsiStrEvent = procedure(const Value: AnsiString) of object; -function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; -procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; - const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); - -type - TWideComponentHelper = class(TComponent) - private - FComponent: TComponent; - protected - procedure Notification(AComponent: TComponent; Operation: TOperation); override; - public - constructor Create(AOwner: TComponent); override; - constructor CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); - end; - -function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; - -implementation - -uses - RTLConsts, ComObj, Math, - Registry, TypInfo, TntSystem, TntSysUtils; - -{ TntPersistent } - -//=========================================================================== -// The Delphi 5 Classes.pas never supported the streaming of WideStrings. -// The Delphi 6 Classes.pas supports WideString streaming. But it's too bad that -// the Delphi 6 IDE doesn't use the updated Classes.pas. Switching between Form/Text -// mode corrupts extended characters in WideStrings even under Delphi 6. -// Delphi 7 seems to finally get right. But let's keep the UTF7 support at design time -// to enable sharing source code with previous versions of Delphi. -// -// The purpose of this solution is to store WideString properties which contain -// non-ASCII chars in the form of UTF7 under the old property name + '_UTF7'. -// -// Special thanks go to Francisco Leong for helping to develop this solution. -// - -{ TTntWideStringPropertyFiler } -type - TTntWideStringPropertyFiler = class - private - FInstance: TPersistent; - FPropInfo: PPropInfo; - procedure ReadDataUTF8(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure WriteDataUTF7(Writer: TWriter); - public - procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); - end; - -function ReaderNeedsUtfHelp(Reader: TReader): Boolean; -begin - if Reader.Owner = nil then - Result := False { designtime - visual form inheritance ancestor } - else if csDesigning in Reader.Owner.ComponentState then - {$IFDEF COMPILER_7_UP} - Result := False { Delphi 7+: designtime - doesn't need UTF help. } - {$ELSE} - Result := True { Delphi 6: designtime - always needs UTF help. } - {$ENDIF} - else - Result := RuntimeUTFStreaming; { runtime } -end; - -procedure TTntWideStringPropertyFiler.ReadDataUTF8(Reader: TReader); -begin - if ReaderNeedsUtfHelp(Reader) then - SetWideStrProp(FInstance, FPropInfo, UTF8ToWideString(Reader.ReadString)) - else - Reader.ReadString; { do nothing with Result } -end; - -procedure TTntWideStringPropertyFiler.ReadDataUTF7(Reader: TReader); -begin - if ReaderNeedsUtfHelp(Reader) then - SetWideStrProp(FInstance, FPropInfo, UTF7ToWideString(Reader.ReadString)) - else - Reader.ReadString; { do nothing with Result } -end; - -procedure TTntWideStringPropertyFiler.WriteDataUTF7(Writer: TWriter); -begin - Writer.WriteString(WideStringToUTF7(GetWideStrProp(FInstance, FPropInfo))); -end; - -procedure TTntWideStringPropertyFiler.DefineProperties(Filer: TFiler; Instance: TPersistent; - PropName: AnsiString); - - {$IFNDEF COMPILER_7_UP} - function HasData: Boolean; - var - CurrPropValue: WideString; - begin - // must be stored - Result := IsStoredProp(Instance, FPropInfo); - if Result - and (Filer.Ancestor <> nil) - and (GetPropInfo(Filer.Ancestor, PropName, [tkWString]) <> nil) then - begin - // must be different than ancestor - CurrPropValue := GetWideStrProp(Instance, FPropInfo); - Result := CurrPropValue <> GetWideStrProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); - end; - if Result then begin - // must be non-blank and different than UTF8 (implies all ASCII <= 127) - CurrPropValue := GetWideStrProp(Instance, FPropInfo); - Result := (CurrPropValue <> '') and (WideStringToUTF8(CurrPropValue) <> CurrPropValue); - end; - end; - {$ENDIF} - -begin - FInstance := Instance; - FPropInfo := GetPropInfo(Instance, PropName, [tkWString]); - if FPropInfo <> nil then begin - // must be published (and of type WideString) - Filer.DefineProperty(PropName + 'W', ReadDataUTF8, nil, False); - {$IFDEF COMPILER_7_UP} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, False); - {$ELSE} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, WriteDataUTF7, HasData); - {$ENDIF} - end; - FInstance := nil; - FPropInfo := nil; -end; - -{ TTntWideCharPropertyFiler } -type - TTntWideCharPropertyFiler = class - private - FInstance: TPersistent; - FPropInfo: PPropInfo; - {$IFNDEF COMPILER_9_UP} - FWriter: TWriter; - procedure GetLookupInfo(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent); - {$ENDIF} - procedure ReadData_W(Reader: TReader); - procedure ReadDataUTF7(Reader: TReader); - procedure WriteData_W(Writer: TWriter); - function ReadChar(Reader: TReader): WideChar; - public - procedure DefineProperties(Filer: TFiler; Instance: TPersistent; PropName: AnsiString); - end; - -{$IFNDEF COMPILER_9_UP} -type - TGetLookupInfoEvent = procedure(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent) of object; - -function AncestorIsValid(Ancestor: TPersistent; Root, RootAncestor: TComponent): Boolean; -begin - Result := (Ancestor <> nil) and (RootAncestor <> nil) and - Root.InheritsFrom(RootAncestor.ClassType); -end; - -function IsDefaultOrdPropertyValue(Instance: TObject; PropInfo: PPropInfo; - OnGetLookupInfo: TGetLookupInfoEvent): Boolean; -var - Ancestor: TPersistent; - LookupRoot: TComponent; - RootAncestor: TComponent; - Root: TComponent; - AncestorValid: Boolean; - Value: Longint; - Default: LongInt; -begin - Ancestor := nil; - Root := nil; - LookupRoot := nil; - RootAncestor := nil; - - if Assigned(OnGetLookupInfo) then - OnGetLookupInfo(Ancestor, Root, LookupRoot, RootAncestor); - - AncestorValid := AncestorIsValid(Ancestor, Root, RootAncestor); - - Result := True; - if (PropInfo^.GetProc <> nil) and (PropInfo^.SetProc <> nil) then - begin - Value := GetOrdProp(Instance, PropInfo); - if AncestorValid then - Result := Value = GetOrdProp(Ancestor, PropInfo) - else - begin - Default := PPropInfo(PropInfo)^.Default; - Result := (Default <> LongInt($80000000)) and (Value = Default); - end; - end; -end; - -procedure TTntWideCharPropertyFiler.GetLookupInfo(var Ancestor: TPersistent; - var Root, LookupRoot, RootAncestor: TComponent); -begin - Ancestor := FWriter.Ancestor; - Root := FWriter.Root; - LookupRoot := FWriter.LookupRoot; - RootAncestor := FWriter.RootAncestor; -end; -{$ENDIF} - -function TTntWideCharPropertyFiler.ReadChar(Reader: TReader): WideChar; -var - Temp: WideString; -begin - case Reader.NextValue of - vaWString: - Temp := Reader.ReadWideString; - vaString: - Temp := Reader.ReadString; - else - raise EReadError.Create(SInvalidPropertyValue); - end; - - if Length(Temp) > 1 then - raise EReadError.Create(SInvalidPropertyValue); - Result := Temp[1]; -end; - -procedure TTntWideCharPropertyFiler.ReadData_W(Reader: TReader); -begin - SetOrdProp(FInstance, FPropInfo, Ord(ReadChar(Reader))); -end; - -procedure TTntWideCharPropertyFiler.ReadDataUTF7(Reader: TReader); -var - S: WideString; -begin - S := UTF7ToWideString(Reader.ReadString); - if S = '' then - SetOrdProp(FInstance, FPropInfo, 0) - else - SetOrdProp(FInstance, FPropInfo, Ord(S[1])) -end; - -type TAccessWriter = class(TWriter); - -procedure TTntWideCharPropertyFiler.WriteData_W(Writer: TWriter); -var - L: Integer; - Temp: WideString; -begin - Temp := WideChar(GetOrdProp(FInstance, FPropInfo)); - - {$IFNDEF FPC} - TAccessWriter(Writer).WriteValue(vaWString); - {$ELSE} - TAccessWriter(Writer).Write(vaWString, SizeOf(vaWString)); - {$ENDIF} - L := Length(Temp); - Writer.Write(L, SizeOf(Integer)); - Writer.Write(Pointer(@Temp[1])^, L * 2); -end; - -procedure TTntWideCharPropertyFiler.DefineProperties(Filer: TFiler; - Instance: TPersistent; PropName: AnsiString); - - {$IFNDEF COMPILER_9_UP} - function HasData: Boolean; - var - CurrPropValue: Integer; - begin - // must be stored - Result := IsStoredProp(Instance, FPropInfo); - if Result and (Filer.Ancestor <> nil) and - (GetPropInfo(Filer.Ancestor, PropName, [tkWChar]) <> nil) then - begin - // must be different than ancestor - CurrPropValue := GetOrdProp(Instance, FPropInfo); - Result := CurrPropValue <> GetOrdProp(Filer.Ancestor, GetPropInfo(Filer.Ancestor, PropName)); - end; - if Result and (Filer is TWriter) then - begin - FWriter := TWriter(Filer); - Result := not IsDefaultOrdPropertyValue(Instance, FPropInfo, GetLookupInfo); - end; - end; - {$ENDIF} - -begin - FInstance := Instance; - FPropInfo := GetPropInfo(Instance, PropName, [tkWChar]); - if FPropInfo <> nil then - begin - // must be published (and of type WideChar) - {$IFDEF COMPILER_9_UP} - Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, False); - {$ELSE} - Filer.DefineProperty(PropName + 'W', ReadData_W, WriteData_W, HasData); - {$ENDIF} - Filer.DefineProperty(PropName + '_UTF7', ReadDataUTF7, nil, False); - end; - FInstance := nil; - FPropInfo := nil; -end; - -procedure TntPersistent_AfterInherited_DefineProperties(Filer: TFiler; Instance: TPersistent); -var - I, Count: Integer; - PropInfo: PPropInfo; - PropList: PPropList; - WideStringFiler: TTntWideStringPropertyFiler; - WideCharFiler: TTntWideCharPropertyFiler; -begin - Count := GetTypeData(Instance.ClassInfo)^.PropCount; - if Count > 0 then - begin - WideStringFiler := TTntWideStringPropertyFiler.Create; - try - WideCharFiler := TTntWideCharPropertyFiler.Create; - try - GetMem(PropList, Count * SizeOf(Pointer)); - try - GetPropInfos(Instance.ClassInfo, PropList); - for I := 0 to Count - 1 do - begin - PropInfo := PropList^[I]; - if (PropInfo = nil) then - break; - if (PropInfo.PropType^.Kind = tkWString) then - WideStringFiler.DefineProperties(Filer, Instance, PropInfo.Name) - else if (PropInfo.PropType^.Kind = tkWChar) then - WideCharFiler.DefineProperties(Filer, Instance, PropInfo.Name) - end; - finally - FreeMem(PropList, Count * SizeOf(Pointer)); - end; - finally - WideCharFiler.Free; - end; - finally - WideStringFiler.Free; - end; - end; -end; - -{ TTntFileStream } - -{$IFDEF FPC} - {$DEFINE HAS_SFCREATEERROREX} -{$ENDIF} -{$IFDEF DELPHI_7_UP} - {$DEFINE HAS_SFCREATEERROREX} -{$ENDIF} - -constructor TTntFileStream.Create(const FileName: WideString; Mode: Word); -var - CreateHandle: Integer; - {$IFDEF HAS_SFCREATEERROREX} - ErrorMessage: WideString; - {$ENDIF} -begin - if Mode = fmCreate then - begin - CreateHandle := WideFileCreate(FileName); - if CreateHandle < 0 then begin - {$IFDEF HAS_SFCREATEERROREX} - ErrorMessage := WideSysErrorMessage(GetLastError); - raise EFCreateError.CreateFmt(SFCreateErrorEx, [WideExpandFileName(FileName), ErrorMessage]); - {$ELSE} - raise EFCreateError.CreateFmt(SFCreateError, [WideExpandFileName(FileName)]); - {$ENDIF} - end; - end else - begin - CreateHandle := WideFileOpen(FileName, Mode); - if CreateHandle < 0 then begin - {$IFDEF HAS_SFCREATEERROREX} - ErrorMessage := WideSysErrorMessage(GetLastError); - raise EFOpenError.CreateFmt(SFOpenErrorEx, [WideExpandFileName(FileName), ErrorMessage]); - {$ELSE} - raise EFOpenError.CreateFmt(SFOpenError, [WideExpandFileName(FileName)]); - {$ENDIF} - end; - end; - inherited Create(CreateHandle); -end; - -destructor TTntFileStream.Destroy; -begin - if Handle >= 0 then FileClose(Handle); -end; - -{ TTntMemoryStream } - -procedure TTntMemoryStream.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntMemoryStream.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -{ TTntResourceStream } - -constructor TTntResourceStream.Create(Instance: THandle; const ResName: WideString; - ResType: PWideChar); -begin - inherited Create; - Initialize(Instance, PWideChar(ResName), ResType); -end; - -constructor TTntResourceStream.CreateFromID(Instance: THandle; ResID: Word; - ResType: PWideChar); -begin - inherited Create; - Initialize(Instance, PWideChar(ResID), ResType); -end; - -procedure TTntResourceStream.Initialize(Instance: THandle; Name, ResType: PWideChar); - - procedure Error; - begin - raise EResNotFound.CreateFmt(SResNotFound, [Name]); - end; - -begin - HResInfo := FindResourceW(Instance, Name, ResType); - if HResInfo = 0 then Error; - HGlobal := LoadResource(Instance, HResInfo); - if HGlobal = 0 then Error; - SetPointer(LockResource(HGlobal), SizeOfResource(Instance, HResInfo)); -end; - -destructor TTntResourceStream.Destroy; -begin - UnlockResource(HGlobal); - FreeResource(HGlobal); { Technically this is not necessary (MS KB #193678) } - inherited Destroy; -end; - -function TTntResourceStream.Write(const Buffer; Count: Longint): Longint; -begin - raise EStreamError.CreateRes(PResStringRec(@SCantWriteResourceStreamError)); -end; - -procedure TTntResourceStream.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -{ TAnsiStrings } - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.LoadFromFileEx(const FileName: WideString; CodePage: Cardinal); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStreamEx(Stream, CodePage); - finally - Stream.Free; - end; -end; - -procedure TAnsiStrings{TNT-ALLOW TAnsiStrings}.SaveToFileEx(const FileName: WideString; CodePage: Cardinal); -var - Stream: TStream; - Utf8BomPtr: PAnsiChar; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - if (CodePage = CP_UTF8) then - begin - Utf8BomPtr := PAnsiChar(UTF8_BOM); - Stream.WriteBuffer(Utf8BomPtr^, Length(UTF8_BOM)); - end; - SaveToStreamEx(Stream, CodePage); - finally - Stream.Free; - end; -end; - -{ TAnsiStringsForWideStringsAdapter } - -constructor TAnsiStringsForWideStringsAdapter.Create(AWideStrings: TTntStrings; _AdapterCodePage: Cardinal); -begin - inherited Create; - FWideStrings := AWideStrings; - FAdapterCodePage := _AdapterCodePage; -end; - -function TAnsiStringsForWideStringsAdapter.AdapterCodePage: Cardinal; -begin - if FAdapterCodePage = 0 then - Result := TntSystem.DefaultSystemCodePage - else - Result := FAdapterCodePage; -end; - -procedure TAnsiStringsForWideStringsAdapter.Clear; -begin - FWideStrings.Clear; -end; - -procedure TAnsiStringsForWideStringsAdapter.Delete(Index: Integer); -begin - FWideStrings.Delete(Index); -end; - -function TAnsiStringsForWideStringsAdapter.Get(Index: Integer): AnsiString; -begin - Result := WideStringToStringEx(FWideStrings.Get(Index), AdapterCodePage); -end; - -procedure TAnsiStringsForWideStringsAdapter.Put(Index: Integer; const S: AnsiString); -begin - FWideStrings.Put(Index, StringToWideStringEx(S, AdapterCodePage)); -end; - -function TAnsiStringsForWideStringsAdapter.GetCount: Integer; -begin - Result := FWideStrings.GetCount; -end; - -procedure TAnsiStringsForWideStringsAdapter.Insert(Index: Integer; const S: AnsiString); -begin - FWideStrings.Insert(Index, StringToWideStringEx(S, AdapterCodePage)); -end; - -function TAnsiStringsForWideStringsAdapter.GetObject(Index: Integer): TObject; -begin - Result := FWideStrings.GetObject(Index); -end; - -procedure TAnsiStringsForWideStringsAdapter.PutObject(Index: Integer; AObject: TObject); -begin - FWideStrings.PutObject(Index, AObject); -end; - -procedure TAnsiStringsForWideStringsAdapter.SetUpdateState(Updating: Boolean); -begin - FWideStrings.SetUpdateState(Updating); -end; - -procedure TAnsiStringsForWideStringsAdapter.LoadFromStreamEx(Stream: TStream; CodePage: Cardinal); -var - Size: Integer; - S: AnsiString; -begin - BeginUpdate; - try - Size := Stream.Size - Stream.Position; - SetString(S, nil, Size); - Stream.Read(Pointer(S)^, Size); - FWideStrings.SetTextStr(StringToWideStringEx(S, CodePage)); - finally - EndUpdate; - end; -end; - -procedure TAnsiStringsForWideStringsAdapter.SaveToStreamEx(Stream: TStream; CodePage: Cardinal); -var - S: AnsiString; -begin - S := WideStringToStringEx(FWideStrings.GetTextStr, CodePage); - Stream.WriteBuffer(Pointer(S)^, Length(S)); -end; - -{ TTntStrings } - -constructor TTntStrings.Create; -begin - inherited; - FAnsiStrings := TAnsiStringsForWideStringsAdapter.Create(Self); - FLastFileCharSet := csUnicode; -end; - -destructor TTntStrings.Destroy; -begin - FreeAndNil(FAnsiStrings); - inherited; -end; - -procedure TTntStrings.SetAnsiStrings(const Value: TAnsiStrings{TNT-ALLOW TAnsiStrings}); -begin - FAnsiStrings.Assign(Value); -end; - -procedure TTntStrings.DefineProperties(Filer: TFiler); - - {$IFNDEF COMPILER_7_UP} - function DoWrite: Boolean; - begin - if Filer.Ancestor <> nil then - begin - Result := True; - if Filer.Ancestor is TWideStrings then - Result := not Equals(TWideStrings(Filer.Ancestor)) - end - else Result := Count > 0; - end; - - function DoWriteAsUTF7: Boolean; - var - i: integer; - begin - Result := False; - for i := 0 to Count - 1 do begin - if (Strings[i] <> '') and (WideStringToUTF8(Strings[i]) <> Strings[i]) then begin - Result := True; - break; { found a string with non-ASCII chars (> 127) } - end; - end; - end; - {$ENDIF} - -begin - inherited DefineProperties(Filer); { Handles main 'Strings' property.' } - Filer.DefineProperty('WideStrings', ReadData, nil, False); - Filer.DefineProperty('WideStringsW', ReadDataUTF8, nil, False); - {$IFDEF COMPILER_7_UP} - Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, False); - {$ELSE} - Filer.DefineProperty('WideStrings_UTF7', ReadDataUTF7, WriteDataUTF7, DoWrite and DoWriteAsUTF7); - {$ENDIF} -end; - -procedure TTntStrings.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - FLastFileCharSet := AutoDetectCharacterSet(Stream); - Stream.Position := 0; - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntStrings.LoadFromStream(Stream: TStream); -begin - LoadFromStream_BOM(Stream, True); -end; - -procedure TTntStrings.LoadFromStream_BOM(Stream: TStream; WithBOM: Boolean); -var - DataLeft: Integer; - StreamCharSet: TTntStreamCharSet; - SW: WideString; - SA: AnsiString; -begin - BeginUpdate; - try - if WithBOM then - StreamCharSet := AutoDetectCharacterSet(Stream) - else - StreamCharSet := csUnicode; - DataLeft := Stream.Size - Stream.Position; - if (StreamCharSet in [csUnicode, csUnicodeSwapped]) then - begin - // BOM indicates Unicode text stream - if DataLeft < SizeOf(WideChar) then - SW := '' - else begin - SetLength(SW, DataLeft div SizeOf(WideChar)); - Stream.Read(PWideChar(SW)^, DataLeft); - if StreamCharSet = csUnicodeSwapped then - StrSwapByteOrder(PWideChar(SW)); - end; - SetTextStr(SW); - end - else if StreamCharSet = csUtf8 then - begin - // BOM indicates UTF-8 text stream - SetLength(SA, DataLeft div SizeOf(AnsiChar)); - Stream.Read(PAnsiChar(SA)^, DataLeft); - SetTextStr(UTF8ToWideString(SA)); - end - else - begin - // without byte order mark it is assumed that we are loading ANSI text - SetLength(SA, DataLeft div SizeOf(AnsiChar)); - Stream.Read(PAnsiChar(SA)^, DataLeft); - SetTextStr(SA); - end; - finally - EndUpdate; - end; -end; - -procedure TTntStrings.ReadData(Reader: TReader); -begin - if Reader.NextValue in [vaString, vaLString] then - SetTextStr(Reader.ReadString) {JCL compatiblity} - else if Reader.NextValue = vaWString then - SetTextStr(Reader.ReadWideString) {JCL compatiblity} - else begin - BeginUpdate; - try - Clear; - Reader.ReadListBegin; - while not Reader.EndOfList do - if Reader.NextValue in [vaString, vaLString] then - Add(Reader.ReadString) {TStrings compatiblity} - else - Add(Reader.ReadWideString); - Reader.ReadListEnd; - finally - EndUpdate; - end; - end; -end; - -procedure TTntStrings.ReadDataUTF7(Reader: TReader); -begin - Reader.ReadListBegin; - if ReaderNeedsUtfHelp(Reader) then - begin - BeginUpdate; - try - Clear; - while not Reader.EndOfList do - Add(UTF7ToWideString(Reader.ReadString)) - finally - EndUpdate; - end; - end else begin - while not Reader.EndOfList do - Reader.ReadString; { do nothing with Result } - end; - Reader.ReadListEnd; -end; - -procedure TTntStrings.ReadDataUTF8(Reader: TReader); -begin - Reader.ReadListBegin; - if ReaderNeedsUtfHelp(Reader) - or (Count = 0){ Legacy support where 'WideStrings' was never written in lieu of WideStringsW } - then begin - BeginUpdate; - try - Clear; - while not Reader.EndOfList do - Add(UTF8ToWideString(Reader.ReadString)) - finally - EndUpdate; - end; - end else begin - while not Reader.EndOfList do - Reader.ReadString; { do nothing with Result } - end; - Reader.ReadListEnd; -end; - -procedure TTntStrings.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TTntStrings.SaveToStream(Stream: TStream); -begin - SaveToStream_BOM(Stream, True); -end; - -procedure TTntStrings.SaveToStream_BOM(Stream: TStream; WithBOM: Boolean); -// Saves the currently loaded text into the given stream. -// WithBOM determines whether to write a byte order mark or not. -var - SW: WideString; - BOM: WideChar; -begin - if WithBOM then begin - BOM := UNICODE_BOM; - Stream.WriteBuffer(BOM, SizeOf(WideChar)); - end; - SW := GetTextStr; - Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); -end; - -procedure TTntStrings.WriteDataUTF7(Writer: TWriter); -var - I: Integer; -begin - Writer.WriteListBegin; - for I := 0 to Count-1 do - Writer.WriteString(WideStringToUTF7(Get(I))); - Writer.WriteListEnd; -end; - -{ TTntStringList } - -destructor TTntStringList.Destroy; -begin - FOnChange := nil; - FOnChanging := nil; - inherited Destroy; - if FCount <> 0 then Finalize(FList^[0], FCount); - FCount := 0; - SetCapacity(0); -end; - -function TTntStringList.Add(const S: WideString): Integer; -begin - Result := AddObject(S, nil); -end; - -function TTntStringList.AddObject(const S: WideString; AObject: TObject): Integer; -begin - if not Sorted then - Result := FCount - else - if Find(S, Result) then - case Duplicates of - dupIgnore: Exit; - dupError: Error(PResStringRec(@SDuplicateString), 0); - end; - InsertItem(Result, S, AObject); -end; - -procedure TTntStringList.Changed; -begin - if (not FUpdating) and Assigned(FOnChange) then - FOnChange(Self); -end; - -procedure TTntStringList.Changing; -begin - if (not FUpdating) and Assigned(FOnChanging) then - FOnChanging(Self); -end; - -procedure TTntStringList.Clear; -begin - if FCount <> 0 then - begin - Changing; - Finalize(FList^[0], FCount); - FCount := 0; - SetCapacity(0); - Changed; - end; -end; - -procedure TTntStringList.Delete(Index: Integer); -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - Finalize(FList^[Index]); - Dec(FCount); - if Index < FCount then - System.Move(FList^[Index + 1], FList^[Index], - (FCount - Index) * SizeOf(TWideStringItem)); - Changed; -end; - -procedure TTntStringList.Exchange(Index1, Index2: Integer); -begin - if (Index1 < 0) or (Index1 >= FCount) then Error(PResStringRec(@SListIndexError), Index1); - if (Index2 < 0) or (Index2 >= FCount) then Error(PResStringRec(@SListIndexError), Index2); - Changing; - ExchangeItems(Index1, Index2); - Changed; -end; - -procedure TTntStringList.ExchangeItems(Index1, Index2: Integer); -var - Temp: Integer; - Item1, Item2: PWideStringItem; -begin - Item1 := @FList^[Index1]; - Item2 := @FList^[Index2]; - Temp := Integer(Item1^.FString); - Integer(Item1^.FString) := Integer(Item2^.FString); - Integer(Item2^.FString) := Temp; - Temp := Integer(Item1^.FObject); - Integer(Item1^.FObject) := Integer(Item2^.FObject); - Integer(Item2^.FObject) := Temp; -end; - -function TTntStringList.Find(const S: WideString; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := FCount - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := CompareStrings(FList^[I].FString, S); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - if Duplicates <> dupAccept then L := I; - end; - end; - end; - Index := L; -end; - -function TTntStringList.Get(Index: Integer): WideString; -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Result := FList^[Index].FString; -end; - -function TTntStringList.GetCapacity: Integer; -begin - Result := FCapacity; -end; - -function TTntStringList.GetCount: Integer; -begin - Result := FCount; -end; - -function TTntStringList.GetObject(Index: Integer): TObject; -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Result := FList^[Index].FObject; -end; - -procedure TTntStringList.Grow; -var - Delta: Integer; -begin - if FCapacity > 64 then Delta := FCapacity div 4 else - if FCapacity > 8 then Delta := 16 else - Delta := 4; - SetCapacity(FCapacity + Delta); -end; - -function TTntStringList.IndexOf(const S: WideString): Integer; -begin - if not Sorted then Result := inherited IndexOf(S) else - if not Find(S, Result) then Result := -1; -end; - -function TTntStringList.IndexOfName(const Name: WideString): Integer; -var - NameKey: WideString; -begin - if not Sorted then - Result := inherited IndexOfName(Name) - else begin - // use sort to find index more quickly - NameKey := Name + NameValueSeparator; - Find(NameKey, Result); - if (Result < 0) or (Result > Count - 1) then - Result := -1 - else if CompareStrings(NameKey, Copy(Strings[Result], 1, Length(NameKey))) <> 0 then - Result := -1 - end; -end; - -procedure TTntStringList.Insert(Index: Integer; const S: WideString); -begin - InsertObject(Index, S, nil); -end; - -procedure TTntStringList.InsertObject(Index: Integer; const S: WideString; - AObject: TObject); -begin - if Sorted then Error(PResStringRec(@SSortedListError), 0); - if (Index < 0) or (Index > FCount) then Error(PResStringRec(@SListIndexError), Index); - InsertItem(Index, S, AObject); -end; - -procedure TTntStringList.InsertItem(Index: Integer; const S: WideString; AObject: TObject); -begin - Changing; - if FCount = FCapacity then Grow; - if Index < FCount then - System.Move(FList^[Index], FList^[Index + 1], - (FCount - Index) * SizeOf(TWideStringItem)); - with FList^[Index] do - begin - Pointer(FString) := nil; - FObject := AObject; - FString := S; - end; - Inc(FCount); - Changed; -end; - -procedure TTntStringList.Put(Index: Integer; const S: WideString); -begin - if Sorted then Error(PResStringRec(@SSortedListError), 0); - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - FList^[Index].FString := S; - Changed; -end; - -procedure TTntStringList.PutObject(Index: Integer; AObject: TObject); -begin - if (Index < 0) or (Index >= FCount) then Error(PResStringRec(@SListIndexError), Index); - Changing; - FList^[Index].FObject := AObject; - Changed; -end; - -procedure TTntStringList.QuickSort(L, R: Integer; SCompare: TWideStringListSortCompare); -var - I, J, P: Integer; -begin - repeat - I := L; - J := R; - P := (L + R) shr 1; - repeat - while SCompare(Self, I, P) < 0 do Inc(I); - while SCompare(Self, J, P) > 0 do Dec(J); - if I <= J then - begin - ExchangeItems(I, J); - if P = I then - P := J - else if P = J then - P := I; - Inc(I); - Dec(J); - end; - until I > J; - if L < J then QuickSort(L, J, SCompare); - L := I; - until I >= R; -end; - -procedure TTntStringList.SetCapacity(NewCapacity: Integer); -begin - ReallocMem(FList, NewCapacity * SizeOf(TWideStringItem)); - FCapacity := NewCapacity; -end; - -procedure TTntStringList.SetSorted(Value: Boolean); -begin - if FSorted <> Value then - begin - if Value then Sort; - FSorted := Value; - end; -end; - -procedure TTntStringList.SetUpdateState(Updating: Boolean); -begin - FUpdating := Updating; - if Updating then Changing else Changed; -end; - -function WideStringListCompareStrings(List: TTntStringList; Index1, Index2: Integer): Integer; -begin - Result := List.CompareStrings(List.FList^[Index1].FString, - List.FList^[Index2].FString); -end; - -procedure TTntStringList.Sort; -begin - CustomSort(WideStringListCompareStrings); -end; - -procedure TTntStringList.CustomSort(Compare: TWideStringListSortCompare); -begin - if not Sorted and (FCount > 1) then - begin - Changing; - QuickSort(0, FCount - 1, Compare); - Changed; - end; -end; - -function TTntStringList.CompareStrings(const S1, S2: WideString): Integer; -begin - if CaseSensitive then - Result := WideCompareStr(S1, S2) - else - Result := WideCompareText(S1, S2); -end; - -procedure TTntStringList.SetCaseSensitive(const Value: Boolean); -begin - if Value <> FCaseSensitive then - begin - FCaseSensitive := Value; - if Sorted then Sort; - end; -end; - -//------------------------- TntClasses introduced procs ---------------------------------- - -function AutoDetectCharacterSet(Stream: TStream): TTntStreamCharSet; -var - ByteOrderMark: WideChar; - BytesRead: Integer; - Utf8Test: array[0..2] of AnsiChar; -begin - // Byte Order Mark - ByteOrderMark := #0; - if (Stream.Size - Stream.Position) >= SizeOf(ByteOrderMark) then begin - BytesRead := Stream.Read(ByteOrderMark, SizeOf(ByteOrderMark)); - if (ByteOrderMark <> UNICODE_BOM) and (ByteOrderMark <> UNICODE_BOM_SWAPPED) then begin - ByteOrderMark := #0; - Stream.Seek(-BytesRead, soFromCurrent); - if (Stream.Size - Stream.Position) >= Length(Utf8Test) * SizeOf(AnsiChar) then begin - BytesRead := Stream.Read(Utf8Test[0], Length(Utf8Test) * SizeOf(AnsiChar)); - if Utf8Test <> UTF8_BOM then - Stream.Seek(-BytesRead, soFromCurrent); - end; - end; - end; - // Test Byte Order Mark - if ByteOrderMark = UNICODE_BOM then - Result := csUnicode - else if ByteOrderMark = UNICODE_BOM_SWAPPED then - Result := csUnicodeSwapped - else if Utf8Test = UTF8_BOM then - Result := csUtf8 - else - Result := csAnsi; -end; - -function FindSortedListByTarget(List: TList; TargetCompare: TListTargetCompare; - Target: Pointer; var Index: Integer): Boolean; -var - L, H, I, C: Integer; -begin - Result := False; - L := 0; - H := List.Count - 1; - while L <= H do - begin - I := (L + H) shr 1; - C := TargetCompare(List[i], Target); - if C < 0 then L := I + 1 else - begin - H := I - 1; - if C = 0 then - begin - Result := True; - L := I; - end; - end; - end; - Index := L; -end; - -function ClassIsRegistered(const clsid: TCLSID): Boolean; -var - OleStr: POleStr; - Reg: TRegIniFile; - Key, Filename: WideString; -begin - // First, check to see if there is a ProgID. This will tell if the - // control is registered on the machine. No ProgID, control won't run - Result := ProgIDFromCLSID(clsid, OleStr) = S_OK; - if not Result then Exit; //Bail as soon as anything goes wrong. - - // Next, make sure that the file is actually there by rooting it out - // of the registry - Key := WideFormat('\SOFTWARE\Classes\CLSID\%s', [GUIDToString(clsid)]); - Reg := TRegIniFile.Create; - try - Reg.RootKey := HKEY_LOCAL_MACHINE; - Result := Reg.OpenKeyReadOnly(Key); - if not Result then Exit; // Bail as soon as anything goes wrong. - - FileName := Reg.ReadString('InProcServer32', '', EmptyStr); - if (Filename = EmptyStr) then // try another key for the file name - begin - FileName := Reg.ReadString('InProcServer', '', EmptyStr); - end; - Result := Filename <> EmptyStr; - if not Result then Exit; - Result := WideFileExists(Filename); - finally - Reg.Free; - end; -end; - -{ TBufferedAnsiString } - -procedure TBufferedAnsiString.Clear; -begin - LastWriteIndex := 0; - if Length(FStringBuffer) > 0 then - FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(AnsiChar), 0); -end; - -procedure TBufferedAnsiString.AddChar(const wc: AnsiChar); -const - MIN_GROW_SIZE = 32; - MAX_GROW_SIZE = 256; -var - GrowSize: Integer; -begin - Inc(LastWriteIndex); - if LastWriteIndex > Length(FStringBuffer) then begin - GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); - GrowSize := Min(GrowSize, MAX_GROW_SIZE); - SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); - FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(AnsiChar), 0); - end; - FStringBuffer[LastWriteIndex] := wc; -end; - -procedure TBufferedAnsiString.AddString(const s: AnsiString); -var - LenS: Integer; - BlockSize: Integer; - AllocSize: Integer; -begin - LenS := Length(s); - if LenS > 0 then begin - Inc(LastWriteIndex); - if LastWriteIndex + LenS - 1 > Length(FStringBuffer) then begin - // determine optimum new allocation size - BlockSize := Length(FStringBuffer) div 2; - if BlockSize < 8 then - BlockSize := 8; - AllocSize := ((LenS div BlockSize) + 1) * BlockSize; - // realloc buffer - SetLength(FStringBuffer, Length(FStringBuffer) + AllocSize); - FillChar(FStringBuffer[Length(FStringBuffer) - AllocSize + 1], AllocSize * SizeOf(AnsiChar), 0); - end; - CopyMemory(@FStringBuffer[LastWriteIndex], @s[1], LenS * SizeOf(AnsiChar)); - Inc(LastWriteIndex, LenS - 1); - end; -end; - -procedure TBufferedAnsiString.AddBuffer(Buff: PAnsiChar; Chars: Integer); -var - i: integer; -begin - for i := 1 to Chars do begin - if Buff^ = #0 then - break; - AddChar(Buff^); - Inc(Buff); - end; -end; - -function TBufferedAnsiString.Value: AnsiString; -begin - Result := PAnsiChar(FStringBuffer); -end; - -function TBufferedAnsiString.BuffPtr: PAnsiChar; -begin - Result := PAnsiChar(FStringBuffer); -end; - -{ TBufferedWideString } - -procedure TBufferedWideString.Clear; -begin - LastWriteIndex := 0; - if Length(FStringBuffer) > 0 then - FillChar(FStringBuffer[1], Length(FStringBuffer) * SizeOf(WideChar), 0); -end; - -procedure TBufferedWideString.AddChar(const wc: WideChar); -const - MIN_GROW_SIZE = 32; - MAX_GROW_SIZE = 256; -var - GrowSize: Integer; -begin - Inc(LastWriteIndex); - if LastWriteIndex > Length(FStringBuffer) then begin - GrowSize := Max(MIN_GROW_SIZE, Length(FStringBuffer)); - GrowSize := Min(GrowSize, MAX_GROW_SIZE); - SetLength(FStringBuffer, Length(FStringBuffer) + GrowSize); - FillChar(FStringBuffer[LastWriteIndex], GrowSize * SizeOf(WideChar), 0); - end; - FStringBuffer[LastWriteIndex] := wc; -end; - -procedure TBufferedWideString.AddString(const s: WideString); -var - i: integer; -begin - for i := 1 to Length(s) do - AddChar(s[i]); -end; - -procedure TBufferedWideString.AddBuffer(Buff: PWideChar; Chars: Integer); -var - i: integer; -begin - for i := 1 to Chars do begin - if Buff^ = #0 then - break; - AddChar(Buff^); - Inc(Buff); - end; -end; - -function TBufferedWideString.Value: WideString; -begin - Result := PWideChar(FStringBuffer); -end; - -function TBufferedWideString.BuffPtr: PWideChar; -begin - Result := PWideChar(FStringBuffer); -end; - -{ TBufferedStreamReader } - -constructor TBufferedStreamReader.Create(Stream: TStream; BufferSize: Integer = 1024); -begin - // init stream - FStream := Stream; - FStreamSize := Stream.Size; - // init buffer - FBufferSize := BufferSize; - SetLength(FBuffer, BufferSize); - FBufferStartPosition := -FBufferSize; { out of any useful range } - // init virtual position - FVirtualPosition := 0; -end; - -function TBufferedStreamReader.Seek(Offset: Integer; Origin: Word): Longint; -begin - case Origin of - soFromBeginning: FVirtualPosition := Offset; - soFromCurrent: Inc(FVirtualPosition, Offset); - soFromEnd: FVirtualPosition := FStreamSize + Offset; - end; - Result := FVirtualPosition; -end; - -procedure TBufferedStreamReader.UpdateBufferFromPosition(StartPos: Integer); -begin - try - FStream.Position := StartPos; - FStream.Read(FBuffer[0], FBufferSize); - FBufferStartPosition := StartPos; - except - FBufferStartPosition := -FBufferSize; { out of any useful range } - raise; - end; -end; - -function TBufferedStreamReader.Read(var Buffer; Count: Integer): Longint; -var - BytesLeft: Integer; - FirstBufferRead: Integer; - StreamDirectRead: Integer; - Buf: PAnsiChar; -begin - if (FVirtualPosition >= 0) and (Count >= 0) then - begin - Result := FStreamSize - FVirtualPosition; - if Result > 0 then - begin - if Result > Count then - Result := Count; - - Buf := @Buffer; - BytesLeft := Result; - - // try to read what is left in buffer - FirstBufferRead := FBufferStartPosition + FBufferSize - FVirtualPosition; - if (FirstBufferRead < 0) or (FirstBufferRead > FBufferSize) then - FirstBufferRead := 0; - FirstBufferRead := Min(FirstBufferRead, Result); - if FirstBufferRead > 0 then begin - Move(FBuffer[FVirtualPosition - FBufferStartPosition], Buf[0], FirstBufferRead); - Dec(BytesLeft, FirstBufferRead); - end; - - if BytesLeft > 0 then begin - // The first read in buffer was not enough - StreamDirectRead := (BytesLeft div FBufferSize) * FBufferSize; - FStream.Position := FVirtualPosition + FirstBufferRead; - FStream.Read(Buf[FirstBufferRead], StreamDirectRead); - Dec(BytesLeft, StreamDirectRead); - - if BytesLeft > 0 then begin - // update buffer, and read what is left - UpdateBufferFromPosition(FStream.Position); - Move(FBuffer[0], Buf[FirstBufferRead + StreamDirectRead], BytesLeft); - end; - end; - - Inc(FVirtualPosition, Result); - Exit; - end; - end; - Result := 0; -end; - -function TBufferedStreamReader.Write(const Buffer; Count: Integer): Longint; -begin - raise ETntInternalError.Create('Internal Error: class can not write.'); - Result := 0; -end; - -//-------- synced wide string ----------------- - -function GetSyncedWideString(var WideStr: WideString; const AnsiStr: AnsiString): WideString; -begin - if AnsiString(WideStr) <> (AnsiStr) then begin - WideStr := AnsiStr; {AnsiStr changed. Keep WideStr in sync.} - end; - Result := WideStr; -end; - -procedure SetSyncedWideString(const Value: WideString; var WideStr: WideString; - const AnsiStr: AnsiString; SetAnsiStr: TSetAnsiStrEvent); -begin - if Value <> GetSyncedWideString(WideStr, AnsiStr) then - begin - if (not WideSameStr(Value, AnsiString(Value))) {unicode chars lost in conversion} - and (AnsiStr = AnsiString(Value)) {AnsiStr is not going to change} - then begin - SetAnsiStr(''); {force the change} - end; - WideStr := Value; - SetAnsiStr(Value); - end; -end; - -{ TWideComponentHelper } - -function CompareComponentHelperToTarget(Item, Target: Pointer): Integer; -begin - if PtrUInt(TWideComponentHelper(Item).FComponent) < PtrUInt(Target) then - Result := -1 - else if PtrUInt(TWideComponentHelper(Item).FComponent) > PtrUInt(Target) then - Result := 1 - else - Result := 0; -end; - -function FindWideComponentHelperIndex(ComponentHelperList: TComponentList; Component: TComponent; var Index: Integer): Boolean; -begin - // find Component in sorted wide caption list (list is sorted by TWideComponentHelper.FComponent) - Result := FindSortedListByTarget(ComponentHelperList, CompareComponentHelperToTarget, Component, Index); -end; - -constructor TWideComponentHelper.Create(AOwner: TComponent); -begin - raise ETntInternalError.Create('TNT Internal Error: TWideComponentHelper.Create should never be encountered.'); -end; - -constructor TWideComponentHelper.CreateHelper(AOwner: TComponent; ComponentHelperList: TComponentList); -var - Index: Integer; -begin - // don't use direct ownership for memory management - inherited Create(nil); - FComponent := AOwner; - FComponent.FreeNotification(Self); - - // insert into list according to sort - FindWideComponentHelperIndex(ComponentHelperList, FComponent, Index); - ComponentHelperList.Insert(Index, Self); -end; - -procedure TWideComponentHelper.Notification(AComponent: TComponent; Operation: TOperation); -begin - inherited; - if (AComponent = FComponent) and (Operation = opRemove) then begin - FComponent := nil; - Free; - end; -end; - -function FindWideComponentHelper(ComponentHelperList: TComponentList; Component: TComponent): TWideComponentHelper; -var - Index: integer; -begin - if FindWideComponentHelperIndex(ComponentHelperList, Component, Index) then begin - Result := TWideComponentHelper(ComponentHelperList[Index]); - Assert(Result.FComponent = Component, 'TNT Internal Error: FindWideComponentHelperIndex failed.'); - end else - Result := nil; -end; - -initialization - RuntimeUTFStreaming := False; { Delphi 6 and higher don't need UTF help at runtime. } - -end. diff --git a/src/lib/TntUnicodeControls/TntFormatStrUtils.pas b/src/lib/TntUnicodeControls/TntFormatStrUtils.pas deleted file mode 100644 index c6b65082..00000000 --- a/src/lib/TntUnicodeControls/TntFormatStrUtils.pas +++ /dev/null @@ -1,521 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntFormatStrUtils; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -// this unit provides functions to work with format strings - -uses - TntSysUtils; - -function GetCanonicalFormatStr(const _FormatString: WideString): WideString; - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} -function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; - const Args: array of const - {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; -{$ENDIF} -{$ENDIF} -procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); -function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; - -type - EFormatSpecError = class(ETntGeneralError); - -implementation - -uses - SysUtils, Math, TntClasses; - -resourcestring - SInvalidFormatSpecifier = 'Invalid Format Specifier: %s'; - SMismatchedArgumentTypes = 'Argument types for index %d do not match. (%s <> %s)'; - SMismatchedArgumentCounts = 'Number of format specifiers do not match.'; - -type - TFormatSpecifierType = (fstInteger, fstFloating, fstPointer, fstString); - -function GetFormatSpecifierType(const FormatSpecifier: WideString): TFormatSpecifierType; -var - LastChar: WideChar; -begin - LastChar := TntWideLastChar(FormatSpecifier); - case LastChar of - 'd', 'D', 'u', 'U', 'x', 'X': - result := fstInteger; - 'e', 'E', 'f', 'F', 'g', 'G', 'n', 'N', 'm', 'M': - result := fstFloating; - 'p', 'P': - result := fstPointer; - 's', 'S': - result := fstString - else - raise ETntInternalError.CreateFmt('Internal Error: Unexpected format type (%s)', [LastChar]); - end; -end; - -type - TFormatStrParser = class(TObject) - private - ParsedString: TBufferedWideString; - PFormatString: PWideChar; - LastIndex: Integer; - ExplicitCount: Integer; - ImplicitCount: Integer; - procedure RaiseInvalidFormatSpecifier; - function ParseChar(c: WideChar): Boolean; - procedure ForceParseChar(c: WideChar); - function ParseDigit: Boolean; - function ParseInteger: Boolean; - procedure ForceParseType; - function PeekDigit: Boolean; - function PeekIndexSpecifier(out Index: Integer): Boolean; - public - constructor Create(const _FormatString: WideString); - destructor Destroy; override; - function ParseFormatSpecifier: Boolean; - end; - -constructor TFormatStrParser.Create(const _FormatString: WideString); -begin - inherited Create; - PFormatString := PWideChar(_FormatString); - ExplicitCount := 0; - ImplicitCount := 0; - LastIndex := -1; - ParsedString := TBufferedWideString.Create; -end; - -destructor TFormatStrParser.Destroy; -begin - FreeAndNil(ParsedString); - inherited; -end; - -procedure TFormatStrParser.RaiseInvalidFormatSpecifier; -begin - raise EFormatSpecError.CreateFmt(SInvalidFormatSpecifier, [ParsedString.Value + PFormatString]); -end; - -function TFormatStrParser.ParseChar(c: WideChar): Boolean; -begin - result := False; - if PFormatString^ = c then begin - result := True; - ParsedString.AddChar(c); - Inc(PFormatString); - end; -end; - -procedure TFormatStrParser.ForceParseChar(c: WideChar); -begin - if not ParseChar(c) then - RaiseInvalidFormatSpecifier; -end; - -function TFormatStrParser.PeekDigit: Boolean; -begin - result := False; - if (PFormatString^ <> #0) - and (PFormatString^ >= '0') - and (PFormatString^ <= '9') then - result := True; -end; - -function TFormatStrParser.ParseDigit: Boolean; -begin - result := False; - if PeekDigit then begin - result := True; - ForceParseChar(PFormatString^); - end; -end; - -function TFormatStrParser.ParseInteger: Boolean; -const - MAX_INT_DIGITS = 6; -var - digitcount: integer; -begin - digitcount := 0; - While ParseDigit do begin - inc(digitcount); - end; - result := (digitcount > 0); - if digitcount > MAX_INT_DIGITS then - RaiseInvalidFormatSpecifier; -end; - -procedure TFormatStrParser.ForceParseType; -begin - if PFormatString^ = #0 then - RaiseInvalidFormatSpecifier; - - case PFormatString^ of - 'd', 'u', 'x', 'e', 'f', 'g', 'n', 'm', 'p', 's', - 'D', 'U', 'X', 'E', 'F', 'G', 'N', 'M', 'P', 'S': - begin - // do nothing - end - else - RaiseInvalidFormatSpecifier; - end; - ForceParseChar(PFormatString^); -end; - -function TFormatStrParser.PeekIndexSpecifier(out Index: Integer): Boolean; -var - SaveParsedString: WideString; - SaveFormatString: PWideChar; -begin - SaveParsedString := ParsedString.Value; - SaveFormatString := PFormatString; - try - ParsedString.Clear; - Result := False; - Index := -1; - if ParseInteger then begin - Index := StrToInt(ParsedString.Value); - if ParseChar(':') then - Result := True; - end; - finally - ParsedString.Clear; - ParsedString.AddString(SaveParsedString); - PFormatString := SaveFormatString; - end; -end; - -function TFormatStrParser.ParseFormatSpecifier: Boolean; -var - ExplicitIndex: Integer; -begin - Result := False; - // Parse entire format specifier - ForceParseChar('%'); - if (PFormatString^ <> #0) - and (not ParseChar(' ')) - and (not ParseChar('%')) then begin - if PeekIndexSpecifier(ExplicitIndex) then begin - Inc(ExplicitCount); - LastIndex := Max(LastIndex, ExplicitIndex); - end else begin - Inc(ImplicitCount); - Inc(LastIndex); - ParsedString.AddString(IntToStr(LastIndex)); - ParsedString.AddChar(':'); - end; - if ParseChar('*') then - begin - Inc(ImplicitCount); - Inc(LastIndex); - ParseChar(':'); - end else if ParseInteger then - ParseChar(':'); - ParseChar('-'); - if ParseChar('*') then begin - Inc(ImplicitCount); - Inc(LastIndex); - end else - ParseInteger; - if ParseChar('.') then begin - if not ParseChar('*') then - ParseInteger; - end; - ForceParseType; - Result := True; - end; -end; - -//----------------------------------- - -function GetCanonicalFormatStr(const _FormatString: WideString): WideString; -var - PosSpec: Integer; -begin - with TFormatStrParser.Create(_FormatString) do - try - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - ParsedString.AddBuffer(PFormatString, PosSpec - 1); - Inc(PFormatString, PosSpec - 1); - // parse format specifier - ParseFormatSpecifier; - finally - PosSpec := Pos('%', PFormatString); - end; - end; - if ((ExplicitCount = 0) and (ImplicitCount = 1)) {simple expression} - or ((ExplicitCount > 0) and (ImplicitCount = 0)) {nothing converted} then - result := _FormatString {original} - else - result := ParsedString.Value + PFormatString; - finally - Free; - end; -end; - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} -function ReplaceFloatingArgumentsInFormatString(const _FormatString: WideString; - const Args: array of const - {$IFDEF COMPILER_7_UP}; FormatSettings: PFormatSettings{$ENDIF}): WideString; -{ This function replaces floating point format specifiers with their actual formatted values. - It also adds index specifiers so that the other format specifiers don't lose their place. - The reason for this is that WideFormat doesn't correctly format floating point specifiers. - See QC#4254. } -var - Parser: TFormatStrParser; - PosSpec: Integer; - Output: TBufferedWideString; -begin - Output := TBufferedWideString.Create; - try - Parser := TFormatStrParser.Create(_FormatString); - with Parser do - try - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - Output.AddBuffer(PFormatString, PosSpec - 1); - Inc(PFormatString, PosSpec - 1); - // parse format specifier - ParsedString.Clear; - if (not ParseFormatSpecifier) - or (GetFormatSpecifierType(ParsedString.Value) <> fstFloating) then - Output.AddBuffer(ParsedString.BuffPtr, MaxInt) - {$IFDEF COMPILER_7_UP} - else if Assigned(FormatSettings) then - Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args, FormatSettings^)) - {$ENDIF} - else - Output.AddString(Format{TNT-ALLOW Format}(ParsedString.Value, Args)); - finally - PosSpec := Pos('%', PFormatString); - end; - end; - Output.AddString(PFormatString); - finally - Free; - end; - Result := Output.Value; - finally - Output.Free; - end; -end; -{$ENDIF} -{$ENDIF} - -procedure GetFormatArgs(const _FormatString: WideString; FormatArgs: TTntStrings); -var - PosSpec: Integer; -begin - with TFormatStrParser.Create(_FormatString) do - try - FormatArgs.Clear; - // loop until no more '%' - PosSpec := Pos('%', PFormatString); - While PosSpec <> 0 do begin - try - // delete everything up until '%' - Inc(PFormatString, PosSpec - 1); - // add format specifier to list - ParsedString.Clear; - if ParseFormatSpecifier then - FormatArgs.Add(ParsedString.Value); - finally - PosSpec := Pos('%', PFormatString); - end; - end; - finally - Free; - end; -end; - -function GetExplicitIndex(const FormatSpecifier: WideString): Integer; -var - IndexStr: WideString; - PosColon: Integer; -begin - result := -1; - PosColon := Pos(':', FormatSpecifier); - if PosColon <> 0 then begin - IndexStr := Copy(FormatSpecifier, 2, PosColon - 2); - result := StrToInt(IndexStr); - end; -end; - -function GetMaxIndex(FormatArgs: TTntStrings): Integer; -var - i: integer; - RunningIndex: Integer; - ExplicitIndex: Integer; -begin - result := -1; - RunningIndex := -1; - for i := 0 to FormatArgs.Count - 1 do begin - ExplicitIndex := GetExplicitIndex(FormatArgs[i]); - if ExplicitIndex <> -1 then - RunningIndex := ExplicitIndex - else - inc(RunningIndex); - result := Max(result, RunningIndex); - end; -end; - -function FormatSpecToObject(SpecType: TFormatSpecifierType): TObject; -begin - {$IFNDEF FPC} - Result := TObject(SpecType); - {$ELSE} - Result := Pointer(SpecType); - {$ENDIF} -end; - -procedure UpdateTypeList(FormatArgs, TypeList: TTntStrings); -var - i: integer; - f: WideString; - SpecType: TFormatSpecifierType; - ExplicitIndex: Integer; - MaxIndex: Integer; - RunningIndex: Integer; -begin - // set count of TypeList to accomodate maximum index - MaxIndex := GetMaxIndex(FormatArgs); - TypeList.Clear; - for i := 0 to MaxIndex do - TypeList.Add(''); - - // for each arg... - RunningIndex := -1; - for i := 0 to FormatArgs.Count - 1 do begin - f := FormatArgs[i]; - ExplicitIndex := GetExplicitIndex(f); - SpecType := GetFormatSpecifierType(f); - - // determine running arg index - if ExplicitIndex <> -1 then - RunningIndex := ExplicitIndex - else - inc(RunningIndex); - - if TypeList[RunningIndex] <> '' then begin - // already exists in list, check for compatibility - if TypeList.Objects[RunningIndex] <> FormatSpecToObject(SpecType) then - raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, - [RunningIndex, TypeList[RunningIndex], f]); - end else begin - // not in list so update it - TypeList[RunningIndex] := f; - TypeList.Objects[RunningIndex] := FormatSpecToObject(SpecType); - end; - end; -end; - -procedure CompareFormatStrings(FormatStr1, FormatStr2: WideString); -var - ArgList1: TTntStringList; - ArgList2: TTntStringList; - TypeList1: TTntStringList; - TypeList2: TTntStringList; - i: integer; -begin - ArgList1 := nil; - ArgList2 := nil; - TypeList1 := nil; - TypeList2 := nil; - try - ArgList1 := TTntStringList.Create; - ArgList2 := TTntStringList.Create; - TypeList1 := TTntStringList.Create; - TypeList2 := TTntStringList.Create; - - GetFormatArgs(FormatStr1, ArgList1); - UpdateTypeList(ArgList1, TypeList1); - - GetFormatArgs(FormatStr2, ArgList2); - UpdateTypeList(ArgList2, TypeList2); - - if TypeList1.Count <> TypeList2.Count then - raise EFormatSpecError.Create(SMismatchedArgumentCounts + CRLF + CRLF + '> ' + FormatStr1 + CRLF + '> ' + FormatStr2); - - for i := 0 to TypeList1.Count - 1 do begin - if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin - raise EFormatSpecError.CreateFmt(SMismatchedArgumentTypes, - [i, TypeList1[i], TypeList2[i]]); - end; - end; - - finally - ArgList1.Free; - ArgList2.Free; - TypeList1.Free; - TypeList2.Free; - end; -end; - -function FormatStringsAreCompatible(FormatStr1, FormatStr2: WideString): Boolean; -var - ArgList1: TTntStringList; - ArgList2: TTntStringList; - TypeList1: TTntStringList; - TypeList2: TTntStringList; - i: integer; -begin - ArgList1 := nil; - ArgList2 := nil; - TypeList1 := nil; - TypeList2 := nil; - try - ArgList1 := TTntStringList.Create; - ArgList2 := TTntStringList.Create; - TypeList1 := TTntStringList.Create; - TypeList2 := TTntStringList.Create; - - GetFormatArgs(FormatStr1, ArgList1); - UpdateTypeList(ArgList1, TypeList1); - - GetFormatArgs(FormatStr2, ArgList2); - UpdateTypeList(ArgList2, TypeList2); - - Result := (TypeList1.Count = TypeList2.Count); - if Result then begin - for i := 0 to TypeList1.Count - 1 do begin - if TypeList1.Objects[i] <> TypeList2.Objects[i] then begin - Result := False; - break; - end; - end; - end; - finally - ArgList1.Free; - ArgList2.Free; - TypeList1.Free; - TypeList2.Free; - end; -end; - -end. diff --git a/src/lib/TntUnicodeControls/TntSysUtils.pas b/src/lib/TntUnicodeControls/TntSysUtils.pas deleted file mode 100644 index b7cf2467..00000000 --- a/src/lib/TntUnicodeControls/TntSysUtils.pas +++ /dev/null @@ -1,1753 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntSysUtils; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{ TODO: Consider: more filename functions from SysUtils } -{ TODO: Consider: string functions from StrUtils. } - -uses - Types, SysUtils, Windows, TntWindows; - -//--------------------------------------------------------------------------------------------- -// Tnt - Types -//--------------------------------------------------------------------------------------------- - -// ......... introduced ......... -type - // The user of the application did something plainly wrong. - ETntUserError = class(Exception); - // A general error occured. (ie. file didn't exist, server didn't return data, etc.) - ETntGeneralError = class(Exception); - // Like Assert(). An error occured that should never have happened, send me a bug report now! - ETntInternalError = class(Exception); - -{$IFNDEF FPC} -type - PtrInt = LongInt; - PtrUInt = LongWord; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- -// Tnt - SysUtils -//--------------------------------------------------------------------------------------------- - -// ......... SBCS and MBCS functions with WideString replacements in SysUtils.pas ......... - -{TNT-WARN CompareStr} {TNT-WARN AnsiCompareStr} -{TNT-WARN SameStr} {TNT-WARN AnsiSameStr} -{TNT-WARN SameText} {TNT-WARN AnsiSameText} -{TNT-WARN CompareText} {TNT-WARN AnsiCompareText} -{TNT-WARN UpperCase} {TNT-WARN AnsiUpperCase} -{TNT-WARN LowerCase} {TNT-WARN AnsiLowerCase} - -{TNT-WARN AnsiPos} { --> Pos() supports WideString. } -{TNT-WARN FmtStr} -{TNT-WARN Format} -{TNT-WARN FormatBuf} - -// ......... MBCS Byte Type Procs ......... - -{TNT-WARN ByteType} -{TNT-WARN StrByteType} -{TNT-WARN ByteToCharIndex} -{TNT-WARN ByteToCharLen} -{TNT-WARN CharToByteIndex} -{TNT-WARN CharToByteLen} - -// ........ null-terminated string functions ......... - -{TNT-WARN StrEnd} -{TNT-WARN StrLen} -{TNT-WARN StrLCopy} -{TNT-WARN StrCopy} -{TNT-WARN StrECopy} -{TNT-WARN StrPLCopy} -{TNT-WARN StrPCopy} -{TNT-WARN StrLComp} -{TNT-WARN AnsiStrLComp} -{TNT-WARN StrComp} -{TNT-WARN AnsiStrComp} -{TNT-WARN StrLIComp} -{TNT-WARN AnsiStrLIComp} -{TNT-WARN StrIComp} -{TNT-WARN AnsiStrIComp} -{TNT-WARN StrLower} -{TNT-WARN AnsiStrLower} -{TNT-WARN StrUpper} -{TNT-WARN AnsiStrUpper} -{TNT-WARN StrPos} -{TNT-WARN AnsiStrPos} -{TNT-WARN StrScan} -{TNT-WARN AnsiStrScan} -{TNT-WARN StrRScan} -{TNT-WARN AnsiStrRScan} -{TNT-WARN StrLCat} -{TNT-WARN StrCat} -{TNT-WARN StrMove} -{TNT-WARN StrPas} -{TNT-WARN StrAlloc} -{TNT-WARN StrBufSize} -{TNT-WARN StrNew} -{TNT-WARN StrDispose} - -{TNT-WARN AnsiExtractQuotedStr} -{TNT-WARN AnsiLastChar} -{TNT-WARN AnsiStrLastChar} -{TNT-WARN QuotedStr} -{TNT-WARN AnsiQuotedStr} -{TNT-WARN AnsiDequotedStr} - -// ........ string functions ......... - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} - // - // pre-Delphi 9 issues w/ WideFormatBuf, WideFmtStr and WideFormat - // - - {$IFDEF COMPILER_7_UP} - type - PFormatSettings = ^TFormatSettings; - {$ENDIF} - - // SysUtils.WideFormatBuf doesn't correctly handle numeric specifiers. - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const): Cardinal; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const; - const FormatSettings: TFormatSettings): Cardinal; overload; - {$ENDIF} - - // SysUtils.WideFmtStr doesn't handle string lengths > 4096. - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const); {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const; const FormatSettings: TFormatSettings); overload; - {$ENDIF} - - {---------------------------------------------------------------------------------------- - Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... - TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); - will fix WideFormat as well as WideFmtStr. - ----------------------------------------------------------------------------------------} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; {$IFDEF COMPILER_7_UP} overload; {$ENDIF} - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; - const FormatSettings: TFormatSettings): WideString; overload; - {$ENDIF} - -{$ENDIF} -{$ENDIF} - -{TNT-WARN WideUpperCase} // SysUtils.WideUpperCase is broken on Win9x for D6, D7, D9. -function Tnt_WideUpperCase(const S: WideString): WideString; -{TNT-WARN WideLowerCase} // SysUtils.WideLowerCase is broken on Win9x for D6, D7, D9. -function Tnt_WideLowerCase(const S: WideString): WideString; - -function TntWideLastChar(const S: WideString): WideChar; - -{TNT-WARN StringReplace} -{TNT-WARN WideStringReplace} // <-- WideStrUtils.WideStringReplace uses SysUtils.WideUpperCase which is broken on Win9x. -function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; - Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; - -{TNT-WARN AdjustLineBreaks} -type TTntTextLineBreakStyle = (tlbsLF, tlbsCRLF, tlbsCR); -function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; -function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; - -{TNT-WARN WrapText} -function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; - MaxCol: Integer): WideString; overload; -function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; overload; - -// ........ filename manipulation ......... - -{TNT-WARN SameFileName} // doesn't apply to Unicode filenames, use WideSameText -{TNT-WARN AnsiCompareFileName} // doesn't apply to Unicode filenames, use WideCompareText -{TNT-WARN AnsiLowerCaseFileName} // doesn't apply to Unicode filenames, use WideLowerCase -{TNT-WARN AnsiUpperCaseFileName} // doesn't apply to Unicode filenames, use WideUpperCase - -{TNT-WARN IncludeTrailingBackslash} -function WideIncludeTrailingBackslash(const S: WideString): WideString; -{TNT-WARN IncludeTrailingPathDelimiter} -function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; -{TNT-WARN ExcludeTrailingBackslash} -function WideExcludeTrailingBackslash(const S: WideString): WideString; -{TNT-WARN ExcludeTrailingPathDelimiter} -function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; -{TNT-WARN IsDelimiter} -function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; -{TNT-WARN IsPathDelimiter} -function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; -{TNT-WARN LastDelimiter} -function WideLastDelimiter(const Delimiters, S: WideString): Integer; -{TNT-WARN ChangeFileExt} -function WideChangeFileExt(const FileName, Extension: WideString): WideString; -{TNT-WARN ExtractFilePath} -function WideExtractFilePath(const FileName: WideString): WideString; -{TNT-WARN ExtractFileDir} -function WideExtractFileDir(const FileName: WideString): WideString; -{TNT-WARN ExtractFileDrive} -function WideExtractFileDrive(const FileName: WideString): WideString; -{TNT-WARN ExtractFileName} -function WideExtractFileName(const FileName: WideString): WideString; -{TNT-WARN ExtractFileExt} -function WideExtractFileExt(const FileName: WideString): WideString; -{TNT-WARN ExtractRelativePath} -function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; - -// ........ file management routines ......... - -{TNT-WARN ExpandFileName} -function WideExpandFileName(const FileName: WideString): WideString; -{TNT-WARN ExtractShortPathName} -function WideExtractShortPathName(const FileName: WideString): WideString; -{TNT-WARN FileCreate} -function WideFileCreate(const FileName: WideString): Integer; -{TNT-WARN FileOpen} -function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; -{TNT-WARN FileAge} -function WideFileAge(const FileName: WideString): Integer; overload; -function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; overload; -{TNT-WARN DirectoryExists} -function WideDirectoryExists(const Name: WideString): Boolean; -{TNT-WARN FileExists} -function WideFileExists(const Name: WideString): Boolean; -{TNT-WARN FileGetAttr} -function WideFileGetAttr(const FileName: WideString): Cardinal; -{TNT-WARN FileSetAttr} -function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; -{TNT-WARN FileIsReadOnly} -function WideFileIsReadOnly(const FileName: WideString): Boolean; -{TNT-WARN FileSetReadOnly} -function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; -{TNT-WARN ForceDirectories} -function WideForceDirectories(Dir: WideString): Boolean; -{TNT-WARN FileSearch} -function WideFileSearch(const Name, DirList: WideString): WideString; -{TNT-WARN RenameFile} -function WideRenameFile(const OldName, NewName: WideString): Boolean; -{TNT-WARN DeleteFile} -function WideDeleteFile(const FileName: WideString): Boolean; -{TNT-WARN CopyFile} -function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; - - -{TNT-WARN TFileName} -type - TWideFileName = type WideString; - -{TNT-WARN TSearchRec} // <-- FindFile - warning on TSearchRec is all that is necessary -type - TSearchRecW = record - Time: Integer; - Size: Int64; - Attr: Integer; - Name: TWideFileName; - ExcludeAttr: Integer; - FindHandle: THandle; - FindData: TWin32FindDataW; - end; -function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; -function WideFindNext(var F: TSearchRecW): Integer; -procedure WideFindClose(var F: TSearchRecW); - -{TNT-WARN CreateDir} -function WideCreateDir(const Dir: WideString): Boolean; -{TNT-WARN RemoveDir} -function WideRemoveDir(const Dir: WideString): Boolean; -{TNT-WARN GetCurrentDir} -function WideGetCurrentDir: WideString; -{TNT-WARN SetCurrentDir} -function WideSetCurrentDir(const Dir: WideString): Boolean; - - -// ........ date/time functions ......... - -{TNT-WARN TryStrToDateTime} -function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; -{TNT-WARN TryStrToDate} -function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; -{TNT-WARN TryStrToTime} -function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; - -{ introduced } -function ValidDateTimeStr(Str: WideString): Boolean; -function ValidDateStr(Str: WideString): Boolean; -function ValidTimeStr(Str: WideString): Boolean; - -{TNT-WARN StrToDateTime} -function TntStrToDateTime(Str: WideString): TDateTime; -{TNT-WARN StrToDate} -function TntStrToDate(Str: WideString): TDateTime; -{TNT-WARN StrToTime} -function TntStrToTime(Str: WideString): TDateTime; -{TNT-WARN StrToDateTimeDef} -function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; -{TNT-WARN StrToDateDef} -function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; -{TNT-WARN StrToTimeDef} -function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; - -{TNT-WARN CurrToStr} -{TNT-WARN CurrToStrF} -function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; -{TNT-WARN StrToCurr} -function TntStrToCurr(const S: WideString): Currency; -{TNT-WARN StrToCurrDef} -function ValidCurrencyStr(const S: WideString): Boolean; -function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; -function GetDefaultCurrencyFmt: TCurrencyFmtW; - -// ........ misc functions ......... - -{TNT-WARN GetLocaleStr} -function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; -{TNT-WARN SysErrorMessage} -function WideSysErrorMessage(ErrorCode: Integer): WideString; - -// ......... introduced ......... - -function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; - -const - CR = WideChar(#13); - LF = WideChar(#10); - CRLF = WideString(#13#10); - WideLineSeparator = WideChar($2028); - -var - Win32PlatformIsUnicode: Boolean; - Win32PlatformIsXP: Boolean; - Win32PlatformIs2003: Boolean; - Win32PlatformIsVista: Boolean; - -{$IFNDEF FPC} -{$IFNDEF COMPILER_7_UP} -function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; -{$ENDIF} -{$ENDIF} -function WinCheckH(RetVal: Cardinal): Cardinal; -function WinCheckFileH(RetVal: Cardinal): Cardinal; -function WinCheckP(RetVal: Pointer): Pointer; - -function WideGetModuleFileName(Instance: HModule): WideString; -function WideSafeLoadLibrary(const Filename: Widestring; - ErrorMode: UINT = SEM_NOOPENFILEERRORBOX): HMODULE; -{$IFNDEF FPC} -function WideLoadPackage(const Name: Widestring): HMODULE; -{$ENDIF} - -function IsWideCharUpper(WC: WideChar): Boolean; -function IsWideCharLower(WC: WideChar): Boolean; -function IsWideCharDigit(WC: WideChar): Boolean; -function IsWideCharSpace(WC: WideChar): Boolean; -function IsWideCharPunct(WC: WideChar): Boolean; -function IsWideCharCntrl(WC: WideChar): Boolean; -function IsWideCharBlank(WC: WideChar): Boolean; -function IsWideCharXDigit(WC: WideChar): Boolean; -function IsWideCharAlpha(WC: WideChar): Boolean; -function IsWideCharAlphaNumeric(WC: WideChar): Boolean; - -function WideTextPos(const SubStr, S: WideString): Integer; - -function ExtractStringArrayStr(P: PWideChar): WideString; -function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; -function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; - -function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; -function IsWideStringMappableToAnsi(const WS: WideString): Boolean; -function IsRTF(const Value: WideString): Boolean; - -function ENG_US_FloatToStr(Value: Extended): WideString; -function ENG_US_StrToFloat(const S: WideString): Extended; - -//--------------------------------------------------------------------------------------------- -// Tnt - Variants -//--------------------------------------------------------------------------------------------- - -// ........ Variants.pas has WideString versions of these functions ......... -{TNT-WARN VarToStr} -{TNT-WARN VarToStrDef} - -var - _SettingChangeTime: Cardinal; - -implementation - -uses - ActiveX, ComObj, SysConst, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils, - TntSystem, TntFormatStrUtils; - -//--------------------------------------------------------------------------------------------- -// Tnt - SysUtils -//--------------------------------------------------------------------------------------------- - -{$IFNDEF FPC} -{$IFNDEF COMPILER_9_UP} - - function _Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const - {$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings {$ENDIF}): Cardinal; - var - OldFormat: WideString; - NewFormat: WideString; - begin - SetString(OldFormat, PWideChar(@FormatStr), FmtLen); - { The reason for this is that WideFormat doesn't correctly format floating point specifiers. - See QC#4254. } - NewFormat := ReplaceFloatingArgumentsInFormatString(OldFormat, Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); - {$IFDEF COMPILER_7_UP} - if FormatSettings <> nil then - Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, - Length(NewFormat), Args, FormatSettings^) - else - {$ENDIF} - Result := WideFormatBuf(Buffer, BufLen, Pointer(NewFormat)^, - Length(NewFormat), Args); - end; - - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const): Cardinal; - begin - Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); - end; - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormatBuf(var Buffer; BufLen: Cardinal; const FormatStr; - FmtLen: Cardinal; const Args: array of const; const FormatSettings: TFormatSettings): Cardinal; - begin - Result := _Tnt_WideFormatBuf(Buffer, BufLen, FormatStr, FmtLen, Args, @FormatSettings); - end; - {$ENDIF} - - procedure _Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const{$IFDEF COMPILER_7_UP}; const FormatSettings: PFormatSettings{$ENDIF}); - var - Len, BufLen: Integer; - Buffer: array[0..4095] of WideChar; - begin - BufLen := Length(Buffer); // Fixes buffer overwrite issue. (See QC #4703, #4744) - if Length(FormatStr) < (Length(Buffer) - (Length(Buffer) div 4)) then - Len := _Tnt_WideFormatBuf(Buffer, Length(Buffer) - 1, Pointer(FormatStr)^, - Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}) - else - begin - BufLen := Length(FormatStr); - Len := BufLen; - end; - if Len >= BufLen - 1 then - begin - while Len >= BufLen - 1 do - begin - Inc(BufLen, BufLen); - Result := ''; // prevent copying of existing data, for speed - SetLength(Result, BufLen); - Len := _Tnt_WideFormatBuf(Pointer(Result)^, BufLen - 1, Pointer(FormatStr)^, - Length(FormatStr), Args{$IFDEF COMPILER_7_UP}, FormatSettings{$ENDIF}); - end; - SetLength(Result, Len); - end - else - SetString(Result, Buffer, Len); - end; - - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const); - begin - _Tnt_WideFmtStr(Result, FormatStr, Args{$IFDEF COMPILER_7_UP}, nil{$ENDIF}); - end; - - {$IFDEF COMPILER_7_UP} - procedure Tnt_WideFmtStr(var Result: WideString; const FormatStr: WideString; - const Args: array of const; const FormatSettings: TFormatSettings); - begin - _Tnt_WideFmtStr(Result, FormatStr, Args, @FormatSettings); - end; - {$ENDIF} - - {---------------------------------------------------------------------------------------- - Without the FormatSettings parameter, Tnt_WideFormat is *NOT* necessary... - TntSystem.InstallTntSystemUpdates([tsFixWideFormat]); - will fix WideFormat as well as WideFmtStr. - ----------------------------------------------------------------------------------------} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const): WideString; - begin - Tnt_WideFmtStr(Result, FormatStr, Args); - end; - - {$IFDEF COMPILER_7_UP} - function Tnt_WideFormat(const FormatStr: WideString; const Args: array of const; - const FormatSettings: TFormatSettings): WideString; - begin - Tnt_WideFmtStr(Result, FormatStr, Args, FormatSettings); - end; - {$ENDIF} - -{$ENDIF} -{$ENDIF FPC} - -function Tnt_WideUpperCase(const S: WideString): WideString; -begin - {$IFNDEF FPC} - {$IFNDEF COMPILER_10_UP} - {$DEFINE WIDEUPPERCASE_BROKEN} - {$ENDIF} - {$ENDIF} - {$IFDEF WIDEUPPERCASE_BROKEN} - { SysUtils.WideUpperCase is broken for Win9x. } - Result := S; - if Length(Result) > 0 then - Tnt_CharUpperBuffW(PWideChar(Result), Length(Result)); - {$ELSE} - Result := SysUtils.WideUpperCase{TNT-ALLOW WideUpperCase}(S); - {$ENDIF} -end; - -function Tnt_WideLowerCase(const S: WideString): WideString; -begin - {$IFNDEF FPC} - {$IFNDEF COMPILER_10_UP} - {$DEFINE WIDELOWERCASE_BROKEN} - {$ENDIF} - {$ENDIF} - {$IFDEF WIDELOWERCASE_BROKEN} - { SysUtils.WideLowerCase is broken for Win9x. } - Result := S; - if Length(Result) > 0 then - Tnt_CharLowerBuffW(PWideChar(Result), Length(Result)); - {$ELSE} - Result := SysUtils.WideLowerCase{TNT-ALLOW WideLowerCase}(S); - {$ENDIF} -end; - -function TntWideLastChar(const S: WideString): WideChar; -var - P: PWideChar; -begin - P := WideLastChar(S); - if P = nil then - Result := #0 - else - Result := P^; -end; - -function Tnt_WideStringReplace(const S, OldPattern, NewPattern: WideString; - Flags: TReplaceFlags; WholeWord: Boolean = False): WideString; - - function IsWordSeparator(WC: WideChar): Boolean; - begin - Result := (WC = WideChar(#0)) - or IsWideCharSpace(WC) - or IsWideCharPunct(WC); - end; - -var - SearchStr, Patt, NewStr: WideString; - Offset: Integer; - PrevChar, NextChar: WideChar; -begin - if rfIgnoreCase in Flags then - begin - SearchStr := Tnt_WideUpperCase(S); - Patt := Tnt_WideUpperCase(OldPattern); - end else - begin - SearchStr := S; - Patt := OldPattern; - end; - NewStr := S; - Result := ''; - while SearchStr <> '' do - begin - Offset := Pos(Patt, SearchStr); - if Offset = 0 then - begin - Result := Result + NewStr; - Break; - end; // done - - if (WholeWord) then - begin - if (Offset = 1) then - PrevChar := TntWideLastChar(Result) - else - PrevChar := NewStr[Offset - 1]; - - if Offset + Length(OldPattern) <= Length(NewStr) then - NextChar := NewStr[Offset + Length(OldPattern)] - else - NextChar := WideChar(#0); - - if (not IsWordSeparator(PrevChar)) - or (not IsWordSeparator(NextChar)) then - begin - Result := Result + Copy(NewStr, 1, Offset + Length(OldPattern) - 1); - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); - continue; - end; - end; - - Result := Result + Copy(NewStr, 1, Offset - 1) + NewPattern; - NewStr := Copy(NewStr, Offset + Length(OldPattern), MaxInt); - if not (rfReplaceAll in Flags) then - begin - Result := Result + NewStr; - Break; - end; - SearchStr := Copy(SearchStr, Offset + Length(Patt), MaxInt); - end; -end; - -function TntAdjustLineBreaksLength(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): Integer; -var - Source, SourceEnd: PWideChar; -begin - Source := Pointer(S); - SourceEnd := Source + Length(S); - Result := Length(S); - while Source < SourceEnd do - begin - case Source^ of - #10, WideLineSeparator: - if Style = tlbsCRLF then - Inc(Result); - #13: - if Style = tlbsCRLF then - if Source[1] = #10 then - Inc(Source) - else - Inc(Result) - else - if Source[1] = #10 then - Dec(Result); - end; - Inc(Source); - end; -end; - -function TntAdjustLineBreaks(const S: WideString; Style: TTntTextLineBreakStyle = tlbsCRLF): WideString; -var - Source, SourceEnd, Dest: PWideChar; - DestLen: Integer; -begin - Source := Pointer(S); - SourceEnd := Source + Length(S); - DestLen := TntAdjustLineBreaksLength(S, Style); - SetString(Result, nil, DestLen); - Dest := Pointer(Result); - while Source < SourceEnd do begin - case Source^ of - #10, WideLineSeparator: - begin - if Style in [tlbsCRLF, tlbsCR] then - begin - Dest^ := #13; - Inc(Dest); - end; - if Style in [tlbsCRLF, tlbsLF] then - begin - Dest^ := #10; - Inc(Dest); - end; - Inc(Source); - end; - #13: - begin - if Style in [tlbsCRLF, tlbsCR] then - begin - Dest^ := #13; - Inc(Dest); - end; - if Style in [tlbsCRLF, tlbsLF] then - begin - Dest^ := #10; - Inc(Dest); - end; - Inc(Source); - if Source^ = #10 then Inc(Source); - end; - else - Dest^ := Source^; - Inc(Dest); - Inc(Source); - end; - end; -end; - -function WideWrapText(const Line, BreakStr: WideString; const BreakChars: TSysCharSet; - MaxCol: Integer): WideString; - - function WideCharIn(C: WideChar; SysCharSet: TSysCharSet): Boolean; - begin - Result := (C <= High(AnsiChar)) and (AnsiChar(C) in SysCharSet); - end; - -const - QuoteChars = ['''', '"']; -var - Col, Pos: Integer; - LinePos, LineLen: Integer; - BreakLen, BreakPos: Integer; - QuoteChar, CurChar: WideChar; - ExistingBreak: Boolean; -begin - Col := 1; - Pos := 1; - LinePos := 1; - BreakPos := 0; - QuoteChar := ' '; - ExistingBreak := False; - LineLen := Length(Line); - BreakLen := Length(BreakStr); - Result := ''; - while Pos <= LineLen do - begin - CurChar := Line[Pos]; - if CurChar = BreakStr[1] then - begin - if QuoteChar = ' ' then - begin - ExistingBreak := WideSameText(BreakStr, Copy(Line, Pos, BreakLen)); - if ExistingBreak then - begin - Inc(Pos, BreakLen-1); - BreakPos := Pos; - end; - end - end - else if WideCharIn(CurChar, BreakChars) then - begin - if QuoteChar = ' ' then BreakPos := Pos - end - else if WideCharIn(CurChar, QuoteChars) then - begin - if CurChar = QuoteChar then - QuoteChar := ' ' - else if QuoteChar = ' ' then - QuoteChar := CurChar; - end; - Inc(Pos); - Inc(Col); - if not (WideCharIn(QuoteChar, QuoteChars)) and (ExistingBreak or - ((Col > MaxCol) and (BreakPos > LinePos))) then - begin - Col := Pos - BreakPos; - Result := Result + Copy(Line, LinePos, BreakPos - LinePos + 1); - if not (WideCharIn(CurChar, QuoteChars)) then - while Pos <= LineLen do - begin - if WideCharIn(Line[Pos], BreakChars) then - Inc(Pos) - else if Copy(Line, Pos, Length(sLineBreak)) = sLineBreak then - Inc(Pos, Length(sLineBreak)) - else - break; - end; - if not ExistingBreak and (Pos < LineLen) then - Result := Result + BreakStr; - Inc(BreakPos); - LinePos := BreakPos; - ExistingBreak := False; - end; - end; - Result := Result + Copy(Line, LinePos, MaxInt); -end; - -function WideWrapText(const Line: WideString; MaxCol: Integer): WideString; -begin - Result := WideWrapText(Line, sLineBreak, [' ', '-', #9], MaxCol); { do not localize } -end; - -function WideIncludeTrailingBackslash(const S: WideString): WideString; -begin - Result := WideIncludeTrailingPathDelimiter(S); -end; - -function WideIncludeTrailingPathDelimiter(const S: WideString): WideString; -begin - Result := S; - if not WideIsPathDelimiter(Result, Length(Result)) then Result := Result + PathDelim; -end; - -function WideExcludeTrailingBackslash(const S: WideString): WideString; -begin - Result := WideExcludeTrailingPathDelimiter(S); -end; - -function WideExcludeTrailingPathDelimiter(const S: WideString): WideString; -begin - Result := S; - if WideIsPathDelimiter(Result, Length(Result)) then - SetLength(Result, Length(Result)-1); -end; - -function WideIsDelimiter(const Delimiters, S: WideString; Index: Integer): Boolean; -begin - Result := False; - if (Index <= 0) or (Index > Length(S)) then exit; - Result := WStrScan(PWideChar(Delimiters), S[Index]) <> nil; -end; - -function WideIsPathDelimiter(const S: WideString; Index: Integer): Boolean; -begin - Result := (Index > 0) and (Index <= Length(S)) and (S[Index] = PathDelim); -end; - -function WideLastDelimiter(const Delimiters, S: WideString): Integer; -var - P: PWideChar; -begin - Result := Length(S); - P := PWideChar(Delimiters); - while Result > 0 do - begin - if (S[Result] <> #0) and (WStrScan(P, S[Result]) <> nil) then - Exit; - Dec(Result); - end; -end; - -function WideChangeFileExt(const FileName, Extension: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('.\:',Filename); - if (I = 0) or (FileName[I] <> '.') then I := MaxInt; - Result := Copy(FileName, 1, I - 1) + Extension; -end; - -function WideExtractFilePath(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('\:', FileName); - Result := Copy(FileName, 1, I); -end; - -function WideExtractFileDir(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter(DriveDelim + PathDelim,Filename); - if (I > 1) and (FileName[I] = PathDelim) and - (not (FileName[I - 1] in [WideChar(PathDelim), WideChar(DriveDelim)])) then Dec(I); - Result := Copy(FileName, 1, I); -end; - -function WideExtractFileDrive(const FileName: WideString): WideString; -var - I, J: Integer; -begin - if (Length(FileName) >= 2) and (FileName[2] = DriveDelim) then - Result := Copy(FileName, 1, 2) - else if (Length(FileName) >= 2) and (FileName[1] = PathDelim) and - (FileName[2] = PathDelim) then - begin - J := 0; - I := 3; - While (I < Length(FileName)) and (J < 2) do - begin - if FileName[I] = PathDelim then Inc(J); - if J < 2 then Inc(I); - end; - if FileName[I] = PathDelim then Dec(I); - Result := Copy(FileName, 1, I); - end else Result := ''; -end; - -function WideExtractFileName(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('\:', FileName); - Result := Copy(FileName, I + 1, MaxInt); -end; - -function WideExtractFileExt(const FileName: WideString): WideString; -var - I: Integer; -begin - I := WideLastDelimiter('.\:', FileName); - if (I > 0) and (FileName[I] = '.') then - Result := Copy(FileName, I, MaxInt) else - Result := ''; -end; - -function WideExtractRelativePath(const BaseName, DestName: WideString): WideString; -var - BasePath, DestPath: WideString; - BaseLead, DestLead: PWideChar; - BasePtr, DestPtr: PWideChar; - - function WideExtractFilePathNoDrive(const FileName: WideString): WideString; - begin - Result := WideExtractFilePath(FileName); - Delete(Result, 1, Length(WideExtractFileDrive(FileName))); - end; - - function Next(var Lead: PWideChar): PWideChar; - begin - Result := Lead; - if Result = nil then Exit; - Lead := WStrScan(Lead, PathDelim); - if Lead <> nil then - begin - Lead^ := #0; - Inc(Lead); - end; - end; - -begin - if WideSameText(WideExtractFileDrive(BaseName), WideExtractFileDrive(DestName)) then - begin - BasePath := WideExtractFilePathNoDrive(BaseName); - DestPath := WideExtractFilePathNoDrive(DestName); - BaseLead := Pointer(BasePath); - BasePtr := Next(BaseLead); - DestLead := Pointer(DestPath); - DestPtr := Next(DestLead); - while (BasePtr <> nil) and (DestPtr <> nil) and WideSameText(BasePtr, DestPtr) do - begin - BasePtr := Next(BaseLead); - DestPtr := Next(DestLead); - end; - Result := ''; - while BaseLead <> nil do - begin - Result := Result + '..' + PathDelim; { Do not localize } - Next(BaseLead); - end; - if (DestPtr <> nil) and (DestPtr^ <> #0) then - Result := Result + DestPtr + PathDelim; - if DestLead <> nil then - Result := Result + DestLead; // destlead already has a trailing backslash - Result := Result + WideExtractFileName(DestName); - end - else - Result := DestName; -end; - -function WideExpandFileName(const FileName: WideString): WideString; -var - FName: PWideChar; - Buffer: array[0..MAX_PATH - 1] of WideChar; -begin - SetString(Result, Buffer, Tnt_GetFullPathNameW(PWideChar(FileName), MAX_PATH, Buffer, FName)); -end; - -function WideExtractShortPathName(const FileName: WideString): WideString; -var - Buffer: array[0..MAX_PATH - 1] of WideChar; -begin - SetString(Result, Buffer, Tnt_GetShortPathNameW(PWideChar(FileName), Buffer, MAX_PATH)); -end; - -function WideFileCreate(const FileName: WideString): Integer; -begin - Result := Integer(Tnt_CreateFileW(PWideChar(FileName), GENERIC_READ or GENERIC_WRITE, - 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0)) -end; - -function WideFileOpen(const FileName: WideString; Mode: LongWord): Integer; -const - AccessMode: array[0..2] of LongWord = ( - GENERIC_READ, - GENERIC_WRITE, - GENERIC_READ or GENERIC_WRITE); - ShareMode: array[0..4] of LongWord = ( - 0, - 0, - FILE_SHARE_READ, - FILE_SHARE_WRITE, - FILE_SHARE_READ or FILE_SHARE_WRITE); -begin - Result := Integer(Tnt_CreateFileW(PWideChar(FileName), AccessMode[Mode and 3], - ShareMode[(Mode and $F0) shr 4], nil, OPEN_EXISTING, - FILE_ATTRIBUTE_NORMAL, 0)); -end; - -function WideFileAge(const FileName: WideString): Integer; -var - Handle: THandle; - FindData: TWin32FindDataW; - LocalFileTime: TFileTime; -begin - Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - begin - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - if FileTimeToDosDateTime(LocalFileTime, LongRec(Result).Hi, LongRec(Result).Lo) then - Exit - end; - end; - Result := -1; -end; - -function WideFileAge(const FileName: WideString; out FileDateTime: TDateTime): Boolean; -var - Handle: THandle; - FindData: TWin32FindDataW; - LSystemTime: TSystemTime; - LocalFileTime: TFileTime; -begin - Result := False; - Handle := Tnt_FindFirstFileW(PWideChar(FileName), FindData); - if Handle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(Handle); - if (FindData.dwFileAttributes and FILE_ATTRIBUTE_DIRECTORY) = 0 then - begin - Result := True; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToSystemTime(LocalFileTime, LSystemTime); - with LSystemTime do - FileDateTime := EncodeDate(wYear, wMonth, wDay) + - EncodeTime(wHour, wMinute, wSecond, wMilliSeconds); - end; - end; -end; - -function WideDirectoryExists(const Name: WideString): Boolean; -var - Code: Cardinal; -begin - Code := WideFileGetAttr(Name); - Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) <> 0); -end; - -function WideFileExists(const Name: WideString): Boolean; -var - Code: Cardinal; -begin - Code := WideFileGetAttr(Name); - Result := (Code <> INVALID_FILE_ATTRIBUTES) and ((FILE_ATTRIBUTE_DIRECTORY and Code) = 0); -end; - -function WideFileGetAttr(const FileName: WideString): Cardinal; -begin - Result := Tnt_GetFileAttributesW(PWideChar(FileName)); -end; - -function WideFileSetAttr(const FileName: WideString; Attr: Integer): Boolean; -begin - Result := Tnt_SetFileAttributesW(PWideChar(FileName), Attr) -end; - -function WideFileIsReadOnly(const FileName: WideString): Boolean; -begin - Result := (Tnt_GetFileAttributesW(PWideChar(FileName)) and faReadOnly) <> 0; -end; - -function WideFileSetReadOnly(const FileName: WideString; ReadOnly: Boolean): Boolean; -var - Flags: Integer; -begin - Result := False; - Flags := Tnt_GetFileAttributesW(PWideChar(FileName)); - if Flags = -1 then Exit; - if ReadOnly then - Flags := Flags or faReadOnly - else - Flags := Flags and not faReadOnly; - Result := Tnt_SetFileAttributesW(PWideChar(FileName), Flags); -end; - -function WideForceDirectories(Dir: WideString): Boolean; -begin - Result := True; - if Length(Dir) = 0 then - raise ETntGeneralError.Create( - {$IFNDEF FPC} SCannotCreateDir {$ELSE} SCannotCreateEmptyDir {$ENDIF}); - Dir := WideExcludeTrailingBackslash(Dir); - if (Length(Dir) < 3) or WideDirectoryExists(Dir) - or (WideExtractFilePath(Dir) = Dir) then Exit; // avoid 'xyz:\' problem. - Result := WideForceDirectories(WideExtractFilePath(Dir)); - if Result then - Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil) -end; - -function WideFileSearch(const Name, DirList: WideString): WideString; -var - I, P, L: Integer; - C: WideChar; -begin - Result := Name; - P := 1; - L := Length(DirList); - while True do - begin - if WideFileExists(Result) then Exit; - while (P <= L) and (DirList[P] = PathSep) do Inc(P); - if P > L then Break; - I := P; - while (P <= L) and (DirList[P] <> PathSep) do - Inc(P); - Result := Copy(DirList, I, P - I); - C := TntWideLastChar(Result); - if (C <> DriveDelim) and (C <> PathDelim) then - Result := Result + PathDelim; - Result := Result + Name; - end; - Result := ''; -end; - -function WideRenameFile(const OldName, NewName: WideString): Boolean; -begin - Result := Tnt_MoveFileW(PWideChar(OldName), PWideChar(NewName)) -end; - -function WideDeleteFile(const FileName: WideString): Boolean; -begin - Result := Tnt_DeleteFileW(PWideChar(FileName)) -end; - -function WideCopyFile(const FromFile, ToFile: WideString; FailIfExists: Boolean): Boolean; -begin - Result := Tnt_CopyFileW(PWideChar(FromFile), PWideChar(ToFile), FailIfExists) -end; - -function _WideFindMatchingFile(var F: TSearchRecW): Integer; -var - LocalFileTime: TFileTime; -begin - with F do - begin - while FindData.dwFileAttributes and ExcludeAttr <> 0 do - if not Tnt_FindNextFileW(FindHandle, FindData) then - begin - Result := GetLastError; - Exit; - end; - FileTimeToLocalFileTime(FindData.ftLastWriteTime, LocalFileTime); - FileTimeToDosDateTime(LocalFileTime, LongRec(Time).Hi, LongRec(Time).Lo); - Size := (Int64(FindData.nFileSizeHigh) shl 32) + FindData.nFileSizeLow; - Attr := FindData.dwFileAttributes; - Name := FindData.cFileName; - end; - Result := 0; -end; - -function WideFindFirst(const Path: WideString; Attr: Integer; var F: TSearchRecW): Integer; -const - faSpecial = faHidden or faSysFile {$IFNDEF COMPILER_9_UP} or faVolumeID {$ENDIF} or faDirectory; -begin - F.ExcludeAttr := not Attr and faSpecial; - F.FindHandle := Tnt_FindFirstFileW(PWideChar(Path), F.FindData); - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Result := _WideFindMatchingFile(F); - if Result <> 0 then WideFindClose(F); - end else - Result := GetLastError; -end; - -function WideFindNext(var F: TSearchRecW): Integer; -begin - if Tnt_FindNextFileW(F.FindHandle, F.FindData) then - Result := _WideFindMatchingFile(F) else - Result := GetLastError; -end; - -procedure WideFindClose(var F: TSearchRecW); -begin - if F.FindHandle <> INVALID_HANDLE_VALUE then - begin - Windows.FindClose(F.FindHandle); - F.FindHandle := INVALID_HANDLE_VALUE; - end; -end; - -function WideCreateDir(const Dir: WideString): Boolean; -begin - Result := Tnt_CreateDirectoryW(PWideChar(Dir), nil); -end; - -function WideRemoveDir(const Dir: WideString): Boolean; -begin - Result := Tnt_RemoveDirectoryW(PWideChar(Dir)); -end; - -function WideGetCurrentDir: WideString; -begin - SetLength(Result, MAX_PATH); - Tnt_GetCurrentDirectoryW(MAX_PATH, PWideChar(Result)); - Result := PWideChar(Result); -end; - -function WideSetCurrentDir(const Dir: WideString): Boolean; -begin - Result := Tnt_SetCurrentDirectoryW(PWideChar(Dir)); -end; - -//============================================================================================= -//== DATE/TIME STRING PARSING ================================================================ -//============================================================================================= - -{$IFDEF FPC} -const - VAR_TIMEVALUEONLY = 1; - VAR_DATEVALUEONLY = 2; -{$ENDIF} - -function _IntTryStrToDateTime(Str: WideString; Flags: Integer; out DateTime: TDateTime): HResult; -begin - Result := VarDateFromStr( - {$IFDEF FPC} POLECHAR(Str) {$ELSE} Str {$ENDIF}, - GetThreadLocale, Flags, Double(DateTime)); - if (not Succeeded(Result)) then begin - if (Flags = VAR_TIMEVALUEONLY) - and SysUtils.TryStrToTime{TNT-ALLOW TryStrToTime}(Str, DateTime) then - Result := S_OK // SysUtils seems confident (works for date = "dd.MM.yy" and time = "H.mm.ss") - else if (Flags = VAR_DATEVALUEONLY) - and SysUtils.TryStrToDate{TNT-ALLOW TryStrToDate}(Str, DateTime) then - Result := S_OK // SysUtils seems confident - else if (Flags = 0) - and SysUtils.TryStrToDateTime{TNT-ALLOW TryStrToDateTime}(Str, DateTime) then - Result := S_OK // SysUtils seems confident - end; -end; - -function TntTryStrToDateTime(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, 0, DateTime)); -end; - -function TntTryStrToDate(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, DateTime)); -end; - -function TntTryStrToTime(Str: WideString; out DateTime: TDateTime): Boolean; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, DateTime)); -end; - -function ValidDateTimeStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, 0, Temp)); -end; - -function ValidDateStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_DATEVALUEONLY, Temp)); -end; - -function ValidTimeStr(Str: WideString): Boolean; -var - Temp: TDateTime; -begin - Result := Succeeded(_IntTryStrToDateTime(Str, VAR_TIMEVALUEONLY, Temp)); -end; - -function TntStrToDateTimeDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToDateTime(Str, Result) then - Result := Default; -end; - -function TntStrToDateDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToDate(Str, Result) then - Result := Default; -end; - -function TntStrToTimeDef(Str: WideString; Default: TDateTime): TDateTime; -begin - if not TntTryStrToTime(Str, Result) then - Result := Default; -end; - -function _IntStrToDateTime(Str: WideString; Flags: Integer; ErrorFormatStr: WideString): TDateTime; -begin - try - OleCheck(_IntTryStrToDateTime(Str, Flags, Result)); - except - on E: Exception do begin - E.Message := E.Message + CRLF + WideFormat(ErrorFormatStr, [Str]); - raise EConvertError.Create(E.Message); - end; - end; -end; - -function TntStrToDateTime(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, 0, SInvalidDateTime); -end; - -function TntStrToDate(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, VAR_DATEVALUEONLY, - {$IFNDEF FPC} SInvalidDate {$ELSE} SInvalidDateTime {$ENDIF}); -end; - -function TntStrToTime(Str: WideString): TDateTime; -begin - Result := _IntStrToDateTime(Str, VAR_TIMEVALUEONLY, - {$IFNDEF FPC} SInvalidTime {$ELSE} SInvalidDateTime {$ENDIF}); -end; - -//============================================================================================= -//== CURRENCY STRING PARSING ================================================================= -//============================================================================================= - -function TntCurrToStr(Value: Currency; lpFormat: PCurrencyFmtW = nil): WideString; -const - MAX_BUFF_SIZE = 64; // can a currency string actually be larger? -var - ValueStr: WideString; -begin - // format lpValue using ENG-US settings - ValueStr := ENG_US_FloatToStr(Value); - // get currency format - SetLength(Result, MAX_BUFF_SIZE); - if 0 = Tnt_GetCurrencyFormatW(GetThreadLocale, 0, PWideChar(ValueStr), - lpFormat, PWideChar(Result), Length(Result)) - then begin - RaiseLastOSError; - end; - Result := PWideChar(Result); -end; - -function TntStrToCurr(const S: WideString): Currency; -begin - try - OleCheck(VarCyFromStr( - {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, - GetThreadLocale, 0, Result)); - except - on E: Exception do begin - E.Message := E.Message + CRLF + WideFormat(SInvalidCurrency, [S]); - raise EConvertError.Create(E.Message); - end; - end; -end; - -function ValidCurrencyStr(const S: WideString): Boolean; -var - Dummy: Currency; -begin - Result := Succeeded(VarCyFromStr( - {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, - GetThreadLocale, 0, Dummy)); -end; - -function TntStrToCurrDef(const S: WideString; const Default: Currency): Currency; -begin - if not Succeeded(VarCyFromStr( - {$IFDEF FPC} POLECHAR(S) {$ELSE} S {$ENDIF}, - GetThreadLocale, 0, Result)) then - Result := Default; -end; - -threadvar - Currency_DecimalSep: WideString; - Currency_ThousandSep: WideString; - Currency_CurrencySymbol: WideString; - -function GetDefaultCurrencyFmt: TCurrencyFmtW; -begin - ZeroMemory(@Result, SizeOf(Result)); - Result.NumDigits := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRDIGITS, '2'), 2); - Result.LeadingZero := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ILZERO, '1'), 1); - Result.Grouping := StrToIntDef(Copy(WideGetLocaleStr(GetThreadLocale, LOCALE_SMONGROUPING, '3;0'), 1, 1), 3); - Currency_DecimalSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONDECIMALSEP, '.'); - Result.lpDecimalSep := {$IFNDEF FPC} PWideChar(Currency_DecimalSep) - {$ELSE} LPTSTR(PWideChar(Currency_DecimalSep)) {$ENDIF}; - Currency_ThousandSep := WideGetLocaleStr(GetThreadLocale, LOCALE_SMONTHOUSANDSEP, ','); - Result.lpThousandSep := {$IFNDEF FPC} PWideChar(Currency_ThousandSep) - {$ELSE} LPTSTR(PWideChar(Currency_ThousandSep)) {$ENDIF}; - Result.NegativeOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_INEGCURR, '0'), 0); - Result.PositiveOrder := StrToIntDef(WideGetLocaleStr(GetThreadLocale, LOCALE_ICURRENCY, '0'), 0); - Currency_CurrencySymbol := WideGetLocaleStr(GetThreadLocale, LOCALE_SCURRENCY, ''); - Result.lpCurrencySymbol := {$IFNDEF FPC} PWideChar(Currency_CurrencySymbol) - {$ELSE} LPTSTR(PWideChar(Currency_CurrencySymbol)) {$ENDIF}; -end; - -//============================================================================================= - -{$IFDEF FPC} -function GetLocaleStr(Locale, LocaleType: Integer; const Default: string): string; -var - L: Integer; - Buffer: array[0..255] of Char; -begin - L := GetLocaleInfo(Locale, LocaleType, Buffer, SizeOf(Buffer)); - if L > 0 then SetString(Result, Buffer, L - 1) else Result := Default; -end; -{$ENDIF} - -function WideGetLocaleStr(LocaleID: LCID; LocaleType: Integer; const Default: WideString): WideString; -var - L: Integer; -begin - if (not Win32PlatformIsUnicode) then - Result := GetLocaleStr{TNT-ALLOW GetLocaleStr}(LocaleID, LocaleType, Default) - else begin - SetLength(Result, 255); - L := GetLocaleInfoW(LocaleID, LocaleType, PWideChar(Result), Length(Result)); - if L > 0 then - SetLength(Result, L - 1) - else - Result := Default; - end; -end; - -function WideSysErrorMessage(ErrorCode: Integer): WideString; -begin - Result := WideLibraryErrorMessage('system', 0, ErrorCode); -end; - -function WideLibraryErrorMessage(const LibName: WideString; Dll: THandle; ErrorCode: Integer): WideString; -var - Len: Integer; - AnsiResult: AnsiString; - Flags: Cardinal; -begin - Flags := FORMAT_MESSAGE_FROM_SYSTEM or FORMAT_MESSAGE_IGNORE_INSERTS or FORMAT_MESSAGE_ARGUMENT_ARRAY; - if Dll <> 0 then - Flags := Flags or FORMAT_MESSAGE_FROM_HMODULE; - if Win32PlatformIsUnicode then begin - SetLength(Result, 256); - Len := FormatMessageW(Flags, Pointer(Dll), ErrorCode, 0, PWideChar(Result), Length(Result), nil); - SetLength(Result, Len); - end else begin - SetLength(AnsiResult, 256); - Len := FormatMessageA(Flags, Pointer(Dll), ErrorCode, 0, PAnsiChar(AnsiResult), Length(AnsiResult), nil); - SetLength(AnsiResult, Len); - Result := AnsiResult; - end; - if Trim(Result) = '' then - Result := WideFormat('Unspecified error (%d) from %s.', [ErrorCode, LibName]); -end; - -{$IFNDEF COMPILER_7_UP} -function CheckWin32Version(AMajor: Integer; AMinor: Integer = 0): Boolean; -begin - Result := (Win32MajorVersion > AMajor) or - ((Win32MajorVersion = AMajor) and - (Win32MinorVersion >= AMinor)); -end; -{$ENDIF} - -function WinCheckH(RetVal: Cardinal): Cardinal; -begin - if RetVal = 0 then RaiseLastOSError; - Result := RetVal; -end; - -function WinCheckFileH(RetVal: Cardinal): Cardinal; -begin - if RetVal = INVALID_HANDLE_VALUE then RaiseLastOSError; - Result := RetVal; -end; - -function WinCheckP(RetVal: Pointer): Pointer; -begin - if RetVal = nil then RaiseLastOSError; - Result := RetVal; -end; - -function WideGetModuleFileName(Instance: HModule): WideString; -begin - SetLength(Result, MAX_PATH); - WinCheckH(Tnt_GetModuleFileNameW(Instance, PWideChar(Result), Length(Result))); - Result := PWideChar(Result) -end; - -function WideSafeLoadLibrary(const Filename: Widestring; ErrorMode: UINT): HMODULE; -var - OldMode: UINT; - FPUControlWord: Word; -begin - OldMode := SetErrorMode(ErrorMode); - try - asm - FNSTCW FPUControlWord - end; - try - Result := Tnt_LoadLibraryW(PWideChar(Filename)); - finally - asm - FNCLEX - FLDCW FPUControlWord - end; - end; - finally - SetErrorMode(OldMode); - end; -end; - -{$IFNDEF FPC} -function WideLoadPackage(const Name: Widestring): HMODULE; -begin - Result := WideSafeLoadLibrary(Name); - if Result = 0 then - begin - raise EPackageError.CreateFmt(sErrorLoadingPackage, [Name, WideSysErrorMessage(GetLastError)]); - end; - try - InitializePackage(Result); - except - FreeLibrary(Result); - raise; - end; -end; -{$ENDIF} - -function _WideCharType(WC: WideChar; dwInfoType: Cardinal): Word; -begin - Win32Check(Tnt_GetStringTypeExW(GetThreadLocale, dwInfoType, PWideChar(@WC), 1, Result)) -end; - -function IsWideCharUpper(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_UPPER) <> 0; -end; - -function IsWideCharLower(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_LOWER) <> 0; -end; - -function IsWideCharDigit(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_DIGIT) <> 0; -end; - -function IsWideCharSpace(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_SPACE) <> 0; -end; - -function IsWideCharPunct(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_PUNCT) <> 0; -end; - -function IsWideCharCntrl(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_CNTRL) <> 0; -end; - -function IsWideCharBlank(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_BLANK) <> 0; -end; - -function IsWideCharXDigit(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_XDIGIT) <> 0; -end; - -function IsWideCharAlpha(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and C1_ALPHA) <> 0; -end; - -function IsWideCharAlphaNumeric(WC: WideChar): Boolean; -begin - Result := (_WideCharType(WC, CT_CTYPE1) and (C1_ALPHA + C1_DIGIT)) <> 0; -end; - -function WideTextPos(const SubStr, S: WideString): Integer; -begin - Result := Pos(Tnt_WideUpperCase(SubStr), Tnt_WideUpperCase(S)); -end; - -function FindDoubleTerminator(P: PWideChar): PWideChar; -begin - Result := P; - while True do begin - Result := WStrScan(Result, #0); - Inc(Result); - if Result^ = #0 then begin - Dec(Result); - break; - end; - end; -end; - -function ExtractStringArrayStr(P: PWideChar): WideString; -var - PEnd: PWideChar; -begin - PEnd := FindDoubleTerminator(P); - Inc(PEnd, 2); // move past #0#0 - SetString(Result, P, PEnd - P); -end; - -function ExtractStringFromStringArray(var P: PWideChar; Separator: WideChar = #0): WideString; -var - Start: PWideChar; -begin - Start := P; - P := WStrScan(Start, Separator); - if P = nil then begin - Result := Start; - P := WStrEnd(Start); - end else begin - SetString(Result, Start, P - Start); - Inc(P); - end; -end; - -function ExtractStringsFromStringArray(P: PWideChar; Separator: WideChar = #0): TWideStringDynArray; -const - GROW_COUNT = 256; -var - Count: Integer; - Item: WideString; -begin - Count := 0; - SetLength(Result, GROW_COUNT); - Item := ExtractStringFromStringArray(P, Separator); - While Item <> '' do begin - if Count > High(Result) then - SetLength(Result, Length(Result) + GROW_COUNT); - Result[Count] := Item; - Inc(Count); - Item := ExtractStringFromStringArray(P, Separator); - end; - SetLength(Result, Count); -end; - -function IsWideCharMappableToAnsi(const WC: WideChar): Boolean; -var - UsedDefaultChar: BOOL; -begin - WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(@WC), 1, nil, 0, nil, @UsedDefaultChar); - Result := not UsedDefaultChar; -end; - -function IsWideStringMappableToAnsi(const WS: WideString): Boolean; -var - UsedDefaultChar: BOOL; -begin - WideCharToMultiByte(DefaultSystemCodePage, 0, PWideChar(WS), Length(WS), nil, 0, nil, @UsedDefaultChar); - Result := not UsedDefaultChar; -end; - -function IsRTF(const Value: WideString): Boolean; -const - RTF_BEGIN_1 = WideString('{\RTF'); - RTF_BEGIN_2 = WideString('{URTF'); -begin - Result := (WideTextPos(RTF_BEGIN_1, Value) = 1) - or (WideTextPos(RTF_BEGIN_2, Value) = 1); -end; - -{$IFDEF COMPILER_7_UP} -var - Cached_ENG_US_FormatSettings: TFormatSettings; - Cached_ENG_US_FormatSettings_Time: Cardinal; - -function ENG_US_FormatSettings: TFormatSettings; -begin - if Cached_ENG_US_FormatSettings_Time = _SettingChangeTime then - Result := Cached_ENG_US_FormatSettings - else begin - GetLocaleFormatSettings(MAKELCID(MAKELANGID(LANG_ENGLISH, SUBLANG_ENGLISH_US)), Result); - Result.DecimalSeparator := '.'; // ignore overrides - Cached_ENG_US_FormatSettings := Result; - Cached_ENG_US_FormatSettings_Time := _SettingChangeTime; - end; - end; - -function ENG_US_FloatToStr(Value: Extended): WideString; -begin - Result := FloatToStr(Value, ENG_US_FormatSettings); -end; - -function ENG_US_StrToFloat(const S: WideString): Extended; -begin - if not TextToFloat(PAnsiChar(AnsiString(S)), Result, fvExtended, ENG_US_FormatSettings) then - Result := StrToFloat(S); // try using native format -end; - -{$ELSE} - -function ENG_US_FloatToStr(Value: Extended): WideString; -var - SaveDecimalSep: AnsiChar; -begin - SaveDecimalSep := SysUtils.DecimalSeparator; - try - SysUtils.DecimalSeparator := '.'; - Result := FloatToStr(Value); - finally - SysUtils.DecimalSeparator := SaveDecimalSep; - end; -end; - -function ENG_US_StrToFloat(const S: WideString): Extended; -var - SaveDecimalSep: AnsiChar; -begin - try - SaveDecimalSep := SysUtils.DecimalSeparator; - try - SysUtils.DecimalSeparator := '.'; - Result := StrToFloat(S); - finally - SysUtils.DecimalSeparator := SaveDecimalSep; - end; - except - if SysUtils.DecimalSeparator <> '.' then - Result := StrToFloat(S) // try using native format - else - raise; - end; -end; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- -// Tnt - Variants -//--------------------------------------------------------------------------------------------- - -initialization - Win32PlatformIsUnicode := (Win32Platform = VER_PLATFORM_WIN32_NT); - Win32PlatformIsXP := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 1)) - or (Win32MajorVersion > 5); - Win32PlatformIs2003 := ((Win32MajorVersion = 5) and (Win32MinorVersion >= 2)) - or (Win32MajorVersion > 5); - Win32PlatformIsVista := (Win32MajorVersion >= 6); - -finalization - Currency_DecimalSep := ''; {make memory sleuth happy} - Currency_ThousandSep := ''; {make memory sleuth happy} - Currency_CurrencySymbol := ''; {make memory sleuth happy} - -end. diff --git a/src/lib/TntUnicodeControls/TntSystem.pas b/src/lib/TntUnicodeControls/TntSystem.pas deleted file mode 100644 index e613ce0c..00000000 --- a/src/lib/TntUnicodeControls/TntSystem.pas +++ /dev/null @@ -1,1427 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntSystem; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -{*****************************************************************************} -{ Special thanks go to Francisco Leong for originating the design for } -{ WideString-enabled resourcestrings. } -{*****************************************************************************} - -interface - -uses - Windows; - -// These functions should not be used by Delphi code since conversions are implicit. -{TNT-WARN WideCharToString} -{TNT-WARN WideCharLenToString} -{TNT-WARN WideCharToStrVar} -{TNT-WARN WideCharLenToStrVar} -{TNT-WARN StringToWideChar} - -// ................ ANSI TYPES ................ -{TNT-WARN Char} -{TNT-WARN PChar} -{TNT-WARN String} - -{TNT-WARN CP_ACP} // <-- use DefaultSystemCodePage -function DefaultSystemCodePage: Cardinal; // implicitly used when converting AnsiString <--> WideString. - -{$IFNDEF FPC} -var - WideCustomLoadResString: function(ResStringRec: PResStringRec; var Value: WideString): Boolean; -{$ENDIF} - -{TNT-WARN LoadResString} -function WideLoadResString(ResStringRec: PResStringRec): WideString; -{TNT-WARN ParamCount} -function WideParamCount: Integer; -{TNT-WARN ParamStr} -function WideParamStr(Index: Integer): WideString; - -// ......... introduced ......... - -const - { Each Unicode stream should begin with the code U+FEFF, } - { which the standard defines as the *byte order mark*. } - UNICODE_BOM = WideChar($FEFF); - UNICODE_BOM_SWAPPED = WideChar($FFFE); - UTF8_BOM = AnsiString(#$EF#$BB#$BF); - -function WideStringToUTF8(const S: WideString): AnsiString; -function UTF8ToWideString(const S: AnsiString): WideString; - -function WideStringToUTF7(const W: WideString): AnsiString; -function UTF7ToWideString(const S: AnsiString): WideString; - -function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; -function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; - -function UCS2ToWideString(const Value: AnsiString): WideString; -function WideStringToUCS2(const Value: WideString): AnsiString; - -function CharSetToCodePage(ciCharset: UINT): Cardinal; -function LCIDToCodePage(ALcid: LCID): Cardinal; -function KeyboardCodePage: Cardinal; -function KeyUnicode(CharCode: Word): WideChar; - -procedure StrSwapByteOrder(Str: PWideChar); - -{$IFDEF USE_SYSTEM_OVERRIDES} - -type - TTntSystemUpdate = - (tsWideResourceStrings - {$IFNDEF COMPILER_9_UP}, tsFixImplicitCodePage, tsFixWideStrConcat, tsFixWideFormat {$ENDIF} - ); - TTntSystemUpdateSet = set of TTntSystemUpdate; - -const - AllTntSystemUpdates = [Low(TTntSystemUpdate)..High(TTntSystemUpdate)]; - -procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); - -{$ENDIF USE_SYSTEM_OVERRIDES} - -implementation - -uses - SysUtils, Variants, TntWindows, TntSysUtils; - -var - GDefaultSystemCodePage: Cardinal; - -function DefaultSystemCodePage: Cardinal; -begin - Result := GDefaultSystemCodePage; -end; - -{$IFDEF USE_SYSTEM_OVERRIDES} -var - IsDebugging: Boolean; -{$ENDIF USE_SYSTEM_OVERRIDES} - -function WideLoadResStringDetect(ResStringRec: PResStringRec): WideString; -var - PCustom: PAnsiChar; -begin - // custom string pointer - PCustom := PAnsiChar(ResStringRec); { I would like to use PWideChar, but this would break legacy code. } - if (StrLen{TNT-ALLOW StrLen}(PCustom) > Cardinal(Length(UTF8_BOM))) - and CompareMem(PCustom, PAnsiChar(UTF8_BOM), Length(UTF8_BOM)) then - // detected UTF8 - Result := UTF8ToWideString(PAnsiChar(PCustom + Length(UTF8_BOM))) - else - // normal - Result := PCustom; -end; - -{$IFNDEF FPC} - -function WideLoadResString(ResStringRec: PResStringRec): WideString; -const - MAX_RES_STRING_SIZE = 4097; { MSDN documents this as the maximum size of a string in table. } -var - Buffer: array [0..MAX_RES_STRING_SIZE] of WideChar; { Buffer leaves room for null terminator. } -begin - if Assigned(WideCustomLoadResString) and WideCustomLoadResString(ResStringRec, Result) then - exit; { a custom resourcestring has been loaded. } - - if ResStringRec = nil then - Result := '' - else if ResStringRec.Identifier < 64*1024 then - SetString(Result, Buffer, - Tnt_LoadStringW(FindResourceHInstance(ResStringRec.Module^), - ResStringRec.Identifier, Buffer, MAX_RES_STRING_SIZE)) - else begin - Result := WideLoadResStringDetect(ResStringRec); - end; -end; - -{$ELSE} - -function WideLoadResString(ResStringRec: PResStringRec): WideString; -begin - Result := WideLoadResStringDetect(ResStringRec); -end; - -{$ENDIF} - -function WideGetParamStr(P: PWideChar; var Param: WideString): PWideChar; -var - i, Len: Integer; - Start, S, Q: PWideChar; -begin - while True do - begin - while (P[0] <> #0) and (P[0] <= ' ') do - Inc(P); - if (P[0] = '"') and (P[1] = '"') then Inc(P, 2) else Break; - end; - Len := 0; - Start := P; - while P[0] > ' ' do - begin - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - begin - Q := P + 1; - Inc(Len, Q - P); - P := Q; - end; - if P[0] <> #0 then - Inc(P); - end - else - begin - Q := P + 1; - Inc(Len, Q - P); - P := Q; - end; - end; - - SetLength(Param, Len); - - P := Start; - S := PWideChar(Param); - i := 0; - while P[0] > ' ' do - begin - if P[0] = '"' then - begin - Inc(P); - while (P[0] <> #0) and (P[0] <> '"') do - begin - Q := P + 1; - while P < Q do - begin - S[i] := P^; - Inc(P); - Inc(i); - end; - end; - if P[0] <> #0 then Inc(P); - end - else - begin - Q := P + 1; - while P < Q do - begin - S[i] := P^; - Inc(P); - Inc(i); - end; - end; - end; - - Result := P; -end; - -function WideParamCount: Integer; -var - P: PWideChar; - S: WideString; -begin - P := WideGetParamStr(GetCommandLineW, S); - Result := 0; - while True do - begin - P := WideGetParamStr(P, S); - if S = '' then Break; - Inc(Result); - end; -end; - -function WideParamStr(Index: Integer): WideString; -var - P: PWideChar; -begin - if Index = 0 then - Result := WideGetModuleFileName(0) - else - begin - P := GetCommandLineW; - while True do - begin - P := WideGetParamStr(P, Result); - if (Index = 0) or (Result = '') then Break; - Dec(Index); - end; - end; -end; - -function WideStringToUTF8(const S: WideString): AnsiString; -begin - Result := UTF8Encode(S); -end; - -function UTF8ToWideString(const S: AnsiString): WideString; -begin - Result := UTF8Decode(S); -end; - - { ======================================================================= } - { Original File: ConvertUTF7.c } - { Author: David B. Goldsmith } - { Copyright (C) 1994, 1996 Taligent, Inc. All rights reserved. } - { } - { This code is copyrighted. Under the copyright laws, this code may not } - { be copied, in whole or part, without prior written consent of Taligent. } - { } - { Taligent grants the right to use this code as long as this ENTIRE } - { copyright notice is reproduced in the code. The code is provided } - { AS-IS, AND TALIGENT DISCLAIMS ALL WARRANTIES, EITHER EXPRESS OR } - { IMPLIED, INCLUDING, BUT NOT LIMITED TO IMPLIED WARRANTIES OF } - { MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT } - { WILL TALIGENT BE LIABLE FOR ANY DAMAGES WHATSOEVER (INCLUDING, } - { WITHOUT LIMITATION, DAMAGES FOR LOSS OF BUSINESS PROFITS, BUSINESS } - { INTERRUPTION, LOSS OF BUSINESS INFORMATION, OR OTHER PECUNIARY } - { LOSS) ARISING OUT OF THE USE OR INABILITY TO USE THIS CODE, EVEN } - { IF TALIGENT HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. } - { BECAUSE SOME STATES DO NOT ALLOW THE EXCLUSION OR LIMITATION OF } - { LIABILITY FOR CONSEQUENTIAL OR INCIDENTAL DAMAGES, THE ABOVE } - { LIMITATION MAY NOT APPLY TO YOU. } - { } - { RESTRICTED RIGHTS LEGEND: Use, duplication, or disclosure by the } - { government is subject to restrictions as set forth in subparagraph } - { (c)(l)(ii) of the Rights in Technical Data and Computer Software } - { clause at DFARS 252.227-7013 and FAR 52.227-19. } - { } - { This code may be protected by one or more U.S. and International } - { Patents. } - { } - { TRADEMARKS: Taligent and the Taligent Design Mark are registered } - { trademarks of Taligent, Inc. } - { ======================================================================= } - -type UCS2 = Word; - -const - _base64: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'; - _direct: AnsiString = 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789''(),-./:?'; - _optional: AnsiString = '!"#$%&*;<=>@[]^_`{|}'; - _spaces: AnsiString = #9#13#10#32; - -var - base64: PAnsiChar; - invbase64: array[0..127] of SmallInt; - direct: PAnsiChar; - optional: PAnsiChar; - spaces: PAnsiChar; - mustshiftsafe: array[0..127] of AnsiChar; - mustshiftopt: array[0..127] of AnsiChar; - -var - needtables: Boolean = True; - -procedure Initialize_UTF7_Data; -begin - base64 := PAnsiChar(_base64); - direct := PAnsiChar(_direct); - optional := PAnsiChar(_optional); - spaces := PAnsiChar(_spaces); -end; - -procedure tabinit; -var - i: Integer; - limit: Integer; -begin - i := 0; - while (i < 128) do - begin - mustshiftopt[i] := #1; - mustshiftsafe[i] := #1; - invbase64[i] := -1; - Inc(i); - end { For }; - limit := Length(_Direct); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(direct[i])] := #0; - mustshiftsafe[Integer(direct[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Spaces); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(spaces[i])] := #0; - mustshiftsafe[Integer(spaces[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Optional); - i := 0; - while (i < limit) do - begin - mustshiftopt[Integer(optional[i])] := #0; - Inc(i); - end { For }; - limit := Length(_Base64); - i := 0; - while (i < limit) do - begin - invbase64[Integer(base64[i])] := i; - Inc(i); - end { For }; - needtables := False; -end; { tabinit } - -function WRITE_N_BITS(x: UCS2; n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): Integer; -begin - BITbuffer := BITbuffer or (x and (not (-1 shl n))) shl (32 - n - bufferbits); - bufferbits := bufferbits + n; - Result := bufferbits; -end; { WRITE_N_BITS } - -function READ_N_BITS(n: Integer; var BITbuffer: Cardinal; var bufferbits: Integer): UCS2; -var - buffertemp: Cardinal; -begin - buffertemp := BITbuffer shr (32 - n); - BITbuffer := BITbuffer shl n; - bufferbits := bufferbits - n; - Result := UCS2(buffertemp); -end; { READ_N_BITS } - -function ConvertUCS2toUTF7(var sourceStart: PWideChar; sourceEnd: PWideChar; - var targetStart: PAnsiChar; targetEnd: PAnsiChar; optional: Boolean; - verbose: Boolean): Integer; -var - r: UCS2; - target: PAnsiChar; - source: PWideChar; - BITbuffer: Cardinal; - bufferbits: Integer; - shifted: Boolean; - needshift: Boolean; - done: Boolean; - mustshift: PAnsiChar; -begin - Initialize_UTF7_Data; - Result := 0; - BITbuffer := 0; - bufferbits := 0; - shifted := False; - source := sourceStart; - target := targetStart; - r := 0; - if needtables then - tabinit; - if optional then - mustshift := @mustshiftopt[0] - else - mustshift := @mustshiftsafe[0]; - repeat - done := source >= sourceEnd; - if not Done then - begin - r := Word(source^); - Inc(Source); - end { If }; - needshift := (not done) and ((r > $7F) or (mustshift[r] <> #0)); - if needshift and (not shifted) then - begin - if (Target >= TargetEnd) then - begin - Result := 2; - break; - end { If }; - target^ := '+'; - Inc(target); - { Special case handling of the SHIFT_IN character } - if (r = UCS2('+')) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end; - target^ := '-'; - Inc(target); - end - else - shifted := True; - end { If }; - if shifted then - begin - { Either write the character to the bit buffer, or pad } - { the bit buffer out to a full base64 character. } - { } - if needshift then - WRITE_N_BITS(r, 16, BITbuffer, bufferbits) - else - WRITE_N_BITS(0, (6 - (bufferbits mod 6)) mod 6, BITbuffer, - bufferbits); - { Flush out as many full base64 characters as possible } - { from the bit buffer. } - { } - while (target < targetEnd) and (bufferbits >= 6) do - begin - Target^ := base64[READ_N_BITS(6, BITbuffer, bufferbits)]; - Inc(Target); - end { While }; - if (bufferbits >= 6) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - end { If }; - if (not needshift) then - begin - { Write the explicit shift out character if } - { 1) The caller has requested we always do it, or } - { 2) The directly encoded character is in the } - { base64 set, or } - { 3) The directly encoded character is SHIFT_OUT. } - { } - if verbose or ((not done) and ((invbase64[r] >= 0) or (r = - Integer('-')))) then - begin - if (target >= targetEnd) then - begin - Result := 2; - Break; - end { If }; - Target^ := '-'; - Inc(Target); - end { If }; - shifted := False; - end { If }; - { The character can be directly encoded as ASCII. } - end { If }; - if (not needshift) and (not done) then - begin - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := AnsiChar(r); - Inc(Target); - end { If }; - until (done); - sourceStart := source; - targetStart := target; -end; { ConvertUCS2toUTF7 } - -function ConvertUTF7toUCS2(var sourceStart: PAnsiChar; sourceEnd: PAnsiChar; - var targetStart: PWideChar; targetEnd: PWideChar): Integer; -var - target: PWideChar { Register }; - source: PAnsiChar { Register }; - BITbuffer: Cardinal { & "Address Of" Used }; - bufferbits: Integer { & "Address Of" Used }; - shifted: Boolean { Used In Boolean Context }; - first: Boolean { Used In Boolean Context }; - wroteone: Boolean; - base64EOF: Boolean; - base64value: Integer; - done: Boolean; - c: UCS2; - prevc: UCS2; - junk: UCS2 { Used In Boolean Context }; -begin - Initialize_UTF7_Data; - Result := 0; - BITbuffer := 0; - bufferbits := 0; - shifted := False; - first := False; - wroteone := False; - source := sourceStart; - target := targetStart; - c := 0; - if needtables then - tabinit; - repeat - { read an ASCII character c } - done := Source >= SourceEnd; - if (not done) then - begin - c := Word(Source^); - Inc(Source); - end { If }; - if shifted then - begin - { We're done with a base64 string if we hit EOF, it's not a valid } - { ASCII character, or it's not in the base64 set. } - { } - base64value := invbase64[c]; - base64EOF := (done or (c > $7F)) or (base64value < 0); - if base64EOF then - begin - shifted := False; - { If the character causing us to drop out was SHIFT_IN or } - { SHIFT_OUT, it may be a special escape for SHIFT_IN. The } - { test for SHIFT_IN is not necessary, but allows an alternate } - { form of UTF-7 where SHIFT_IN is escaped by SHIFT_IN. This } - { only works for some values of SHIFT_IN. } - { } - if ((not done) and ((c = Integer('+')) or (c = Integer('-')))) then - begin - { get another character c } - prevc := c; - Done := Source >= SourceEnd; - if (not Done) then - begin - c := Word(Source^); - Inc(Source); - { If no base64 characters were encountered, and the } - { character terminating the shift sequence was } - { SHIFT_OUT, then it's a special escape for SHIFT_IN. } - { } - end; - if first and (prevc = Integer('-')) then - begin - { write SHIFT_IN unicode } - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := WideChar('+'); - Inc(Target); - end - else - begin - if (not wroteone) then - begin - Result := 1; - end { If }; - end { Else }; - ; - end { If } - else - begin - if (not wroteone) then - begin - Result := 1; - end { If }; - end { Else }; - end { If } - else - begin - { Add another 6 bits of base64 to the bit buffer. } - WRITE_N_BITS(base64value, 6, BITbuffer, - bufferbits); - first := False; - end { Else }; - { Extract as many full 16 bit characters as possible from the } - { bit buffer. } - { } - while (bufferbits >= 16) and (target < targetEnd) do - begin - { write a unicode } - Target^ := WideChar(READ_N_BITS(16, BITbuffer, bufferbits)); - Inc(Target); - wroteone := True; - end { While }; - if (bufferbits >= 16) then - begin - if (target >= targetEnd) then - begin - Result := 2; - Break; - end; - end { If }; - if (base64EOF) then - begin - junk := READ_N_BITS(bufferbits, BITbuffer, bufferbits); - if (junk <> 0) then - begin - Result := 1; - end { If }; - end { If }; - end { If }; - if (not shifted) and (not done) then - begin - if (c = Integer('+')) then - begin - shifted := True; - first := True; - wroteone := False; - end { If } - else - begin - { It must be a directly encoded character. } - if (c > $7F) then - begin - Result := 1; - end { If }; - if (target >= targetEnd) then - begin - Result := 2; - break; - end { If }; - Target^ := WideChar(c); - Inc(Target); - end { Else }; - end { If }; - until (done); - sourceStart := source; - targetStart := target; -end; { ConvertUTF7toUCS2 } - - {*****************************************************************************} - { Thanks to Francisco Leong for providing the Pascal conversion of } - { ConvertUTF7.c (by David B. Goldsmith) } - {*****************************************************************************} - -resourcestring - SBufferOverflow = 'Buffer overflow'; - SInvalidUTF7 = 'Invalid UTF7'; - -function WideStringToUTF7(const W: WideString): AnsiString; -var - SourceStart, SourceEnd: PWideChar; - TargetStart, TargetEnd: PAnsiChar; -begin - if W = '' then - Result := '' - else - begin - SetLength(Result, Length(W) * 7); // Assume worst case - SourceStart := PWideChar(@W[1]); - SourceEnd := PWideChar(@W[Length(W)]) + 1; - TargetStart := PAnsiChar(@Result[1]); - TargetEnd := PAnsiChar(@Result[Length(Result)]) + 1; - if ConvertUCS2toUTF7(SourceStart, SourceEnd, TargetStart, - TargetEnd, True, False) <> 0 - then - raise ETntInternalError.Create(SBufferOverflow); - SetLength(Result, TargetStart - PAnsiChar(@Result[1])); - end; -end; - -function UTF7ToWideString(const S: AnsiString): WideString; -var - SourceStart, SourceEnd: PAnsiChar; - TargetStart, TargetEnd: PWideChar; -begin - if (S = '') then - Result := '' - else - begin - SetLength(Result, Length(S)); // Assume Worst case - SourceStart := PAnsiChar(@S[1]); - SourceEnd := PAnsiChar(@S[Length(S)]) + 1; - TargetStart := PWideChar(@Result[1]); - TargetEnd := PWideChar(@Result[Length(Result)]) + 1; - case ConvertUTF7toUCS2(SourceStart, SourceEnd, TargetStart, - TargetEnd) of - 1: raise ETntGeneralError.Create(SInvalidUTF7); - 2: raise ETntInternalError.Create(SBufferOverflow); - end; - SetLength(Result, TargetStart - PWideChar(@Result[1])); - end; -end; - -function StringToWideStringEx(const S: AnsiString; CodePage: Cardinal): WideString; -var - InputLength, - OutputLength: Integer; -begin - if CodePage = CP_UTF7 then - Result := UTF7ToWideString(S) // CP_UTF7 not supported on Windows 95 - else if CodePage = CP_UTF8 then - Result := UTF8ToWideString(S) // CP_UTF8 not supported on Windows 95 - else begin - InputLength := Length(S); - OutputLength := MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, nil, 0); - SetLength(Result, OutputLength); - MultiByteToWideChar(CodePage, 0, PAnsiChar(S), InputLength, PWideChar(Result), OutputLength); - end; -end; - -function WideStringToStringEx(const WS: WideString; CodePage: Cardinal): AnsiString; -var - InputLength, - OutputLength: Integer; -begin - if CodePage = CP_UTF7 then - Result := WideStringToUTF7(WS) // CP_UTF7 not supported on Windows 95 - else if CodePage = CP_UTF8 then - Result := WideStringToUTF8(WS) // CP_UTF8 not supported on Windows 95 - else begin - InputLength := Length(WS); - OutputLength := WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, nil, 0, nil, nil); - SetLength(Result, OutputLength); - WideCharToMultiByte(CodePage, 0, PWideChar(WS), InputLength, PAnsiChar(Result), OutputLength, nil, nil); - end; -end; - -function UCS2ToWideString(const Value: AnsiString): WideString; -begin - if Length(Value) = 0 then - Result := '' - else - SetString(Result, PWideChar(@Value[1]), Length(Value) div SizeOf(WideChar)) -end; - -function WideStringToUCS2(const Value: WideString): AnsiString; -begin - if Length(Value) = 0 then - Result := '' - else - SetString(Result, PAnsiChar(@Value[1]), Length(Value) * SizeOf(WideChar)) -end; - -{ Windows.pas doesn't declare TranslateCharsetInfo() correctly. } -function TranslateCharsetInfo(lpSrc: PDWORD; var lpCs: TCharsetInfo; dwFlags: DWORD): BOOL; stdcall; external gdi32 name 'TranslateCharsetInfo'; - -function CharSetToCodePage(ciCharset: UINT): Cardinal; -var - C: TCharsetInfo; -begin - Win32Check(TranslateCharsetInfo(PDWORD(ciCharset), C, TCI_SRCCHARSET)); - Result := C.ciACP -end; - -function LCIDToCodePage(ALcid: LCID): Cardinal; -var - Buf: array[0..6] of AnsiChar; -begin - GetLocaleInfo(ALcid, LOCALE_IDefaultAnsiCodePage, Buf, 6); - Result := StrToIntDef(Buf, GetACP); -end; - -function KeyboardCodePage: Cardinal; -begin - Result := LCIDToCodePage(GetKeyboardLayout(0) and $FFFF); -end; - -function KeyUnicode(CharCode: Word): WideChar; -var - AChar: AnsiChar; -begin - // converts the given character (as it comes with a WM_CHAR message) into its - // corresponding Unicode character depending on the active keyboard layout - if CharCode <= Word(High(AnsiChar)) then begin - AChar := AnsiChar(CharCode); - MultiByteToWideChar(KeyboardCodePage, MB_USEGLYPHCHARS, @AChar, 1, @Result, 1); - end else - Result := WideChar(CharCode); -end; - -procedure StrSwapByteOrder(Str: PWideChar); -var - P: PWord; -begin - P := PWord(Str); - While (P^ <> 0) do begin - P^ := MakeWord(HiByte(P^), LoByte(P^)); - Inc(P); - end; -end; - -{$IFDEF USE_SYSTEM_OVERRIDES} - -//-------------------------------------------------------------------- -// LoadResString() -// -// This system function is used to retrieve a resourcestring and -// return the result as an AnsiString. If we believe that the result -// is only a temporary value, and that it will be immediately -// assigned to a WideString or a Variant, then we will save the -// Unicode result as well as a reference to the original Ansi string. -// WStrFromPCharLen() or VarFromLStr() will return this saved -// Unicode string if it appears to receive the most recent result -// of LoadResString. -//-------------------------------------------------------------------- - - - //=========================================================================================== - // - // function CodeMatchesPatternForUnicode(...); - // - // GIVEN: SomeWideString := SSomeResString; { WideString := resourcestring } - // - // Delphi will compile this statement into the following: - // ------------------------------------------------- - // TempAnsiString := LoadResString(@SSomeResString); - // LINE 1: lea edx,[SomeTempAnsiString] - // LINE 2: mov eax,[@SomeResString] - // LINE 3: call LoadResString - // - // WStrFromLStr(SomeWideString, TempAnsiString); { SomeWideString := TempAnsiString } - // LINE 4: mov edx,[SomeTempAnsiString] - // LINE 5: mov/lea eax [@SomeWideString] - // LINE 6: call @WStrFromLStr - // ------------------------------------------------- - // - // The order in which the parameters are prepared for WStrFromLStr (ie LINE 4 & 5) is - // reversed when assigning a non-temporary AnsiString to a WideString. - // - // This code, for example, results in LINE 4 and LINE 5 being swapped. - // - // SomeAnsiString := SSomeResString; - // SomeWideString := SomeAnsiString; - // - // Since we know the "signature" used by the compiler, we can detect this pattern. - // If we believe it is only temporary, we can save the Unicode results for later - // retrieval from WStrFromLStr. - // - // One final note: When assigning a resourcestring to a Variant, the same patterns exist. - //=========================================================================================== - -function CodeMatchesPatternForUnicode(PLine4: PAnsiChar): Boolean; -const - SIZEOF_OPCODE = 1 {byte}; - MOV_16_OPCODE = AnsiChar($8B); { we'll assume operand size is 16 bits } - MOV_32_OPCODE = AnsiChar($B8); { we'll assume operand size is 32 bits } - LEA_OPCODE = AnsiChar($8D); { operand size can be 16 or 40 bits } - CALL_OPCODE = AnsiChar($E8); { assumed operand size is 32 bits } - BREAK_OPCODE = AnsiChar($CC); {in a breakpoint} -var - PLine1: PAnsiChar; - PLine2: PAnsiChar; - PLine3: PAnsiChar; - DataSize: Integer; // bytes in first LEA operand -begin - Result := False; - - PLine3 := PLine4 - SizeOf(CALL_OPCODE) - 4; - PLine2 := PLine3 - SizeOf(MOV_32_OPCODE) - 4; - - // figure PLine1 and operand size - DataSize := 2; { try 16 bit operand for line 1 } - PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); - if (PLine1^ <> LEA_OPCODE) and (not (IsDebugging and (PLine1^ = BREAK_OPCODE))) then - begin - DataSize := 5; { try 40 bit operand for line 1 } - PLine1 := PLine2 - DataSize - SizeOf(LEA_OPCODE); - end; - if (PLine1^ = LEA_OPCODE) or (IsDebugging and (PLine1^ = BREAK_OPCODE)) then - begin - if CompareMem(PLine1 + SIZEOF_OPCODE, PLine4 + SIZEOF_OPCODE, DataSize) then - begin - // After this check, it seems to match the WideString <- (temp) AnsiString pattern - Result := True; // It is probably OK. (The side effects of being wrong aren't very bad.) - end; - end; -end; - -threadvar - PLastResString: PAnsiChar; - LastResStringValue: AnsiString; - LastWideResString: WideString; - -procedure FreeTntSystemThreadVars; -begin - LastResStringValue := ''; - LastWideResString := ''; -end; - -procedure Custom_System_EndThread(ExitCode: Integer); -begin - FreeTntSystemThreadVars; - {$IFDEF COMPILER_10_UP} - if Assigned(SystemThreadEndProc) then - SystemThreadEndProc(ExitCode); - {$ENDIF} - ExitThread(ExitCode); -end; - -function Custom_System_LoadResString(ResStringRec: PResStringRec): AnsiString; -var - ReturnAddr: Pointer; -begin - // get return address - asm - PUSH ECX - MOV ECX, [EBP + 4] - MOV ReturnAddr, ECX - POP ECX - end; - // check calling code pattern - if CodeMatchesPatternForUnicode(ReturnAddr) then begin - // result will probably be assigned to an intermediate AnsiString - // on its way to either a WideString or Variant. - LastWideResString := WideLoadResString(ResStringRec); - Result := LastWideResString; - LastResStringValue := Result; - if Result = '' then - PLastResString := nil - else - PLastResString := PAnsiChar(Result); - end else begin - // result will probably be assigned to an actual AnsiString variable. - PLastResString := nil; - Result := WideLoadResString(ResStringRec); - end; -end; - -//-------------------------------------------------------------------- -// WStrFromPCharLen() -// -// This system function is used to assign an AnsiString to a WideString. -// It has been modified to assign Unicode results from LoadResString. -// Another purpose of this function is to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_WStrFromPCharLen(var Dest: WideString; Source: PAnsiChar; Length: Integer); -var - DestLen: Integer; - Buffer: array[0..2047] of WideChar; - Local_PLastResString: Pointer; -begin - Local_PLastResString := PLastResString; - if (Local_PLastResString <> nil) - and (Local_PLastResString = Source) - and (System.Length(LastResStringValue) = Length) - and (LastResStringValue = Source) then begin - // use last unicode resource string - PLastResString := nil; { clear for further use } - Dest := LastWideResString; - end else begin - if Local_PLastResString <> nil then - PLastResString := nil; { clear for further use } - if Length <= 0 then - begin - Dest := ''; - Exit; - end; - if Length + 1 < High(Buffer) then - begin - DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Buffer, - High(Buffer)); - if DestLen > 0 then - begin - SetLength(Dest, DestLen); - Move(Pointer(@Buffer[0])^, Pointer(Dest)^, DestLen * SizeOf(WideChar)); - Exit; - end; - end; - DestLen := (Length + 1); - SetLength(Dest, DestLen); // overallocate, trim later - DestLen := MultiByteToWideChar(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), - DestLen); - if DestLen < 0 then - DestLen := 0; - SetLength(Dest, DestLen); - end; -end; - -{$IFNDEF COMPILER_9_UP} - -//-------------------------------------------------------------------- -// LStrFromPWCharLen() -// -// This system function is used to assign an WideString to an AnsiString. -// It has not been modified from its original purpose other than to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_LStrFromPWCharLen(var Dest: AnsiString; Source: PWideChar; Length: Integer); -var - DestLen: Integer; - Buffer: array[0..4095] of AnsiChar; -begin - if Length <= 0 then - begin - Dest := ''; - Exit; - end; - if Length + 1 < (High(Buffer) div sizeof(WideChar)) then - begin - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, - Length, Buffer, High(Buffer), - nil, nil); - if DestLen >= 0 then - begin - SetLength(Dest, DestLen); - Move(Pointer(@Buffer[0])^, PAnsiChar(Dest)^, DestLen); - Exit; - end; - end; - - DestLen := (Length + 1) * sizeof(WideChar); - SetLength(Dest, DestLen); // overallocate, trim later - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Source, Length, Pointer(Dest), DestLen, - nil, nil); - if DestLen < 0 then - DestLen := 0; - SetLength(Dest, DestLen); -end; - -//-------------------------------------------------------------------- -// WStrToString() -// -// This system function is used to assign an WideString to an short string. -// It has not been modified from its original purpose other than to specify the code page. -//-------------------------------------------------------------------- - -procedure Custom_System_WStrToString(Dest: PShortString; const Source: WideString; MaxLen: Integer); -var - SourceLen, DestLen: Integer; - Buffer: array[0..511] of AnsiChar; -begin - if MaxLen > 255 then MaxLen := 255; - SourceLen := Length(Source); - if SourceLen >= MaxLen then SourceLen := MaxLen; - if SourceLen = 0 then - DestLen := 0 - else begin - DestLen := WideCharToMultiByte(DefaultSystemCodePage, 0, Pointer(Source), SourceLen, - Buffer, SizeOf(Buffer), nil, nil); - if DestLen > MaxLen then DestLen := MaxLen; - end; - Dest^[0] := Chr(DestLen); - if DestLen > 0 then Move(Buffer, Dest^[1], DestLen); -end; - -{$ENDIF} - -//-------------------------------------------------------------------- -// VarFromLStr() -// -// This system function is used to assign an AnsiString to a Variant. -// It has been modified to assign Unicode results from LoadResString. -//-------------------------------------------------------------------- - -procedure Custom_System_VarFromLStr(var V: TVarData; const Value: AnsiString); -const - varDeepData = $BFE8; -var - Local_PLastResString: Pointer; -begin - if (V.VType and varDeepData) <> 0 then - VarClear(PVariant(@V)^); - - Local_PLastResString := PLastResString; - if (Local_PLastResString <> nil) - and (Local_PLastResString = PAnsiChar(Value)) - and (LastResStringValue = Value) then begin - // use last unicode resource string - PLastResString := nil; { clear for further use } - V.VOleStr := nil; - V.VType := varOleStr; - WideString(Pointer(V.VOleStr)) := Copy(LastWideResString, 1, MaxInt); - end else begin - if Local_PLastResString <> nil then - PLastResString := nil; { clear for further use } - V.VString := nil; - V.VType := varString; - AnsiString(V.VString) := Value; - end; -end; - -{$IFNDEF COMPILER_9_UP} - -//-------------------------------------------------------------------- -// WStrCat3() A := B + C; -// -// This system function is used to concatenate two strings into one result. -// This function is added because A := '' + '' doesn't necessarily result in A = ''; -//-------------------------------------------------------------------- - -procedure Custom_System_WStrCat3(var Dest: WideString; const Source1, Source2: WideString); - - function NewWideString(CharLength: Longint): Pointer; - var - _NewWideString: function(CharLength: Longint): Pointer; - begin - asm - PUSH ECX - MOV ECX, offset System.@NewWideString; - MOV _NewWideString, ECX - POP ECX - end; - Result := _NewWideString(CharLength); - end; - - procedure WStrSet(var S: WideString; P: PWideChar); - var - Temp: Pointer; - begin - Temp := Pointer(InterlockedExchange(Integer(S), Integer(P))); - if Temp <> nil then - WideString(Temp) := ''; - end; - -var - Source1Len, Source2Len: Integer; - NewStr: PWideChar; -begin - Source1Len := Length(Source1); - Source2Len := Length(Source2); - if (Source1Len <> 0) or (Source2Len <> 0) then - begin - NewStr := NewWideString(Source1Len + Source2Len); - Move(Pointer(Source1)^, Pointer(NewStr)^, Source1Len * sizeof(WideChar)); - Move(Pointer(Source2)^, NewStr[Source1Len], Source2Len * sizeof(WideChar)); - WStrSet(Dest, NewStr); - end else - Dest := ''; -end; - -{$ENDIF} - -//-------------------------------------------------------------------- -// System proc replacements -//-------------------------------------------------------------------- - -type - POverwrittenData = ^TOverwrittenData; - TOverwrittenData = record - Location: Pointer; - OldCode: array[0..6] of Byte; - end; - -procedure OverwriteProcedure(OldProcedure, NewProcedure: pointer; Data: POverwrittenData = nil); -{ OverwriteProcedure originally from Igor Siticov } -{ Modified by Jacques Garcia Vazquez } -var - x: PAnsiChar; - y: integer; - ov2, ov: cardinal; - p: pointer; -begin - if Assigned(Data) and (Data.Location <> nil) then - exit; { procedure already overwritten } - - // need six bytes in place of 5 - x := PAnsiChar(OldProcedure); - if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - - // if a jump is present then a redirect is found - // $FF25 = jmp dword ptr [xxx] - // This redirect is normally present in bpl files, but not in exe files - p := OldProcedure; - - if Word(p^) = $25FF then - begin - Inc(Integer(p), 2); // skip the jump - // get the jump address p^ and dereference it p^^ - p := Pointer(Pointer(p^)^); - - // release the memory - if not VirtualProtect(Pointer(x), 6, ov, @ov2) then - RaiseLastOSError; - - // re protect the correct one - x := PAnsiChar(p); - if not VirtualProtect(Pointer(x), 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - end; - - if Assigned(Data) then - begin - Move(x^, Data.OldCode, 6); - { Assign Location last so that Location <> nil only if OldCode is properly initialized. } - Data.Location := x; - end; - - x[0] := AnsiChar($E9); - y := integer(NewProcedure) - integer(p) - 5; - x[1] := AnsiChar(y and 255); - x[2] := AnsiChar((y shr 8) and 255); - x[3] := AnsiChar((y shr 16) and 255); - x[4] := AnsiChar((y shr 24) and 255); - - if not VirtualProtect(Pointer(x), 6, ov, @ov2) then - RaiseLastOSError; -end; - -procedure RestoreProcedure(OriginalProc: Pointer; Data: TOverwrittenData); -var - ov, ov2: Cardinal; -begin - if Data.Location <> nil then begin - if not VirtualProtect(Data.Location, 6, PAGE_EXECUTE_READWRITE, @ov) then - RaiseLastOSError; - Move(Data.OldCode, Data.Location^, 6); - if not VirtualProtect(Data.Location, 6, ov, @ov2) then - RaiseLastOSError; - end; -end; - -function Addr_System_EndThread: Pointer; -begin - Result := @System.EndThread; -end; - -function Addr_System_LoadResString: Pointer; -begin - Result := @System.LoadResString{TNT-ALLOW LoadResString}; -end; - -function Addr_System_WStrFromPCharLen: Pointer; -asm - mov eax, offset System.@WStrFromPCharLen; -end; - -{$IFNDEF COMPILER_9_UP} -function Addr_System_LStrFromPWCharLen: Pointer; -asm - mov eax, offset System.@LStrFromPWCharLen; -end; - -function Addr_System_WStrToString: Pointer; -asm - mov eax, offset System.@WStrToString; -end; -{$ENDIF} - -function Addr_System_VarFromLStr: Pointer; -asm - mov eax, offset System.@VarFromLStr; -end; - -function Addr_System_WStrCat3: Pointer; -asm - mov eax, offset System.@WStrCat3; -end; - -var - System_EndThread_Code, - System_LoadResString_Code, - System_WStrFromPCharLen_Code, - {$IFNDEF COMPILER_9_UP} - System_LStrFromPWCharLen_Code, - System_WStrToString_Code, - {$ENDIF} - System_VarFromLStr_Code - {$IFNDEF COMPILER_9_UP} - , - System_WStrCat3_Code, - SysUtils_WideFmtStr_Code - {$ENDIF} - : TOverwrittenData; - -procedure InstallEndThreadOverride; -begin - OverwriteProcedure(Addr_System_EndThread, @Custom_System_EndThread, @System_EndThread_Code); -end; - -procedure InstallStringConversionOverrides; -begin - OverwriteProcedure(Addr_System_WStrFromPCharLen, @Custom_System_WStrFromPCharLen, @System_WStrFromPCharLen_Code); - {$IFNDEF COMPILER_9_UP} - OverwriteProcedure(Addr_System_LStrFromPWCharLen, @Custom_System_LStrFromPWCharLen, @System_LStrFromPWCharLen_Code); - OverwriteProcedure(Addr_System_WStrToString, @Custom_System_WStrToString, @System_WStrToString_Code); - {$ENDIF} -end; - -procedure InstallWideResourceStrings; -begin - OverwriteProcedure(Addr_System_LoadResString, @Custom_System_LoadResString, @System_LoadResString_Code); - OverwriteProcedure(Addr_System_VarFromLStr, @Custom_System_VarFromLStr, @System_VarFromLStr_Code); -end; - -{$IFNDEF COMPILER_9_UP} -procedure InstallWideStringConcatenationFix; -begin - OverwriteProcedure(Addr_System_WStrCat3, @Custom_System_WStrCat3, @System_WStrCat3_Code); -end; - -procedure InstallWideFormatFixes; -begin - OverwriteProcedure(@SysUtils.WideFmtStr, @TntSysUtils.Tnt_WideFmtStr, @SysUtils_WideFmtStr_Code); -end; -{$ENDIF} - -procedure InstallTntSystemUpdates(Updates: TTntSystemUpdateSet = AllTntSystemUpdates); -begin - InstallEndThreadOverride; - if tsWideResourceStrings in Updates then begin - InstallStringConversionOverrides; - InstallWideResourceStrings; - end; - {$IFNDEF COMPILER_9_UP} - if tsFixImplicitCodePage in Updates then begin - InstallStringConversionOverrides; - { CP_ACP is the code page used by the non-Unicode Windows API. } - GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; - end; - if tsFixWideStrConcat in Updates then begin - InstallWideStringConcatenationFix; - end; - if tsFixWideFormat in Updates then begin - InstallWideFormatFixes; - end; - {$ENDIF} -end; - -{$IFNDEF COMPILER_9_UP} -var - StartupDefaultUserCodePage: Cardinal; -{$ENDIF} - -procedure UninstallSystemOverrides; -begin - RestoreProcedure(Addr_System_EndThread, System_EndThread_Code); - // String Conversion - RestoreProcedure(Addr_System_WStrFromPCharLen, System_WStrFromPCharLen_Code); - {$IFNDEF COMPILER_9_UP} - RestoreProcedure(Addr_System_LStrFromPWCharLen, System_LStrFromPWCharLen_Code); - RestoreProcedure(Addr_System_WStrToString, System_WStrToString_Code); - GDefaultSystemCodePage := StartupDefaultUserCodePage; - {$ENDIF} - // Wide resourcestring - RestoreProcedure(Addr_System_LoadResString, System_LoadResString_Code); - RestoreProcedure(Addr_System_VarFromLStr, System_VarFromLStr_Code); - {$IFNDEF COMPILER_9_UP} - // WideString concat fix - RestoreProcedure(Addr_System_WStrCat3, System_WStrCat3_Code); - // WideFormat fixes - RestoreProcedure(@SysUtils.WideFmtStr, SysUtils_WideFmtStr_Code); - {$ENDIF} -end; - -{$ENDIF USE_SYSTEM_OVERRIDES} - -initialization - {$IFDEF COMPILER_9_UP} - {$DEFINE USE_GETACP} - {$ENDIF} - {$IFDEF FPC} - {$DEFINE USE_GETACP} - {$ENDIF} - {$IFDEF USE_GETACP} - GDefaultSystemCodePage := GetACP; - {$ELSE} - {$IFDEF COMPILER_7_UP} - if (Win32Platform = VER_PLATFORM_WIN32_NT) and (Win32MajorVersion >= 5) then - GDefaultSystemCodePage := CP_THREAD_ACP // Win 2K/XP/... - else - GDefaultSystemCodePage := LCIDToCodePage(GetThreadLocale); // Win NT4/95/98/ME - {$ELSE} - GDefaultSystemCodePage := CP_ACP{TNT-ALLOW CP_ACP}; - {$ENDIF} - {$ENDIF} - {$IFDEF USE_SYSTEM_OVERRIDES} - {$IFNDEF COMPILER_9_UP} - StartupDefaultUserCodePage := DefaultSystemCodePage; - {$ENDIF} - IsDebugging := DebugHook > 0; - {$ENDIF USE_SYSTEM_OVERRIDES} - -finalization - {$IFDEF USE_SYSTEM_OVERRIDES} - UninstallSystemOverrides; - FreeTntSystemThreadVars; { Make MemorySleuth happy. } - {$ENDIF USE_SYSTEM_OVERRIDES} - -end. diff --git a/src/lib/TntUnicodeControls/TntWideStrUtils.pas b/src/lib/TntUnicodeControls/TntWideStrUtils.pas deleted file mode 100644 index 99f63aea..00000000 --- a/src/lib/TntUnicodeControls/TntWideStrUtils.pas +++ /dev/null @@ -1,455 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWideStrUtils; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{ Wide string manipulation functions } - -{$IFNDEF COMPILER_9_UP} -function WStrAlloc(Size: Cardinal): PWideChar; -function WStrBufSize(const Str: PWideChar): Cardinal; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WStrNew(const Str: PWideChar): PWideChar; -procedure WStrDispose(Str: PWideChar); -{$ENDIF} -//--------------------------------------------------------------------------------------------- -{$IFNDEF COMPILER_9_UP} -function WStrLen(Str: PWideChar): Cardinal; -function WStrEnd(Str: PWideChar): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WStrCopy(Dest, Source: PWideChar): PWideChar; -function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; -function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; -function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; -// WStrComp and WStrPos were introduced as broken in Delphi 2006, but fixed in Delphi 2006 Update 2 -function WStrComp(Str1, Str2: PWideChar): Integer; -function WStrPos(Str, SubStr: PWideChar): PWideChar; -{$ENDIF} -function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; -function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; - -{ ------------ introduced --------------- } -function WStrECopy(Dest, Source: PWideChar): PWideChar; -function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -function WStrIComp(Str1, Str2: PWideChar): Integer; -function WStrLower(Str: PWideChar): PWideChar; -function WStrUpper(Str: PWideChar): PWideChar; -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; -function WStrPas(const Str: PWideChar): WideString; - -{ SysUtils.pas } //------------------------------------------------------------------------- - -{$IFNDEF COMPILER_10_UP} -function WideLastChar(const S: WideString): PWideChar; -function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; -{$ENDIF} -{$IFNDEF COMPILER_9_UP} -function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; -{$ENDIF} -{$IFNDEF COMPILER_10_UP} -function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; -{$ENDIF} - -implementation - -uses - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} Math, Windows, TntWindows; - -{$IFNDEF COMPILER_9_UP} -function WStrAlloc(Size: Cardinal): PWideChar; -begin - Size := SizeOf(Cardinal) + (Size * SizeOf(WideChar)); - GetMem(Result, Size); - PCardinal(Result)^ := Size; - Inc(PAnsiChar(Result), SizeOf(Cardinal)); -end; - -function WStrBufSize(const Str: PWideChar): Cardinal; -var - P: PWideChar; -begin - P := Str; - Dec(PAnsiChar(P), SizeOf(Cardinal)); - Result := PCardinal(P)^ - SizeOf(Cardinal); - Result := Result div SizeOf(WideChar); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrMove(Dest: PWideChar; const Source: PWideChar; Count: Cardinal): PWideChar; -var - Length: Integer; -begin - Result := Dest; - Length := Count * SizeOf(WideChar); - Move(Source^, Dest^, Length); -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WStrNew(const Str: PWideChar): PWideChar; -var - Size: Cardinal; -begin - if Str = nil then Result := nil else - begin - Size := WStrLen(Str) + 1; - Result := WStrMove(WStrAlloc(Size), Str, Size); - end; -end; - -procedure WStrDispose(Str: PWideChar); -begin - if Str <> nil then - begin - Dec(PAnsiChar(Str), SizeOf(Cardinal)); - FreeMem(Str, Cardinal(Pointer(Str)^)); - end; -end; -{$ENDIF} - -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_9_UP} -function WStrLen(Str: PWideChar): Cardinal; -begin - Result := WStrEnd(Str) - Str; -end; - -function WStrEnd(Str: PWideChar): PWideChar; -begin - // returns a pointer to the end of a null terminated string - Result := Str; - While Result^ <> #0 do - Inc(Result); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrCat(Dest: PWideChar; const Source: PWideChar): PWideChar; -begin - Result := Dest; - WStrCopy(WStrEnd(Dest), Source); -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WStrCopy(Dest, Source: PWideChar): PWideChar; -begin - Result := WStrLCopy(Dest, Source, MaxInt); -end; - -function WStrLCopy(Dest, Source: PWideChar; MaxLen: Cardinal): PWideChar; -var - Count: Cardinal; -begin - // copies a specified maximum number of characters from Source to Dest - Result := Dest; - Count := 0; - While (Count < MaxLen) and (Source^ <> #0) do begin - Dest^ := Source^; - Inc(Source); - Inc(Dest); - Inc(Count); - end; - Dest^ := #0; -end; - -function WStrPCopy(Dest: PWideChar; const Source: WideString): PWideChar; -begin - Result := WStrLCopy(Dest, PWideChar(Source), Length(Source)); -end; - -function WStrPLCopy(Dest: PWideChar; const Source: WideString; MaxLen: Cardinal): PWideChar; -begin - Result := WStrLCopy(Dest, PWideChar(Source), MaxLen); -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WStrScan(const Str: PWideChar; Chr: WideChar): PWideChar; -begin - Result := Str; - while Result^ <> Chr do - begin - if Result^ = #0 then - begin - Result := nil; - Exit; - end; - Inc(Result); - end; -end; - -function WStrComp(Str1, Str2: PWideChar): Integer; -begin - Result := WStrLComp(Str1, Str2, MaxInt); -end; - -function WStrPos(Str, SubStr: PWideChar): PWideChar; -var - PSave: PWideChar; - P: PWideChar; - PSub: PWideChar; -begin - // returns a pointer to the first occurance of SubStr in Str - Result := nil; - if (Str <> nil) and (Str^ <> #0) and (SubStr <> nil) and (SubStr^ <> #0) then begin - P := Str; - While P^ <> #0 do begin - if P^ = SubStr^ then begin - // investigate possibility here - PSave := P; - PSub := SubStr; - While (P^ = PSub^) do begin - Inc(P); - Inc(PSub); - if (PSub^ = #0) then begin - Result := PSave; - exit; // found a match - end; - if (P^ = #0) then - exit; // no match, hit end of string - end; - P := PSave; - end; - Inc(P); - end; - end; -end; -{$ENDIF} - -function Tnt_WStrComp(Str1, Str2: PWideChar): Integer; deprecated; -begin - Result := WStrComp(Str1, Str2); -end; - -function Tnt_WStrPos(Str, SubStr: PWideChar): PWideChar; deprecated; -begin - Result := WStrPos(Str, SubStr); -end; - -//------------------------------------------------------------------------------ - -function WStrECopy(Dest, Source: PWideChar): PWideChar; -begin - Result := WStrEnd(WStrCopy(Dest, Source)); -end; - -function WStrComp_EX(Str1, Str2: PWideChar; MaxLen: Cardinal; dwCmpFlags: Cardinal): Integer; -var - Len1, Len2: Integer; -begin - if MaxLen = Cardinal(MaxInt) then begin - Len1 := -1; - Len2 := -1; - end else begin - Len1 := Min(WStrLen(Str1), MaxLen); - Len2 := Min(WStrLen(Str2), MaxLen); - end; - Result := Tnt_CompareStringW(GetThreadLocale, dwCmpFlags, Str1, Len1, Str2, Len2) - 2; -end; - -function WStrLComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -begin - Result := WStrComp_EX(Str1, Str2, MaxLen, 0); -end; - -function WStrLIComp(Str1, Str2: PWideChar; MaxLen: Cardinal): Integer; -begin - Result := WStrComp_EX(Str1, Str2, MaxLen, NORM_IGNORECASE); -end; - -function WStrIComp(Str1, Str2: PWideChar): Integer; -begin - Result := WStrLIComp(Str1, Str2, MaxInt); -end; - -function WStrLower(Str: PWideChar): PWideChar; -begin - Result := Str; - Tnt_CharLowerBuffW(Str, WStrLen(Str)) -end; - -function WStrUpper(Str: PWideChar): PWideChar; -begin - Result := Str; - Tnt_CharUpperBuffW(Str, WStrLen(Str)) -end; - -function WStrRScan(const Str: PWideChar; Chr: WideChar): PWideChar; -var - MostRecentFound: PWideChar; -begin - if Chr = #0 then - Result := WStrEnd(Str) - else - begin - Result := nil; - MostRecentFound := Str; - while True do - begin - while MostRecentFound^ <> Chr do - begin - if MostRecentFound^ = #0 then - Exit; - Inc(MostRecentFound); - end; - Result := MostRecentFound; - Inc(MostRecentFound); - end; - end; -end; - -function WStrLCat(Dest: PWideChar; const Source: PWideChar; MaxLen: Cardinal): PWideChar; -begin - Result := Dest; - WStrLCopy(WStrEnd(Dest), Source, MaxLen - WStrLen(Dest)); -end; - -function WStrPas(const Str: PWideChar): WideString; -begin - Result := Str; -end; - -//--------------------------------------------------------------------------------------------- - -{$IFNDEF COMPILER_10_UP} -function WideLastChar(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil - else - Result := @S[Length(S)]; -end; - -function WideQuotedStr(const S: WideString; Quote: WideChar): WideString; -var - P, Src, - Dest: PWideChar; - AddCount: Integer; -begin - AddCount := 0; - P := WStrScan(PWideChar(S), Quote); - while (P <> nil) do - begin - Inc(P); - Inc(AddCount); - P := WStrScan(P, Quote); - end; - - if AddCount = 0 then - Result := Quote + S + Quote - else - begin - SetLength(Result, Length(S) + AddCount + 2); - Dest := PWideChar(Result); - Dest^ := Quote; - Inc(Dest); - Src := PWideChar(S); - P := WStrScan(Src, Quote); - repeat - Inc(P); - Move(Src^, Dest^, 2 * (P - Src)); - Inc(Dest, P - Src); - Dest^ := Quote; - Inc(Dest); - Src := P; - P := WStrScan(Src, Quote); - until P = nil; - P := WStrEnd(Src); - Move(Src^, Dest^, 2 * (P - Src)); - Inc(Dest, P - Src); - Dest^ := Quote; - end; -end; -{$ENDIF} - -{$IFNDEF COMPILER_9_UP} -function WideExtractQuotedStr(var Src: PWideChar; Quote: WideChar): Widestring; -var - P, Dest: PWideChar; - DropCount: Integer; -begin - Result := ''; - if (Src = nil) or (Src^ <> Quote) then Exit; - Inc(Src); - DropCount := 1; - P := Src; - Src := WStrScan(Src, Quote); - while Src <> nil do // count adjacent pairs of quote chars - begin - Inc(Src); - if Src^ <> Quote then Break; - Inc(Src); - Inc(DropCount); - Src := WStrScan(Src, Quote); - end; - if Src = nil then Src := WStrEnd(P); - if ((Src - P) <= 1) then Exit; - if DropCount = 1 then - SetString(Result, P, Src - P - 1) - else - begin - SetLength(Result, Src - P - DropCount); - Dest := PWideChar(Result); - Src := WStrScan(P, Quote); - while Src <> nil do - begin - Inc(Src); - if Src^ <> Quote then Break; - Move(P^, Dest^, (Src - P) * SizeOf(WideChar)); - Inc(Dest, Src - P); - Inc(Src); - P := Src; - Src := WStrScan(Src, Quote); - end; - if Src = nil then Src := WStrEnd(P); - Move(P^, Dest^, (Src - P - 1) * SizeOf(WideChar)); - end; -end; -{$ENDIF} - -{$IFNDEF COMPILER_10_UP} -function WideDequotedStr(const S: WideString; AQuote: WideChar): WideString; -var - LText : PWideChar; -begin - LText := PWideChar(S); - Result := WideExtractQuotedStr(LText, AQuote); - if Result = '' then - Result := S; -end; -{$ENDIF} - - -end. diff --git a/src/lib/TntUnicodeControls/TntWideStrings.pas b/src/lib/TntUnicodeControls/TntWideStrings.pas deleted file mode 100644 index 75132d22..00000000 --- a/src/lib/TntUnicodeControls/TntWideStrings.pas +++ /dev/null @@ -1,846 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWideStrings; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -{$IFDEF COMPILER_10_UP} - {$MESSAGE FATAL 'Do not refer to TntWideStrings.pas. It works correctly in Delphi 2006.'} -{$ENDIF} - -uses - Classes; - -{******************************************************************************} -{ } -{ Delphi 2005 introduced TWideStrings in WideStrings.pas. } -{ Unfortunately, it was not ready for prime time. } -{ Setting CommaText is not consistent, and it relies on CharNextW } -{ Which is only available on Windows NT+. } -{ } -{******************************************************************************} - -type - TWideStrings = class; - -{ IWideStringsAdapter interface } -{ Maintains link between TWideStrings and IWideStrings implementations } - - IWideStringsAdapter = interface - ['{25FE0E3B-66CB-48AA-B23B-BCFA67E8F5DA}'] - procedure ReferenceStrings(S: TWideStrings); - procedure ReleaseStrings; - end; - - TWideStringsEnumerator = class - private - FIndex: Integer; - FStrings: TWideStrings; - public - constructor Create(AStrings: TWideStrings); - function GetCurrent: WideString; - function MoveNext: Boolean; - property Current: WideString read GetCurrent; - end; - -{$IFDEF FPC} - TStringsDefined = set of ( - sdDelimiter, sdQuoteChar, sdNameValueSeparator, sdLineBreak, - sdStrictDelimiter); -{$ENDIF} - -{$DEFINE NAMEVALUESEPARATOR_RW} -{$IFNDEF COMPILER_7_UP} - {$UNDEF NAMEVALUESEPARATOR_RW} -{$ENDIF} - -{ TWideStrings class } - - TWideStrings = class(TPersistent) - private - FDefined: TStringsDefined; - FDelimiter: WideChar; - FQuoteChar: WideChar; - {$IFDEF NAMEVALUESEPARATOR_RW} - FNameValueSeparator: WideChar; - {$ENDIF} - FUpdateCount: Integer; - FAdapter: IWideStringsAdapter; - function GetCommaText: WideString; - function GetDelimitedText: WideString; - function GetName(Index: Integer): WideString; - function GetValue(const Name: WideString): WideString; - procedure ReadData(Reader: TReader); - procedure SetCommaText(const Value: WideString); - procedure SetDelimitedText(const Value: WideString); - procedure SetStringsAdapter(const Value: IWideStringsAdapter); - procedure SetValue(const Name, Value: WideString); - procedure WriteData(Writer: TWriter); - function GetDelimiter: WideChar; - procedure SetDelimiter(const Value: WideChar); - function GetQuoteChar: WideChar; - procedure SetQuoteChar(const Value: WideChar); - function GetNameValueSeparator: WideChar; - {$IFDEF NAMEVALUESEPARATOR_RW} - procedure SetNameValueSeparator(const Value: WideChar); - {$ENDIF} - function GetValueFromIndex(Index: Integer): WideString; - procedure SetValueFromIndex(Index: Integer; const Value: WideString); - protected - procedure AssignTo(Dest: TPersistent); override; - procedure DefineProperties(Filer: TFiler); override; - procedure Error(const Msg: WideString; Data: Integer); overload; - procedure Error(Msg: PResStringRec; Data: Integer); overload; - function ExtractName(const S: WideString): WideString; - function Get(Index: Integer): WideString; virtual; abstract; - function GetCapacity: Integer; virtual; - function GetCount: Integer; virtual; abstract; - function GetObject(Index: Integer): TObject; virtual; - function GetTextStr: WideString; virtual; - procedure Put(Index: Integer; const S: WideString); virtual; - procedure PutObject(Index: Integer; AObject: TObject); virtual; - procedure SetCapacity(NewCapacity: Integer); virtual; - procedure SetTextStr(const Value: WideString); virtual; - procedure SetUpdateState(Updating: Boolean); virtual; - property UpdateCount: Integer read FUpdateCount; - function CompareStrings(const S1, S2: WideString): Integer; virtual; - public - destructor Destroy; override; - function Add(const S: WideString): Integer; virtual; - function AddObject(const S: WideString; AObject: TObject): Integer; virtual; - procedure Append(const S: WideString); - procedure AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); overload; virtual; - procedure AddStrings(Strings: TWideStrings); overload; virtual; - procedure Assign(Source: TPersistent); override; - procedure BeginUpdate; - procedure Clear; virtual; abstract; - procedure Delete(Index: Integer); virtual; abstract; - procedure EndUpdate; - function Equals(Strings: TWideStrings): Boolean; - procedure Exchange(Index1, Index2: Integer); virtual; - function GetEnumerator: TWideStringsEnumerator; - function GetTextW: PWideChar; virtual; - function IndexOf(const S: WideString): Integer; virtual; - function IndexOfName(const Name: WideString): Integer; virtual; - function IndexOfObject(AObject: TObject): Integer; virtual; - procedure Insert(Index: Integer; const S: WideString); virtual; abstract; - procedure InsertObject(Index: Integer; const S: WideString; - AObject: TObject); virtual; - procedure LoadFromFile(const FileName: WideString); virtual; - procedure LoadFromStream(Stream: TStream); virtual; - procedure Move(CurIndex, NewIndex: Integer); virtual; - procedure SaveToFile(const FileName: WideString); virtual; - procedure SaveToStream(Stream: TStream); virtual; - procedure SetTextW(const Text: PWideChar); virtual; - property Capacity: Integer read GetCapacity write SetCapacity; - property CommaText: WideString read GetCommaText write SetCommaText; - property Count: Integer read GetCount; - property Delimiter: WideChar read GetDelimiter write SetDelimiter; - property DelimitedText: WideString read GetDelimitedText write SetDelimitedText; - property Names[Index: Integer]: WideString read GetName; - property Objects[Index: Integer]: TObject read GetObject write PutObject; - property QuoteChar: WideChar read GetQuoteChar write SetQuoteChar; - property Values[const Name: WideString]: WideString read GetValue write SetValue; - property ValueFromIndex[Index: Integer]: WideString read GetValueFromIndex write SetValueFromIndex; - property NameValueSeparator: WideChar read GetNameValueSeparator {$IFDEF NAMEVALUESEPARATOR_RW} write SetNameValueSeparator {$ENDIF}; - property Strings[Index: Integer]: WideString read Get write Put; default; - property Text: WideString read GetTextStr write SetTextStr; - property StringsAdapter: IWideStringsAdapter read FAdapter write SetStringsAdapter; - end; - - PWideStringItem = ^TWideStringItem; - TWideStringItem = record - FString: WideString; - FObject: TObject; - end; - - PWideStringItemList = ^TWideStringItemList; - TWideStringItemList = array[0..MaxListSize] of TWideStringItem; - -implementation - -uses - Windows, SysUtils, TntSystem, {$IFDEF COMPILER_9_UP} WideStrUtils, {$ELSE} TntWideStrUtils, {$ENDIF} - TntSysUtils, TntClasses; - -{ TWideStringsEnumerator } - -constructor TWideStringsEnumerator.Create(AStrings: TWideStrings); -begin - inherited Create; - FIndex := -1; - FStrings := AStrings; -end; - -function TWideStringsEnumerator.GetCurrent: WideString; -begin - Result := FStrings[FIndex]; -end; - -function TWideStringsEnumerator.MoveNext: Boolean; -begin - Result := FIndex < FStrings.Count - 1; - if Result then - Inc(FIndex); -end; - -{ TWideStrings } - -destructor TWideStrings.Destroy; -begin - StringsAdapter := nil; - inherited; -end; - -function TWideStrings.Add(const S: WideString): Integer; -begin - Result := GetCount; - Insert(Result, S); -end; - -function TWideStrings.AddObject(const S: WideString; AObject: TObject): Integer; -begin - Result := Add(S); - PutObject(Result, AObject); -end; - -procedure TWideStrings.Append(const S: WideString); -begin - Add(S); -end; - -procedure TWideStrings.AddStrings(Strings: TStrings{TNT-ALLOW TStrings}); -var - I: Integer; -begin - BeginUpdate; - try - for I := 0 to Strings.Count - 1 do - AddObject(Strings[I], Strings.Objects[I]); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.AddStrings(Strings: TWideStrings); -var - I: Integer; -begin - BeginUpdate; - try - for I := 0 to Strings.Count - 1 do - AddObject(Strings[I], Strings.Objects[I]); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.Assign(Source: TPersistent); -begin - if Source is TWideStrings then - begin - BeginUpdate; - try - Clear; - FDefined := TWideStrings(Source).FDefined; - {$IFDEF NAMEVALUESEPARATOR_RW} - FNameValueSeparator := TWideStrings(Source).FNameValueSeparator; - {$ENDIF} - FQuoteChar := TWideStrings(Source).FQuoteChar; - FDelimiter := TWideStrings(Source).FDelimiter; - AddStrings(TWideStrings(Source)); - finally - EndUpdate; - end; - end - else if Source is TStrings{TNT-ALLOW TStrings} then - begin - BeginUpdate; - try - Clear; - {$IFDEF NAMEVALUESEPARATOR_RW} - FNameValueSeparator := WideChar(TStrings{TNT-ALLOW TStrings}(Source).NameValueSeparator); - {$ENDIF} - FQuoteChar := WideChar(TStrings{TNT-ALLOW TStrings}(Source).QuoteChar); - FDelimiter := WideChar(TStrings{TNT-ALLOW TStrings}(Source).Delimiter); - AddStrings(TStrings{TNT-ALLOW TStrings}(Source)); - finally - EndUpdate; - end; - end - else - inherited Assign(Source); -end; - -procedure TWideStrings.AssignTo(Dest: TPersistent); -var - I: Integer; -begin - if Dest is TWideStrings then Dest.Assign(Self) - else if Dest is TStrings{TNT-ALLOW TStrings} then - begin - TStrings{TNT-ALLOW TStrings}(Dest).BeginUpdate; - try - TStrings{TNT-ALLOW TStrings}(Dest).Clear; - {$IFDEF NAMEVALUESEPARATOR_RW} - TStrings{TNT-ALLOW TStrings}(Dest).NameValueSeparator := AnsiChar(NameValueSeparator); - {$ENDIF} - TStrings{TNT-ALLOW TStrings}(Dest).QuoteChar := AnsiChar(QuoteChar); - TStrings{TNT-ALLOW TStrings}(Dest).Delimiter := AnsiChar(Delimiter); - for I := 0 to Count - 1 do - TStrings{TNT-ALLOW TStrings}(Dest).AddObject(Strings[I], Objects[I]); - finally - TStrings{TNT-ALLOW TStrings}(Dest).EndUpdate; - end; - end - else - inherited AssignTo(Dest); -end; - -procedure TWideStrings.BeginUpdate; -begin - if FUpdateCount = 0 then SetUpdateState(True); - Inc(FUpdateCount); -end; - -procedure TWideStrings.DefineProperties(Filer: TFiler); - - function DoWrite: Boolean; - begin - if Filer.Ancestor <> nil then - begin - Result := True; - if Filer.Ancestor is TWideStrings then - Result := not Equals(TWideStrings(Filer.Ancestor)) - end - else Result := Count > 0; - end; - -begin - Filer.DefineProperty('Strings', ReadData, WriteData, DoWrite); -end; - -procedure TWideStrings.EndUpdate; -begin - Dec(FUpdateCount); - if FUpdateCount = 0 then SetUpdateState(False); -end; - -function TWideStrings.Equals(Strings: TWideStrings): Boolean; -var - I, Count: Integer; -begin - Result := False; - Count := GetCount; - if Count <> Strings.GetCount then Exit; - for I := 0 to Count - 1 do if Get(I) <> Strings.Get(I) then Exit; - Result := True; -end; - -procedure TWideStrings.Error(const Msg: WideString; Data: Integer); - - function ReturnAddr: Pointer; - asm - MOV EAX,[EBP+4] - end; - -begin - raise EStringListError.CreateFmt(Msg, [Data]) at ReturnAddr; -end; - -procedure TWideStrings.Error(Msg: PResStringRec; Data: Integer); -begin - Error(WideLoadResString(Msg), Data); -end; - -procedure TWideStrings.Exchange(Index1, Index2: Integer); -var - TempObject: TObject; - TempString: WideString; -begin - BeginUpdate; - try - TempString := Strings[Index1]; - TempObject := Objects[Index1]; - Strings[Index1] := Strings[Index2]; - Objects[Index1] := Objects[Index2]; - Strings[Index2] := TempString; - Objects[Index2] := TempObject; - finally - EndUpdate; - end; -end; - -function TWideStrings.ExtractName(const S: WideString): WideString; -var - P: Integer; -begin - Result := S; - P := Pos(NameValueSeparator, Result); - if P <> 0 then - SetLength(Result, P-1) else - SetLength(Result, 0); -end; - -function TWideStrings.GetCapacity: Integer; -begin // descendents may optionally override/replace this default implementation - Result := Count; -end; - -function TWideStrings.GetCommaText: WideString; -var - LOldDefined: TStringsDefined; - LOldDelimiter: WideChar; - LOldQuoteChar: WideChar; -begin - LOldDefined := FDefined; - LOldDelimiter := FDelimiter; - LOldQuoteChar := FQuoteChar; - Delimiter := ','; - QuoteChar := '"'; - try - Result := GetDelimitedText; - finally - FDelimiter := LOldDelimiter; - FQuoteChar := LOldQuoteChar; - FDefined := LOldDefined; - end; -end; - -function TWideStrings.GetDelimitedText: WideString; -var - S: WideString; - P: PWideChar; - I, Count: Integer; -begin - Count := GetCount; - if (Count = 1) and (Get(0) = '') then - Result := WideString(QuoteChar) + QuoteChar - else - begin - Result := ''; - for I := 0 to Count - 1 do - begin - S := Get(I); - P := PWideChar(S); - while not ((P^ in [WideChar(#0)..WideChar(' ')]) or (P^ = QuoteChar) or (P^ = Delimiter)) do - Inc(P); - if (P^ <> #0) then S := WideQuotedStr(S, QuoteChar); - Result := Result + S + Delimiter; - end; - System.Delete(Result, Length(Result), 1); - end; -end; - -function TWideStrings.GetName(Index: Integer): WideString; -begin - Result := ExtractName(Get(Index)); -end; - -function TWideStrings.GetObject(Index: Integer): TObject; -begin - Result := nil; -end; - -function TWideStrings.GetEnumerator: TWideStringsEnumerator; -begin - Result := TWideStringsEnumerator.Create(Self); -end; - -function TWideStrings.GetTextW: PWideChar; -begin - Result := WStrNew(PWideChar(GetTextStr)); -end; - -function TWideStrings.GetTextStr: WideString; -var - I, L, Size, Count: Integer; - P: PWideChar; - S, LB: WideString; -begin - Count := GetCount; - Size := 0; - LB := sLineBreak; - for I := 0 to Count - 1 do Inc(Size, Length(Get(I)) + Length(LB)); - SetString(Result, nil, Size); - P := Pointer(Result); - for I := 0 to Count - 1 do - begin - S := Get(I); - L := Length(S); - if L <> 0 then - begin - System.Move(Pointer(S)^, P^, L * SizeOf(WideChar)); - Inc(P, L); - end; - L := Length(LB); - if L <> 0 then - begin - System.Move(Pointer(LB)^, P^, L * SizeOf(WideChar)); - Inc(P, L); - end; - end; -end; - -function TWideStrings.GetValue(const Name: WideString): WideString; -var - I: Integer; -begin - I := IndexOfName(Name); - if I >= 0 then - Result := Copy(Get(I), Length(Name) + 2, MaxInt) else - Result := ''; -end; - -function TWideStrings.IndexOf(const S: WideString): Integer; -begin - for Result := 0 to GetCount - 1 do - if CompareStrings(Get(Result), S) = 0 then Exit; - Result := -1; -end; - -function TWideStrings.IndexOfName(const Name: WideString): Integer; -var - P: Integer; - S: WideString; -begin - for Result := 0 to GetCount - 1 do - begin - S := Get(Result); - P := Pos(NameValueSeparator, S); - if (P <> 0) and (CompareStrings(Copy(S, 1, P - 1), Name) = 0) then Exit; - end; - Result := -1; -end; - -function TWideStrings.IndexOfObject(AObject: TObject): Integer; -begin - for Result := 0 to GetCount - 1 do - if GetObject(Result) = AObject then Exit; - Result := -1; -end; - -procedure TWideStrings.InsertObject(Index: Integer; const S: WideString; - AObject: TObject); -begin - Insert(Index, S); - PutObject(Index, AObject); -end; - -procedure TWideStrings.LoadFromFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmOpenRead or fmShareDenyWrite); - try - LoadFromStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TWideStrings.LoadFromStream(Stream: TStream); -var - Size: Integer; - S: WideString; -begin - BeginUpdate; - try - Size := Stream.Size - Stream.Position; - SetString(S, nil, Size div SizeOf(WideChar)); - Stream.Read(Pointer(S)^, Length(S) * SizeOf(WideChar)); - SetTextStr(S); - finally - EndUpdate; - end; -end; - -procedure TWideStrings.Move(CurIndex, NewIndex: Integer); -var - TempObject: TObject; - TempString: WideString; -begin - if CurIndex <> NewIndex then - begin - BeginUpdate; - try - TempString := Get(CurIndex); - TempObject := GetObject(CurIndex); - Delete(CurIndex); - InsertObject(NewIndex, TempString, TempObject); - finally - EndUpdate; - end; - end; -end; - -procedure TWideStrings.Put(Index: Integer; const S: WideString); -var - TempObject: TObject; -begin - TempObject := GetObject(Index); - Delete(Index); - InsertObject(Index, S, TempObject); -end; - -procedure TWideStrings.PutObject(Index: Integer; AObject: TObject); -begin -end; - -procedure TWideStrings.ReadData(Reader: TReader); -begin - if Reader.NextValue in [vaString, vaLString] then - SetTextStr(Reader.ReadString) {JCL compatiblity} - else if Reader.NextValue = vaWString then - SetTextStr(Reader.ReadWideString) {JCL compatiblity} - else begin - BeginUpdate; - try - Clear; - Reader.ReadListBegin; - while not Reader.EndOfList do - if Reader.NextValue in [vaString, vaLString] then - Add(Reader.ReadString) {TStrings compatiblity} - else - Add(Reader.ReadWideString); - Reader.ReadListEnd; - finally - EndUpdate; - end; - end; -end; - -procedure TWideStrings.SaveToFile(const FileName: WideString); -var - Stream: TStream; -begin - Stream := TTntFileStream.Create(FileName, fmCreate); - try - SaveToStream(Stream); - finally - Stream.Free; - end; -end; - -procedure TWideStrings.SaveToStream(Stream: TStream); -var - SW: WideString; -begin - SW := GetTextStr; - Stream.WriteBuffer(PWideChar(SW)^, Length(SW) * SizeOf(WideChar)); -end; - -procedure TWideStrings.SetCapacity(NewCapacity: Integer); -begin - // do nothing - descendents may optionally implement this method -end; - -procedure TWideStrings.SetCommaText(const Value: WideString); -begin - Delimiter := ','; - QuoteChar := '"'; - SetDelimitedText(Value); -end; - -procedure TWideStrings.SetStringsAdapter(const Value: IWideStringsAdapter); -begin - if FAdapter <> nil then FAdapter.ReleaseStrings; - FAdapter := Value; - if FAdapter <> nil then FAdapter.ReferenceStrings(Self); -end; - -procedure TWideStrings.SetTextW(const Text: PWideChar); -begin - SetTextStr(Text); -end; - -procedure TWideStrings.SetTextStr(const Value: WideString); -var - P, Start: PWideChar; - S: WideString; -begin - BeginUpdate; - try - Clear; - P := Pointer(Value); - if P <> nil then - while P^ <> #0 do - begin - Start := P; - while not (P^ in [WideChar(#0), WideChar(#10), WideChar(#13)]) and (P^ <> WideLineSeparator) do - Inc(P); - SetString(S, Start, P - Start); - Add(S); - if P^ = #13 then Inc(P); - if P^ = #10 then Inc(P); - if P^ = WideLineSeparator then Inc(P); - end; - finally - EndUpdate; - end; -end; - -procedure TWideStrings.SetUpdateState(Updating: Boolean); -begin -end; - -procedure TWideStrings.SetValue(const Name, Value: WideString); -var - I: Integer; -begin - I := IndexOfName(Name); - if Value <> '' then - begin - if I < 0 then I := Add(''); - Put(I, Name + NameValueSeparator + Value); - end else - begin - if I >= 0 then Delete(I); - end; -end; - -procedure TWideStrings.WriteData(Writer: TWriter); -var - I: Integer; -begin - Writer.WriteListBegin; - for I := 0 to Count-1 do begin - Writer.WriteWideString(Get(I)); - end; - Writer.WriteListEnd; -end; - -procedure TWideStrings.SetDelimitedText(const Value: WideString); -var - P, P1: PWideChar; - S: WideString; -begin - BeginUpdate; - try - Clear; - P := PWideChar(Value); - while P^ in [WideChar(#1)..WideChar(' ')] do - Inc(P); - while P^ <> #0 do - begin - if P^ = QuoteChar then - S := WideExtractQuotedStr(P, QuoteChar) - else - begin - P1 := P; - while (P^ > ' ') and (P^ <> Delimiter) do - Inc(P); - SetString(S, P1, P - P1); - end; - Add(S); - while P^ in [WideChar(#1)..WideChar(' ')] do - Inc(P); - if P^ = Delimiter then - begin - P1 := P; - Inc(P1); - if P1^ = #0 then - Add(''); - repeat - Inc(P); - until not (P^ in [WideChar(#1)..WideChar(' ')]); - end; - end; - finally - EndUpdate; - end; -end; - -function TWideStrings.GetDelimiter: WideChar; -begin - if not (sdDelimiter in FDefined) then - Delimiter := ','; - Result := FDelimiter; -end; - -function TWideStrings.GetQuoteChar: WideChar; -begin - if not (sdQuoteChar in FDefined) then - QuoteChar := '"'; - Result := FQuoteChar; -end; - -procedure TWideStrings.SetDelimiter(const Value: WideChar); -begin - if (FDelimiter <> Value) or not (sdDelimiter in FDefined) then - begin - Include(FDefined, sdDelimiter); - FDelimiter := Value; - end -end; - -procedure TWideStrings.SetQuoteChar(const Value: WideChar); -begin - if (FQuoteChar <> Value) or not (sdQuoteChar in FDefined) then - begin - Include(FDefined, sdQuoteChar); - FQuoteChar := Value; - end -end; - -function TWideStrings.CompareStrings(const S1, S2: WideString): Integer; -begin - Result := WideCompareText(S1, S2); -end; - -function TWideStrings.GetNameValueSeparator: WideChar; -begin - {$IFDEF NAMEVALUESEPARATOR_RW} - if not (sdNameValueSeparator in FDefined) then - NameValueSeparator := '='; - Result := FNameValueSeparator; - {$ELSE} - Result := '='; - {$ENDIF} -end; - -{$IFDEF NAMEVALUESEPARATOR_RW} -procedure TWideStrings.SetNameValueSeparator(const Value: WideChar); -begin - if (FNameValueSeparator <> Value) or not (sdNameValueSeparator in FDefined) then - begin - Include(FDefined, sdNameValueSeparator); - FNameValueSeparator := Value; - end -end; -{$ENDIF} - -function TWideStrings.GetValueFromIndex(Index: Integer): WideString; -begin - if Index >= 0 then - Result := Copy(Get(Index), Length(Names[Index]) + 2, MaxInt) else - Result := ''; -end; - -procedure TWideStrings.SetValueFromIndex(Index: Integer; const Value: WideString); -begin - if Value <> '' then - begin - if Index < 0 then Index := Add(''); - Put(Index, Names[Index] + NameValueSeparator + Value); - end - else - if Index >= 0 then Delete(Index); -end; - -end. diff --git a/src/lib/TntUnicodeControls/TntWindows.pas b/src/lib/TntUnicodeControls/TntWindows.pas deleted file mode 100644 index 8fd7ec88..00000000 --- a/src/lib/TntUnicodeControls/TntWindows.pas +++ /dev/null @@ -1,1501 +0,0 @@ - -{*****************************************************************************} -{ } -{ Tnt Delphi Unicode Controls } -{ http://www.tntware.com/delphicontrols/unicode/ } -{ Version: 2.3.0 } -{ } -{ Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } -{ } -{*****************************************************************************} - -unit TntWindows; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$INCLUDE TntCompilers.inc} - -interface - -uses - Windows, ShellApi, ShlObj; - -// ......... compatibility - -const - DT_NOFULLWIDTHCHARBREAK = $00080000; - -const - INVALID_FILE_ATTRIBUTES = DWORD(-1); - -// ................ ANSI TYPES ................ -{TNT-WARN LPSTR} -{TNT-WARN PLPSTR} -{TNT-WARN LPCSTR} -{TNT-WARN LPCTSTR} -{TNT-WARN LPTSTR} - -// ........ EnumResourceTypesW, EnumResourceNamesW and EnumResourceLanguagesW are supposed .... -// ........ to work on Win95/98/ME but have caused access violations in testing on Win95 ...... -// .. TNT--WARN EnumResourceTypes .. -// .. TNT--WARN EnumResourceTypesA .. -// .. TNT--WARN EnumResourceNames .. -// .. TNT--WARN EnumResourceNamesA .. -// .. TNT--WARN EnumResourceLanguages .. -// .. TNT--WARN EnumResourceLanguagesA .. - -//------------------------------------------------------------------------------------------ - -// ......... The Unicode form of these functions are supported on Windows 95/98/ME ......... -{TNT-WARN ExtTextOut} -{TNT-WARN ExtTextOutA} -{TNT-WARN Tnt_ExtTextOutW} - -{TNT-WARN FindResource} -{TNT-WARN FindResourceA} -{TNT-WARN Tnt_FindResourceW} - -{TNT-WARN FindResourceEx} -{TNT-WARN FindResourceExA} -{TNT-WARN Tnt_FindResourceExW} - -{TNT-WARN GetCharWidth} -{TNT-WARN GetCharWidthA} -{TNT-WARN Tnt_GetCharWidthW} - -{TNT-WARN GetCommandLine} -{TNT-WARN GetCommandLineA} -{TNT-WARN Tnt_GetCommandLineW} - -{TNT-WARN GetTextExtentPoint} -{TNT-WARN GetTextExtentPointA} -{TNT-WARN Tnt_GetTextExtentPointW} - -{TNT-WARN GetTextExtentPoint32} -{TNT-WARN GetTextExtentPoint32A} -{TNT-WARN Tnt_GetTextExtentPoint32W} - -{TNT-WARN lstrcat} -{TNT-WARN lstrcatA} -{TNT-WARN Tnt_lstrcatW} - -{TNT-WARN lstrcpy} -{TNT-WARN lstrcpyA} -{TNT-WARN Tnt_lstrcpyW} - -{TNT-WARN lstrlen} -{TNT-WARN lstrlenA} -{TNT-WARN Tnt_lstrlenW} - -{TNT-WARN MessageBox} -{TNT-WARN MessageBoxA} -{TNT-WARN Tnt_MessageBoxW} - -{TNT-WARN MessageBoxEx} -{TNT-WARN MessageBoxExA} -{TNT-WARN Tnt_MessageBoxExA} - -{TNT-WARN TextOut} -{TNT-WARN TextOutA} -{TNT-WARN Tnt_TextOutW} - -//------------------------------------------------------------------------------------------ - -{TNT-WARN LOCALE_USER_DEFAULT} // <-- use GetThreadLocale -{TNT-WARN LOCALE_SYSTEM_DEFAULT} // <-- use GetThreadLocale - -//------------------------------------------------------------------------------------------ -// compatiblity -//------------------------------------------------------------------------------------------ -{$IFNDEF COMPILER_9_UP} -type - {$IFDEF FPC} - TStartupInfoA = STARTUPINFO; - TStartupInfoW = STARTUPINFO; - {$ELSE} - TStartupInfoA = _STARTUPINFOA; - TStartupInfoW = record - cb: DWORD; - lpReserved: PWideChar; - lpDesktop: PWideChar; - lpTitle: PWideChar; - dwX: DWORD; - dwY: DWORD; - dwXSize: DWORD; - dwYSize: DWORD; - dwXCountChars: DWORD; - dwYCountChars: DWORD; - dwFillAttribute: DWORD; - dwFlags: DWORD; - wShowWindow: Word; - cbReserved2: Word; - lpReserved2: PByte; - hStdInput: THandle; - hStdOutput: THandle; - hStdError: THandle; - end; - {$ENDIF} - -function CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; stdcall; external kernel32 name 'CreateProcessW'; - -{$ENDIF} - -{$IFDEF FPC} -type - TCurrencyFmtA = CURRENCYFMT; - TCurrencyFmtW = CURRENCYFMT; - PCurrencyFmtA = ^TCurrencyFmtA; - PCurrencyFmtW = ^TCurrencyFmtW; -{$ENDIF} - -//------------------------------------------------------------------------------------------ - -{TNT-WARN SetWindowText} -{TNT-WARN SetWindowTextA} -{TNT-WARN SetWindowTextW} -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; - -{TNT-WARN RemoveDirectory} -{TNT-WARN RemoveDirectoryA} -{TNT-WARN RemoveDirectoryW} -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetShortPathName} -{TNT-WARN GetShortPathNameA} -{TNT-WARN GetShortPathNameW} -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; - -{TNT-WARN GetFullPathName} -{TNT-WARN GetFullPathNameA} -{TNT-WARN GetFullPathNameW} -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; - -{TNT-WARN CreateFile} -{TNT-WARN CreateFileA} -{TNT-WARN CreateFileW} -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; - -{TNT-WARN FindFirstFile} -{TNT-WARN FindFirstFileA} -{TNT-WARN FindFirstFileW} -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; - -{TNT-WARN FindNextFile} -{TNT-WARN FindNextFileA} -{TNT-WARN FindNextFileW} -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; - -{TNT-WARN GetFileAttributes} -{TNT-WARN GetFileAttributesA} -{TNT-WARN GetFileAttributesW} -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; - -{TNT-WARN SetFileAttributes} -{TNT-WARN SetFileAttributesA} -{TNT-WARN SetFileAttributesW} -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; - -{TNT-WARN CreateDirectory} -{TNT-WARN CreateDirectoryA} -{TNT-WARN CreateDirectoryW} -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; - -{TNT-WARN MoveFile} -{TNT-WARN MoveFileA} -{TNT-WARN MoveFileW} -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; - -{TNT-WARN CopyFile} -{TNT-WARN CopyFileA} -{TNT-WARN CopyFileW} -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; - -{TNT-WARN DeleteFile} -{TNT-WARN DeleteFileA} -{TNT-WARN DeleteFileW} -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; - -{TNT-WARN DrawText} -{TNT-WARN DrawTextA} -{TNT-WARN DrawTextW} -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; - -{TNT-WARN GetDiskFreeSpace} -{TNT-WARN GetDiskFreeSpaceA} -{TNT-WARN GetDiskFreeSpaceW} -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; - -{TNT-WARN GetVolumeInformation} -{TNT-WARN GetVolumeInformationA} -{TNT-WARN GetVolumeInformationW} -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; - -{TNT-WARN GetModuleFileName} -{TNT-WARN GetModuleFileNameA} -{TNT-WARN GetModuleFileNameW} -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; - -{TNT-WARN GetTempPath} -{TNT-WARN GetTempPathA} -{TNT-WARN GetTempPathW} -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN GetTempFileName} -{TNT-WARN GetTempFileNameA} -{TNT-WARN GetTempFileNameW} -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; - -{TNT-WARN GetWindowsDirectory} -{TNT-WARN GetWindowsDirectoryA} -{TNT-WARN GetWindowsDirectoryW} -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetSystemDirectory} -{TNT-WARN GetSystemDirectoryA} -{TNT-WARN GetSystemDirectoryW} -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; - -{TNT-WARN GetCurrentDirectory} -{TNT-WARN GetCurrentDirectoryA} -{TNT-WARN GetCurrentDirectoryW} -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; - -{TNT-WARN SetCurrentDirectory} -{TNT-WARN SetCurrentDirectoryA} -{TNT-WARN SetCurrentDirectoryW} -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; - -{TNT-WARN GetComputerName} -{TNT-WARN GetComputerNameA} -{TNT-WARN GetComputerNameW} -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN GetUserName} -{TNT-WARN GetUserNameA} -{TNT-WARN GetUserNameW} -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; - -{TNT-WARN ShellExecute} -{TNT-WARN ShellExecuteA} -{TNT-WARN ShellExecuteW} -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; - -{TNT-WARN LoadLibrary} -{TNT-WARN LoadLibraryA} -{TNT-WARN LoadLibraryW} -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; - -{TNT-WARN LoadLibraryEx} -{TNT-WARN LoadLibraryExA} -{TNT-WARN LoadLibraryExW} -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; - -{TNT-WARN CreateProcess} -{TNT-WARN CreateProcessA} -{TNT-WARN CreateProcessW} -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; - -{TNT-WARN GetCurrencyFormat} -{TNT-WARN GetCurrencyFormatA} -{TNT-WARN GetCurrencyFormatW} -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; - -{TNT-WARN CompareString} -{TNT-WARN CompareStringA} -{TNT-WARN CompareStringW} -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; - -{TNT-WARN CharUpper} -{TNT-WARN CharUpperA} -{TNT-WARN CharUpperW} -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharUpperBuff} -{TNT-WARN CharUpperBuffA} -{TNT-WARN CharUpperBuffW} -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN CharLower} -{TNT-WARN CharLowerA} -{TNT-WARN CharLowerW} -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; - -{TNT-WARN CharLowerBuff} -{TNT-WARN CharLowerBuffA} -{TNT-WARN CharLowerBuffW} -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; - -{TNT-WARN GetStringTypeEx} -{TNT-WARN GetStringTypeExA} -{TNT-WARN GetStringTypeExW} -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; - -{TNT-WARN LoadString} -{TNT-WARN LoadStringA} -{TNT-WARN LoadStringW} -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; - -{$IFDEF FPC} -type - TMenuItemInfoW = TMENUITEMINFO; - tagMenuItemINFOW = tagMENUITEMINFO; -{$ENDIF} - -{TNT-WARN InsertMenuItem} -{TNT-WARN InsertMenuItemA} -{TNT-WARN InsertMenuItemW} -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: tagMenuItemINFOW): BOOL; - -{TNT-WARN ExtractIconEx} -{TNT-WARN ExtractIconExA} -{TNT-WARN ExtractIconExW} -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; - -{TNT-WARN ExtractAssociatedIcon} -{TNT-WARN ExtractAssociatedIconA} -{TNT-WARN ExtractAssociatedIconW} -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; - -{TNT-WARN GetFileVersionInfoSize} -{TNT-WARN GetFileVersionInfoSizeA} -{TNT-WARN GetFileVersionInfoSizeW} -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; - -{TNT-WARN GetFileVersionInfo} -{TNT-WARN GetFileVersionInfoA} -{TNT-WARN GetFileVersionInfoW} -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; - -const - VQV_FIXEDFILEINFO = '\'; - VQV_VARFILEINFO_TRANSLATION = '\VarFileInfo\Translation'; - VQV_STRINGFILEINFO = '\StringFileInfo'; - - VER_COMMENTS = 'Comments'; - VER_INTERNALNAME = 'InternalName'; - VER_PRODUCTNAME = 'ProductName'; - VER_COMPANYNAME = 'CompanyName'; - VER_LEGALCOPYRIGHT = 'LegalCopyright'; - VER_PRODUCTVERSION = 'ProductVersion'; - VER_FILEDESCRIPTION = 'FileDescription'; - VER_LEGALTRADEMARKS = 'LegalTrademarks'; - VER_PRIVATEBUILD = 'PrivateBuild'; - VER_FILEVERSION = 'FileVersion'; - VER_ORIGINALFILENAME = 'OriginalFilename'; - VER_SPECIALBUILD = 'SpecialBuild'; - -{TNT-WARN VerQueryValue} -{TNT-WARN VerQueryValueA} -{TNT-WARN VerQueryValueW} -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; - -type -{$IFDEF FPC} - PSHNAMEMAPPINGA = ^SHNAMEMAPPINGA; - SHNAMEMAPPINGA = record - pszOldPath : LPSTR; - pszNewPath : LPSTR; - cchOldPath : longint; - cchNewPath : longint; - end; - - PSHNAMEMAPPINGW = ^SHNAMEMAPPINGW; - SHNAMEMAPPINGW = record - pszOldPath : LPWSTR; - pszNewPath : LPWSTR; - cchOldPath : longint; - cchNewPath : longint; - end; -{$ENDIF} - - TSHNameMappingHeaderA = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGA; - end; - PSHNameMappingHeaderA = ^TSHNameMappingHeaderA; - - TSHNameMappingHeaderW = record - cNumOfMappings: Cardinal; - lpNM: PSHNAMEMAPPINGW; - end; - PSHNameMappingHeaderW = ^TSHNameMappingHeaderW; - -{TNT-WARN SHFileOperation} -{TNT-WARN SHFileOperationA} -{TNT-WARN SHFileOperationW} // <-- no stub on early Windows 95 -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; - -{TNT-WARN SHFreeNameMappings} -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); - -{TNT-WARN SHBrowseForFolder} -{TNT-WARN SHBrowseForFolderA} -{TNT-WARN SHBrowseForFolderW} // <-- no stub on early Windows 95 -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; - -{TNT-WARN SHGetPathFromIDList} -{TNT-WARN SHGetPathFromIDListA} -{TNT-WARN SHGetPathFromIDListW} // <-- no stub on early Windows 95 -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; - -{TNT-WARN SHGetFileInfo} -{TNT-WARN SHGetFileInfoA} -{TNT-WARN SHGetFileInfoW} // <-- no stub on early Windows 95 -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; - -// ......... introduced ......... -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; - -function LANGIDFROMLCID(lcid: LCID): WORD; -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -function PRIMARYLANGID(lgid: WORD): WORD; -function SORTIDFROMLCID(lcid: LCID): WORD; -function SUBLANGID(lgid: WORD): WORD; - -implementation - -uses - SysUtils, Math, TntSysUtils, - {$IFDEF COMPILER_9_UP} WideStrUtils, {$ENDIF} TntWideStrUtils; - -function _PAnsiCharWithNil(const S: AnsiString): PAnsiChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PAnsiChar(S); -end; - -function _PWideCharWithNil(const S: WideString): PWideChar; -begin - if S = '' then - Result := nil {Win9x needs nil for some parameters instead of empty strings} - else - Result := PWideChar(S); -end; - -function _WStr(lpString: PWideChar; cchCount: Integer): WideString; -begin - if cchCount = -1 then - Result := lpString - else - Result := Copy(WideString(lpString), 1, cchCount); -end; - -procedure _MakeWideWin32FindData(var WideFindData: TWIN32FindDataW; AnsiFindData: TWIN32FindDataA); -begin - CopyMemory(@WideFindData, @AnsiFindData, - PtrUInt(@WideFindData.cFileName) - PtrUInt(@WideFindData)); - WStrPCopy(WideFindData.cFileName, AnsiFindData.cFileName); - WStrPCopy(WideFindData.cAlternateFileName, AnsiFindData.cAlternateFileName); -end; - -function Tnt_SetWindowTextW(hWnd: HWND; lpString: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetWindowTextW{TNT-ALLOW SetWindowTextW}(hWnd, lpString) - else - Result := SetWindowTextA{TNT-ALLOW SetWindowTextA}(hWnd, PAnsiChar(AnsiString(lpString))); -end; - -//----------------------------- - -type - TPathLengthResultOption = (poAllowDirectoryMode, poZeroSmallBuff, poExactCopy, poExactCopySubPaths); - TPathLengthResultOptions = set of TPathLengthResultOption; - -procedure _ExactStrCopyW(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; -begin - for i := 1 to Count do begin - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; -end; - -procedure _ExactCopySubPaths(pDest, pSource: PWideChar; Count: Integer); -var - i: integer; - OriginalSource: PWideChar; - PNextSlash: PWideChar; -begin - if Count >= 4 then begin - OriginalSource := pSource; - PNextSlash := WStrScan(pSource, '\'); - for i := 1 to Count - 1 do begin - // determine next path delimiter - if pSource > pNextSlash then begin - PNextSlash := WStrScan(pSource, '\'); - end; - // leave if no more sub paths - if (PNextSlash = nil) - or ((pNextSlash - OriginalSource) >= Count) then begin - exit; - end; - // copy char - pDest^ := pSource^; - Inc(PSource); - Inc(pDest); - end; - end; -end; - -function _HandlePathLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength > Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if (poExactCopy in Options) then begin - // exact - Result := nBufferLength; - _ExactStrCopyW(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else begin - // other - if (poAllowDirectoryMode in Options) - and (nBufferLength = Cardinal(Length(WideBuff))) then begin - Result := Length(WideBuff) + 1; - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength - 1); - end else begin - Result := Length(WideBuff) + 1; - if (nBufferLength > 0) then begin - if (poZeroSmallBuff in Options) then - lpBuffer^ := #0 - else if (poExactCopySubPaths in Options) then - _ExactCopySubPaths(lpBuffer, PWideChar(WideBuff), nBufferLength); - end; - end; - end; -end; - -function _HandleStringLengthResult(nBufferLength: DWORD; lpBuffer: PWideChar; const AnsiBuff: AnsiString; Options: TPathLengthResultOptions): Integer; -var - WideBuff: WideString; -begin - WideBuff := AnsiBuff; - if nBufferLength >= Cardinal(Length(WideBuff)) then begin - // normal - Result := Length(WideBuff); - WStrLCopy(lpBuffer, PWideChar(WideBuff), nBufferLength); - end else if nBufferLength = 0 then - Result := Length(WideBuff) - else - Result := 0; -end; - -//------------------------------------------- - -function Tnt_RemoveDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := RemoveDirectoryW{TNT-ALLOW RemoveDirectoryW}(PWideChar(lpPathName)) - else - Result := RemoveDirectoryA{TNT-ALLOW RemoveDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetShortPathNameW(lpszLongPath: PWideChar; lpszShortPath: PWideChar; - cchBuffer: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetShortPathNameW{TNT-ALLOW GetShortPathNameW}(lpszLongPath, lpszShortPath, cchBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetShortPathNameA{TNT-ALLOW GetShortPathNameA}(PAnsiChar(AnsiString(lpszLongPath)), - PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(cchBuffer, lpszShortPath, AnsiBuff, [poExactCopySubPaths]); - end; -end; - -function Tnt_GetFullPathNameW(lpFileName: PWideChar; nBufferLength: DWORD; - lpBuffer: PWideChar; var lpFilePart: PWideChar): DWORD; -var - AnsiBuff: AnsiString; - AnsiFilePart: PAnsiChar; - AnsiLeadingChars: Integer; - WideLeadingChars: Integer; -begin - if Win32PlatformIsUnicode then - Result := GetFullPathNameW{TNT-ALLOW GetFullPathNameW}(lpFileName, nBufferLength, lpBuffer, lpFilePart) - else begin - SetLength(AnsiBuff, MAX_PATH * 2); - SetLength(AnsiBuff, GetFullPathNameA{TNT-ALLOW GetFullPathNameA}(PAnsiChar(AnsiString(lpFileName)), - Length(AnsiBuff), PAnsiChar(AnsiBuff), AnsiFilePart)); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poZeroSmallBuff]); - // deal w/ lpFilePart - if (AnsiFilePart = nil) or (nBufferLength < Result) then - lpFilePart := nil - else begin - AnsiLeadingChars := AnsiFilePart - PAnsiChar(AnsiBuff); - WideLeadingChars := Length(WideString(Copy(AnsiBuff, 1, AnsiLeadingChars))); - lpFilePart := lpBuffer + WideLeadingChars; - end; - end; -end; - -function Tnt_CreateFileW(lpFileName: PWideChar; dwDesiredAccess, dwShareMode: DWORD; - lpSecurityAttributes: PSecurityAttributes; dwCreationDisposition, dwFlagsAndAttributes: DWORD; - hTemplateFile: THandle): THandle; -begin - if Win32PlatformIsUnicode then - Result := CreateFileW{TNT-ALLOW CreateFileW}(lpFileName, dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) - else - Result := CreateFileA{TNT-ALLOW CreateFileA}(PAnsiChar(AnsiString(lpFileName)), dwDesiredAccess, dwShareMode, - lpSecurityAttributes, dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile) -end; - -function Tnt_FindFirstFileW(lpFileName: PWideChar; var lpFindFileData: TWIN32FindDataW): THandle; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindFirstFileW{TNT-ALLOW FindFirstFileW}(lpFileName, lpFindFileData) - else begin - Result := FindFirstFileA{TNT-ALLOW FindFirstFileA}(PAnsiChar(AnsiString(lpFileName)), - Ansi_lpFindFileData); - if Result <> INVALID_HANDLE_VALUE then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_FindNextFileW(hFindFile: THandle; var lpFindFileData: TWIN32FindDataW): BOOL; -var - Ansi_lpFindFileData: TWIN32FindDataA; -begin - if Win32PlatformIsUnicode then - Result := FindNextFileW{TNT-ALLOW FindNextFileW}(hFindFile, lpFindFileData) - else begin - Result := FindNextFileA{TNT-ALLOW FindNextFileA}(hFindFile, Ansi_lpFindFileData); - if Result then - _MakeWideWin32FindData(lpFindFileData, Ansi_lpFindFileData); - end; -end; - -function Tnt_GetFileAttributesW(lpFileName: PWideChar): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileAttributesW{TNT-ALLOW GetFileAttributesW}(lpFileName) - else - Result := GetFileAttributesA{TNT-ALLOW GetFileAttributesA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_SetFileAttributesW(lpFileName: PWideChar; dwFileAttributes: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetFileAttributesW{TNT-ALLOW SetFileAttributesW}(lpFileName, dwFileAttributes) - else - Result := SetFileAttributesA{TNT-ALLOW SetFileAttributesA}(PAnsiChar(AnsiString(lpFileName)), dwFileAttributes); -end; - -function Tnt_CreateDirectoryW(lpPathName: PWideChar; - lpSecurityAttributes: PSecurityAttributes): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CreateDirectoryW{TNT-ALLOW CreateDirectoryW}(lpPathName, lpSecurityAttributes) - else - Result := CreateDirectoryA{TNT-ALLOW CreateDirectoryA}(PAnsiChar(AnsiString(lpPathName)), lpSecurityAttributes); -end; - -function Tnt_MoveFileW(lpExistingFileName, lpNewFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := MoveFileW{TNT-ALLOW MoveFileW}(lpExistingFileName, lpNewFileName) - else - Result := MoveFileA{TNT-ALLOW MoveFileA}(PAnsiChar(AnsiString(lpExistingFileName)), PAnsiChar(AnsiString(lpNewFileName))); -end; - -function Tnt_CopyFileW(lpExistingFileName, lpNewFileName: PWideChar; bFailIfExists: BOOL): BOOL; -begin - if Win32PlatformIsUnicode then - Result := CopyFileW{TNT-ALLOW CopyFileW}(lpExistingFileName, lpNewFileName, bFailIfExists) - else - Result := CopyFileA{TNT-ALLOW CopyFileA}(PAnsiChar(AnsiString(lpExistingFileName)), - PAnsiChar(AnsiString(lpNewFileName)), bFailIfExists); -end; - -function Tnt_DeleteFileW(lpFileName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := DeleteFileW{TNT-ALLOW DeleteFileW}(lpFileName) - else - Result := DeleteFileA{TNT-ALLOW DeleteFileA}(PAnsiChar(AnsiString(lpFileName))); -end; - -function Tnt_DrawTextW(hDC: HDC; lpString: PWideChar; nCount: Integer; - var lpRect: TRect; uFormat: UINT): Integer; -begin - if Win32PlatformIsUnicode then - Result := DrawTextW{TNT-ALLOW DrawTextW}(hDC, lpString, nCount, lpRect, uFormat) - else - Result := DrawTextA{TNT-ALLOW DrawTextA}(hDC, - PAnsiChar(AnsiString(_WStr(lpString, nCount))), -1, lpRect, uFormat); -end; - -function Tnt_GetDiskFreeSpaceW(lpRootPathName: PWideChar; var lpSectorsPerCluster, - lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters: DWORD): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetDiskFreeSpaceW{TNT-ALLOW GetDiskFreeSpaceW}(lpRootPathName, - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) - else - Result := GetDiskFreeSpaceA{TNT-ALLOW GetDiskFreeSpaceA}(PAnsiChar(AnsiString(lpRootPathName)), - lpSectorsPerCluster, lpBytesPerSector, lpNumberOfFreeClusters, lpTotalNumberOfClusters) -end; - -function Tnt_GetVolumeInformationW(lpRootPathName: PWideChar; lpVolumeNameBuffer: PWideChar; - nVolumeNameSize: DWORD; lpVolumeSerialNumber: PDWORD; - var lpMaximumComponentLength, lpFileSystemFlags: DWORD; lpFileSystemNameBuffer: PWideChar; - nFileSystemNameSize: DWORD): BOOL; -var - AnsiFileSystemNameBuffer: AnsiString; - AnsiVolumeNameBuffer: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetVolumeInformationW{TNT-ALLOW GetVolumeInformationW}(lpRootPathName, lpVolumeNameBuffer, nVolumeNameSize, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, lpFileSystemNameBuffer, nFileSystemNameSize) - else begin - SetLength(AnsiVolumeNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - SetLength(AnsiFileSystemNameBuffer, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiFileSystemNameBuffer); - Result := GetVolumeInformationA{TNT-ALLOW GetVolumeInformationA}(PAnsiChar(AnsiString(lpRootPathName)), PAnsiChar(AnsiVolumeNameBuffer), AnsiBuffLen, lpVolumeSerialNumber, lpMaximumComponentLength, lpFileSystemFlags, PAnsiChar(AnsiFileSystemNameBuffer), AnsiBuffLen); - if Result then begin - SetLength(AnsiFileSystemNameBuffer, AnsiBuffLen); - if (nFileSystemNameSize <= AnsiBuffLen) or (Length(AnsiFileSystemNameBuffer) = 0) then - Result := False - else begin - WStrPLCopy(lpFileSystemNameBuffer, AnsiFileSystemNameBuffer, nFileSystemNameSize); - WStrPLCopy(lpVolumeNameBuffer, AnsiVolumeNameBuffer, nVolumeNameSize); - end; - end; - end; -end; - -function Tnt_GetModuleFileNameW(hModule: HINST; lpFilename: PWideChar; nSize: DWORD): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetModuleFileNameW{TNT-ALLOW GetModuleFileNameW}(hModule, lpFilename, nSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetModuleFileNameA{TNT-ALLOW GetModuleFileNameA}(hModule, PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(nSize, lpFilename, AnsiBuff, [poExactCopy]); - end; -end; - -function Tnt_GetTempPathW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempPathW{TNT-ALLOW GetTempPathW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetTempPathA{TNT-ALLOW GetTempPathA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_GetTempFileNameW(lpPathName, lpPrefixString: PWideChar; uUnique: UINT; - lpTempFileName: PWideChar): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetTempFileNameW{TNT-ALLOW GetTempFileNameW}(lpPathName, lpPrefixString, uUnique, lpTempFileName) - else begin - SetLength(AnsiBuff, MAX_PATH); - Result := GetTempFileNameA{TNT-ALLOW GetTempFileNameA}(PAnsiChar(AnsiString(lpPathName)), PAnsiChar(lpPrefixString), uUnique, PAnsiChar(AnsiBuff)); - AnsiBuff := PAnsiChar(AnsiBuff); - _HandlePathLengthResult(MAX_PATH, lpTempFileName, AnsiBuff, [poZeroSmallBuff]); - end; -end; - -function Tnt_GetWindowsDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetWindowsDirectoryW{TNT-ALLOW GetWindowsDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetWindowsDirectoryA{TNT-ALLOW GetWindowsDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetSystemDirectoryW(lpBuffer: PWideChar; uSize: UINT): UINT; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetSystemDirectoryW{TNT-ALLOW GetSystemDirectoryW}(lpBuffer, uSize) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetSystemDirectoryA{TNT-ALLOW GetSystemDirectoryA}(PAnsiChar(AnsiBuff), Length(AnsiBuff))); - Result := _HandlePathLengthResult(uSize, lpBuffer, AnsiBuff, []); - end; -end; - -function Tnt_GetCurrentDirectoryW(nBufferLength: DWORD; lpBuffer: PWideChar): DWORD; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrentDirectoryW{TNT-ALLOW GetCurrentDirectoryW}(nBufferLength, lpBuffer) - else begin - SetLength(AnsiBuff, MAX_PATH); - SetLength(AnsiBuff, GetCurrentDirectoryA{TNT-ALLOW GetCurrentDirectoryA}(Length(AnsiBuff), PAnsiChar(AnsiBuff))); - Result := _HandlePathLengthResult(nBufferLength, lpBuffer, AnsiBuff, [poAllowDirectoryMode, poZeroSmallBuff]); - end; -end; - -function Tnt_SetCurrentDirectoryW(lpPathName: PWideChar): BOOL; -begin - if Win32PlatformIsUnicode then - Result := SetCurrentDirectoryW{TNT-ALLOW SetCurrentDirectoryW}(lpPathName) - else - Result := SetCurrentDirectoryA{TNT-ALLOW SetCurrentDirectoryA}(PAnsiChar(AnsiString(lpPathName))); -end; - -function Tnt_GetComputerNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetComputerNameW{TNT-ALLOW GetComputerNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, MAX_COMPUTERNAME_LENGTH + 1); - AnsiBuffLen := Length(AnsiBuff); - Result := GetComputerNameA{TNT-ALLOW GetComputerNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_GetUserNameW(lpBuffer: PWideChar; var nSize: DWORD): BOOL; -var - AnsiBuff: AnsiString; - AnsiBuffLen: DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetUserNameW{TNT-ALLOW GetUserNameW}(lpBuffer, nSize) - else begin - SetLength(AnsiBuff, 255); - AnsiBuffLen := Length(AnsiBuff); - Result := GetUserNameA{TNT-ALLOW GetUserNameA}(PAnsiChar(AnsiBuff), AnsiBuffLen); - if Result then begin - SetLength(AnsiBuff, AnsiBuffLen); - if (nSize <= AnsiBuffLen) or (Length(AnsiBuff) = 0) then begin - nSize := AnsiBuffLen + 1; - Result := False; - end else begin - WStrPLCopy(lpBuffer, AnsiBuff, nSize); - nSize := WStrLen(lpBuffer); - end; - end; - end; -end; - -function Tnt_ShellExecuteW(hWnd: HWND; Operation, FileName, Parameters, - Directory: PWideChar; ShowCmd: Integer): HINST; -begin - if Win32PlatformIsUnicode then - Result := ShellExecuteW{TNT-ALLOW ShellExecuteW}(hWnd, _PWideCharWithNil(WideString(Operation)), - FileName, Parameters, - Directory, ShowCmd) - else begin - Result := ShellExecuteA{TNT-ALLOW ShellExecuteA}(hWnd, _PAnsiCharWithNil(AnsiString(Operation)), - _PAnsiCharWithNil(AnsiString(FileName)), _PAnsiCharWithNil(AnsiString(Parameters)), - _PAnsiCharWithNil(AnsiString(Directory)), ShowCmd) - end; -end; - -function Tnt_LoadLibraryW(lpLibFileName: PWideChar): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryW{TNT-ALLOW LoadLibraryW}(lpLibFileName) - else - Result := LoadLibraryA{TNT-ALLOW LoadLibraryA}(PAnsiChar(AnsiString(lpLibFileName))); -end; - -function Tnt_LoadLibraryExW(lpLibFileName: PWideChar; hFile: THandle; dwFlags: DWORD): HMODULE; -begin - if Win32PlatformIsUnicode then - Result := LoadLibraryExW{TNT-ALLOW LoadLibraryExW}(lpLibFileName, hFile, dwFlags) - else - Result := LoadLibraryExA{TNT-ALLOW LoadLibraryExA}(PAnsiChar(AnsiString(lpLibFileName)), hFile, dwFlags); -end; - -function Tnt_CreateProcessW(lpApplicationName: PWideChar; lpCommandLine: PWideChar; - lpProcessAttributes, lpThreadAttributes: PSecurityAttributes; - bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; - lpCurrentDirectory: PWideChar; const lpStartupInfo: TStartupInfoW; - var lpProcessInformation: TProcessInformation): BOOL; -var - AnsiStartupInfo: TStartupInfoA; -begin - if Win32PlatformIsUnicode then begin - Result := CreateProcessW{TNT-ALLOW CreateProcessW}(lpApplicationName, lpCommandLine, - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - lpCurrentDirectory, lpStartupInfo, lpProcessInformation) - end else begin - CopyMemory(@AnsiStartupInfo, @lpStartupInfo, SizeOf(TStartupInfo)); - AnsiStartupInfo.lpReserved := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpReserved)); - AnsiStartupInfo.lpDesktop := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpDesktop)); - AnsiStartupInfo.lpTitle := _PAnsiCharWithNil(AnsiString(lpStartupInfo.lpTitle)); - Result := CreateProcessA{TNT-ALLOW CreateProcessA}(_PAnsiCharWithNil(AnsiString(lpApplicationName)), - _PAnsiCharWithNil(AnsiString(lpCommandLine)), - lpProcessAttributes, lpThreadAttributes, bInheritHandles, dwCreationFlags, lpEnvironment, - _PAnsiCharWithNil(AnsiString(lpCurrentDirectory)), AnsiStartupInfo, lpProcessInformation); - end; -end; - -function Tnt_GetCurrencyFormatW(Locale: LCID; dwFlags: DWORD; lpValue: PWideChar; - lpFormat: PCurrencyFmtW; lpCurrencyStr: PWideChar; cchCurrency: Integer): Integer; -const - MAX_ANSI_BUFF_SIZE = 64; // can a currency string actually be larger? -var - AnsiFormat: TCurrencyFmtA; - PAnsiFormat: PCurrencyFmtA; - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetCurrencyFormatW{TNT-ALLOW GetCurrencyFormatW}(Locale, dwFlags, lpValue, - {$IFNDEF FPC} lpFormat {$ELSE} PCurrencyFmt(lpFormat) {$ENDIF}, - lpCurrencyStr, cchCurrency) - else begin - if lpFormat = nil then - PAnsiFormat := nil - else begin - ZeroMemory(@AnsiFormat, SizeOf(AnsiFormat)); - AnsiFormat.NumDigits := lpFormat.NumDigits; - AnsiFormat.LeadingZero := lpFormat.LeadingZero; - AnsiFormat.Grouping := lpFormat.Grouping; - AnsiFormat.lpDecimalSep := PAnsiChar(AnsiString(lpFormat.lpDecimalSep)); - AnsiFormat.lpThousandSep := PAnsiChar(AnsiString(lpFormat.lpThousandSep)); - AnsiFormat.NegativeOrder := lpFormat.NegativeOrder; - AnsiFormat.PositiveOrder := lpFormat.PositiveOrder; - AnsiFormat.lpCurrencySymbol := PAnsiChar(AnsiString(lpFormat.lpCurrencySymbol)); - PAnsiFormat := @AnsiFormat; - end; - SetLength(AnsiBuff, MAX_ANSI_BUFF_SIZE); - SetLength(AnsiBuff, GetCurrencyFormatA{TNT-ALLOW GetCurrencyFormatA}(Locale, dwFlags, - PAnsiChar(AnsiString(lpValue)), PAnsiFormat, PAnsiChar(AnsiBuff), MAX_ANSI_BUFF_SIZE)); - Result := _HandleStringLengthResult(cchCurrency, lpCurrencyStr, AnsiBuff, []); - end; -end; - -function Tnt_CompareStringW(Locale: LCID; dwCmpFlags: DWORD; lpString1: PWideChar; - cchCount1: Integer; lpString2: PWideChar; cchCount2: Integer): Integer; -var - WideStr1, WideStr2: WideString; - AnsiStr1, AnsiStr2: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := CompareStringW{TNT-ALLOW CompareStringW}(Locale, dwCmpFlags, lpString1, cchCount1, lpString2, cchCount2) - else begin - WideStr1 := _WStr(lpString1, cchCount1); - WideStr2 := _WStr(lpString2, cchCount2); - if (dwCmpFlags = 0) then begin - // binary comparison - if WideStr1 < WideStr2 then - Result := 1 - else if WideStr1 = WideStr2 then - Result := 2 - else - Result := 3; - end else begin - AnsiStr1 := WideStr1; - AnsiStr2 := WideStr2; - Result := CompareStringA{TNT-ALLOW CompareStringA}(Locale, dwCmpFlags, - PAnsiChar(AnsiStr1), -1, PAnsiChar(AnsiStr2), -1); - end; - end; -end; - -function Tnt_CharUpperW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharUpperW{TNT-ALLOW CharUpperW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharUpperA{TNT-ALLOW CharUpperA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharUpperBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharUpperBuffW{TNT-ALLOW CharUpperBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharUpperW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_CharLowerW(lpsz: PWideChar): PWideChar; -var - AStr: AnsiString; - WStr: WideString; -begin - if Win32PlatformIsUnicode then - Result := CharLowerW{TNT-ALLOW CharLowerW}(lpsz) - else begin - if HiWord(Cardinal(lpsz)) = 0 then begin - // literal char mode - Result := lpsz; - if IsWideCharMappableToAnsi(WideChar(lpsz)) then begin - AStr := WideChar(lpsz); // single character may be more than one byte - CharLowerA{TNT-ALLOW CharLowerA}(PAnsiChar(AStr)); - WStr := AStr; // should always be single wide char - if Length(WStr) = 1 then - Result := PWideChar(WStr[1]); - end - end else begin - // null-terminated string mode - Result := lpsz; - while lpsz^ <> #0 do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; - end; -end; - -function Tnt_CharLowerBuffW(lpsz: PWideChar; cchLength: DWORD): DWORD; -var - i: integer; -begin - if Win32PlatformIsUnicode then - Result := CharLowerBuffW{TNT-ALLOW CharLowerBuffW}(lpsz, cchLength) - else begin - Result := cchLength; - for i := 1 to cchLength do begin - lpsz^ := WideChar(Tnt_CharLowerW(PWideChar(lpsz^))); - Inc(lpsz); - end; - end; -end; - -function Tnt_GetStringTypeExW(Locale: LCID; dwInfoType: DWORD; - lpSrcStr: PWideChar; cchSrc: Integer; var lpCharType): BOOL; -var - AStr: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := GetStringTypeExW{TNT-ALLOW GetStringTypeExW}(Locale, dwInfoType, lpSrcStr, cchSrc, lpCharType) - else begin - AStr := _WStr(lpSrcStr, cchSrc); - Result := GetStringTypeExA{TNT-ALLOW GetStringTypeExA}(Locale, dwInfoType, - PAnsiChar(AStr), -1, lpCharType); - end; -end; - -function Win9x_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -// This function originated by the WINE Project. -// It was translated to Pascal by Francisco Leong. -// It was further modified by Troy Wolbrink. -var - hmem: HGLOBAL; - hrsrc: THandle; - p: PWideChar; - string_num, i: Integer; - block: Integer; -begin - Result := 0; - // Netscape v3 fix... - if (HIWORD(uID) = $FFFF) then begin - uID := UINT(-(Integer(uID))); - end; - // figure block, string_num - block := ((uID shr 4) and $FFFF) + 1; // bits 4 - 19, mask out bits 20 - 31, inc by 1 - string_num := uID and $000F; - // get handle & pointer to string block - hrsrc := FindResource{TNT-ALLOW FindResource}(hInstance, MAKEINTRESOURCE(block), RT_STRING); - if (hrsrc <> 0) then - begin - hmem := LoadResource(hInstance, hrsrc); - if (hmem <> 0) then - begin - p := LockResource(hmem); - // walk the block to the requested string - for i := 0 to string_num - 1 do begin - p := p + Integer(p^) + 1; - end; - Result := Integer(p^); { p points to the length of string } - Inc(p); { p now points to the actual string } - if (lpBuffer <> nil) and (nBufferMax > 0) then - begin - Result := min(nBufferMax - 1, Result); { max length to copy } - if (Result > 0) then begin - CopyMemory(lpBuffer, p, Result * sizeof(WideChar)); - end; - lpBuffer[Result] := WideChar(0); { null terminate } - end; - end; - end; -end; - -function Tnt_LoadStringW(hInstance: HINST; uID: UINT; lpBuffer: PWideChar; nBufferMax: Integer): Integer; -begin - if Win32PlatformIsUnicode then - Result := Windows.LoadStringW{TNT-ALLOW LoadStringW}(hInstance, uID, lpBuffer, nBufferMax) - else - Result := Win9x_LoadStringW(hInstance, uID, lpBuffer, nBufferMax); -end; - -function Tnt_InsertMenuItemW(hMenu: HMENU; uItem: DWORD; fByPosition: BOOL; lpmii: TMenuItemInfoW): BOOL; -begin - if Win32PlatformIsUnicode then - Result := InsertMenuItemW{TNT-ALLOW InsertMenuItemW}(hMenu, uItem, fByPosition, - {$IFDEF FPC}@{$ENDIF}lpmii) - else begin - TMenuItemInfoA(lpmii).dwTypeData := PAnsiChar(AnsiString(lpmii.dwTypeData)); - Result := InsertMenuItemA{TNT-ALLOW InsertMenuItemA}(hMenu, uItem, fByPosition, - {$IFDEF FPC}@{$ENDIF}TMenuItemInfoA(lpmii)); - end; -end; - -function Tnt_ExtractIconExW(lpszFile: PWideChar; nIconIndex: Integer; - var phiconLarge, phiconSmall: HICON; nIcons: UINT): UINT; -begin - if Win32PlatformIsUnicode then - Result := ExtractIconExW{TNT-ALLOW ExtractIconExW}(lpszFile, - nIconIndex, phiconLarge, phiconSmall, nIcons) - else - Result := ExtractIconExA{TNT-ALLOW ExtractIconExA}(PAnsiChar(AnsiString(lpszFile)), - nIconIndex, phiconLarge, phiconSmall, nIcons); -end; - -function Tnt_ExtractAssociatedIconW(hInst: HINST; lpIconPath: PWideChar; - var lpiIcon: Word): HICON; -begin - if Win32PlatformIsUnicode then - Result := ExtractAssociatedIconW{TNT-ALLOW ExtractAssociatedIconW}(hInst, - lpIconPath, {$IFDEF FPC}@{$ENDIF}lpiIcon) - else - Result := ExtractAssociatedIconA{TNT-ALLOW ExtractAssociatedIconA}(hInst, - PAnsiChar(AnsiString(lpIconPath)), {$IFDEF FPC}@{$ENDIF}lpiIcon) -end; - -function Tnt_GetFileVersionInfoSizeW(lptstrFilename: PWideChar; var lpdwHandle: DWORD): DWORD; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoSizeW{TNT-ALLOW GetFileVersionInfoSizeW}(lptstrFilename, lpdwHandle) - else - Result := GetFileVersionInfoSizeA{TNT-ALLOW GetFileVersionInfoSizeA}(PAnsiChar(AnsiString(lptstrFilename)), lpdwHandle); -end; - -function Tnt_GetFileVersionInfoW(lptstrFilename: PWideChar; dwHandle, dwLen: DWORD; - lpData: Pointer): BOOL; -begin - if Win32PlatformIsUnicode then - Result := GetFileVersionInfoW{TNT-ALLOW GetFileVersionInfoW}(lptstrFilename, dwHandle, dwLen, lpData) - else - Result := GetFileVersionInfoA{TNT-ALLOW GetFileVersionInfoA}(PAnsiChar(AnsiString(lptstrFilename)), dwHandle, dwLen, lpData); -end; - -var - Last_VerQueryValue_String: WideString; - -function Tnt_VerQueryValueW(pBlock: Pointer; lpSubBlock: PWideChar; - var lplpBuffer: Pointer; var puLen: UINT): BOOL; -var - AnsiBuff: AnsiString; -begin - if Win32PlatformIsUnicode then - Result := VerQueryValueW{TNT-ALLOW VerQueryValueW}(pBlock, lpSubBlock, lplpBuffer, puLen) - else begin - Result := VerQueryValueA{TNT-ALLOW VerQueryValueA}(pBlock, PAnsiChar(AnsiString(lpSubBlock)), lplpBuffer, puLen); - if WideTextPos(VQV_STRINGFILEINFO, lpSubBlock) <> 1 then - else begin - { /StringFileInfo, convert ansi result to unicode } - SetString(AnsiBuff, PAnsiChar(lplpBuffer), puLen); - Last_VerQueryValue_String := AnsiBuff; - lplpBuffer := PWideChar(Last_VerQueryValue_String); - puLen := Length(Last_VerQueryValue_String); - end; - end; -end; - -//--------------------------------------------------------------------------------------- -// Wide functions from Shell32.dll should be loaded dynamically (no stub on early Win95) -//--------------------------------------------------------------------------------------- - -type - TSHFileOperationW = function(var lpFileOp: TSHFileOpStructW): Integer; stdcall; - TSHBrowseForFolderW = function(var lpbi: TBrowseInfoW): PItemIDList; stdcall; - TSHGetPathFromIDListW = function(pidl: PItemIDList; pszPath: PWideChar): BOOL; stdcall; - TSHGetFileInfoW = function(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; stdcall; - -var - Safe_SHFileOperationW: TSHFileOperationW = nil; - Safe_SHBrowseForFolderW: TSHBrowseForFolderW = nil; - Safe_SHGetPathFromIDListW: TSHGetPathFromIDListW = nil; - Safe_SHGetFileInfoW: TSHGetFileInfoW = nil; - -var Shell32DLL: HModule = 0; - -procedure LoadWideShell32Procs; -begin - if Shell32DLL = 0 then begin - Shell32DLL := WinCheckH(Tnt_LoadLibraryW('shell32.dll')); - Safe_SHFileOperationW := WinCheckP(GetProcAddress(Shell32DLL, 'SHFileOperationW')); - Safe_SHBrowseForFolderW := WinCheckP(GetProcAddress(Shell32DLL, 'SHBrowseForFolderW')); - Safe_SHGetPathFromIDListW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetPathFromIDListW')); - Safe_SHGetFileInfoW := WinCheckP(GetProcAddress(Shell32DLL, 'SHGetFileInfoW')); - end; -end; - -function Tnt_SHFileOperationW(var lpFileOp: TSHFileOpStructW): Integer; -var - AnsiFileOp: TSHFileOpStructA; - MapCount: Integer; - PAnsiMap: PSHNameMappingA; - PWideMap: PSHNameMappingW; - OldPath: WideString; - NewPath: WideString; - i: integer; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHFileOperationW(lpFileOp); - end else begin - AnsiFileOp := TSHFileOpStructA(lpFileOp); - // convert PChar -> PWideChar - if lpFileOp.pFrom = nil then - AnsiFileOp.pFrom := nil - else - AnsiFileOp.pFrom := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pFrom))); - if lpFileOp.pTo = nil then - AnsiFileOp.pTo := nil - else - AnsiFileOp.pTo := PAnsiChar(AnsiString(ExtractStringArrayStr(lpFileOp.pTo))); - AnsiFileOp.lpszProgressTitle := PAnsiChar(AnsiString(lpFileOp.lpszProgressTitle)); - Result := SHFileOperationA{TNT-ALLOW SHFileOperationA}( - {$IFDEF FPC}@{$ENDIF}AnsiFileOp); - // return struct results - lpFileOp.fAnyOperationsAborted := AnsiFileOp.fAnyOperationsAborted; - lpFileOp.hNameMappings := nil; - if (AnsiFileOp.hNameMappings <> nil) - and ((FOF_WANTMAPPINGHANDLE and AnsiFileOp.fFlags) <> 0) then begin - // alloc mem - MapCount := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).cNumOfMappings; - lpFileOp.hNameMappings := - AllocMem(SizeOf({hNameMappings}Cardinal) + SizeOf(TSHNameMappingW) * MapCount); - PSHNameMappingHeaderW(lpFileOp.hNameMappings).cNumOfMappings := MapCount; - // init pointers - PAnsiMap := PSHNameMappingHeaderA(AnsiFileOp.hNameMappings).lpNM; - PWideMap := PSHNameMappingHeaderW(lpFileOp.hNameMappings).lpNM; - for i := 1 to MapCount do begin - // old path - OldPath := Copy(PAnsiMap.pszOldPath, 1, PAnsiMap.cchOldPath); - PWideMap.pszOldPath := WStrNew(PWideChar(OldPath)); - PWideMap.cchOldPath := WStrLen(PWideMap.pszOldPath); - // new path - NewPath := Copy(PAnsiMap.pszNewPath, 1, PAnsiMap.cchNewPath); - PWideMap.pszNewPath := WStrNew(PWideChar(NewPath)); - PWideMap.cchNewPath := WStrLen(PWideMap.pszNewPath); - // next record - Inc(PAnsiMap); - Inc(PWideMap); - end; - end; - end; -end; - -procedure Tnt_SHFreeNameMappings(hNameMappings: THandle); -var - i: integer; - MapCount: Integer; - PWideMap: PSHNameMappingW; -begin - if Win32PlatformIsUnicode then - SHFreeNameMappings{TNT-ALLOW SHFreeNameMappings}(hNameMappings) - else begin - // free strings - MapCount := PSHNameMappingHeaderW(hNameMappings).cNumOfMappings; - PWideMap := PSHNameMappingHeaderW(hNameMappings).lpNM; - for i := 1 to MapCount do begin - WStrDispose(PWideMap.pszOldPath); - WStrDispose(PWideMap.pszNewPath); - Inc(PWideMap); - end; - // free struct - FreeMem(Pointer(hNameMappings)); - end; -end; - -function Tnt_SHBrowseForFolderW(var lpbi: TBrowseInfoW): PItemIDList; -var - AnsiInfo: TBrowseInfoA; - AnsiBuffer: array[0..MAX_PATH] of AnsiChar; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHBrowseForFolderW(lpbi); - end else begin - AnsiInfo := TBrowseInfoA(lpbi); - AnsiInfo.lpszTitle := PAnsiChar(AnsiString(lpbi.lpszTitle)); - if lpbi.pszDisplayName <> nil then - AnsiInfo.pszDisplayName := AnsiBuffer; - Result := SHBrowseForFolderA{TNT-ALLOW SHBrowseForFolderA}( - {$IFDEF FPC}@{$ENDIF}AnsiInfo); - if lpbi.pszDisplayName <> nil then - WStrPCopy(lpbi.pszDisplayName, AnsiInfo.pszDisplayName); - lpbi.iImage := AnsiInfo.iImage; - end; -end; - -function Tnt_SHGetPathFromIDListW(pidl: PItemIDList; pszPath: PWideChar): BOOL; -var - AnsiPath: AnsiString; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetPathFromIDListW(pidl, pszPath); - end else begin - SetLength(AnsiPath, MAX_PATH); - Result := SHGetPathFromIDListA{TNT-ALLOW SHGetPathFromIDListA}(pidl, PAnsiChar(AnsiPath)); - if Result then - WStrPCopy(pszPath, PAnsiChar(AnsiPath)) - end; -end; - -function Tnt_SHGetFileInfoW(pszPath: PWideChar; dwFileAttributes: DWORD; - var psfi: TSHFileInfoW; cbFileInfo, uFlags: UINT): DWORD; -var - SHFileInfoA: TSHFileInfoA; -begin - if Win32PlatformIsUnicode then begin - LoadWideShell32Procs; - Result := Safe_SHGetFileInfoW(pszPath, dwFileAttributes, psfi, cbFileInfo, uFlags) - end else begin - Result := SHGetFileInfoA{TNT-ALLOW SHGetFileInfoA}(PAnsiChar(AnsiString(pszPath)), - dwFileAttributes, SHFileInfoA, SizeOf(TSHFileInfoA), uFlags); - // update pfsi... - ZeroMemory(@psfi, SizeOf(TSHFileInfoW)); - psfi.hIcon := SHFileInfoA.hIcon; - psfi.iIcon := SHFileInfoA.iIcon; - psfi.dwAttributes := SHFileInfoA.dwAttributes; - WStrPLCopy(psfi.szDisplayName, SHFileInfoA.szDisplayName, MAX_PATH); - WStrPLCopy(psfi.szTypeName, SHFileInfoA.szTypeName, 80); - end; -end; - - -function Tnt_Is_IntResource(ResStr: LPCWSTR): Boolean; -begin - Result := HiWord(Cardinal(ResStr)) = 0; -end; - -function LANGIDFROMLCID(lcid: LCID): WORD; -begin - Result := LoWord(lcid); -end; - -function MAKELANGID(usPrimaryLanguage, usSubLanguage: WORD): WORD; -begin - Result := (usSubLanguage shl 10) or usPrimaryLanguage; -end; - -function MAKELCID(wLanguageID: WORD; wSortID: WORD = SORT_DEFAULT): LCID; -begin - Result := MakeLong(wLanguageID, wSortID); -end; - -function PRIMARYLANGID(lgid: WORD): WORD; -begin - Result := lgid and $03FF; -end; - -function SORTIDFROMLCID(lcid: LCID): WORD; -begin - Result := HiWord(lcid); -end; - -function SUBLANGID(lgid: WORD): WORD; -begin - Result := lgid shr 10; -end; - -initialization - -finalization - if Shell32DLL <> 0 then - FreeLibrary(Shell32DLL); - -end. diff --git a/src/lib/bass/delphi/bass.pas b/src/lib/bass/delphi/bass.pas deleted file mode 100644 index 85d10355..00000000 --- a/src/lib/bass/delphi/bass.pas +++ /dev/null @@ -1,900 +0,0 @@ -{ - BASS 2.4 Delphi unit - Copyright (c) 1999-2008 Un4seen Developments Ltd. - - See the BASS.CHM file for more detailed documentation - - How to install - -------------- - Copy BASS.PAS to the \LIB subdirectory of your Delphi path or your project dir -} - -unit Bass; - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$PACKRECORDS C} -{$ENDIF} - -{$IFDEF MSWINDOWS} - {$DEFINE DLL_STDCALL} -{$ELSE} - {$DEFINE DLL_CDECL} -{$ENDIF} - -// IMPORTANT: define BASS_242 when switching to 2.4.2(.1) as -// BASS_RECORDINFO.driver was removed. -// Otherwise BASS_RECORDINFO.freq will point to a wrong location. -{$UNDEF BASS_242} - - -{$IFDEF MSWINDOWS} -uses - Windows; -{$ENDIF} - -const - BASSVERSION = $204; // API version - BASSVERSIONTEXT = '2.4'; - - // Use these to test for error from functions that return a DWORD or QWORD - DW_ERROR = Cardinal(-1); // -1 (DWORD) - QW_ERROR = Int64(-1); // -1 (QWORD) - - // Error codes returned by BASS_ErrorGetCode() - BASS_OK = 0; // all is OK - BASS_ERROR_MEM = 1; // memory error - BASS_ERROR_FILEOPEN = 2; // can't open the file - BASS_ERROR_DRIVER = 3; // can't find a free sound driver - BASS_ERROR_BUFLOST = 4; // the sample buffer was lost - BASS_ERROR_HANDLE = 5; // invalid handle - BASS_ERROR_FORMAT = 6; // unsupported sample format - BASS_ERROR_POSITION = 7; // invalid position - BASS_ERROR_INIT = 8; // BASS_Init has not been successfully called - BASS_ERROR_START = 9; // BASS_Start has not been successfully called - BASS_ERROR_ALREADY = 14; // already initialized/paused/whatever - BASS_ERROR_NOCHAN = 18; // can't get a free channel - BASS_ERROR_ILLTYPE = 19; // an illegal type was specified - BASS_ERROR_ILLPARAM = 20; // an illegal parameter was specified - BASS_ERROR_NO3D = 21; // no 3D support - BASS_ERROR_NOEAX = 22; // no EAX support - BASS_ERROR_DEVICE = 23; // illegal device number - BASS_ERROR_NOPLAY = 24; // not playing - BASS_ERROR_FREQ = 25; // illegal sample rate - BASS_ERROR_NOTFILE = 27; // the stream is not a file stream - BASS_ERROR_NOHW = 29; // no hardware voices available - BASS_ERROR_EMPTY = 31; // the MOD music has no sequence data - BASS_ERROR_NONET = 32; // no internet connection could be opened - BASS_ERROR_CREATE = 33; // couldn't create the file - BASS_ERROR_NOFX = 34; // effects are not enabled - BASS_ERROR_NOTAVAIL = 37; // requested data is not available - BASS_ERROR_DECODE = 38; // the channel is a "decoding channel" - BASS_ERROR_DX = 39; // a sufficient DirectX version is not installed - BASS_ERROR_TIMEOUT = 40; // connection timedout - BASS_ERROR_FILEFORM = 41; // unsupported file format - BASS_ERROR_SPEAKER = 42; // unavailable speaker - BASS_ERROR_VERSION = 43; // invalid BASS version (used by add-ons) - BASS_ERROR_CODEC = 44; // codec is not available/supported - BASS_ERROR_ENDED = 45; // the channel/file has ended - BASS_ERROR_UNKNOWN = -1; // some other mystery problem - - // BASS_SetConfig options - BASS_CONFIG_BUFFER = 0; - BASS_CONFIG_UPDATEPERIOD = 1; - BASS_CONFIG_GVOL_SAMPLE = 4; - BASS_CONFIG_GVOL_STREAM = 5; - BASS_CONFIG_GVOL_MUSIC = 6; - BASS_CONFIG_CURVE_VOL = 7; - BASS_CONFIG_CURVE_PAN = 8; - BASS_CONFIG_FLOATDSP = 9; - BASS_CONFIG_3DALGORITHM = 10; - BASS_CONFIG_NET_TIMEOUT = 11; - BASS_CONFIG_NET_BUFFER = 12; - BASS_CONFIG_PAUSE_NOPLAY = 13; - BASS_CONFIG_NET_PREBUF = 15; - BASS_CONFIG_NET_PASSIVE = 18; - BASS_CONFIG_REC_BUFFER = 19; - BASS_CONFIG_NET_PLAYLIST = 21; - BASS_CONFIG_MUSIC_VIRTUAL = 22; - BASS_CONFIG_VERIFY = 23; - BASS_CONFIG_UPDATETHREADS = 24; - - // BASS_SetConfigPtr options - BASS_CONFIG_NET_AGENT = 16; - BASS_CONFIG_NET_PROXY = 17; - - // Initialization flags - BASS_DEVICE_8BITS = 1; // use 8 bit resolution, else 16 bit - BASS_DEVICE_MONO = 2; // use mono, else stereo - BASS_DEVICE_3D = 4; // enable 3D functionality - BASS_DEVICE_LATENCY = 256; // calculate device latency (BASS_INFO struct) - BASS_DEVICE_CPSPEAKERS = 1024; // detect speakers via Windows control panel - BASS_DEVICE_SPEAKERS = 2048; // force enabling of speaker assignment - BASS_DEVICE_NOSPEAKER = 4096; // ignore speaker arrangement - - // DirectSound interfaces (for use with BASS_GetDSoundObject) - BASS_OBJECT_DS = 1; // IDirectSound - BASS_OBJECT_DS3DL = 2; // IDirectSound3DListener - - // BASS_DEVICEINFO flags - BASS_DEVICE_ENABLED = 1; - BASS_DEVICE_DEFAULT = 2; - BASS_DEVICE_INIT = 4; - - // BASS_INFO flags (from DSOUND.H) - DSCAPS_CONTINUOUSRATE = $00000010; // supports all sample rates between min/maxrate - DSCAPS_EMULDRIVER = $00000020; // device does NOT have hardware DirectSound support - DSCAPS_CERTIFIED = $00000040; // device driver has been certified by Microsoft - DSCAPS_SECONDARYMONO = $00000100; // mono - DSCAPS_SECONDARYSTEREO = $00000200; // stereo - DSCAPS_SECONDARY8BIT = $00000400; // 8 bit - DSCAPS_SECONDARY16BIT = $00000800; // 16 bit - - // BASS_RECORDINFO flags (from DSOUND.H) - DSCCAPS_EMULDRIVER = DSCAPS_EMULDRIVER; // device does NOT have hardware DirectSound recording support - DSCCAPS_CERTIFIED = DSCAPS_CERTIFIED; // device driver has been certified by Microsoft - - // defines for formats field of BASS_RECORDINFO (from MMSYSTEM.H) - WAVE_FORMAT_1M08 = $00000001; // 11.025 kHz, Mono, 8-bit - WAVE_FORMAT_1S08 = $00000002; // 11.025 kHz, Stereo, 8-bit - WAVE_FORMAT_1M16 = $00000004; // 11.025 kHz, Mono, 16-bit - WAVE_FORMAT_1S16 = $00000008; // 11.025 kHz, Stereo, 16-bit - WAVE_FORMAT_2M08 = $00000010; // 22.05 kHz, Mono, 8-bit - WAVE_FORMAT_2S08 = $00000020; // 22.05 kHz, Stereo, 8-bit - WAVE_FORMAT_2M16 = $00000040; // 22.05 kHz, Mono, 16-bit - WAVE_FORMAT_2S16 = $00000080; // 22.05 kHz, Stereo, 16-bit - WAVE_FORMAT_4M08 = $00000100; // 44.1 kHz, Mono, 8-bit - WAVE_FORMAT_4S08 = $00000200; // 44.1 kHz, Stereo, 8-bit - WAVE_FORMAT_4M16 = $00000400; // 44.1 kHz, Mono, 16-bit - WAVE_FORMAT_4S16 = $00000800; // 44.1 kHz, Stereo, 16-bit - - BASS_SAMPLE_8BITS = 1; // 8 bit - BASS_SAMPLE_FLOAT = 256; // 32-bit floating-point - BASS_SAMPLE_MONO = 2; // mono - BASS_SAMPLE_LOOP = 4; // looped - BASS_SAMPLE_3D = 8; // 3D functionality - BASS_SAMPLE_SOFTWARE = 16; // not using hardware mixing - BASS_SAMPLE_MUTEMAX = 32; // mute at max distance (3D only) - BASS_SAMPLE_VAM = 64; // DX7 voice allocation & management - BASS_SAMPLE_FX = 128; // old implementation of DX8 effects - BASS_SAMPLE_OVER_VOL = $10000; // override lowest volume - BASS_SAMPLE_OVER_POS = $20000; // override longest playing - BASS_SAMPLE_OVER_DIST = $30000; // override furthest from listener (3D only) - - BASS_STREAM_PRESCAN = $20000; // enable pin-point seeking/length (MP3/MP2/MP1) - BASS_MP3_SETPOS = BASS_STREAM_PRESCAN; - BASS_STREAM_AUTOFREE = $40000; // automatically free the stream when it stop/ends - BASS_STREAM_RESTRATE = $80000; // restrict the download rate of internet file streams - BASS_STREAM_BLOCK = $100000;// download/play internet file stream in small blocks - BASS_STREAM_DECODE = $200000;// don't play the stream, only decode (BASS_ChannelGetData) - BASS_STREAM_STATUS = $800000;// give server status info (HTTP/ICY tags) in DOWNLOADPROC - - BASS_MUSIC_FLOAT = BASS_SAMPLE_FLOAT; - BASS_MUSIC_MONO = BASS_SAMPLE_MONO; - BASS_MUSIC_LOOP = BASS_SAMPLE_LOOP; - BASS_MUSIC_3D = BASS_SAMPLE_3D; - BASS_MUSIC_FX = BASS_SAMPLE_FX; - BASS_MUSIC_AUTOFREE = BASS_STREAM_AUTOFREE; - BASS_MUSIC_DECODE = BASS_STREAM_DECODE; - BASS_MUSIC_PRESCAN = BASS_STREAM_PRESCAN; // calculate playback length - BASS_MUSIC_CALCLEN = BASS_MUSIC_PRESCAN; - BASS_MUSIC_RAMP = $200; // normal ramping - BASS_MUSIC_RAMPS = $400; // sensitive ramping - BASS_MUSIC_SURROUND = $800; // surround sound - BASS_MUSIC_SURROUND2 = $1000; // surround sound (mode 2) - BASS_MUSIC_FT2MOD = $2000; // play .MOD as FastTracker 2 does - BASS_MUSIC_PT1MOD = $4000; // play .MOD as ProTracker 1 does - BASS_MUSIC_NONINTER = $10000; // non-interpolated sample mixing - BASS_MUSIC_SINCINTER = $800000; // sinc interpolated sample mixing - BASS_MUSIC_POSRESET = $8000; // stop all notes when moving position - BASS_MUSIC_POSRESETEX = $400000; // stop all notes and reset bmp/etc when moving position - BASS_MUSIC_STOPBACK = $80000; // stop the music on a backwards jump effect - BASS_MUSIC_NOSAMPLE = $100000; // don't load the samples - - // Speaker assignment flags - BASS_SPEAKER_FRONT = $1000000; // front speakers - BASS_SPEAKER_REAR = $2000000; // rear/side speakers - BASS_SPEAKER_CENLFE = $3000000; // center & LFE speakers (5.1) - BASS_SPEAKER_REAR2 = $4000000; // rear center speakers (7.1) - BASS_SPEAKER_LEFT = $10000000; // modifier: left - BASS_SPEAKER_RIGHT = $20000000; // modifier: right - BASS_SPEAKER_FRONTLEFT = BASS_SPEAKER_FRONT or BASS_SPEAKER_LEFT; - BASS_SPEAKER_FRONTRIGHT = BASS_SPEAKER_FRONT or BASS_SPEAKER_RIGHT; - BASS_SPEAKER_REARLEFT = BASS_SPEAKER_REAR or BASS_SPEAKER_LEFT; - BASS_SPEAKER_REARRIGHT = BASS_SPEAKER_REAR or BASS_SPEAKER_RIGHT; - BASS_SPEAKER_CENTER = BASS_SPEAKER_CENLFE or BASS_SPEAKER_LEFT; - BASS_SPEAKER_LFE = BASS_SPEAKER_CENLFE or BASS_SPEAKER_RIGHT; - BASS_SPEAKER_REAR2LEFT = BASS_SPEAKER_REAR2 or BASS_SPEAKER_LEFT; - BASS_SPEAKER_REAR2RIGHT = BASS_SPEAKER_REAR2 or BASS_SPEAKER_RIGHT; - - BASS_UNICODE = $80000000; - - BASS_RECORD_PAUSE = $8000; // start recording paused - - // DX7 voice allocation & management flags - BASS_VAM_HARDWARE = 1; - BASS_VAM_SOFTWARE = 2; - BASS_VAM_TERM_TIME = 4; - BASS_VAM_TERM_DIST = 8; - BASS_VAM_TERM_PRIO = 16; - - // BASS_CHANNELINFO types - BASS_CTYPE_SAMPLE = 1; - BASS_CTYPE_RECORD = 2; - BASS_CTYPE_STREAM = $10000; - BASS_CTYPE_STREAM_OGG = $10002; - BASS_CTYPE_STREAM_MP1 = $10003; - BASS_CTYPE_STREAM_MP2 = $10004; - BASS_CTYPE_STREAM_MP3 = $10005; - BASS_CTYPE_STREAM_AIFF = $10006; - BASS_CTYPE_STREAM_WAV = $40000; // WAVE flag, LOWORD=codec - BASS_CTYPE_STREAM_WAV_PCM = $50001; - BASS_CTYPE_STREAM_WAV_FLOAT = $50003; - BASS_CTYPE_MUSIC_MOD = $20000; - BASS_CTYPE_MUSIC_MTM = $20001; - BASS_CTYPE_MUSIC_S3M = $20002; - BASS_CTYPE_MUSIC_XM = $20003; - BASS_CTYPE_MUSIC_IT = $20004; - BASS_CTYPE_MUSIC_MO3 = $00100; // MO3 flag - - // 3D channel modes - BASS_3DMODE_NORMAL = 0; // normal 3D processing - BASS_3DMODE_RELATIVE = 1; // position is relative to the listener - BASS_3DMODE_OFF = 2; // no 3D processing - - // software 3D mixing algorithms (used with BASS_CONFIG_3DALGORITHM) - BASS_3DALG_DEFAULT = 0; - BASS_3DALG_OFF = 1; - BASS_3DALG_FULL = 2; - BASS_3DALG_LIGHT = 3; - -{$IFDEF MSWINDOWS} - // EAX environments, use with BASS_SetEAXParameters - EAX_ENVIRONMENT_GENERIC = 0; - EAX_ENVIRONMENT_PADDEDCELL = 1; - EAX_ENVIRONMENT_ROOM = 2; - EAX_ENVIRONMENT_BATHROOM = 3; - EAX_ENVIRONMENT_LIVINGROOM = 4; - EAX_ENVIRONMENT_STONEROOM = 5; - EAX_ENVIRONMENT_AUDITORIUM = 6; - EAX_ENVIRONMENT_CONCERTHALL = 7; - EAX_ENVIRONMENT_CAVE = 8; - EAX_ENVIRONMENT_ARENA = 9; - EAX_ENVIRONMENT_HANGAR = 10; - EAX_ENVIRONMENT_CARPETEDHALLWAY = 11; - EAX_ENVIRONMENT_HALLWAY = 12; - EAX_ENVIRONMENT_STONECORRIDOR = 13; - EAX_ENVIRONMENT_ALLEY = 14; - EAX_ENVIRONMENT_FOREST = 15; - EAX_ENVIRONMENT_CITY = 16; - EAX_ENVIRONMENT_MOUNTAINS = 17; - EAX_ENVIRONMENT_QUARRY = 18; - EAX_ENVIRONMENT_PLAIN = 19; - EAX_ENVIRONMENT_PARKINGLOT = 20; - EAX_ENVIRONMENT_SEWERPIPE = 21; - EAX_ENVIRONMENT_UNDERWATER = 22; - EAX_ENVIRONMENT_DRUGGED = 23; - EAX_ENVIRONMENT_DIZZY = 24; - EAX_ENVIRONMENT_PSYCHOTIC = 25; - // total number of environments - EAX_ENVIRONMENT_COUNT = 26; -{$ENDIF} - - BASS_STREAMPROC_END = $80000000; // end of user stream flag - - - // BASS_StreamCreateFileUser file systems - STREAMFILE_NOBUFFER = 0; - STREAMFILE_BUFFER = 1; - STREAMFILE_BUFFERPUSH = 2; - - // BASS_StreamPutFileData options - BASS_FILEDATA_END = 0; // end & close the file - - // BASS_StreamGetFilePosition modes - BASS_FILEPOS_CURRENT = 0; - BASS_FILEPOS_DECODE = BASS_FILEPOS_CURRENT; - BASS_FILEPOS_DOWNLOAD = 1; - BASS_FILEPOS_END = 2; - BASS_FILEPOS_START = 3; - BASS_FILEPOS_CONNECTED = 4; - BASS_FILEPOS_BUFFER = 5; - - // BASS_ChannelSetSync types - BASS_SYNC_POS = 0; - BASS_SYNC_END = 2; - BASS_SYNC_META = 4; - BASS_SYNC_SLIDE = 5; - BASS_SYNC_STALL = 6; - BASS_SYNC_DOWNLOAD = 7; - BASS_SYNC_FREE = 8; - BASS_SYNC_SETPOS = 11; - BASS_SYNC_MUSICPOS = 10; - BASS_SYNC_MUSICINST = 1; - BASS_SYNC_MUSICFX = 3; - BASS_SYNC_OGG_CHANGE = 12; - BASS_SYNC_MIXTIME = $40000000; // FLAG: sync at mixtime, else at playtime - BASS_SYNC_ONETIME = $80000000; // FLAG: sync only once, else continuously - - // BASS_ChannelIsActive return values - BASS_ACTIVE_STOPPED = 0; - BASS_ACTIVE_PLAYING = 1; - BASS_ACTIVE_STALLED = 2; - BASS_ACTIVE_PAUSED = 3; - - // Channel attributes - BASS_ATTRIB_FREQ = 1; - BASS_ATTRIB_VOL = 2; - BASS_ATTRIB_PAN = 3; - BASS_ATTRIB_EAXMIX = 4; - BASS_ATTRIB_MUSIC_AMPLIFY = $100; - BASS_ATTRIB_MUSIC_PANSEP = $101; - BASS_ATTRIB_MUSIC_PSCALER = $102; - BASS_ATTRIB_MUSIC_BPM = $103; - BASS_ATTRIB_MUSIC_SPEED = $104; - BASS_ATTRIB_MUSIC_VOL_GLOBAL = $105; - BASS_ATTRIB_MUSIC_VOL_CHAN = $200; // + channel # - BASS_ATTRIB_MUSIC_VOL_INST = $300; // + instrument # - - // BASS_ChannelGetData flags - BASS_DATA_AVAILABLE = 0; // query how much data is buffered - BASS_DATA_FLOAT = $40000000; // flag: return floating-point sample data - BASS_DATA_FFT256 = $80000000; // 256 sample FFT - BASS_DATA_FFT512 = $80000001; // 512 FFT - BASS_DATA_FFT1024 = $80000002; // 1024 FFT - BASS_DATA_FFT2048 = $80000003; // 2048 FFT - BASS_DATA_FFT4096 = $80000004; // 4096 FFT - BASS_DATA_FFT8192 = $80000005; // 8192 FFT - BASS_DATA_FFT_INDIVIDUAL = $10; // FFT flag: FFT for each channel, else all combined - BASS_DATA_FFT_NOWINDOW = $20; // FFT flag: no Hanning window - - // BASS_ChannelGetTags types : what's returned - BASS_TAG_ID3 = 0; // ID3v1 tags : TAG_ID3 structure - BASS_TAG_ID3V2 = 1; // ID3v2 tags : variable length block - BASS_TAG_OGG = 2; // OGG comments : series of null-terminated UTF-8 strings - BASS_TAG_HTTP = 3; // HTTP headers : series of null-terminated ANSI strings - BASS_TAG_ICY = 4; // ICY headers : series of null-terminated ANSI strings - BASS_TAG_META = 5; // ICY metadata : ANSI string - BASS_TAG_VENDOR = 9; // OGG encoder : UTF-8 string - BASS_TAG_LYRICS3 = 10; // Lyric3v2 tag : ASCII string - BASS_TAG_RIFF_INFO = $100; // RIFF "INFO" tags : series of null-terminated ANSI strings - BASS_TAG_RIFF_BEXT = $101; // RIFF/BWF Broadcast Audio Extension tags : TAG_BEXT structure - BASS_TAG_MUSIC_NAME = $10000; // MOD music name : ANSI string - BASS_TAG_MUSIC_MESSAGE = $10001; // MOD message : ANSI string - BASS_TAG_MUSIC_INST = $10100; // + instrument #, MOD instrument name : ANSI string - BASS_TAG_MUSIC_SAMPLE = $10300; // + sample #, MOD sample name : ANSI string - - // BASS_ChannelGetLength/GetPosition/SetPosition modes - BASS_POS_BYTE = 0; // byte position - BASS_POS_MUSIC_ORDER = 1; // order.row position, MAKELONG(order,row) - - // BASS_RecordSetInput flags - BASS_INPUT_OFF = $10000; - BASS_INPUT_ON = $20000; - - BASS_INPUT_TYPE_MASK = $FF000000; - BASS_INPUT_TYPE_UNDEF = $00000000; - BASS_INPUT_TYPE_DIGITAL = $01000000; - BASS_INPUT_TYPE_LINE = $02000000; - BASS_INPUT_TYPE_MIC = $03000000; - BASS_INPUT_TYPE_SYNTH = $04000000; - BASS_INPUT_TYPE_CD = $05000000; - BASS_INPUT_TYPE_PHONE = $06000000; - BASS_INPUT_TYPE_SPEAKER = $07000000; - BASS_INPUT_TYPE_WAVE = $08000000; - BASS_INPUT_TYPE_AUX = $09000000; - BASS_INPUT_TYPE_ANALOG = $0A000000; - - BASS_FX_DX8_CHORUS = 0; - BASS_FX_DX8_COMPRESSOR = 1; - BASS_FX_DX8_DISTORTION = 2; - BASS_FX_DX8_ECHO = 3; - BASS_FX_DX8_FLANGER = 4; - BASS_FX_DX8_GARGLE = 5; - BASS_FX_DX8_I3DL2REVERB = 6; - BASS_FX_DX8_PARAMEQ = 7; - BASS_FX_DX8_REVERB = 8; - - BASS_DX8_PHASE_NEG_180 = 0; - BASS_DX8_PHASE_NEG_90 = 1; - BASS_DX8_PHASE_ZERO = 2; - BASS_DX8_PHASE_90 = 3; - BASS_DX8_PHASE_180 = 4; - -type - DWORD = cardinal; - BOOL = LongBool; - FLOAT = Single; - QWORD = int64; // 64-bit (replace "int64" with "comp" if using Delphi 3) - - HMUSIC = DWORD; // MOD music handle - HSAMPLE = DWORD; // sample handle - HCHANNEL = DWORD; // playing sample's channel handle - HSTREAM = DWORD; // sample stream handle - HRECORD = DWORD; // recording handle - HSYNC = DWORD; // synchronizer handle - HDSP = DWORD; // DSP handle - HFX = DWORD; // DX8 effect handle - HPLUGIN = DWORD; // Plugin handle - - // Device info structure - BASS_DEVICEINFO = record - name: PAnsiChar; // description - driver: PAnsiChar; // driver - flags: DWORD; - end; - - BASS_INFO = record - flags: DWORD; // device capabilities (DSCAPS_xxx flags) - hwsize: DWORD; // size of total device hardware memory - hwfree: DWORD; // size of free device hardware memory - freesam: DWORD; // number of free sample slots in the hardware - free3d: DWORD; // number of free 3D sample slots in the hardware - minrate: DWORD; // min sample rate supported by the hardware - maxrate: DWORD; // max sample rate supported by the hardware - eax: BOOL; // device supports EAX? (always FALSE if BASS_DEVICE_3D was not used) - minbuf: DWORD; // recommended minimum buffer length in ms (requires BASS_DEVICE_LATENCY) - dsver: DWORD; // DirectSound version - latency: DWORD; // delay (in ms) before start of playback (requires BASS_DEVICE_LATENCY) - initflags: DWORD; // BASS_Init "flags" parameter - speakers: DWORD; // number of speakers available - freq: DWORD; // current output rate (OSX only) - end; - - // Recording device info structure - BASS_RECORDINFO = record - flags: DWORD; // device capabilities (DSCCAPS_xxx flags) - formats: DWORD; // supported standard formats (WAVE_FORMAT_xxx flags) - inputs: DWORD; // number of inputs - singlein: BOOL; // only 1 input can be set at a time - {$IFNDEF BASS_242} - driver: PChar; // driver - {$ENDIF} - freq: DWORD; // current input rate (OSX only) - end; - - // Sample info structure - BASS_SAMPLE = record - freq: DWORD; // default playback rate - volume: FLOAT; // default volume (0-100) - pan: FLOAT; // default pan (-100=left, 0=middle, 100=right) - flags: DWORD; // BASS_SAMPLE_xxx flags - length: DWORD; // length (in samples, not bytes) - max: DWORD; // maximum simultaneous playbacks - origres: DWORD; // original resolution - chans: DWORD; // number of channels - mingap: DWORD; // minimum gap (ms) between creating channels - mode3d: DWORD; // BASS_3DMODE_xxx mode - mindist: FLOAT; // minimum distance - maxdist: FLOAT; // maximum distance - iangle: DWORD; // angle of inside projection cone - oangle: DWORD; // angle of outside projection cone - outvol: FLOAT; // delta-volume outside the projection cone - vam: DWORD; // voice allocation/management flags (BASS_VAM_xxx) - priority: DWORD; // priority (0=lowest, $ffffffff=highest) - end; - - // Channel info structure - BASS_CHANNELINFO = record - freq: DWORD; // default playback rate - chans: DWORD; // channels - flags: DWORD; // BASS_SAMPLE/STREAM/MUSIC/SPEAKER flags - ctype: DWORD; // type of channel - origres: DWORD; // original resolution - plugin: HPLUGIN; // plugin - sample: HSAMPLE; // sample - filename: PAnsiChar; // filename - end; - - BASS_PLUGINFORM = record - ctype: DWORD; // channel type - name: PAnsiChar; // format description - exts: PAnsiChar; // file extension filter (*.ext1;*.ext2;etc...) - end; - PBASS_PLUGINFORMS = ^TBASS_PLUGINFORMS; - TBASS_PLUGINFORMS = array[0..maxInt div sizeOf(BASS_PLUGINFORM) - 1] of BASS_PLUGINFORM; - - BASS_PLUGININFO = record - version: DWORD; // version (same form as BASS_GetVersion) - formatc: DWORD; // number of formats - formats: PBASS_PLUGINFORMS; // the array of formats - end; - PBASS_PLUGININFO = ^BASS_PLUGININFO; - - // 3D vector (for 3D positions/velocities/orientations) - BASS_3DVECTOR = record - x: FLOAT; // +=right, -=left - y: FLOAT; // +=up, -=down - z: FLOAT; // +=front, -=behind - end; - - // User file stream callback functions - FILECLOSEPROC = procedure(user: Pointer); {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - FILELENPROC = function(user: Pointer): QWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - FILEREADPROC = function(buffer: Pointer; length: DWORD; user: Pointer): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - FILESEEKPROC = function(offset: QWORD; user: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - - BASS_FILEPROCS = record - close: FILECLOSEPROC; - length: FILELENPROC; - read: FILEREADPROC; - seek: FILESEEKPROC; - end; - - // ID3v1 tag structure - TAG_ID3 = record - id: Array[0..2] of AnsiChar; - title: Array[0..29] of AnsiChar; - artist: Array[0..29] of AnsiChar; - album: Array[0..29] of AnsiChar; - year: Array[0..3] of AnsiChar; - comment: Array[0..29] of AnsiChar; - genre: Byte; - end; - - // BWF Broadcast Audio Extension tag structure - TAG_BEXT = record - Description: Array[0..255] of AnsiChar; // description - Originator: Array[0..31] of AnsiChar; // name of the originator - OriginatorReference: Array[0..31] of AnsiChar; // reference of the originator - OriginationDate: Array[0..9] of AnsiChar; // date of creation (yyyy-mm-dd) - OriginationTime: Array[0..7] of AnsiChar; // time of creation (hh-mm-ss) - TimeReference: QWORD; // first sample count since midnight (little-endian) - Version: Word; // BWF version (little-endian) - UMID: Array[0..63] of Byte; // SMPTE UMID - Reserved: Array[0..189] of Byte; - CodingHistory: Array of AnsiChar; // history - end; - - BASS_DX8_CHORUS = record - fWetDryMix: FLOAT; - fDepth: FLOAT; - fFeedback: FLOAT; - fFrequency: FLOAT; - lWaveform: DWORD; // 0=triangle, 1=sine - fDelay: FLOAT; - lPhase: DWORD; // BASS_DX8_PHASE_xxx - end; - - BASS_DX8_COMPRESSOR = record - fGain: FLOAT; - fAttack: FLOAT; - fRelease: FLOAT; - fThreshold: FLOAT; - fRatio: FLOAT; - fPredelay: FLOAT; - end; - - BASS_DX8_DISTORTION = record - fGain: FLOAT; - fEdge: FLOAT; - fPostEQCenterFrequency: FLOAT; - fPostEQBandwidth: FLOAT; - fPreLowpassCutoff: FLOAT; - end; - - BASS_DX8_ECHO = record - fWetDryMix: FLOAT; - fFeedback: FLOAT; - fLeftDelay: FLOAT; - fRightDelay: FLOAT; - lPanDelay: BOOL; - end; - - BASS_DX8_FLANGER = record - fWetDryMix: FLOAT; - fDepth: FLOAT; - fFeedback: FLOAT; - fFrequency: FLOAT; - lWaveform: DWORD; // 0=triangle, 1=sine - fDelay: FLOAT; - lPhase: DWORD; // BASS_DX8_PHASE_xxx - end; - - BASS_DX8_GARGLE = record - dwRateHz: DWORD; // Rate of modulation in hz - dwWaveShape: DWORD; // 0=triangle, 1=square - end; - - BASS_DX8_I3DL2REVERB = record - lRoom: Longint; // [-10000, 0] default: -1000 mB - lRoomHF: Longint; // [-10000, 0] default: 0 mB - flRoomRolloffFactor: FLOAT; // [0.0, 10.0] default: 0.0 - flDecayTime: FLOAT; // [0.1, 20.0] default: 1.49s - flDecayHFRatio: FLOAT; // [0.1, 2.0] default: 0.83 - lReflections: Longint; // [-10000, 1000] default: -2602 mB - flReflectionsDelay: FLOAT; // [0.0, 0.3] default: 0.007 s - lReverb: Longint; // [-10000, 2000] default: 200 mB - flReverbDelay: FLOAT; // [0.0, 0.1] default: 0.011 s - flDiffusion: FLOAT; // [0.0, 100.0] default: 100.0 % - flDensity: FLOAT; // [0.0, 100.0] default: 100.0 % - flHFReference: FLOAT; // [20.0, 20000.0] default: 5000.0 Hz - end; - - BASS_DX8_PARAMEQ = record - fCenter: FLOAT; - fBandwidth: FLOAT; - fGain: FLOAT; - end; - - BASS_DX8_REVERB = record - fInGain: FLOAT; // [-96.0,0.0] default: 0.0 dB - fReverbMix: FLOAT; // [-96.0,0.0] default: 0.0 db - fReverbTime: FLOAT; // [0.001,3000.0] default: 1000.0 ms - fHighFreqRTRatio: FLOAT; // [0.001,0.999] default: 0.001 - end; - - // callback function types - STREAMPROC = function(handle: HSTREAM; buffer: Pointer; length: DWORD; user: Pointer): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - { - User stream callback function. NOTE: A stream function should obviously be as - quick as possible, other streams (and MOD musics) can't be mixed until - it's finished. - handle : The stream that needs writing - buffer : Buffer to write the samples in - length : Number of bytes to write - user : The 'user' parameter value given when calling BASS_StreamCreate - RETURN : Number of bytes written. Set the BASS_STREAMPROC_END flag to end - the stream. - } - -const - // special STREAMPROCs - STREAMPROC_DUMMY {: STREAMPROC} = Pointer(0); // "dummy" stream - STREAMPROC_PUSH {: STREAMPROC} = Pointer(-1); // push stream - -type - - DOWNLOADPROC = procedure(buffer: Pointer; length: DWORD; user: Pointer); {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - { - Internet stream download callback function. - buffer : Buffer containing the downloaded data... NULL=end of download - length : Number of bytes in the buffer - user : The 'user' parameter value given when calling BASS_StreamCreateURL - } - - SYNCPROC = procedure(handle: HSYNC; channel, data: DWORD; user: Pointer); {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - { - Sync callback function. NOTE: a sync callback function should be very - quick as other syncs cannot be processed until it has finished. If the - sync is a "mixtime" sync, then other streams and MOD musics can not be - mixed until it's finished either. - handle : The sync that has occured - channel: Channel that the sync occured in - data : Additional data associated with the sync's occurance - user : The 'user' parameter given when calling BASS_ChannelSetSync - } - - DSPPROC = procedure(handle: HDSP; channel: DWORD; buffer: Pointer; length: DWORD; user: Pointer); {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - { - DSP callback function. NOTE: A DSP function should obviously be as quick - as possible... other DSP functions, streams and MOD musics can not be - processed until it's finished. - handle : The DSP handle - channel: Channel that the DSP is being applied to - buffer : Buffer to apply the DSP to - length : Number of bytes in the buffer - user : The 'user' parameter given when calling BASS_ChannelSetDSP - } - - RECORDPROC = function(handle: HRECORD; buffer: Pointer; length: DWORD; user: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} - { - Recording callback function. - handle : The recording handle - buffer : Buffer containing the recorded sample data - length : Number of bytes - user : The 'user' parameter value given when calling BASS_RecordStart - RETURN : TRUE = continue recording, FALSE = stop - } - - -// Functions -const -{$IFDEF MSWINDOWS} - bassdll = 'bass.dll'; -{$ENDIF} -{$IFDEF DARWIN} - bassdll = 'libbass.dylib'; - {$linklib libbass} -{$ENDIF} - -function BASS_SetConfig(option, value: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetConfig(option: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SetConfigPtr(option: DWORD; value: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetConfigPtr(option: DWORD): Pointer; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetVersion: DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ErrorGetCode: Integer; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetDeviceInfo(device: DWORD; var info: BASS_DEVICEINFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$IFDEF MSWINDOWS} -function BASS_Init(device: Integer; freq, flags: DWORD; win: HWND; clsid: PGUID): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$ELSE} -function BASS_Init(device: Integer; freq, flags: DWORD; win: Pointer; clsid: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$ENDIF} -function BASS_SetDevice(device: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetDevice: DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Free: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$IFDEF MSWINDOWS} -function BASS_GetDSoundObject(obj: DWORD): Pointer; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$ENDIF} -function BASS_GetInfo(var info: BASS_INFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Update(length: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetCPU: FLOAT; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Start: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Stop: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Pause: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SetVolume(volume: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetVolume: FLOAT; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_PluginLoad(filename: PAnsiChar; flags: DWORD): HPLUGIN; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_PluginFree(handle: HPLUGIN): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_PluginGetInfo(handle: HPLUGIN): PBASS_PLUGININFO; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_Set3DFactors(distf, rollf, doppf: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Get3DFactors(var distf, rollf, doppf: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Set3DPosition(var pos, vel, front, top: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_Get3DPosition(var pos, vel, front, top: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -procedure BASS_Apply3D; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$IFDEF MSWINDOWS} -function BASS_SetEAXParameters(env: Integer; vol, decay, damp: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_GetEAXParameters(var env: DWORD; var vol, decay, damp: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -{$ENDIF} - -function BASS_MusicLoad(mem: BOOL; f: Pointer; offset: QWORD; length, flags, freq: DWORD): HMUSIC; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_MusicFree(handle: HMUSIC): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_SampleLoad(mem: BOOL; f: Pointer; offset: QWORD; length, max, flags: DWORD): HSAMPLE; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleCreate(length, freq, chans, max, flags: DWORD): HSAMPLE; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleFree(handle: HSAMPLE): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleSetData(handle: HSAMPLE; buffer: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleGetData(handle: HSAMPLE; buffer: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleGetInfo(handle: HSAMPLE; var info: BASS_SAMPLE): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleSetInfo(handle: HSAMPLE; var info: BASS_SAMPLE): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleGetChannel(handle: HSAMPLE; onlynew: BOOL): HCHANNEL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleGetChannels(handle: HSAMPLE; channels: Pointer): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_SampleStop(handle: HSAMPLE): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_StreamCreate(freq, chans, flags: DWORD; proc: STREAMPROC; user: Pointer): HSTREAM; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamCreateFile(mem: BOOL; f: Pointer; offset, length: QWORD; flags: DWORD): HSTREAM; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamCreateURL(url: PAnsiChar; offset: DWORD; flags: DWORD; proc: DOWNLOADPROC; user: Pointer):HSTREAM; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamCreateFileUser(system, flags: DWORD; var procs: BASS_FILEPROCS; user: Pointer): HSTREAM; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamFree(handle: HSTREAM): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamGetFilePosition(handle: HSTREAM; mode: DWORD): QWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamPutData(handle: HSTREAM; buffer: Pointer; length: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_StreamPutFileData(handle: HSTREAM; buffer: Pointer; length: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_RecordGetDeviceInfo(device: DWORD; var info: BASS_DEVICEINFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordInit(device: Integer):BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordSetDevice(device: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordGetDevice: DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordFree: BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordGetInfo(var info: BASS_RECORDINFO): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordGetInputName(input: Integer): PAnsiChar; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordSetInput(input: Integer; flags: DWORD; volume: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordGetInput(input: Integer; var volume: FLOAT): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_RecordStart(freq, chans, flags: DWORD; proc: RECORDPROC; user: Pointer): HRECORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_ChannelBytes2Seconds(handle: DWORD; pos: QWORD): Double; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; -function BASS_ChannelSeconds2Bytes(handle: DWORD; pos: Double): QWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; -function BASS_ChannelGetDevice(handle: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetDevice(handle, device: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelIsActive(handle: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; -function BASS_ChannelGetInfo(handle: DWORD; var info: BASS_CHANNELINFO):BOOL;{$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; -function BASS_ChannelGetTags(handle: HSTREAM; tags: DWORD): PAnsiChar; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelFlags(handle, flags, mask: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelUpdate(handle, length: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelLock(handle: DWORD; lock: BOOL): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelPlay(handle: DWORD; restart: BOOL): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelStop(handle: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelPause(handle: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetAttribute(handle, attrib: DWORD; value: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGetAttribute(handle, attrib: DWORD; var value: FLOAT): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSlideAttribute(handle, attrib: DWORD; value: FLOAT; time: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelIsSliding(handle, attrib: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF}external bassdll; -function BASS_ChannelSet3DAttributes(handle: DWORD; mode: Integer; min, max: FLOAT; iangle, oangle, outvol: Integer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGet3DAttributes(handle: DWORD; var mode: DWORD; var min, max: FLOAT; var iangle, oangle, outvol: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSet3DPosition(handle: DWORD; var pos, orient, vel: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGet3DPosition(handle: DWORD; var pos, orient, vel: BASS_3DVECTOR): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGetLength(handle, mode: DWORD): QWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetPosition(handle: DWORD; pos: QWORD; mode: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGetPosition(handle, mode: DWORD): QWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGetLevel(handle: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelGetData(handle: DWORD; buffer: Pointer; length: DWORD): DWORD; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetSync(handle: DWORD; type_: DWORD; param: QWORD; proc: SYNCPROC; user: Pointer): HSYNC; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelRemoveSync(handle: DWORD; sync: HSYNC): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetDSP(handle: DWORD; proc: DSPPROC; user: Pointer; priority: Integer): HDSP; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelRemoveDSP(handle: DWORD; dsp: HDSP): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetLink(handle, chan: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelRemoveLink(handle, chan: DWORD): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelSetFX(handle, type_: DWORD; priority: Integer): HFX; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_ChannelRemoveFX(handle: DWORD; fx: HFX): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - -function BASS_FXSetParameters(handle: HFX; par: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_FXGetParameters(handle: HFX; par: Pointer): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; -function BASS_FXReset(handle: HFX): BOOL; {$IFDEF DLL_STDCALL}stdcall;{$ENDIF}{$IFDEF DLL_CDECL}cdecl;{$ENDIF} external bassdll; - - -function BASS_SPEAKER_N(n: DWORD): DWORD; -{$IFDEF MSWINDOWS} -function BASS_SetEAXPreset(env: Integer): BOOL; -{ - This function is defined in the implementation part of this unit. - It is not part of BASS.DLL but an extra function which makes it easier - to set the predefined EAX environments. - env : a EAX_ENVIRONMENT_xxx constant -} -{$ENDIF} - -implementation - -function BASS_SPEAKER_N(n: DWORD): DWORD; -begin - Result := n shl 24; -end; - -{$IFDEF MSWINDOWS} -function BASS_SetEAXPreset(env: Integer): BOOL; -begin - case (env) of - EAX_ENVIRONMENT_GENERIC: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_GENERIC, 0.5, 1.493, 0.5); - EAX_ENVIRONMENT_PADDEDCELL: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_PADDEDCELL, 0.25, 0.1, 0); - EAX_ENVIRONMENT_ROOM: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_ROOM, 0.417, 0.4, 0.666); - EAX_ENVIRONMENT_BATHROOM: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_BATHROOM, 0.653, 1.499, 0.166); - EAX_ENVIRONMENT_LIVINGROOM: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_LIVINGROOM, 0.208, 0.478, 0); - EAX_ENVIRONMENT_STONEROOM: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_STONEROOM, 0.5, 2.309, 0.888); - EAX_ENVIRONMENT_AUDITORIUM: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_AUDITORIUM, 0.403, 4.279, 0.5); - EAX_ENVIRONMENT_CONCERTHALL: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_CONCERTHALL, 0.5, 3.961, 0.5); - EAX_ENVIRONMENT_CAVE: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_CAVE, 0.5, 2.886, 1.304); - EAX_ENVIRONMENT_ARENA: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_ARENA, 0.361, 7.284, 0.332); - EAX_ENVIRONMENT_HANGAR: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_HANGAR, 0.5, 10.0, 0.3); - EAX_ENVIRONMENT_CARPETEDHALLWAY: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_CARPETEDHALLWAY, 0.153, 0.259, 2.0); - EAX_ENVIRONMENT_HALLWAY: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_HALLWAY, 0.361, 1.493, 0); - EAX_ENVIRONMENT_STONECORRIDOR: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_STONECORRIDOR, 0.444, 2.697, 0.638); - EAX_ENVIRONMENT_ALLEY: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_ALLEY, 0.25, 1.752, 0.776); - EAX_ENVIRONMENT_FOREST: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_FOREST, 0.111, 3.145, 0.472); - EAX_ENVIRONMENT_CITY: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_CITY, 0.111, 2.767, 0.224); - EAX_ENVIRONMENT_MOUNTAINS: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_MOUNTAINS, 0.194, 7.841, 0.472); - EAX_ENVIRONMENT_QUARRY: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_QUARRY, 1, 1.499, 0.5); - EAX_ENVIRONMENT_PLAIN: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_PLAIN, 0.097, 2.767, 0.224); - EAX_ENVIRONMENT_PARKINGLOT: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_PARKINGLOT, 0.208, 1.652, 1.5); - EAX_ENVIRONMENT_SEWERPIPE: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_SEWERPIPE, 0.652, 2.886, 0.25); - EAX_ENVIRONMENT_UNDERWATER: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_UNDERWATER, 1, 1.499, 0); - EAX_ENVIRONMENT_DRUGGED: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_DRUGGED, 0.875, 8.392, 1.388); - EAX_ENVIRONMENT_DIZZY: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_DIZZY, 0.139, 17.234, 0.666); - EAX_ENVIRONMENT_PSYCHOTIC: - Result := BASS_SetEAXParameters(EAX_ENVIRONMENT_PSYCHOTIC, 0.486, 7.563, 0.806); - else - Result := FALSE; - end; -end; -{$ENDIF} - -end. -// END OF FILE ///////////////////////////////////////////////////////////////// - diff --git a/src/lib/collections/CollArray.pas b/src/lib/collections/CollArray.pas deleted file mode 100644 index a10ba905..00000000 --- a/src/lib/collections/CollArray.pas +++ /dev/null @@ -1,183 +0,0 @@ -unit CollArray; - -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0.3 $ - * $Revision: 1.2 $ - * $Log: D:\QVCS Repositories\Delphi Collections\CollArray.qbt $ - * - * Colllection implementations based on arrays. - * - * Revision 1.2 by: Matthew Greet Rev date: 12/06/04 20:02:16 - * Capacity property. - * - * Revision 1.1 by: Matthew Greet Rev date: 06/04/03 10:30:36 - * Size property dropped. - * Unused abstract functions still implemented. - * - * Revision 1.0 by: Matthew Greet Rev date: 01/03/03 10:50:02 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -interface - -uses - Collections; - -type - TArray = class(TAbstractList) - private - FArray: array of ICollectable; - protected - function TrueGetItem(Index: Integer): ICollectable; override; - procedure TrueSetItem(Index: Integer; const Value: ICollectable); override; - procedure TrueAppend(const Item: ICollectable); override; - procedure TrueClear; override; - function TrueDelete(Index: Integer): ICollectable; override; - procedure TrueInsert(Index: Integer; const Item: ICollectable); override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - constructor Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean = false); override; - constructor Create(Size: Integer; NaturalItemsOnly: Boolean = false); overload; virtual; - constructor Create(const Collection: ICollection); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetFixedSize: Boolean; override; - function GetSize: Integer; override; - end; - -implementation - -constructor TArray.Create(NaturalItemsOnly: Boolean); -begin - Create(0, NaturalItemsOnly); -end; - -constructor TArray.Create(Size: Integer; NaturalItemsOnly: Boolean = false); -begin - inherited Create(NaturalItemsOnly); - SetLength(FArray, Size); -end; - -constructor TArray.Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -var - Item: ICollectable; - ItemError: TCollectionError; - I: Integer; -begin - inherited Create(ItemArray, NaturalItemsOnly); - SetLength(FArray, Length(ItemArray)); - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := ItemArray[I]; - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - end - else - Items[I] := Item; - end; -end; - -constructor TArray.Create(const Collection: ICollection); -var - Iterator: IIterator; - I: Integer; -begin - inherited Create(Collection); - SetLength(FArray, Collection.GetSize); - Iterator := Collection.GetIterator; - I := 0; - while not Iterator.EOF do - begin - Items[I] := Iterator.CurrentItem; - Inc(I); - Iterator.Next; - end; -end; - -destructor TArray.Destroy; -var - I: Integer; -begin - // Delete interface references to all items - for I := Low(FArray) to High(FArray) do - begin - FArray[I] := nil; - end; - inherited Destroy; -end; - -function TArray.TrueGetItem(Index: Integer): ICollectable; -begin - Result := FArray[Index]; -end; - -procedure TArray.TrueSetItem(Index: Integer; const Value: ICollectable); -begin - FArray[Index] := Value; -end; - -procedure TArray.TrueAppend(const Item: ICollectable); -begin - // Ignored as collection is fixed size -end; - -procedure TArray.TrueClear; -begin - // Ignored as collection is fixed size -end; - -function TArray.TrueDelete(Index: Integer): ICollectable; -begin - // Ignored as collection is fixed size -end; - -procedure TArray.TrueInsert(Index: Integer; const Item: ICollectable); -begin - // Ignored as collection is fixed size -end; - -function TArray.GetCapacity: Integer; -begin - Result := Size; -end; - -procedure TArray.SetCapacity(Value: Integer); -begin - // Ignored -end; - -function TArray.GetFixedSize: Boolean; -begin - Result := true; -end; - -function TArray.GetSize: Integer; -begin - Result := Length(FArray); -end; - -end. diff --git a/src/lib/collections/CollHash.pas b/src/lib/collections/CollHash.pas deleted file mode 100644 index 796fc740..00000000 --- a/src/lib/collections/CollHash.pas +++ /dev/null @@ -1,1497 +0,0 @@ -unit CollHash; - -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0.3 $ - * $Revision: 1.1.1.2 $ - * $Log: D:\QVCS Repositories\Delphi Collections\CollHash.qbt $ - * - * Collection implementations based on hash tables. - * - * Revision 1.1.1.2 by: Matthew Greet Rev date: 12/06/04 20:04:30 - * Capacity property. - * - * Revision 1.1.1.1 by: Matthew Greet Rev date: 24/10/03 16:48:16 - * v1.0 branch. - * - * Revision 1.1 by: Matthew Greet Rev date: 06/04/03 10:40:16 - * Added integer map and string map versions. - * THashSet uses its own implementation, not THashMap. - * DefaulMaxLoadFactor changed. - * - * Revision 1.0 by: Matthew Greet Rev date: 01/03/03 10:50:02 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -interface - -uses - Classes, Math, - Collections; - -const - DefaultTableSize = 100; - MaxLoadFactorMin = 0.01; // Minimum allowed value for MaxLoadFactor property. - DefaultMaxLoadFactor = 5.0; - -type - THashMap = class(TAbstractMap) - private - FArray: TListArray; - FCapacity: Integer; - FMaxLoadFactor: Double; - FSize: Integer; - FTableSize: Integer; - protected - function GetAssociationIterator: IMapIterator; override; - procedure SetMaxLoadFactor(Value: Double); virtual; - procedure SetTableSize(Value: Integer); virtual; - procedure ChangeCapacity(Value: TListArray); virtual; - procedure CheckLoadFactor(AlwaysChangeCapacity: Boolean); virtual; - function GetHash(const Key: ICollectable): Integer; virtual; - function GetKeyPosition(const Key: ICollectable): TCollectionPosition; override; - procedure Rehash; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): IAssociation; override; - function TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; override; - function TrueRemove2(Position: TCollectionPosition): IAssociation; override; - public - constructor Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); override; - destructor Destroy; override; - class function GetAlwaysNaturalKeys: Boolean; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetNaturalKeyIID: TGUID; override; - function GetSize: Integer; override; - property MaxLoadFactor: Double read FMaxLoadFactor write SetMaxLoadFactor; - property TableSize: Integer read FTableSize write SetTableSize; - end; - - THashSet = class(TAbstractSet) - private - FArray: TListArray; - FCapacity: Integer; - FMaxLoadFactor: Double; - FSize: Integer; - FTableSize: Integer; - protected - procedure SetMaxLoadFactor(Value: Double); virtual; - procedure SetTableSize(Value: Integer); virtual; - procedure ChangeCapacity(Value: TListArray); virtual; - procedure CheckLoadFactor(AlwaysChangeCapacity: Boolean); virtual; - function GetHash(const Item: ICollectable): Integer; virtual; - function GetPosition(const Item: ICollectable): TCollectionPosition; override; - procedure Rehash; - procedure TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); override; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): ICollectable; override; - procedure TrueRemove2(Position: TCollectionPosition); override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - destructor Destroy; override; - class function GetAlwaysNaturalItems: Boolean; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetIterator: IIterator; override; - function GetNaturalItemIID: TGUID; override; - function GetSize: Integer; override; - property MaxLoadFactor: Double read FMaxLoadFactor write SetMaxLoadFactor; - property TableSize: Integer read FTableSize write SetTableSize; - end; - - THashIntegerMap = class(TAbstractIntegerMap) - private - FArray: TListArray; - FCapacity: Integer; - FMaxLoadFactor: Double; - FSize: Integer; - FTableSize: Integer; - protected - function GetAssociationIterator: IIntegerMapIterator; override; - procedure SetMaxLoadFactor(Value: Double); virtual; - procedure SetTableSize(Value: Integer); virtual; - procedure ChangeCapacity(Value: TListArray); virtual; - procedure CheckLoadFactor(AlwaysChangeCapacity: Boolean); virtual; - function GetHash(const Key: Integer): Integer; virtual; - function GetKeyPosition(const Key: Integer): TCollectionPosition; override; - procedure Rehash; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): IIntegerAssociation; override; - function TruePut(Position: TCollectionPosition; const Association: IIntegerAssociation): IIntegerAssociation; override; - function TrueRemove2(Position: TCollectionPosition): IIntegerAssociation; override; - public - constructor Create; override; - constructor Create(NaturalItemsOnly: Boolean); override; - constructor Create(NaturalItemsOnly: Boolean; TableSize: Integer; MaxLoadFactor: Double = DefaultMaxLoadFactor); overload; virtual; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetSize: Integer; override; - property MaxLoadFactor: Double read FMaxLoadFactor write SetMaxLoadFactor; - property TableSize: Integer read FTableSize write SetTableSize; - end; - - THashStringMap = class(TAbstractStringMap) - private - FArray: TListArray; - FCapacity: Integer; - FMaxLoadFactor: Double; - FSize: Integer; - FTableSize: Integer; - protected - function GetAssociationIterator: IStringMapIterator; override; - procedure SetMaxLoadFactor(Value: Double); virtual; - procedure SetTableSize(Value: Integer); virtual; - procedure ChangeCapacity(Value: TListArray); virtual; - procedure CheckLoadFactor(AlwaysChangeCapacity: Boolean); virtual; - function GetHash(const Key: String): Integer; virtual; - function GetKeyPosition(const Key: String): TCollectionPosition; override; - procedure Rehash; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): IStringAssociation; override; - function TruePut(Position: TCollectionPosition; const Association: IStringAssociation): IStringAssociation; override; - function TrueRemove2(Position: TCollectionPosition): IStringAssociation; override; - public - constructor Create; override; - constructor Create(NaturalItemsOnly: Boolean); override; - constructor Create(NaturalItemsOnly: Boolean; TableSize: Integer; MaxLoadFactor: Double = DefaultMaxLoadFactor); overload; virtual; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetSize: Integer; override; - property MaxLoadFactor: Double read FMaxLoadFactor write SetMaxLoadFactor; - property TableSize: Integer read FTableSize write SetTableSize; - end; - -implementation - -const - (* (sqrt(5) - 1)/2 - See Introduction to Algorithms in Pascal, 1995, by Thomas W. Parsons, - published by John Wiley & Sons, Inc, ISBN 0-471-11600-9 - *) - HashFactor = 0.618033988749894848204586834365638; - -type - THashIterator = class(TAbstractIterator) - private - FHashSet: THashSet; - FHash: Integer; - FChainIndex: Integer; - protected - constructor Create(HashSet: THashSet); - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - end; - - THashAssociationIterator = class(TAbstractAssociationIterator) - private - FHashMap: THashMap; - FHash: Integer; - FChainIndex: Integer; - protected - constructor Create(HashMap: THashMap); - function TrueFirst: IAssociation; override; - function TrueNext: IAssociation; override; - procedure TrueRemove; override; - end; - - THashIntegerIterator = class(TAbstractIntegerAssociationIterator) - private - FHashIntegerMap: THashIntegerMap; - FHash: Integer; - FChainIndex: Integer; - protected - constructor Create(HashIntegerMap: THashIntegerMap); - function TrueFirst: IIntegerAssociation; override; - function TrueNext: IIntegerAssociation; override; - procedure TrueRemove; override; - end; - - THashStringIterator = class(TAbstractStringAssociationIterator) - private - FHashStringMap: THashStringMap; - FHash: Integer; - FChainIndex: Integer; - protected - constructor Create(HashStringMap: THashStringMap); - function TrueFirst: IStringAssociation; override; - function TrueNext: IStringAssociation; override; - procedure TrueRemove; override; - end; - - THashPosition = class(TCollectionPosition) - private - FChain: TList; - FIndex: Integer; - public - constructor Create(Found: Boolean; Chain: TList; Index: Integer); - property Chain: TList read FChain; - property Index: Integer read FIndex; - end; - -{ THashMap } -constructor THashMap.Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); -var - I: Integer; -begin - // Force use of natural keys - inherited Create(NaturalItemsOnly, true); - FTableSize := DefaultTableSize; - FMaxLoadFactor := DefaultMaxLoadFactor; - SetLength(FArray, FTableSize); - for I := Low(FArray) to High(FArray) do - FArray[I] := TList.Create; - FCapacity := 0; - FSize := 0; - ChangeCapacity(FArray); -end; - -destructor THashMap.Destroy; -var - I: Integer; -begin - for I := Low(FArray) to High(FArray) do - FArray[I].Free; - FArray := nil; - inherited Destroy; -end; - -class function THashMap.GetAlwaysNaturalKeys: Boolean; -begin - Result := true; -end; - -function THashMap.GetNaturalKeyIID: TGUID; -begin - Result := HashableIID; -end; - -function THashMap.GetAssociationIterator: IMapIterator; -begin - Result := THashAssociationIterator.Create(Self); -end; - -procedure THashMap.SetTableSize(Value: Integer); -begin - if (FTableSize <> Value) and (Value >= 1) then - begin - FTableSize := Value; - Rehash; - end; -end; - -procedure THashMap.SetMaxLoadFactor(Value: Double); -begin - if (FMaxLoadFactor <> Value) and (Value >= MaxLoadFactorMin) then - begin - FMaxLoadFactor := Value; - CheckLoadFactor(false); - end; -end; - -procedure THashMap.ChangeCapacity(Value: TListArray); -var - Chain: TList; - I, Total, ChainCapacity: Integer; -begin - if FCapacity mod FTableSize = 0 then - ChainCapacity := Trunc(FCapacity / FTableSize) - else - ChainCapacity := Trunc(FCapacity / FTableSize) + 1; - Total := 0; - for I := Low(Value) to High(Value) do - begin - Chain := Value[I]; - Chain.Capacity := ChainCapacity; - Total := Total + Chain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashMap.CheckLoadFactor(AlwaysChangeCapacity: Boolean); -var - LoadFactor: Double; -begin - LoadFactor := Capacity / TableSize; - if LoadFactor > MaxLoadFactor then - TableSize := Trunc(Capacity / Max(MaxLoadFactor, MaxLoadFactorMin)) - else if AlwaysChangeCapacity then - ChangeCapacity(FArray); -end; - -function THashMap.GetHash(const Key: ICollectable): Integer; -var - Hashable: IHashable; - HashCode: Cardinal; -begin - Key.QueryInterface(IHashable, Hashable); - HashCode := Hashable.HashCode; - Result := Trunc(Frac(HashCode * HashFactor) * TableSize); -end; - -function THashMap.GetKeyPosition(const Key: ICollectable): TCollectionPosition; -var - Chain: TList; - I: Integer; - Success: Boolean; -begin - Chain := FArray[GetHash(Key)]; - Success := false; - for I := 0 to Chain.Count - 1 do - begin - Success := KeyComparator.Equals(Key, IAssociation(Chain[I]).GetKey); - if Success then - Break; - end; - Result := THashPosition.Create(Success, Chain, I); -end; - -procedure THashMap.Rehash; -var - NewArray: TListArray; - OldChain, NewChain: TList; - Association: IAssociation; - Total: Integer; - I, J: Integer; - Hash: Integer; -begin - // Create new chains - SetLength(NewArray, TableSize); - for I := Low(NewArray) to High(NewArray) do - begin - NewChain := TList.Create; - NewArray[I] := NewChain; - end; - ChangeCapacity(NewArray); - - // Transfer from old chains to new and drop old - for I := Low(FArray) to High(FArray) do - begin - OldChain := FArray[I]; - for J := 0 to OldChain.Count - 1 do - begin - Association := IAssociation(OldChain[J]); - Hash := GetHash(Association.GetKey); - NewArray[Hash].Add(Pointer(Association)); - end; - OldChain.Free; - end; - FArray := NewArray; - - // Find actual, new capacity - Total := 0; - for I := Low(FArray) to High(FArray) do - begin - NewChain := FArray[I]; - Total := Total + NewChain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashMap.TrueClear; -var - Association: IAssociation; - Chain: TList; - I, J: Integer; -begin - for I := Low(FArray) to High(FArray) do - begin - Chain := FArray[I]; - for J := 0 to Chain.Count - 1 do - begin - Association := IAssociation(Chain[J]); - Chain[J] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; - end; - Chain.Clear; - end; - FSize := 0; -end; - -function THashMap.TrueGet(Position: TCollectionPosition): IAssociation; -var - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Result := IAssociation(HashPosition.Chain.Items[HashPosition.Index]); -end; - -function THashMap.TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; -var - HashPosition: THashPosition; - OldAssociation: IAssociation; -begin - HashPosition := THashPosition(Position); - if HashPosition.Found then - begin - OldAssociation := IAssociation(HashPosition.Chain.Items[HashPosition.Index]); - HashPosition.Chain.Items[HashPosition.Index] := Pointer(Association); - Result := OldAssociation; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - OldAssociation._Release; - end - else - begin - HashPosition.Chain.Add(Pointer(Association)); - Inc(FSize); - Result := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - end; -end; - -function THashMap.TrueRemove2(Position: TCollectionPosition): IAssociation; -var - Association: IAssociation; - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Association := IAssociation(TrueGet(Position)); - HashPosition.Chain.Delete(HashPosition.Index); - Dec(FSize); - Result := Association; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - -function THashMap.GetCapacity; -begin - Result := FCapacity; -end; - -procedure THashMap.SetCapacity(Value: Integer); -begin - FCapacity := Value; - CheckLoadFactor(true); -end; - -function THashMap.GetSize: Integer; -begin - Result := FSize; -end; - -{ THashSet } -constructor THashSet.Create(NaturalItemsOnly: Boolean); -var - I: Integer; -begin - // Force use of natural items - inherited Create(true); - FTableSize := DefaultTableSize; - FMaxLoadFactor := DefaultMaxLoadFactor; - SetLength(FArray, FTableSize); - for I := Low(FArray) to High(FArray) do - FArray[I] := TList.Create; - FSize := 0; -end; - -destructor THashSet.Destroy; -var - I: Integer; -begin - for I := Low(FArray) to High(FArray) do - FArray[I].Free; - FArray := nil; - inherited Destroy; -end; - -procedure THashSet.SetTableSize(Value: Integer); -begin - if (FTableSize <> Value) and (Value >= 1) then - begin - FTableSize := Value; - Rehash; - end; -end; - -procedure THashSet.SetMaxLoadFactor(Value: Double); -begin - if (FMaxLoadFactor <> Value) and (Value >= MaxLoadFactorMin) then - begin - FMaxLoadFactor := Value; - CheckLoadFactor(false); - end; -end; - -procedure THashSet.ChangeCapacity(Value: TListArray); -var - Chain: TList; - I, Total, ChainCapacity: Integer; -begin - if FCapacity mod FTableSize = 0 then - ChainCapacity := Trunc(FCapacity / FTableSize) - else - ChainCapacity := Trunc(FCapacity / FTableSize) + 1; - Total := 0; - for I := Low(Value) to High(Value) do - begin - Chain := Value[I]; - Chain.Capacity := ChainCapacity; - Total := Total + Chain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashSet.CheckLoadFactor(AlwaysChangeCapacity: Boolean); -var - LoadFactor: Double; -begin - LoadFactor := Capacity / TableSize; - if LoadFactor > MaxLoadFactor then - TableSize := Trunc(Capacity / Max(MaxLoadFactor, MaxLoadFactorMin)) - else if AlwaysChangeCapacity then - ChangeCapacity(FArray); -end; - -function THashSet.GetHash(const Item: ICollectable): Integer; -var - Hashable: IHashable; - HashCode: Cardinal; -begin - Item.QueryInterface(IHashable, Hashable); - HashCode := Hashable.HashCode; - Result := Trunc(Frac(HashCode * HashFactor) * TableSize); -end; - -function THashSet.GetPosition(const Item: ICollectable): TCollectionPosition; -var - Chain: TList; - I: Integer; - Success: Boolean; -begin - Chain := FArray[GetHash(Item)]; - Success := false; - for I := 0 to Chain.Count - 1 do - begin - Success := Comparator.Equals(Item, ICollectable(Chain[I])); - if Success then - Break; - end; - Result := THashPosition.Create(Success, Chain, I); -end; - -procedure THashSet.Rehash; -var - NewArray: TListArray; - OldChain, NewChain: TList; - Item: ICollectable; - Total: Integer; - I, J: Integer; - Hash: Integer; -begin - // Create new chains - SetLength(NewArray, TableSize); - for I := Low(NewArray) to High(NewArray) do - begin - NewChain := TList.Create; - NewArray[I] := NewChain; - end; - ChangeCapacity(NewArray); - - // Transfer from old chains to new and drop old - for I := Low(FArray) to High(FArray) do - begin - OldChain := FArray[I]; - for J := 0 to OldChain.Count - 1 do - begin - Item := ICollectable(OldChain[J]); - Hash := GetHash(Item); - NewArray[Hash].Add(Pointer(Item)); - end; - OldChain.Free; - end; - FArray := NewArray; - - // Find actual, new capacity - Total := 0; - for I := Low(FArray) to High(FArray) do - begin - NewChain := FArray[I]; - Total := Total + NewChain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashSet.TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); -var - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - HashPosition.Chain.Add(Pointer(Item)); - Inc(FSize); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._AddRef; -end; - -procedure THashSet.TrueClear; -var - Item: ICollectable; - Chain: TList; - I, J: Integer; -begin - for I := Low(FArray) to High(FArray) do - begin - Chain := FArray[I]; - for J := 0 to Chain.Count - 1 do - begin - Item := ICollectable(Chain[J]); - Chain[J] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._Release; - end; - Chain.Clear; - end; - FSize := 0; -end; - -function THashSet.TrueGet(Position: TCollectionPosition): ICollectable; -var - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Result := ICollectable(HashPosition.Chain.Items[HashPosition.Index]); -end; - -procedure THashSet.TrueRemove2(Position: TCollectionPosition); -var - Item: ICollectable; - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Item := TrueGet(Position); - HashPosition.Chain.Delete(HashPosition.Index); - Dec(FSize); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._Release; -end; - -class function THashSet.GetAlwaysNaturalItems: Boolean; -begin - Result := true; -end; - -function THashSet.GetIterator: IIterator; -begin - Result := THashIterator.Create(Self); -end; - -function THashSet.GetNaturalItemIID: TGUID; -begin - Result := HashableIID; -end; - -function THashSet.GetCapacity; -begin - Result := FCapacity; -end; - -procedure THashSet.SetCapacity(Value: Integer); -begin - FCapacity := Value; - CheckLoadFactor(true); -end; - -function THashSet.GetSize: Integer; -begin - Result := FSize; -end; - -{ THashIntegerMap } -constructor THashIntegerMap.Create; -begin - Create(false, DefaultTableSize, DefaultMaxLoadFactor); -end; - -constructor THashIntegerMap.Create(NaturalItemsOnly: Boolean); -begin - Create(NaturalItemsOnly, DefaultTableSize, DefaultMaxLoadFactor); -end; - -constructor THashIntegerMap.Create(NaturalItemsOnly: Boolean; TableSize: Integer; MaxLoadFactor: Double = DefaultMaxLoadFactor); -var - I: Integer; -begin - inherited Create(NaturalItemsOnly); - SetLength(FArray, TableSize); - for I := Low(FArray) to High(FArray) do - FArray[I] := TList.Create; - FTableSize := TableSize; - FMaxLoadFactor := MaxLoadFactor; - FSize := 0; -end; - -destructor THashIntegerMap.Destroy; -var - I: Integer; -begin - for I := Low(FArray) to High(FArray) do - FArray[I].Free; - FArray := nil; - inherited Destroy; -end; - -function THashIntegerMap.GetAssociationIterator: IIntegerMapIterator; -begin - Result := THashIntegerIterator.Create(Self); -end; - -procedure THashIntegerMap.SetTableSize(Value: Integer); -begin - if (FTableSize <> Value) and (Value >= 1) then - begin - FTableSize := Value; - Rehash; - end; -end; - -procedure THashIntegerMap.SetMaxLoadFactor(Value: Double); -begin - if (FMaxLoadFactor <> Value) and (Value >= MaxLoadFactorMin) then - begin - FMaxLoadFactor := Value; - CheckLoadFactor(false); - end; -end; - -procedure THashIntegerMap.ChangeCapacity; -var - Chain: TList; - I, Total, ChainCapacity: Integer; -begin - if FCapacity mod FTableSize = 0 then - ChainCapacity := Trunc(FCapacity / FTableSize) - else - ChainCapacity := Trunc(FCapacity / FTableSize) + 1; - Total := 0; - for I := Low(Value) to High(Value) do - begin - Chain := Value[I]; - Chain.Capacity := ChainCapacity; - Total := Total + Chain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashIntegerMap.CheckLoadFactor(AlwaysChangeCapacity: Boolean); -var - LoadFactor: Double; -begin - LoadFactor := Capacity / TableSize; - if LoadFactor > MaxLoadFactor then - TableSize := Trunc(Capacity / Max(MaxLoadFactor, MaxLoadFactorMin)) - else if AlwaysChangeCapacity then - ChangeCapacity(FArray); -end; - -function THashIntegerMap.GetHash(const Key: Integer): Integer; -begin - Result := Trunc(Frac(Cardinal(Key) * HashFactor) * TableSize); -end; - -function THashIntegerMap.GetKeyPosition(const Key: Integer): TCollectionPosition; -var - Chain: TList; - I: Integer; - Success: Boolean; -begin - Chain := FArray[GetHash(Key)]; - Success := false; - for I := 0 to Chain.Count - 1 do - begin - Success := (Key = IIntegerAssociation(Chain[I]).GetKey); - if Success then - Break; - end; - Result := THashPosition.Create(Success, Chain, I); -end; - -procedure THashIntegerMap.Rehash; -var - NewArray: TListArray; - OldChain, NewChain: TList; - Association: IIntegerAssociation; - Total: Integer; - I, J: Integer; - Hash: Integer; -begin - // Create new chains - SetLength(NewArray, TableSize); - for I := Low(NewArray) to High(NewArray) do - begin - NewChain := TList.Create; - NewArray[I] := NewChain; - end; - ChangeCapacity(NewArray); - - // Transfer from old chains to new and drop old - for I := Low(FArray) to High(FArray) do - begin - OldChain := FArray[I]; - for J := 0 to OldChain.Count - 1 do - begin - Association := IIntegerAssociation(OldChain[J]); - Hash := GetHash(Association.GetKey); - NewArray[Hash].Add(Pointer(Association)); - end; - OldChain.Free; - end; - FArray := NewArray; - - // Find actual, new capacity - Total := 0; - for I := Low(FArray) to High(FArray) do - begin - NewChain := FArray[I]; - Total := Total + NewChain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashIntegerMap.TrueClear; -var - Association: IIntegerAssociation; - Chain: TList; - I, J: Integer; -begin - for I := Low(FArray) to High(FArray) do - begin - Chain := FArray[I]; - for J := 0 to Chain.Count - 1 do - begin - Association := IIntegerAssociation(Chain[J]); - Chain[J] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; - end; - Chain.Clear; - end; - FSize := 0; -end; - -function THashIntegerMap.TrueGet(Position: TCollectionPosition): IIntegerAssociation; -var - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Result := IIntegerAssociation(HashPosition.Chain.Items[HashPosition.Index]); -end; - -function THashIntegerMap.TruePut(Position: TCollectionPosition; const Association: IIntegerAssociation): IIntegerAssociation; -var - HashPosition: THashPosition; - OldAssociation: IIntegerAssociation; -begin - HashPosition := THashPosition(Position); - if HashPosition.Found then - begin - OldAssociation := IIntegerAssociation(HashPosition.Chain.Items[HashPosition.Index]); - HashPosition.Chain.Items[HashPosition.Index] := Pointer(Association); - Result := OldAssociation; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - OldAssociation._Release; - end - else - begin - HashPosition.Chain.Add(Pointer(Association)); - Inc(FSize); - Result := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - end; -end; - -function THashIntegerMap.TrueRemove2(Position: TCollectionPosition): IIntegerAssociation; -var - Association: IIntegerAssociation; - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Association := IIntegerAssociation(TrueGet(Position)); - HashPosition.Chain.Delete(HashPosition.Index); - Dec(FSize); - Result := Association; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - -function THashIntegerMap.GetCapacity; -begin - Result := FCapacity; -end; - -procedure THashIntegerMap.SetCapacity(Value: Integer); -begin - FCapacity := Value; - CheckLoadFactor(true); -end; - -function THashIntegerMap.GetSize: Integer; -begin - Result := FSize; -end; - -{ THashStringMap } -constructor THashStringMap.Create; -begin - Create(false, DefaultTableSize, DefaultMaxLoadFactor); -end; - -constructor THashStringMap.Create(NaturalItemsOnly: Boolean); -begin - Create(NaturalItemsOnly, DefaultTableSize, DefaultMaxLoadFactor); -end; - -constructor THashStringMap.Create(NaturalItemsOnly: Boolean; TableSize: Integer; MaxLoadFactor: Double = DefaultMaxLoadFactor); -var - I: Integer; -begin - inherited Create(NaturalItemsOnly); - SetLength(FArray, TableSize); - for I := Low(FArray) to High(FArray) do - FArray[I] := TList.Create; - FTableSize := TableSize; - FMaxLoadFactor := MaxLoadFactor; - FSize := 0; -end; - -destructor THashStringMap.Destroy; -var - I: Integer; -begin - for I := Low(FArray) to High(FArray) do - FArray[I].Free; - FArray := nil; - inherited Destroy; -end; - -function THashStringMap.GetAssociationIterator: IStringMapIterator; -begin - Result := THashStringIterator.Create(Self); -end; - -procedure THashStringMap.SetTableSize(Value: Integer); -begin - if (FTableSize <> Value) and (Value >= 1) then - begin - FTableSize := Value; - Rehash; - end; -end; - -procedure THashStringMap.SetMaxLoadFactor(Value: Double); -begin - if (FMaxLoadFactor <> Value) and (Value >= MaxLoadFactorMin) then - begin - FMaxLoadFactor := Value; - CheckLoadFactor(false); - end; -end; - -procedure THashStringMap.ChangeCapacity; -var - Chain: TList; - I, Total, ChainCapacity: Integer; -begin - if FCapacity mod FTableSize = 0 then - ChainCapacity := Trunc(FCapacity / FTableSize) - else - ChainCapacity := Trunc(FCapacity / FTableSize) + 1; - Total := 0; - for I := Low(Value) to High(Value) do - begin - Chain := Value[I]; - Chain.Capacity := ChainCapacity; - Total := Total + Chain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashStringMap.CheckLoadFactor(AlwaysChangeCapacity: Boolean); -var - LoadFactor: Double; -begin - LoadFactor := Capacity / TableSize; - if LoadFactor > MaxLoadFactor then - TableSize := Trunc(Capacity / Max(MaxLoadFactor, MaxLoadFactorMin)) - else if AlwaysChangeCapacity then - ChangeCapacity(FArray); -end; - -function THashStringMap.GetHash(const Key: String): Integer; -var - HashCode: Cardinal; - I: Integer; -begin - HashCode := 0; - for I := 1 to Length(Key) do - HashCode := (HashCode shl 1) xor Ord(Key[I]); - Result := Trunc(Frac(HashCode * HashFactor) * TableSize); -end; - -function THashStringMap.GetKeyPosition(const Key: String): TCollectionPosition; -var - Chain: TList; - I: Integer; - Success: Boolean; -begin - Chain := FArray[GetHash(Key)]; - Success := false; - for I := 0 to Chain.Count - 1 do - begin - Success := (Key = IStringAssociation(Chain[I]).GetKey); - if Success then - Break; - end; - Result := THashPosition.Create(Success, Chain, I); -end; - -procedure THashStringMap.Rehash; -var - NewArray: TListArray; - OldChain, NewChain: TList; - Association: IStringAssociation; - Total: Integer; - I, J: Integer; - Hash: Integer; -begin - // Create new chains - SetLength(NewArray, TableSize); - for I := Low(NewArray) to High(NewArray) do - begin - NewChain := TList.Create; - NewArray[I] := NewChain; - end; - ChangeCapacity(NewArray); - - // Transfer from old chains to new and drop old - for I := Low(FArray) to High(FArray) do - begin - OldChain := FArray[I]; - for J := 0 to OldChain.Count - 1 do - begin - Association := IStringAssociation(OldChain[J]); - Hash := GetHash(Association.GetKey); - NewArray[Hash].Add(Pointer(Association)); - end; - OldChain.Free; - end; - FArray := NewArray; - - // Find actual, new capacity - Total := 0; - for I := Low(FArray) to High(FArray) do - begin - NewChain := FArray[I]; - Total := Total + NewChain.Capacity; - end; - FCapacity := Total; -end; - -procedure THashStringMap.TrueClear; -var - Association: IStringAssociation; - Chain: TList; - I, J: Integer; -begin - for I := Low(FArray) to High(FArray) do - begin - Chain := FArray[I]; - for J := 0 to Chain.Count - 1 do - begin - Association := IStringAssociation(Chain[J]); - Chain[J] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; - end; - Chain.Clear; - end; - FSize := 0; -end; - -function THashStringMap.TrueGet(Position: TCollectionPosition): IStringAssociation; -var - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Result := IStringAssociation(HashPosition.Chain.Items[HashPosition.Index]); -end; - -function THashStringMap.TruePut(Position: TCollectionPosition; const Association: IStringAssociation): IStringAssociation; -var - HashPosition: THashPosition; - OldAssociation: IStringAssociation; -begin - HashPosition := THashPosition(Position); - if HashPosition.Found then - begin - OldAssociation := IStringAssociation(HashPosition.Chain.Items[HashPosition.Index]); - HashPosition.Chain.Items[HashPosition.Index] := Pointer(Association); - Result := OldAssociation; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - OldAssociation._Release; - end - else - begin - HashPosition.Chain.Add(Pointer(Association)); - Inc(FSize); - Result := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - end; -end; - -function THashStringMap.TrueRemove2(Position: TCollectionPosition): IStringAssociation; -var - Association: IStringAssociation; - HashPosition: THashPosition; -begin - HashPosition := THashPosition(Position); - Association := IStringAssociation(TrueGet(Position)); - HashPosition.Chain.Delete(HashPosition.Index); - Dec(FSize); - Result := Association; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - -function THashStringMap.GetCapacity; -begin - Result := FCapacity; -end; - -procedure THashStringMap.SetCapacity(Value: Integer); -begin - FCapacity := Value; - CheckLoadFactor(true); -end; - -function THashStringMap.GetSize: Integer; -begin - Result := FSize; -end; - -{ THashPosition } -constructor THashPosition.Create(Found: Boolean; Chain: TList; Index: Integer); -begin - inherited Create(Found); - FChain := Chain; - FIndex := Index; -end; - -{ THashIterator } -constructor THashIterator.Create(HashSet: THashSet); -begin - inherited Create(true); - FHashSet := HashSet; - First; -end; - -function THashIterator.TrueFirst: ICollectable; -var - Chain: TList; - Success: Boolean; -begin - FHash := 0; - FChainIndex := 0; - Success := false; - while FHash < FHashSet.TableSize do - begin - Chain := FHashSet.FArray[FHash]; - Success := Chain.Count > 0; - if Success then - Break; - Inc(FHash); - end; - if Success then - Result := ICollectable(FHashSet.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -function THashIterator.TrueNext: ICollectable; -var - Chain: TList; - Success: Boolean; -begin - Success := false; - Chain := FHashSet.FArray[FHash]; - repeat - Inc(FChainIndex); - if FChainIndex >= Chain.Count then - begin - Inc(FHash); - FChainIndex := -1; - if FHash < FHashSet.TableSize then - Chain := FHashSet.FArray[FHash]; - end - else - Success := true; - until Success or (FHash >= FHashSet.TableSize); - if Success then - Result := ICollectable(FHashSet.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -procedure THashIterator.TrueRemove; -var - Item: ICollectable; -begin - Item := ICollectable(FHashSet.FArray[FHash].Items[FChainIndex]); - FHashSet.FArray[FHash].Delete(FChainIndex); - Dec(FChainIndex); - Dec(FHashSet.FSize); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._Release; -end; - - -{ THashAssociationIterator } -constructor THashAssociationIterator.Create(HashMap: THashMap); -begin - inherited Create(true); - FHashMap := HashMap; - First; -end; - -function THashAssociationIterator.TrueFirst: IAssociation; -var - Chain: TList; - Success: Boolean; -begin - FHash := 0; - FChainIndex := 0; - Success := false; - while FHash < FHashMap.TableSize do - begin - Chain := FHashMap.FArray[FHash]; - Success := Chain.Count > 0; - if Success then - Break; - Inc(FHash); - end; - if Success then - Result := IAssociation(FHashMap.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -function THashAssociationIterator.TrueNext: IAssociation; -var - Chain: TList; - Success: Boolean; -begin - Success := false; - Chain := FHashMap.FArray[FHash]; - repeat - Inc(FChainIndex); - if FChainIndex >= Chain.Count then - begin - Inc(FHash); - FChainIndex := -1; - if FHash < FHashMap.TableSize then - Chain := FHashMap.FArray[FHash]; - end - else - Success := true; - until Success or (FHash >= FHashMap.TableSize); - if Success then - Result := IAssociation(FHashMap.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -procedure THashAssociationIterator.TrueRemove; -var - Association: IAssociation; -begin - Association := IAssociation(FHashMap.FArray[FHash].Items[FChainIndex]); - FHashMap.FArray[FHash].Delete(FChainIndex); - Dec(FChainIndex); - Dec(FHashMap.FSize); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - - -{ THashIntegerIterator } -constructor THashIntegerIterator.Create(HashIntegerMap: THashIntegerMap); -begin - inherited Create(true); - FHashIntegerMap := HashIntegerMap; - First; -end; - -function THashIntegerIterator.TrueFirst: IIntegerAssociation; -var - Chain: TList; - Success: Boolean; -begin - FHash := 0; - FChainIndex := 0; - Success := false; - while FHash < FHashIntegerMap.TableSize do - begin - Chain := FHashIntegerMap.FArray[FHash]; - Success := Chain.Count > 0; - if Success then - Break; - Inc(FHash); - end; - if Success then - Result := IIntegerAssociation(FHashIntegerMap.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -function THashIntegerIterator.TrueNext: IIntegerAssociation; -var - Chain: TList; - Success: Boolean; -begin - Success := false; - Chain := FHashIntegerMap.FArray[FHash]; - repeat - Inc(FChainIndex); - if FChainIndex >= Chain.Count then - begin - Inc(FHash); - FChainIndex := -1; - if FHash < FHashIntegerMap.TableSize then - Chain := FHashIntegerMap.FArray[FHash]; - end - else - Success := true; - until Success or (FHash >= FHashIntegerMap.TableSize); - if Success then - Result := IIntegerAssociation(FHashIntegerMap.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -procedure THashIntegerIterator.TrueRemove; -var - Association: IIntegerAssociation; -begin - Association := IIntegerAssociation(FHashIntegerMap.FArray[FHash].Items[FChainIndex]); - FHashIntegerMap.FArray[FHash].Delete(FChainIndex); - Dec(FChainIndex); - Dec(FHashIntegerMap.FSize); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - -{ THashStringIterator } -constructor THashStringIterator.Create(HashStringMap: THashStringMap); -begin - inherited Create(true); - FHashStringMap := HashStringMap; - First; -end; - -function THashStringIterator.TrueFirst: IStringAssociation; -var - Chain: TList; - Success: Boolean; -begin - FHash := 0; - FChainIndex := 0; - Success := false; - while FHash < FHashStringMap.TableSize do - begin - Chain := FHashStringMap.FArray[FHash]; - Success := Chain.Count > 0; - if Success then - Break; - Inc(FHash); - end; - if Success then - Result := IStringAssociation(FHashStringMap.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -function THashStringIterator.TrueNext: IStringAssociation; -var - Chain: TList; - Success: Boolean; -begin - Success := false; - Chain := FHashStringMap.FArray[FHash]; - repeat - Inc(FChainIndex); - if FChainIndex >= Chain.Count then - begin - Inc(FHash); - FChainIndex := -1; - if FHash < FHashStringMap.TableSize then - Chain := FHashStringMap.FArray[FHash]; - end - else - Success := true; - until Success or (FHash >= FHashStringMap.TableSize); - if Success then - Result := IStringAssociation(FHashStringMap.FArray[FHash].Items[FChainIndex]) - else - Result := nil; -end; - -procedure THashStringIterator.TrueRemove; -var - Association: IStringAssociation; -begin - Association := IStringAssociation(FHashStringMap.FArray[FHash].Items[FChainIndex]); - FHashStringMap.FArray[FHash].Delete(FChainIndex); - Dec(FChainIndex); - Dec(FHashStringMap.FSize); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - - -end. diff --git a/src/lib/collections/CollLibrary.pas b/src/lib/collections/CollLibrary.pas deleted file mode 100644 index b7e3d268..00000000 --- a/src/lib/collections/CollLibrary.pas +++ /dev/null @@ -1,131 +0,0 @@ -unit CollLibrary; - -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0.3 $ - * $Revision: 1.0.1.1 $ - * $Log: D:\QVCS Repositories\Delphi Collections\CollLibrary.qbt $ - * - * Initial version. - * - * Revision 1.0.1.1 by: Matthew Greet Rev date: 24/10/03 16:48:16 - * v1.0 branch. - * - * Revision 1.0 by: Matthew Greet Rev date: 06/04/03 10:40:32 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -interface - -uses - Collections, CollArray, CollHash, CollList, CollPArray, CollWrappers; - -type - TMiscCollectionLibrary = class - public - class function ClassNameToClassType(ClassName: String): TAbstractCollectionClass; - class function EqualIID(const IID1, IID2: TGUID): Boolean; - class function HashCode(Value: String): Integer; - class procedure ShuffleArray(var ItemArray: array of ICollectable); - class procedure ShuffleList(const List: IList); - end; - -implementation - -{ TMiscCollectionLibrary } -class function TMiscCollectionLibrary.ClassNameToClassType(ClassName: String): TAbstractCollectionClass; -begin - if ClassName = 'TArray' then - Result := TArray - else if ClassName = 'THashSet' then - Result := THashSet - else if ClassName = 'THashMap' then - Result := THashMap - else if ClassName = 'THashIntegerMap' then - Result := THashIntegerMap - else if ClassName = 'THashStringMap' then - Result := THashStringMap - else if ClassName = 'TListSet' then - Result := TListSet - else if ClassName = 'TListMap' then - Result := TListMap - else if ClassName = 'TPArrayBag' then - Result := TPArrayBag - else if ClassName = 'TPArraySet' then - Result := TPArraySet - else if ClassName = 'TPArrayList' then - Result := TPArrayList - else if ClassName = 'TPArrayMap' then - Result := TPArrayMap - else - Result := nil; -end; - -class function TMiscCollectionLibrary.EqualIID(const IID1, IID2: TGUID): Boolean; -begin - Result := (IID1.D1 = IID2.D1) and (IID1.D2 = IID2.D2) and (IID1.D3 = IID2.D3) and - (IID1.D4[0] = IID2.D4[0]) and (IID1.D4[1] = IID2.D4[1]) and - (IID1.D4[2] = IID2.D4[2]) and (IID1.D4[3] = IID2.D4[3]) and - (IID1.D4[4] = IID2.D4[4]) and (IID1.D4[5] = IID2.D4[5]) and - (IID1.D4[6] = IID2.D4[6]) and (IID1.D4[7] = IID2.D4[7]); -end; - -class function TMiscCollectionLibrary.HashCode(Value: String): Integer; -var - I: Integer; -begin - Result := 0; - for I := 1 to Length(Value) do - Result := (Result shl 1) xor Ord(Value[I]); -end; - -class procedure TMiscCollectionLibrary.ShuffleArray(var ItemArray: array of ICollectable); -var - Item: ICollectable; - ArraySize, I, Index: Integer; -begin - Randomize; - ArraySize := Length(ItemArray); - for I := 0 to ArraySize - 1 do - begin - Index := (I + Random(ArraySize - 1) + 1) mod ArraySize; - Item := ItemArray[I]; - ItemArray[I] := ItemArray[Index]; - ItemArray[Index] := Item; - end; -end; - -class procedure TMiscCollectionLibrary.ShuffleList(const List: IList); -var - ListSize, I: Integer; -begin - Randomize; - ListSize := List.GetSize; - for I := 0 to ListSize - 1 do - begin - List.Exchange(I, (I + Random(ListSize - 1) + 1) mod ListSize); - end; -end; - - -end. diff --git a/src/lib/collections/CollList.pas b/src/lib/collections/CollList.pas deleted file mode 100644 index 68aa0d66..00000000 --- a/src/lib/collections/CollList.pas +++ /dev/null @@ -1,270 +0,0 @@ -unit CollList; - -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0.3 $ - * $Revision: 1.1.1.2 $ - * $Log: D:\QVCS Repositories\Delphi Collections\CollList.qbt $ - * - * Collection implementations based on sorted TPArrayList instances. - * - * Revision 1.1.1.2 by: Matthew Greet Rev date: 12/06/04 20:05:54 - * Capacity property. - * - * Revision 1.1.1.1 by: Matthew Greet Rev date: 14/02/04 17:45:38 - * v1.0 branch. - * - * Revision 1.1 by: Matthew Greet Rev date: 06/04/03 10:41:52 - * Uses TExposedPArrayList to improve performance. - * - * Revision 1.0 by: Matthew Greet Rev date: 01/03/03 10:50:02 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -interface - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -uses - Collections, CollPArray; - -type - TListSet = class(TAbstractSet) - private - FList: TExposedPArrayList; - protected - function GetPosition(const Item: ICollectable): TCollectionPosition; override; - procedure TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); override; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): ICollectable; override; - procedure TrueRemove2(Position: TCollectionPosition); override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetIterator: IIterator; override; - function GetNaturalItemIID: TGUID; override; - function GetSize: Integer; override; - end; - - TListMap = class(TAbstractMap) - private - FList: TExposedPArrayList; - protected - function GetAssociationIterator: IMapIterator; override; - function GetKeyPosition(const Key: ICollectable): TCollectionPosition; override; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): IAssociation; override; - function TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; override; - function TrueRemove2(Position: TCollectionPosition): IAssociation; override; - public - constructor Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - procedure SetKeyComparator(const Value: IComparator); override; - function GetNaturalKeyIID: TGUID; override; - function GetSize: Integer; override; - end; - -implementation - -type - TListPosition = class(TCollectionPosition) - private - FSearchResult: TSearchResult; - public - constructor Create(Found: Boolean; SearchResult: TSearchResult); - property SearchResult: TSearchResult read FSearchResult; - end; - -constructor TListSet.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FList := TExposedPArrayList.Create(NaturalItemsOnly); - FList.Comparator := Comparator; - FList.Sort; -end; - -destructor TListSet.Destroy; -begin - FList.Free; - inherited Destroy; -end; - -function TListSet.GetPosition(const Item: ICollectable): TCollectionPosition; -var - SearchResult: TSearchResult; -begin - SearchResult := FList.Search(Item); - Result := TListPosition.Create((SearchResult.ResultType = srFoundAtIndex), SearchResult); -end; - -procedure TListSet.TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); -var - SearchResult: TSearchResult; - Index: Integer; -begin - SearchResult := TListPosition(Position).SearchResult; - Index := SearchResult.Index; - if SearchResult.ResultType = srBeforeIndex then - FList.TrueInsert(Index, Item) - else - FList.TrueAppend(Item); -end; - -procedure TListSet.TrueClear; -begin - FList.Clear; -end; - -function TListSet.TrueGet(Position: TCollectionPosition): ICollectable; -begin - Result := FList.Items[TListPosition(Position).SearchResult.Index]; -end; - -procedure TListSet.TrueRemove2(Position: TCollectionPosition); -begin - FList.Delete(TListPosition(Position).SearchResult.Index); -end; - -function TListSet.GetCapacity: Integer; -begin - Result := FList.Capacity; -end; - -procedure TListSet.SetCapacity(Value: Integer); -begin - FList.Capacity := Value; -end; - -function TListSet.GetIterator: IIterator; -begin - Result := FList.GetIterator; -end; - -function TListSet.GetNaturalItemIID: TGUID; -begin - Result := ComparableIID; -end; - -function TListSet.GetSize: Integer; -begin - Result := FList.Size; -end; - -constructor TListMap.Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); -begin - inherited Create(NaturalItemsOnly, NaturalKeysOnly); - FList := TExposedPArrayList.Create(false); - FList.Comparator := AssociationComparator; - FList.Sort; -end; - -destructor TListMap.Destroy; -begin - FList.Free; - inherited Destroy; -end; - -function TListMap.GetAssociationIterator: IMapIterator; -begin - Result := TAssociationIterator.Create(FList.GetIterator); -end; - -function TListMap.GetKeyPosition(const Key: ICollectable): TCollectionPosition; -var - Association: IAssociation; - SearchResult: TSearchResult; -begin - Association := TAssociation.Create(Key, nil); - SearchResult := FList.Search(Association); - Result := TListPosition.Create((SearchResult.ResultType = srFoundAtIndex), SearchResult); -end; - -procedure TListMap.TrueClear; -begin - FList.Clear; -end; - -function TListMap.TrueGet(Position: TCollectionPosition): IAssociation; -begin - Result := (FList.Items[TListPosition(Position).SearchResult.Index]) as IAssociation; -end; - -function TListMap.TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; -var - SearchResult: TSearchResult; - Index: Integer; -begin - SearchResult := TListPosition(Position).SearchResult; - Index := SearchResult.Index; - if SearchResult.ResultType = srFoundAtIndex then - begin - Result := (FList.Items[Index]) as IAssociation; - FList.Items[Index] := Association; - end - else if SearchResult.ResultType = srBeforeIndex then - FList.TrueInsert(Index, Association) - else - FList.TrueAppend(Association); -end; - -function TListMap.TrueRemove2(Position: TCollectionPosition): IAssociation; -begin - Result := (FList.Items[TListPosition(Position).SearchResult.Index]) as IAssociation; - FList.Delete(TListPosition(Position).SearchResult.Index); -end; - -procedure TListMap.SetKeyComparator(const Value: IComparator); -begin - inherited SetKeyComparator(Value); - FList.Sort; -end; - -function TListMap.GetCapacity: Integer; -begin - Result := FList.Capacity; -end; - -procedure TListMap.SetCapacity(Value: Integer); -begin - FList.Capacity := Value; -end; - -function TListMap.GetNaturalKeyIID: TGUID; -begin - Result := ComparableIID; -end; - -function TListMap.GetSize: Integer; -begin - Result := FList.Size; -end; - -constructor TListPosition.Create(Found: Boolean; SearchResult: TSearchResult); -begin - inherited Create(Found); - FSearchResult := SearchResult; -end; - -end. diff --git a/src/lib/collections/CollPArray.pas b/src/lib/collections/CollPArray.pas deleted file mode 100644 index 5ebd534b..00000000 --- a/src/lib/collections/CollPArray.pas +++ /dev/null @@ -1,689 +0,0 @@ -unit CollPArray; - -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0.3 $ - * $Revision: 1.2.1.2 $ - * $Log: D:\QVCS Repositories\Delphi Collections\CollPArray.qbt $ - * - * Collection implementations based on TList. - * - * Revision 1.2.1.2 by: Matthew Greet Rev date: 12/06/04 20:08:30 - * Capacity property. - * - * Revision 1.2.1.1 by: Matthew Greet Rev date: 14/02/04 17:46:10 - * v1.0 branch. - * - * Revision 1.2 by: Matthew Greet Rev date: 28/04/03 15:07:14 - * Correctly handles nil items. - * - * Revision 1.1 by: Matthew Greet Rev date: 06/04/03 10:43:16 - * Added TPArrayMap and TExposedPArrayList. - * - * Revision 1.0 by: Matthew Greet Rev date: 01/03/03 10:50:02 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -interface - -uses - Classes, - Collections; - -type - TPArrayBag = class(TAbstractBag) - private - FList: TList; - protected - function TrueAdd(const Item: ICollectable): Boolean; override; - procedure TrueClear; override; - function TrueRemove(const Item: ICollectable): ICollectable; override; - function TrueRemoveAll(const Item: ICollectable): ICollection; override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetIterator: IIterator; override; - function GetSize: Integer; override; - function TrueContains(const Item: ICollectable): Boolean; override; - end; - - TPArraySet = class(TAbstractSet) - private - FList: TList; - protected - function GetPosition(const Item: ICollectable): TCollectionPosition; override; - procedure TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); override; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): ICollectable; override; - procedure TrueRemove2(Position: TCollectionPosition); override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetIterator: IIterator; override; - function GetSize: Integer; override; - end; - - TPArrayList = class(TAbstractList) - private - FList: TList; - protected - function TrueGetItem(Index: Integer): ICollectable; override; - procedure TrueSetItem(Index: Integer; const Item: ICollectable); override; - procedure TrueAppend(const Item: ICollectable); override; - procedure TrueClear; override; - function TrueDelete(Index: Integer): ICollectable; override; - procedure TrueInsert(Index: Integer; const Item: ICollectable); override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetIterator: IIterator; override; - function GetSize: Integer; override; - end; - - TPArrayMap = class(TAbstractMap) - private - FList: TList; - protected - function GetAssociationIterator: IMapIterator; override; - function GetKeyPosition(const Key: ICollectable): TCollectionPosition; override; - procedure TrueClear; override; - function TrueGet(Position: TCollectionPosition): IAssociation; override; - function TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; override; - function TrueRemove2(Position: TCollectionPosition): IAssociation; override; - public - constructor Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); override; - destructor Destroy; override; - function GetCapacity: Integer; override; - procedure SetCapacity(Value: Integer); override; - function GetSize: Integer; override; - end; - - // Same as TPArrayList but raises method visibilities so items can be manually - // appended or inserted without resetting sort flag. - TExposedPArrayList = class(TPArrayList) - public - procedure TrueAppend(const Item: ICollectable); override; - procedure TrueInsert(Index: Integer; const Item: ICollectable); override; - end; - - -implementation - -type - TPArrayIterator = class(TAbstractIterator) - private - FList: TList; - FIndex: Integer; - protected - constructor Create(List: TList; AllowRemove: Boolean); - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - end; - - TPArrayAssociationIterator = class(TAbstractAssociationIterator) - private - FList: TList; - FIndex: Integer; - protected - constructor Create(List: TList; AllowRemove: Boolean); - function TrueFirst: IAssociation; override; - function TrueNext: IAssociation; override; - procedure TrueRemove; override; - end; - - TPArrayPosition = class(TCollectionPosition) - private - FIndex: Integer; - public - constructor Create(Found: Boolean; Index: Integer); - property Index: Integer read FIndex; - end; - -constructor TPArrayBag.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FList := TList.Create; -end; - -destructor TPArrayBag.Destroy; -begin - FList.Free; - inherited Destroy; -end; - -function TPArrayBag.TrueAdd(const Item: ICollectable): Boolean; -begin - FList.Add(Pointer(Item)); - Result := true; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._AddRef; -end; - -procedure TPArrayBag.TrueClear; -var - Item: ICollectable; - I: Integer; -begin - // Delete all interface references - for I := 0 to FList.Count - 1 do - begin - Item := ICollectable(FList[I]); - FList[I] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._Release; - end; - FList.Clear; -end; - -function TPArrayBag.TrueContains(const Item: ICollectable): Boolean; -var - I: Integer; - Success: Boolean; -begin - // Sequential search - I := 0; - Success := false; - while (I < FList.Count) and not Success do - begin - Success := Comparator.Equals(Item, ICollectable(FList[I])); - Inc(I); - end; - Result := Success; -end; - -function TPArrayBag.TrueRemove(const Item: ICollectable): ICollectable; -var - Item2: ICollectable; - I: Integer; - Found: Boolean; -begin - // Sequential search - I := 0; - Found := false; - Result := nil; - while (I < FList.Count) and not Found do - begin - Item2 := ICollectable(FList[I]); - if Comparator.Equals(Item, Item2) then - begin - Found := true; - Result := Item2; - FList.Delete(I); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item2 <> nil then - Item2._Release; - end - else - Inc(I); - end; -end; - -function TPArrayBag.TrueRemoveAll(const Item: ICollectable): ICollection; -var - ResultCollection: TPArrayBag; - Item2: ICollectable; - I: Integer; -begin - // Sequential search - I := 0; - ResultCollection := TPArrayBag.Create; - while I < FList.Count do - begin - Item2 := ICollectable(FList[I]); - if Comparator.Equals(Item, Item2) then - begin - ResultCollection.Add(Item2); - FList.Delete(I); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._Release; - end - else - Inc(I); - end; - Result := ResultCollection; -end; - -function TPArrayBag.GetCapacity: Integer; -begin - Result := FList.Capacity; -end; - -procedure TPArrayBag.SetCapacity(Value: Integer); -begin - FList.Capacity := Value; -end; - -function TPArrayBag.GetIterator: IIterator; -begin - Result := TPArrayIterator.Create(FList, true); -end; - -function TPArrayBag.GetSize: Integer; -begin - Result := FList.Count; -end; - -constructor TPArraySet.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FList := TList.Create; -end; - -destructor TPArraySet.Destroy; -begin - FList.Free; - inherited Destroy; -end; - -function TPArraySet.GetPosition(const Item: ICollectable): TCollectionPosition; -var - I: Integer; - Success: Boolean; -begin - // Sequential search - I := 0; - Success := false; - while (I < FList.Count) do - begin - Success := Comparator.Equals(Item, ICollectable(FList[I])); - if Success then - break; - Inc(I); - end; - Result := TPArrayPosition.Create(Success, I); -end; - -procedure TPArraySet.TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); -begin - FList.Add(Pointer(Item)); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._AddRef; -end; - -procedure TPArraySet.TrueClear; -var - Item: ICollectable; - I: Integer; -begin - // Delete all interface references - for I := 0 to FList.Count - 1 do - begin - Item := ICollectable(FList[I]); - FList[I] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._Release; - end; - FList.Clear; -end; - -function TPArraySet.TrueGet(Position: TCollectionPosition): ICollectable; -begin - Result := ICollectable(FList.Items[TPArrayPosition(Position).Index]); -end; - -procedure TPArraySet.TrueRemove2(Position: TCollectionPosition); -var - Item: ICollectable; -begin - Item := ICollectable(FList[TPArrayPosition(Position).Index]); - FList.Delete(TPArrayPosition(Position).Index); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._Release; -end; - -function TPArraySet.GetCapacity: Integer; -begin - Result := FList.Capacity; -end; - -procedure TPArraySet.SetCapacity(Value: Integer); -begin - FList.Capacity := Value; -end; - -function TPArraySet.GetIterator: IIterator; -begin - Result := TPArrayIterator.Create(FList, true); -end; - -function TPArraySet.GetSize: Integer; -begin - Result := FList.Count; -end; - -constructor TPArrayList.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FList := TList.Create; -end; - -destructor TPArrayList.Destroy; -begin - FList.Free; - inherited Destroy; -end; - -function TPArrayList.TrueGetItem(Index: Integer): ICollectable; -begin - Result := ICollectable(FList.Items[Index]); -end; - -procedure TPArrayList.TrueSetItem(Index: Integer; const Item: ICollectable); -var - OldItem: ICollectable; -begin - OldItem := ICollectable(FList[Index]); - FList[Index] := Pointer(Item); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._AddRef; - if OldItem <> nil then - OldItem._Release; -end; - -procedure TPArrayList.TrueAppend(const Item: ICollectable); -begin - FList.Add(Pointer(Item)); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._AddRef; -end; - -procedure TPArrayList.TrueClear; -var - Item: ICollectable; - I: Integer; -begin - // Delete all interface references - for I := 0 to FList.Count - 1 do - begin - Item := ICollectable(FList[I]); - FList[I] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._Release; - end; - FList.Clear; -end; - -function TPArrayList.TrueDelete(Index: Integer): ICollectable; -begin - Result := ICollectable(FList[Index]); - FList.Delete(Index); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Result <> nil then - Result._Release; -end; - -procedure TPArrayList.TrueInsert(Index: Integer; const Item: ICollectable); -begin - FList.Insert(Index, Pointer(Item)); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - if Item <> nil then - Item._AddRef; -end; - -function TPArrayList.GetCapacity: Integer; -begin - Result := FList.Capacity; -end; - -procedure TPArrayList.SetCapacity(Value: Integer); -begin - FList.Capacity := Value; -end; - -function TPArrayList.GetIterator: IIterator; -begin - Result := TPArrayIterator.Create(FList, true); -end; - -function TPArrayList.GetSize: Integer; -begin - Result := FList.Count; -end; - -constructor TPArrayMap.Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); -begin - inherited Create(NaturalItemsOnly, NaturalKeysOnly); - FList := TList.Create; -end; - -destructor TPArrayMap.Destroy; -begin - FList.Free; - inherited Destroy; -end; - -function TPArrayMap.GetAssociationIterator: IMapIterator; -begin - Result := TPArrayAssociationIterator.Create(FList, true); -end; - -function TPArrayMap.GetKeyPosition(const Key: ICollectable): TCollectionPosition; -var - I: Integer; - Success: Boolean; -begin - // Sequential search - I := 0; - Success := false; - while (I < FList.Count) do - begin - Success := KeyComparator.Equals(Key, IAssociation(FList[I]).GetKey); - if Success then - break; - Inc(I); - end; - Result := TPArrayPosition.Create(Success, I); -end; - -procedure TPArrayMap.TrueClear; -var - Association: IAssociation; - I: Integer; -begin - // Delete all interface references - for I := 0 to FList.Count - 1 do - begin - Association := IAssociation(FList[I]); - FList[I] := nil; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; - end; - FList.Clear; -end; - -function TPArrayMap.TrueGet(Position: TCollectionPosition): IAssociation; -begin - Result := IAssociation(FList.Items[TPArrayPosition(Position).Index]); -end; - -function TPArrayMap.TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; -var - OldAssociation: IAssociation; - Index: Integer; -begin - if Position.Found then - begin - Index := (Position as TPArrayPosition).Index; - OldAssociation := IAssociation(FList[Index]); - FList[Index] := Pointer(Association); - end - else - begin - OldAssociation := nil; - FList.Add(Pointer(Association)); - end; - Result := OldAssociation; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._AddRef; - if OldAssociation <> nil then - OldAssociation._Release; -end; - -function TPArrayMap.TrueRemove2(Position: TCollectionPosition): IAssociation; -var - OldAssociation: IAssociation; -begin - OldAssociation := IAssociation(FList[TPArrayPosition(Position).Index]); - FList.Delete(TPArrayPosition(Position).Index); - Result := OldAssociation; - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - OldAssociation._Release; -end; - -function TPArrayMap.GetCapacity: Integer; -begin - Result := FList.Capacity; -end; - -procedure TPArrayMap.SetCapacity(Value: Integer); -begin - FList.Capacity := Value; -end; - -function TPArrayMap.GetSize: Integer; -begin - Result := FList.Count; -end; - -procedure TExposedPArrayList.TrueAppend(const Item: ICollectable); -begin - inherited TrueAppend(Item); -end; - -procedure TExposedPArrayList.TrueInsert(Index: Integer; const Item: ICollectable); -begin - inherited TrueInsert(Index, Item); -end; - -{ TPArrayIterator } -constructor TPArrayIterator.Create(List: TList; AllowRemove: Boolean); -begin - inherited Create(AllowRemove); - FList := List; - FIndex := -1; -end; - -function TPArrayIterator.TrueFirst: ICollectable; -begin - FIndex := 0; - if FIndex < FList.Count then - Result := ICollectable(FList[FIndex]) - else - Result := nil; -end; - -function TPArrayIterator.TrueNext: ICollectable; -begin - Inc(FIndex); - if FIndex < FList.Count then - Result := ICollectable(FList[FIndex]) - else - Result := nil; -end; - -procedure TPArrayIterator.TrueRemove; -var - Item: ICollectable; -begin - Item := ICollectable(FList[FIndex]); - FList.Delete(FIndex); - Dec(FIndex); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Item._Release; -end; - -{ TPArrayAssociationIterator } -constructor TPArrayAssociationIterator.Create(List: TList; AllowRemove: Boolean); -begin - inherited Create(AllowRemove); - FList := List; - FIndex := -1; -end; - -function TPArrayAssociationIterator.TrueFirst: IAssociation; -begin - FIndex := 0; - if FIndex < FList.Count then - Result := IAssociation(FList[FIndex]) - else - Result := nil; -end; - -function TPArrayAssociationIterator.TrueNext: IAssociation; -begin - Inc(FIndex); - if FIndex < FList.Count then - Result := IAssociation(FList[FIndex]) - else - Result := nil; -end; - -procedure TPArrayAssociationIterator.TrueRemove; -var - Association: IAssociation; -begin - Association := IAssociation(FList[FIndex]); - FList.Delete(FIndex); - Dec(FIndex); - // Storing interface reference as a pointer does not update reference - // count automatically, so this must be done manually - Association._Release; -end; - -{ TPArrayPosition } -constructor TPArrayPosition.Create(Found: Boolean; Index: Integer); -begin - inherited Create(Found); - FIndex := Index; -end; - -end. diff --git a/src/lib/collections/CollWrappers.pas b/src/lib/collections/CollWrappers.pas deleted file mode 100644 index 513103a2..00000000 --- a/src/lib/collections/CollWrappers.pas +++ /dev/null @@ -1,876 +0,0 @@ -unit CollWrappers; - -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0.3 $ - * $Revision: 1.1.1.1 $ - * $Log: D:\QVCS Repositories\Delphi Collections\CollWrappers.qbt $ - * - * Various primitive type wrappers, adapters and abstract base classes for - * natural items. - * - * Revision 1.1.1.1 by: Matthew Greet Rev date: 24/10/03 16:48:16 - * v1.0 branch. - * - * Revision 1.1 by: Matthew Greet Rev date: 06/04/03 10:51:04 - * Primitive type wrapper interfaces added. - * Abstract, template classes added. - * All classes implement reference counting by descending from - * TInterfacedObject. - * - * - * Revision 1.0 by: Matthew Greet Rev date: 01/03/03 10:50:02 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -interface - -uses - SysUtils, - Collections; - -type - IAssociationWrapper = interface - ['{54DF42E0-64F2-11D7-8120-0002E3165EF8}'] - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetKey: ICollectable; - function GetValue: TObject; - property AutoDestroy: Boolean read GetAutoDestroy write SetAutoDestroy; - property Key: ICollectable read GetKey; - property Value: TObject read GetValue; - end; - - IBoolean = interface - ['{62D1D160-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: Boolean; - property Value: Boolean read GetValue; - end; - - ICardinal = interface - ['{6AF7B1C0-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: Cardinal; - property Value: Cardinal read GetValue; - end; - - IChar = interface - ['{73AD00E0-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: Char; - property Value: Char read GetValue; - end; - - IClass = interface - ['{7A84B660-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: TClass; - property Value: TClass read GetValue; - end; - - IDouble = interface - ['{815C6BE0-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: Double; - property Value: Double read GetValue; - end; - - IInteger = interface - ['{88ECC300-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: Integer; - property Value: Integer read GetValue; - end; - - IIntegerAssociationWrapper = interface - ['{8F582220-64F2-11D7-8120-0002E3165EF8}'] - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetKey: Integer; - function GetValue: TObject; - property AutoDestroy: Boolean read GetAutoDestroy write SetAutoDestroy; - property Key: Integer read GetKey; - property Value: TObject read GetValue; - end; - - IInterfaceWrapper = interface - ['{962E5100-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: IUnknown; - property Value: IUnknown read GetValue; - end; - - IObject = interface - ['{9C675580-64F2-11D7-8120-0002E3165EF8}'] - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetValue: TObject; - property Value: TObject read GetValue; - end; - - IString = interface - ['{A420DF80-64F2-11D7-8120-0002E3165EF8}'] - function GetValue: String; - property Value: String read GetValue; - end; - - IStringAssociationWrapper = interface - ['{AB98CCA0-64F2-11D7-8120-0002E3165EF8}'] - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetKey: String; - function GetValue: TObject; - property AutoDestroy: Boolean read GetAutoDestroy write SetAutoDestroy; - property Key: String read GetKey; - property Value: TObject read GetValue; - end; - - TAbstractItem = class(TInterfacedObject, ICollectable) - public - function GetInstance: TObject; virtual; - end; - - TAbstractIntegerMappable = class(TAbstractItem, IEquatable, IIntegerMappable) - private - FKey: Integer; - protected - function MakeKey: Integer; virtual; abstract; - public - procedure AfterConstruction; override; - function Equals(const Item: ICollectable): Boolean; virtual; - function GetKey: Integer; virtual; - end; - - TAbstractMappable = class(TAbstractItem, IEquatable, IMappable) - private - FKey: ICollectable; - protected - function MakeKey: ICollectable; virtual; abstract; - public - destructor Destroy; override; - procedure AfterConstruction; override; - function Equals(const Item: ICollectable): Boolean; virtual; - function GetKey: ICollectable; virtual; - end; - - TAbstractStringMappable = class(TAbstractItem, IEquatable, IStringMappable) - private - FKey: String; - protected - function MakeKey: String; virtual; abstract; - public - procedure AfterConstruction; override; - function Equals(const Item: ICollectable): Boolean; virtual; - function GetKey: String; virtual; - end; - - TAssociationWrapper = class(TAbstractItem, IEquatable, IMappable, IAssociationWrapper) - private - FAutoDestroy: Boolean; - FKey: ICollectable; - FValue: TObject; - public - constructor Create(const Key: ICollectable; Value: TObject); overload; - constructor Create(Key: Integer; Value: TObject); overload; - constructor Create(Key: String; Value: TObject); overload; - constructor Create(Key, Value: TObject; AutoDestroyKey: Boolean = true); overload; - destructor Destroy; override; - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetKey: ICollectable; - function GetValue: TObject; - function Equals(const Item: ICollectable): Boolean; - property AutoDestroy: Boolean read GetAutoDestroy write SetAutoDestroy; - property Key: ICollectable read GetKey; - property Value: TObject read GetValue; - end; - - TBooleanWrapper = class(TAbstractItem, IEquatable, IHashable, IComparable, IBoolean) - private - FValue: Boolean; - public - constructor Create(Value: Boolean); - function GetValue: Boolean; - function CompareTo(const Item: ICollectable): Integer; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - property Value: Boolean read GetValue; - end; - - TCardinalWrapper = class(TAbstractItem, IEquatable, IHashable, IComparable, ICardinal) - private - FValue: Cardinal; - public - constructor Create(Value: Cardinal); - function GetValue: Cardinal; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - function CompareTo(const Item: ICollectable): Integer; - property Value: Cardinal read GetValue; - end; - - TCharWrapper = class(TAbstractItem, IEquatable, IHashable, IComparable, IChar) - private - FValue: Char; - public - constructor Create(Value: Char); - function GetValue: Char; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - function CompareTo(const Item: ICollectable): Integer; - property Value: Char read GetValue; - end; - - TClassWrapper = class(TAbstractItem, IEquatable, IHashable, IClass) - private - FValue: TClass; - public - constructor Create(Value: TClass); - function GetValue: TClass; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - property Value: TClass read GetValue; - end; - - TDoubleWrapper = class(TAbstractItem, IEquatable, IHashable, IComparable, IDouble) - private - FValue: Double; - public - constructor Create(Value: Double); - function GetValue: Double; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - function CompareTo(const Item: ICollectable): Integer; - property Value: Double read GetValue; - end; - - TIntegerWrapper = class(TAbstractItem, IEquatable, IHashable, IComparable, IInteger) - private - FValue: Integer; - public - constructor Create(Value: Integer); - function GetValue: Integer; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - function CompareTo(const Item: ICollectable): Integer; - property Value: Integer read GetValue; - end; - - TIntegerAssociationWrapper = class(TAbstractItem, IEquatable, IIntegerMappable, IIntegerAssociationWrapper) - private - FAutoDestroy: Boolean; - FKey: Integer; - FValue: TObject; - public - constructor Create(const Key: Integer; Value: TObject); overload; - destructor Destroy; override; - function Equals(const Item: ICollectable): Boolean; - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetKey: Integer; - function GetValue: TObject; - property AutoDestroy: Boolean read GetAutoDestroy write SetAutoDestroy; - property Key: Integer read GetKey; - property Value: TObject read GetValue; - end; - - TInterfaceWrapper = class(TAbstractItem, IHashable, IEquatable, IInterfaceWrapper) - private - FValue: IUnknown; - public - constructor Create(const Value: IUnknown); - destructor Destroy; override; - function GetValue: IUnknown; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - property Value: IUnknown read GetValue; - end; - - TObjectWrapper = class(TAbstractItem, IEquatable, IComparable, IHashable, IObject) - private - FAutoDestroy: Boolean; - FValue: TObject; - public - constructor Create(Value: TObject); overload; - destructor Destroy; override; - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetValue: TObject; - function CompareTo(const Item: ICollectable): Integer; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - property AutoDestroy: Boolean read FAutoDestroy write FAutoDestroy; - property Value: TObject read GetValue; - end; - - TStringWrapper = class(TAbstractItem, IEquatable, IHashable, IComparable, IString) - private - FValue: String; - public - constructor Create(Value: String); - function GetValue: String; - function Equals(const Item: ICollectable): Boolean; - function HashCode: Integer; - function CompareTo(const Item: ICollectable): Integer; - property Value: String read FValue; - end; - - TStringAssociationWrapper = class(TAbstractItem, IEquatable, IStringMappable, IStringAssociationWrapper) - private - FAutoDestroy: Boolean; - FKey: String; - FValue: TObject; - public - constructor Create(const Key: String; Value: TObject); overload; - destructor Destroy; override; - function GetAutoDestroy: Boolean; - procedure SetAutoDestroy(Value: Boolean); - function GetKey: String; - function GetValue: TObject; - function Equals(const Item: ICollectable): Boolean; - property AutoDestroy: Boolean read GetAutoDestroy write SetAutoDestroy; - property Key: String read GetKey; - property Value: TObject read GetValue; - end; - -implementation - -{ TAbstractItem } -function TAbstractItem.GetInstance: TObject; -begin - Result := Self; -end; - - -{ TAbstractIntegerMappable } -procedure TAbstractIntegerMappable.AfterConstruction; -begin - inherited AfterConstruction; - FKey := MakeKey; -end; - -function TAbstractIntegerMappable.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self = Item.GetInstance); -end; - -function TAbstractIntegerMappable.GetKey: Integer; -begin - Result := FKey; -end; - -{ TAbstractMappable } -destructor TAbstractMappable.Destroy; -begin - FKey := nil; - inherited Destroy; -end; - -procedure TAbstractMappable.AfterConstruction; -begin - inherited AfterConstruction; - FKey := MakeKey; -end; - -function TAbstractMappable.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self = Item.GetInstance); -end; - -function TAbstractMappable.GetKey: ICollectable; -begin - Result := FKey; -end; - -{ TAbstractStringMappable } -procedure TAbstractStringMappable.AfterConstruction; -begin - inherited AfterConstruction; - FKey := MakeKey; -end; - -function TAbstractStringMappable.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self = Item.GetInstance); -end; - -function TAbstractStringMappable.GetKey: String; -begin - Result := FKey; -end; - -{ TAssociationWrapper } -constructor TAssociationWrapper.Create(const Key: ICollectable; Value: TObject); -begin - inherited Create; - FAutoDestroy := true; - FKey := Key; - FValue := Value; -end; - -constructor TAssociationWrapper.Create(Key: Integer; Value: TObject); -begin - Create(TIntegerWrapper.Create(Key) as ICollectable, Value); -end; - -constructor TAssociationWrapper.Create(Key: String; Value: TObject); -begin - Create(TStringWrapper.Create(Key) as ICollectable, Value); -end; - -constructor TAssociationWrapper.Create(Key, Value: TObject; AutoDestroyKey: Boolean); -var - KeyWrapper: TObjectWrapper; -begin - KeyWrapper := TObjectWrapper.Create(Key); - KeyWrapper.AutoDestroy := AutoDestroyKey; - Create(KeyWrapper as ICollectable, Value); -end; - -destructor TAssociationWrapper.Destroy; -begin - if FAutoDestroy then - FValue.Free; - FKey := nil; - inherited Destroy; -end; - -function TAssociationWrapper.GetAutoDestroy: Boolean; -begin - Result := FAutoDestroy; -end; - -procedure TAssociationWrapper.SetAutoDestroy(Value: Boolean); -begin - FAutoDestroy := Value; -end; - -function TAssociationWrapper.GetKey: ICollectable; -begin - Result := FKey; -end; - -function TAssociationWrapper.GetValue: TObject; -begin - Result := FValue; -end; - -function TAssociationWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TAssociationWrapper).Value) -end; - -{ TCardinalWrapper } -constructor TCardinalWrapper.Create(Value: Cardinal); -begin - inherited Create; - FValue := Value; -end; - -function TCardinalWrapper.GetValue: Cardinal; -begin - Result := FValue; -end; - -function TCardinalWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TCardinalWrapper).Value) -end; - -function TCardinalWrapper.HashCode: Integer; -begin - Result := FValue; -end; - -function TCardinalWrapper.CompareTo(const Item: ICollectable): Integer; -var - Value2: Cardinal; -begin - Value2 := (Item.GetInstance as TCardinalWrapper).Value; - if Value < Value2 then - Result := -1 - else if Value > Value2 then - Result := 1 - else - Result := 0; -end; - -{ TBooleanWrapper } -constructor TBooleanWrapper.Create(Value: Boolean); -begin - inherited Create; - FValue := Value; -end; - -function TBooleanWrapper.GetValue: Boolean; -begin - Result := FValue; -end; - -function TBooleanWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TBooleanWrapper).Value) -end; - -function TBooleanWrapper.HashCode: Integer; -begin - Result := Ord(FValue); -end; - -function TBooleanWrapper.CompareTo(const Item: ICollectable): Integer; -var - Value2: Boolean; -begin - Value2 := (Item.GetInstance as TBooleanWrapper).Value; - if not Value and Value2 then - Result := -1 - else if Value and not Value2 then - Result := 1 - else - Result := 0; -end; - -{ TCharWrapper } -constructor TCharWrapper.Create(Value: Char); -begin - inherited Create; - FValue := Value; -end; - -function TCharWrapper.GetValue: Char; -begin - Result := FValue; -end; - -function TCharWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TCharWrapper).Value) -end; - -function TCharWrapper.HashCode: Integer; -begin - Result := Integer(FValue); -end; - -function TCharWrapper.CompareTo(const Item: ICollectable): Integer; -var - Value2: Char; -begin - Value2 := (Item.GetInstance as TCharWrapper).Value; - if Value < Value2 then - Result := -1 - else if Value > Value2 then - Result := 1 - else - Result := 0; -end; - -{ TClassWrapper } -constructor TClassWrapper.Create(Value: TClass); -begin - inherited Create; - FValue := Value; -end; - -function TClassWrapper.GetValue: TClass; -begin - Result := FValue; -end; - -function TClassWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TClassWrapper).Value) -end; - -function TClassWrapper.HashCode: Integer; -begin - Result := Integer(FValue.ClassInfo); -end; - -{ TDoubleWrapper } -constructor TDoubleWrapper.Create(Value: Double); -begin - inherited Create; - FValue := Value; -end; - -function TDoubleWrapper.GetValue: Double; -begin - Result := FValue; -end; - -function TDoubleWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TDoubleWrapper).Value) -end; - -function TDoubleWrapper.HashCode: Integer; -var - DblAsInt: array[0..1] of Integer; -begin - Double(DblAsInt) := Value; - Result := DblAsInt[0] xor DblAsInt[1]; -end; - -function TDoubleWrapper.CompareTo(const Item: ICollectable): Integer; -var - Value2: Double; -begin - Value2 := (Item.GetInstance as TDoubleWrapper).Value; - if Value < Value2 then - Result := -1 - else if Value > Value2 then - Result := 1 - else - Result := 0; -end; - -{ TIntegerWrapper } -constructor TIntegerWrapper.Create(Value: Integer); -begin - inherited Create; - FValue := Value; -end; - -function TIntegerWrapper.GetValue: Integer; -begin - Result := FValue; -end; - -function TIntegerWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TIntegerWrapper).Value) -end; - -function TIntegerWrapper.HashCode: Integer; -begin - Result := FValue; -end; - -function TIntegerWrapper.CompareTo(const Item: ICollectable): Integer; -var - Value2: Integer; -begin - Value2 := (Item.GetInstance as TIntegerWrapper).Value; - if Value < Value2 then - Result := -1 - else if Value > Value2 then - Result := 1 - else - Result := 0; -end; - -{ TIntegerAssociationWrapper } -constructor TIntegerAssociationWrapper.Create(const Key: Integer; Value: TObject); -begin - inherited Create; - FAutoDestroy := true; - FKey := Key; - FValue := Value; -end; - -destructor TIntegerAssociationWrapper.Destroy; -begin - if FAutoDestroy then - FValue.Free; - inherited Destroy; -end; - -function TIntegerAssociationWrapper.GetAutoDestroy: Boolean; -begin - Result := FAutoDestroy; -end; - -procedure TIntegerAssociationWrapper.SetAutoDestroy(Value: Boolean); -begin - FAutoDestroy := Value; -end; - -function TIntegerAssociationWrapper.GetValue: TObject; -begin - Result := FValue; -end; - -function TIntegerAssociationWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TIntegerAssociationWrapper).Value) -end; - -function TIntegerAssociationWrapper.GetKey: Integer; -begin - Result := FKey; -end; - -{ TStringAssociationWrapper } -constructor TStringAssociationWrapper.Create(const Key: String; Value: TObject); -begin - inherited Create; - FAutoDestroy := true; - FKey := Key; - FValue := Value; -end; - -destructor TStringAssociationWrapper.Destroy; -begin - if FAutoDestroy then - FValue.Free; - inherited Destroy; -end; - -function TStringAssociationWrapper.GetAutoDestroy: Boolean; -begin - Result := FAutoDestroy; -end; - -procedure TStringAssociationWrapper.SetAutoDestroy(Value: Boolean); -begin - FAutoDestroy := Value; -end; - -function TStringAssociationWrapper.GetValue: TObject; -begin - Result := FValue; -end; - -function TStringAssociationWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TStringAssociationWrapper).Value) -end; - -function TStringAssociationWrapper.GetKey: String; -begin - Result := FKey; -end; - -{ TInterfaceWrapper } -constructor TInterfaceWrapper.Create(const Value: IUnknown); -begin - inherited Create; - FValue := Value; -end; - -destructor TInterfaceWrapper.Destroy; -begin - FValue := nil; - inherited Destroy; -end; - -function TInterfaceWrapper.GetValue: IUnknown; -begin - Result := FValue; -end; - -function TInterfaceWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TInterfaceWrapper).Value) -end; - -function TInterfaceWrapper.HashCode: Integer; -begin - Result := Integer(Pointer(FValue)); -end; - -{ TObjectWrapper } -constructor TObjectWrapper.Create(Value: TObject); -begin - inherited Create; - FAutoDestroy := true; - FValue := Value; -end; - -destructor TObjectWrapper.Destroy; -begin - if FAutoDestroy then - FValue.Free; - inherited Destroy; -end; - -function TObjectWrapper.GetAutoDestroy: Boolean; -begin - Result := FAutoDestroy; -end; - -procedure TObjectWrapper.SetAutoDestroy(Value: Boolean); -begin - FAutoDestroy := Value; -end; - -function TObjectWrapper.GetValue: TObject; -begin - Result := FValue; -end; - -function TObjectWrapper.CompareTo(const Item: ICollectable): Integer; -var - Value1, Value2: Integer; -begin - Value1 := Integer(Pointer(Self)); - if Item <> nil then - Value2 := Integer(Pointer(Item)) - else - Value2 := Low(Integer); - if (Value1 < Value2) then - Result := -1 - else if (Value1 > Value2) then - Result := 1 - else - Result := 0; -end; - -function TObjectWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TObjectWrapper).Value) -end; - -function TObjectWrapper.HashCode: Integer; -begin - Result := Integer(Pointer(FValue)); -end; - -{ TStringWrapper } -constructor TStringWrapper.Create(Value: String); -begin - inherited Create; - FValue := Value; -end; - -function TStringWrapper.GetValue: String; -begin - Result := FValue; -end; - -function TStringWrapper.Equals(const Item: ICollectable): Boolean; -begin - Result := (Self.Value = (Item.GetInstance as TStringWrapper).Value) -end; - -function TStringWrapper.HashCode: Integer; -var - I: Integer; -begin - Result := 0; - for I := 1 to Length(FValue) do - Result := (Result shl 1) xor Ord(FValue[I]); -end; - -function TStringWrapper.CompareTo(const Item: ICollectable): Integer; -begin - Result := CompareStr(Self.Value, (Item.GetInstance as TStringWrapper).Value) -end; - - -end. diff --git a/src/lib/collections/Collections.pas b/src/lib/collections/Collections.pas deleted file mode 100644 index 0c94173d..00000000 --- a/src/lib/collections/Collections.pas +++ /dev/null @@ -1,5318 +0,0 @@ -unit Collections; -(***************************************************************************** - * Copyright 2003 by Matthew Greet - * This library is free software; you can redistribute it and/or modify it - * under the terms of the GNU Lesser General Public License as published by the - * Free Software Foundation; either version 2.1 of the License, or (at your - * option) any later version. - * - * This library is distributed in the hope that it will be useful, but WITHOUT - * ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS - * FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public License for more - * details. (http://opensource.org/licenses/lgpl-license.php) - * - * See http://www.warmachine.u-net.com/delphi_collections for updates and downloads. - * - * $Version: v1.0 $ - * $Revision: 1.1.1.4 $ - * $Log: D:\QVCS Repositories\Delphi Collections\Collections.qbt $ - * - * Main unit containing all interface and abstract class definitions. - * - * Revision 1.1.1.4 by: Matthew Greet Rev date: 14/03/05 23:26:32 - * Fixed RemoveAll for TAbstractList for sorted lists. - * - * Revision 1.1.1.3 by: Matthew Greet Rev date: 14/10/04 16:31:18 - * Fixed memory lean in ContainsKey of TAbstractStringMap and - * TAbstractIntegerMap. - * - * Revision 1.1.1.2 by: Matthew Greet Rev date: 12/06/04 20:03:26 - * Capacity property. - * Memory leak fixed. - * - * Revision 1.1.1.1 by: Matthew Greet Rev date: 13/02/04 16:12:10 - * v1.0 branch. - * - * Revision 1.1 by: Matthew Greet Rev date: 06/04/03 10:36:30 - * Added integer map and string map collection types with supporting - * classes. - * Add clone and filter functions with supporting classes. - * Added nil not allowed collection error. - * Properties appear in collection interfaces as well as abstract - * classes. - * - * Revision 1.0 by: Matthew Greet Rev date: 01/03/03 10:50:02 - * Initial revision. - * - * FPC compatibility fixes by: UltraStar Deluxe Team - * - * $Endlog$ - *****************************************************************************) - -{$IFDEF FPC} - {$MODE Delphi}{$H+} -{$ENDIF} - -interface - -uses - Classes, SysUtils; - -const - EquatableIID: TGUID = '{EAC823A7-0B90-11D7-8120-0002E3165EF8}'; - HashableIID: TGUID = '{98998440-4C3E-11D7-8120-0002E3165EF8}'; - ComparableIID: TGUID = '{9F4C96C0-0CF0-11D7-8120-0002E3165EF8}'; - MappableIID: TGUID = '{DAEC8CA0-0DBB-11D7-8120-0002E3165EF8}'; - StringMappableIID: TGUID = '{3CC61F40-5F92-11D7-8120-0002E3165EF8}'; - IntegerMappableIID: TGUID = '{774FC760-5F92-11D7-8120-0002E3165EF8}'; - -type - TDefaultComparator = class; - TNaturalComparator = class; - ICollectable = interface; - - TCollectableArray = array of ICollectable; - TIntegerArray = array of Integer; - TStringArray = array of String; - TListArray = array of TList; - - TCollectionError = (ceOK, ceDuplicate, ceDuplicateKey, ceFixedSize, ceNilNotAllowed, ceNotNaturalItem, ceOutOfRange); - TCollectionErrors = set of TCollectionError; - - TSearchResultType = (srNotFound, srFoundAtIndex, srBeforeIndex, srAfterEnd); - - TCollectionType = (ctBag, ctSet, ctList, ctMap, ctIntegerMap, ctStringMap); - - TCollectionFilterFunc = function (const Item: ICollectable): Boolean of object; - TCollectionCompareFunc = function (const Item1, Item2: ICollectable): Integer of object; - - TSearchResult = record - ResultType: TSearchResultType; - Index: Integer; - end; - - ICollectable = interface - ['{98998441-4C3E-11D7-8120-0002E3165EF8}'] - function GetInstance: TObject; - end; - - IEquatable = interface - ['{EAC823A7-0B90-11D7-8120-0002E3165EF8}'] - function GetInstance: TObject; - function Equals(const Item: ICollectable): Boolean; - end; - - IHashable = interface(IEquatable) - ['{98998440-4C3E-11D7-8120-0002E3165EF8}'] - function HashCode: Integer; - end; - - IComparable = interface(IEquatable) - ['{9F4C96C0-0CF0-11D7-8120-0002E3165EF8}'] - function CompareTo(const Item: ICollectable): Integer; - end; - - IMappable = interface(IEquatable) - ['{DAEC8CA0-0DBB-11D7-8120-0002E3165EF8}'] - function GetKey: ICollectable; - end; - - IStringMappable = interface(IEquatable) - ['{3CC61F40-5F92-11D7-8120-0002E3165EF8}'] - function GetKey: String; - end; - - IIntegerMappable = interface(IEquatable) - ['{774FC760-5F92-11D7-8120-0002E3165EF8}'] - function GetKey: Integer; - end; - - IComparator = interface - ['{1F20CD60-10FE-11D7-8120-0002E3165EF8}'] - function GetInstance: TObject; - function Compare(const Item1, Item2: ICollectable): Integer; - function Equals(const Item1, Item2: ICollectable): Boolean; overload; - function Equals(const Comparator: IComparator): Boolean; overload; - end; - - IFilter = interface - ['{27FE44C0-638E-11D7-8120-0002E3165EF8}'] - function Accept(const Item: ICollectable): Boolean; - end; - - IIterator = interface - ['{F6930500-1113-11D7-8120-0002E3165EF8}'] - function GetAllowRemoval: Boolean; - function CurrentItem: ICollectable; - function EOF: Boolean; - function First: ICollectable; - function Next: ICollectable; - function Remove: Boolean; - end; - - IMapIterator = interface(IIterator) - ['{848CC0E0-2A31-11D7-8120-0002E3165EF8}'] - function CurrentKey: ICollectable; - end; - - IIntegerMapIterator = interface(IIterator) - ['{C7169780-606C-11D7-8120-0002E3165EF8}'] - function CurrentKey: Integer; - end; - - IStringMapIterator = interface(IIterator) - ['{1345ED20-5F93-11D7-8120-0002E3165EF8}'] - function CurrentKey: String; - end; - - IAssociation = interface(ICollectable) - ['{556CD700-4DB3-11D7-8120-0002E3165EF8}'] - function GetKey: ICollectable; - function GetValue: ICollectable; - end; - - IIntegerAssociation = interface(ICollectable) - ['{ED954420-5F94-11D7-8120-0002E3165EF8}'] - function GetKey: Integer; - function GetValue: ICollectable; - end; - - IStringAssociation = interface(ICollectable) - ['{FB87D2A0-5F94-11D7-8120-0002E3165EF8}'] - function GetKey: String; - function GetValue: ICollectable; - end; - - IAssociationComparator = interface(IComparator) - ['{EA9BE6E0-A852-11D8-B93A-0002E3165EF8}'] - function GetKeyComparator: IComparator; - procedure SetKeyComparator(Value: IComparator); - property KeyComparator: IComparator read GetKeyComparator write SetKeyComparator; - end; - - IIntegerAssociationComparator = interface(IComparator) - ['{EA9BE6E1-A852-11D8-B93A-0002E3165EF8}'] - end; - - IStringAssociationComparator = interface(IComparator) - ['{EA9BE6E2-A852-11D8-B93A-0002E3165EF8}'] - end; - - ICollection = interface - ['{EAC823AC-0B90-11D7-8120-0002E3165EF8}'] - function GetAsArray: TCollectableArray; - function GetCapacity: Integer; - procedure SetCapacity(Value: Integer); - function GetComparator: IComparator; - procedure SetComparator(const Value: IComparator); - function GetDuplicates: Boolean; - function GetFixedSize: Boolean; - function GetIgnoreErrors: TCollectionErrors; - procedure SetIgnoreErrors(Value: TCollectionErrors); - function GetInstance: TObject; - function GetIterator: IIterator; overload; - function GetIterator(const Filter: IFilter): IIterator; overload; - function GetIterator(FilterFunc: TCollectionFilterFunc): IIterator; overload; - function GetNaturalItemIID: TGUID; - function GetNaturalItemsOnly: Boolean; - function GetSize: Integer; - function GetType: TCollectionType; - function Add(const Item: ICollectable): Boolean; overload; - function Add(const ItemArray: array of ICollectable): Integer; overload; - function Add(const Collection: ICollection): Integer; overload; - function Clear: Integer; - function Clone: ICollection; - function Contains(const Item: ICollectable): Boolean; overload; - function Contains(const ItemArray: array of ICollectable): Boolean; overload; - function Contains(const Collection: ICollection): Boolean; overload; - function Equals(const Collection: ICollection): Boolean; - function Find(const Filter: IFilter): ICollectable; overload; - function Find(FilterFunc: TCollectionFilterFunc): ICollectable; overload; - function FindAll(const Filter: IFilter = nil): ICollection; overload; - function FindAll(FilterFunc: TCollectionFilterFunc): ICollection; overload; - function IsEmpty: Boolean; - function IsNaturalItem(const Item: ICollectable): Boolean; - function IsNilAllowed: Boolean; - function ItemAllowed(const Item: ICollectable): TCollectionError; - function ItemCount(const Item: ICollectable): Integer; overload; - function ItemCount(const ItemArray: array of ICollectable): Integer; overload; - function ItemCount(const Collection: ICollection): Integer; overload; - function Matching(const ItemArray: array of ICollectable): ICollection; overload; - function Matching(const Collection: ICollection): ICollection; overload; - function Remove(const Item: ICollectable): ICollectable; overload; - function Remove(const ItemArray: array of ICollectable): ICollection; overload; - function Remove(const Collection: ICollection): ICollection; overload; - function RemoveAll(const Item: ICollectable): ICollection; overload; - function RemoveAll(const ItemArray: array of ICollectable): ICollection; overload; - function RemoveAll(const Collection: ICollection): ICollection; overload; - function Retain(const ItemArray: array of ICollectable): ICollection; overload; - function Retain(const Collection: ICollection): ICollection; overload; - property AsArray: TCollectableArray read GetAsArray; - property Capacity: Integer read GetCapacity write SetCapacity; - property Comparator: IComparator read GetComparator write SetComparator; - property FixedSize: Boolean read GetFixedSize; - property IgnoreErrors: TCollectionErrors read GetIgnoreErrors write SetIgnoreErrors; - property NaturalItemIID: TGUID read GetNaturalItemIID; - property NaturalItemsOnly: Boolean read GetNaturalItemsOnly; - property Size: Integer read GetSize; - end; - - IBag = interface(ICollection) - ['{C29C9560-2D59-11D7-8120-0002E3165EF8}'] - function CloneAsBag: IBag; - end; - - ISet = interface(ICollection) - ['{DD7888E2-0BB1-11D7-8120-0002E3165EF8}'] - function CloneAsSet: ISet; - function Complement(const Universe: ISet): ISet; - function Intersect(const Set2: ISet): ISet; - function Union(const Set2: ISet): ISet; - end; - - IList = interface(ICollection) - ['{EE81AB60-0B9F-11D7-8120-0002E3165EF8}'] - function GetDuplicates: Boolean; - procedure SetDuplicates(Value: Boolean); - function GetItem(Index: Integer): ICollectable; - procedure SetItem(Index: Integer; const Item: ICollectable); - function GetSorted: Boolean; - procedure SetSorted(Value: Boolean); - function CloneAsList: IList; - function Delete(Index: Integer): ICollectable; - procedure Exchange(Index1, Index2: Integer); - function First: ICollectable; - function IndexOf(const Item: ICollectable): Integer; - function Insert(Index: Integer; const Item: ICollectable): Boolean; overload; - function Insert(Index: Integer; const ItemArray: array of ICollectable): Integer; overload; - function Insert(Index: Integer; const Collection: ICollection): Integer; overload; - function Last: ICollectable; - procedure Sort(const Comparator: IComparator); overload; - procedure Sort(CompareFunc: TCollectionCompareFunc); overload; - property Duplicates: Boolean read GetDuplicates write SetDuplicates; - property Items[Index: Integer]: ICollectable read GetItem write SetItem; default; - property Sorted: Boolean read GetSorted write SetSorted; - end; - - IMap = interface(ICollection) - ['{AD458280-2A6B-11D7-8120-0002E3165EF8}'] - function GetItem(const Key: ICollectable): ICollectable; - procedure SetItem(const Key, Item: ICollectable); - function GetKeyComparator: IComparator; - procedure SetKeyComparator(const Value: IComparator); - function GetKeyIterator: IIterator; - function GetKeys: ISet; - function GetMapIterator: IMapIterator; - function GetMapIteratorByKey(const Filter: IFilter): IMapIterator; overload; - function GetMapIteratorByKey(FilterFunc: TCollectionFilterFunc): IMapIterator; overload; - function GetNaturalKeyIID: TGUID; - function GetNaturalKeysOnly: Boolean; - function GetValues: ICollection; - function CloneAsMap: IMap; - function ContainsKey(const Key: ICollectable): Boolean; overload; - function ContainsKey(const KeyArray: array of ICollectable): Boolean; overload; - function ContainsKey(const Collection: ICollection): Boolean; overload; - function Get(const Key: ICollectable): ICollectable; - function IsNaturalKey(const Key: ICollectable): Boolean; - function KeyAllowed(const Key: ICollectable): TCollectionError; - function MatchingKey(const KeyArray: array of ICollectable): ICollection; overload; - function MatchingKey(const Collection: ICollection): ICollection; overload; - function Put(const Item: ICollectable): ICollectable; overload; - function Put(const Key, Item: ICollectable): ICollectable; overload; - function Put(const ItemArray: array of ICollectable): ICollection; overload; - function Put(const Collection: ICollection): ICollection; overload; - function Put(const Map: IMap): ICollection; overload; - function RemoveKey(const Key: ICollectable): ICollectable; overload; - function RemoveKey(const KeyArray: array of ICollectable): ICollection; overload; - function RemoveKey(const Collection: ICollection): ICollection; overload; - function RetainKey(const KeyArray: array of ICollectable): ICollection; overload; - function RetainKey(const Collection: ICollection): ICollection; overload; - property KeyComparator: IComparator read GetKeyComparator write SetKeyComparator; - property Items[const Key: ICollectable]: ICollectable read GetItem write SetItem; default; - property NaturalKeyIID: TGUID read GetNaturalKeyIID; - property NaturalKeysOnly: Boolean read GetNaturalKeysOnly; - end; - - IIntegerMap = interface(ICollection) - ['{93DBA9A0-606C-11D7-8120-0002E3165EF8}'] - function GetItem(const Key: Integer): ICollectable; - procedure SetItem(const Key: Integer; const Item: ICollectable); - function GetKeys: ISet; - function GetMapIterator: IIntegerMapIterator; - function GetValues: ICollection; - function CloneAsIntegerMap: IIntegerMap; - function ContainsKey(const Key: Integer): Boolean; overload; - function ContainsKey(const KeyArray: array of Integer): Boolean; overload; - function Get(const Key: Integer): ICollectable; - function Put(const Item: ICollectable): ICollectable; overload; - function Put(const Key: Integer; const Item: ICollectable): ICollectable; overload; - function Put(const ItemArray: array of ICollectable): ICollection; overload; - function Put(const Collection: ICollection): ICollection; overload; - function Put(const Map: IIntegerMap): ICollection; overload; - function RemoveKey(const Key: Integer): ICollectable; overload; - function RemoveKey(const KeyArray: array of Integer): ICollection; overload; - function RetainKey(const KeyArray: array of Integer): ICollection; overload; - property Items[const Key: Integer]: ICollectable read GetItem write SetItem; default; - end; - - IStringMap = interface(ICollection) - ['{20531A20-5F92-11D7-8120-0002E3165EF8}'] - function GetItem(const Key: String): ICollectable; - procedure SetItem(const Key: String; const Item: ICollectable); - function GetKeys: ISet; - function GetMapIterator: IStringMapIterator; - function GetValues: ICollection; - function CloneAsStringMap: IStringMap; - function ContainsKey(const Key: String): Boolean; overload; - function ContainsKey(const KeyArray: array of String): Boolean; overload; - function Get(const Key: String): ICollectable; - function Put(const Item: ICollectable): ICollectable; overload; - function Put(const Key: String; const Item: ICollectable): ICollectable; overload; - function Put(const ItemArray: array of ICollectable): ICollection; overload; - function Put(const Collection: ICollection): ICollection; overload; - function Put(const Map: IStringMap): ICollection; overload; - function RemoveKey(const Key: String): ICollectable; overload; - function RemoveKey(const KeyArray: array of String): ICollection; overload; - function RetainKey(const KeyArray: array of String): ICollection; overload; - property Items[const Key: String]: ICollectable read GetItem write SetItem; default; - end; - - TCollectionPosition = class - private - FFound: Boolean; - public - constructor Create(Found: Boolean); - property Found: Boolean read FFound; - end; - - TAbstractComparator = class(TInterfacedObject, IComparator) - public - class function GetDefaultComparator: IComparator; - class function GetNaturalComparator: IComparator; - class function GetReverseNaturalComparator: IComparator; - function GetInstance: TObject; - function Compare(const Item1, Item2: ICollectable): Integer; virtual; abstract; - function Equals(const Item1, Item2: ICollectable): Boolean; overload; virtual; abstract; - function Equals(const Comparator: IComparator): Boolean; overload; virtual; - end; - - TDefaultComparator = class(TAbstractComparator) - protected - constructor Create; - public - function Compare(const Item1, Item2: ICollectable): Integer; override; - function Equals(const Item1, Item2: ICollectable): Boolean; override; - end; - - TNaturalComparator = class(TAbstractComparator) - protected - constructor Create; - public - function Compare(const Item1, Item2: ICollectable): Integer; override; - function Equals(const Item1, Item2: ICollectable): Boolean; override; - end; - - TReverseNaturalComparator = class(TAbstractComparator) - protected - constructor Create; - public - function Compare(const Item1, Item2: ICollectable): Integer; override; - function Equals(const Item1, Item2: ICollectable): Boolean; override; - end; - - TAssociation = class(TInterfacedObject, ICollectable, IAssociation) - private - FKey: ICollectable; - FValue: ICollectable; - public - constructor Create(const Key, Value: ICollectable); virtual; - destructor Destroy; override; - function GetInstance: TObject; virtual; - function GetKey: ICollectable; - function GetValue: ICollectable; - end; - - TIntegerAssociation = class(TInterfacedObject, ICollectable, IIntegerAssociation) - private - FKey: Integer; - FValue: ICollectable; - public - constructor Create(const Key: Integer; const Value: ICollectable); virtual; - destructor Destroy; override; - function GetInstance: TObject; virtual; - function GetKey: Integer; - function GetValue: ICollectable; - end; - - TStringAssociation = class(TInterfacedObject, ICollectable, IStringAssociation) - private - FKey: String; - FValue: ICollectable; - public - constructor Create(const Key: String; const Value: ICollectable); virtual; - destructor Destroy; override; - function GetInstance: TObject; virtual; - function GetKey: String; - function GetValue: ICollectable; - end; - - TAssociationComparator = class(TAbstractComparator, IAssociationComparator) - private - FKeyComparator: IComparator; - public - constructor Create(NaturalKeys: Boolean = false); - destructor Destroy; override; - function GetKeyComparator: IComparator; - procedure SetKeyComparator(Value: IComparator); - function Compare(const Item1, Item2: ICollectable): Integer; override; - function Equals(const Item1, Item2: ICollectable): Boolean; override; - property KeyComparator: IComparator read GetKeyComparator write SetKeyComparator; - end; - - TIntegerAssociationComparator = class(TAbstractComparator, IIntegerAssociationComparator) - public - constructor Create; - destructor Destroy; override; - function Compare(const Item1, Item2: ICollectable): Integer; override; - function Equals(const Item1, Item2: ICollectable): Boolean; override; - end; - - TStringAssociationComparator = class(TAbstractComparator, IStringAssociationComparator) - public - constructor Create; - destructor Destroy; override; - function Compare(const Item1, Item2: ICollectable): Integer; override; - function Equals(const Item1, Item2: ICollectable): Boolean; override; - end; - - - - TAbstractCollection = class(TInterfacedObject, ICollection) - private - FCreated: Boolean; // Required to avoid passing destroyed object reference to exception - FComparator: IComparator; - FIgnoreErrors: TCollectionErrors; - FNaturalItemsOnly: Boolean; - protected - procedure CollectionError(ErrorType: TCollectionError); - procedure InitFrom(const Collection: ICollection); overload; virtual; - function TrueAdd(const Item: ICollectable): Boolean; virtual; abstract; - procedure TrueClear; virtual; abstract; - function TrueContains(const Item: ICollectable): Boolean; virtual; abstract; - function TrueItemCount(const Item: ICollectable): Integer; virtual; - function TrueRemove(const Item: ICollectable): ICollectable; virtual; abstract; - function TrueRemoveAll(const Item: ICollectable): ICollection; virtual; abstract; - public - constructor Create; overload; virtual; - constructor Create(NaturalItemsOnly: Boolean); overload; virtual; - constructor Create(const ItemArray: array of ICollectable); overload; virtual; - constructor Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; virtual; - constructor Create(const Collection: ICollection); overload; virtual; - destructor Destroy; override; - class function GetAlwaysNaturalItems: Boolean; virtual; - function GetAsArray: TCollectableArray; virtual; - function GetCapacity: Integer; virtual; abstract; - procedure SetCapacity(Value: Integer); virtual; abstract; - function GetComparator: IComparator; virtual; - procedure SetComparator(const Value: IComparator); virtual; - function GetDuplicates: Boolean; virtual; - function GetFixedSize: Boolean; virtual; - function GetIgnoreErrors: TCollectionErrors; - procedure SetIgnoreErrors(Value: TCollectionErrors); - function GetInstance: TObject; - function GetIterator: IIterator; overload; virtual; abstract; - function GetIterator(const Filter: IFilter): IIterator; overload; virtual; - function GetIterator(FilterFunc: TCollectionFilterFunc): IIterator; overload; virtual; - function GetNaturalItemIID: TGUID; virtual; abstract; - function GetNaturalItemsOnly: Boolean; virtual; - function GetSize: Integer; virtual; abstract; - function GetType: TCollectionType; virtual; abstract; - function Add(const Item: ICollectable): Boolean; overload; virtual; - function Add(const ItemArray: array of ICollectable): Integer; overload; virtual; - function Add(const Collection: ICollection): Integer; overload; virtual; - procedure AfterConstruction; override; - procedure BeforeDestruction; override; - function Clear: Integer; virtual; - function Clone: ICollection; virtual; - function Contains(const Item: ICollectable): Boolean; overload; virtual; - function Contains(const ItemArray: array of ICollectable): Boolean; overload; virtual; - function Contains(const Collection: ICollection): Boolean; overload; virtual; - function Equals(const Collection: ICollection): Boolean; virtual; - function Find(const Filter: IFilter): ICollectable; overload; virtual; - function Find(FilterFunc: TCollectionFilterFunc): ICollectable; overload; virtual; - function FindAll(const Filter: IFilter): ICollection; overload; virtual; - function FindAll(FilterFunc: TCollectionFilterFunc): ICollection; overload; virtual; - function IsEmpty: Boolean; virtual; - function IsNaturalItem(const Item: ICollectable): Boolean; virtual; - function IsNilAllowed: Boolean; virtual; abstract; - function ItemAllowed(const Item: ICollectable): TCollectionError; virtual; - function ItemCount(const Item: ICollectable): Integer; overload; virtual; - function ItemCount(const ItemArray: array of ICollectable): Integer; overload; virtual; - function ItemCount(const Collection: ICollection): Integer; overload; virtual; - function Matching(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function Matching(const Collection: ICollection): ICollection; overload; virtual; - function Remove(const Item: ICollectable): ICollectable; overload; virtual; - function Remove(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function Remove(const Collection: ICollection): ICollection; overload; virtual; - function RemoveAll(const Item: ICollectable): ICollection; overload; virtual; - function RemoveAll(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function RemoveAll(const Collection: ICollection): ICollection; overload; virtual; - function Retain(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function Retain(const Collection: ICollection): ICollection; overload; virtual; - property AsArray: TCollectableArray read GetAsArray; - property Capacity: Integer read GetCapacity write SetCapacity; - property Comparator: IComparator read GetComparator write SetComparator; - property FixedSize: Boolean read GetFixedSize; - property IgnoreErrors: TCollectionErrors read GetIgnoreErrors write SetIgnoreErrors; - property NaturalItemIID: TGUID read GetNaturalItemIID; - property NaturalItemsOnly: Boolean read GetNaturalItemsOnly; - property Size: Integer read GetSize; - end; - - TAbstractBag = class(TAbstractCollection, IBag) - public - function CloneAsBag: IBag; virtual; - function GetNaturalItemIID: TGUID; override; - function GetType: TCollectionType; override; - function IsNilAllowed: Boolean; override; - end; - - TAbstractSet = class (TAbstractCollection, ISet) - protected - function GetPosition(const Item: ICollectable): TCollectionPosition; virtual; abstract; - function TrueAdd(const Item: ICollectable): Boolean; override; - procedure TrueAdd2(Position: TCollectionPosition; const Item: ICollectable); virtual; abstract; - function TrueContains(const Item: ICollectable): Boolean; override; - function TrueGet(Position: TCollectionPosition): ICollectable; virtual; abstract; - function TrueRemove(const Item: ICollectable): ICollectable; override; - procedure TrueRemove2(Position: TCollectionPosition); virtual; abstract; - function TrueRemoveAll(const Item: ICollectable): ICollection; override; - public - function GetDuplicates: Boolean; override; - function GetNaturalItemIID: TGUID; override; - function GetType: TCollectionType; override; - function CloneAsSet: ISet; virtual; - function Complement(const Universe: ISet): ISet; overload; virtual; - function Intersect(const Set2: ISet): ISet; overload; virtual; - function IsNilAllowed: Boolean; override; - function Union(const Set2: ISet): ISet; overload; virtual; - end; - - TAbstractList = class(TAbstractCollection, IList) - private - FDuplicates: Boolean; - FSorted: Boolean; - protected - function BinarySearch(const Item: ICollectable): TSearchResult; virtual; - procedure InitFrom(const Collection: ICollection); override; - procedure QuickSort(Lo, Hi: Integer; const Comparator: IComparator); overload; virtual; - procedure QuickSort(Lo, Hi: Integer; CompareFunc: TCollectionCompareFunc); overload; virtual; - function SequentialSearch(const Item: ICollectable; const SearchComparator: IComparator = nil): TSearchResult; virtual; - function TrueContains(const Item: ICollectable): Boolean; override; - function TrueGetItem(Index: Integer): ICollectable; virtual; abstract; - procedure TrueSetItem(Index: Integer; const Item: ICollectable); virtual; abstract; - function TrueAdd(const Item: ICollectable): Boolean; override; - procedure TrueAppend(const Item: ICollectable); virtual; abstract; - function TrueDelete(Index: Integer): ICollectable; virtual; abstract; - procedure TrueInsert(Index: Integer; const Item: ICollectable); virtual; abstract; - function TrueItemCount(const Item: ICollectable): Integer; override; - function TrueRemove(const Item: ICollectable): ICollectable; override; - function TrueRemoveAll(const Item: ICollectable): ICollection; override; - public - constructor Create(NaturalItemsOnly: Boolean); override; - function GetDuplicates: Boolean; override; - procedure SetDuplicates(Value: Boolean); virtual; - function GetItem(Index: Integer): ICollectable; virtual; - procedure SetItem(Index: Integer; const Item: ICollectable); virtual; - function GetIterator: IIterator; override; - function GetNaturalItemIID: TGUID; override; - function GetSorted: Boolean; virtual; - procedure SetSorted(Value: Boolean); virtual; - function GetType: TCollectionType; override; - function CloneAsList: IList; virtual; - function Delete(Index: Integer): ICollectable; virtual; - procedure Exchange(Index1, Index2: Integer); virtual; - function First: ICollectable; virtual; - function IndexOf(const Item: ICollectable): Integer; virtual; - function Insert(Index: Integer; const Item: ICollectable): Boolean; overload; virtual; - function Insert(Index: Integer; const ItemArray: array of ICollectable): Integer; overload; virtual; - function Insert(Index: Integer; const Collection: ICollection): Integer; overload; virtual; - function IsNilAllowed: Boolean; override; - function Last: ICollectable; virtual; - function Search(const Item: ICollectable; const SearchComparator: IComparator = nil): TSearchResult; virtual; - procedure Sort(const SortComparator: IComparator = nil); overload; virtual; - procedure Sort(CompareFunc: TCollectionCompareFunc); overload; virtual; - property Duplicates: Boolean read GetDuplicates write SetDuplicates; - property Items[Index: Integer]: ICollectable read GetItem write SetItem; default; - property Sorted: Boolean read GetSorted write SetSorted; - end; - - TAbstractMap = class(TAbstractCollection, IMap) - private - FAssociationComparator: IAssociationComparator; - FKeyComparator: IComparator; - FNaturalKeysOnly: Boolean; - protected - function GetAssociationIterator: IMapIterator; virtual; abstract; - function GetKeyPosition(const Key: ICollectable): TCollectionPosition; virtual; abstract; - procedure InitFrom(const Collection: ICollection); override; - function TrueAdd(const Item: ICollectable): Boolean; override; - function TrueContains(const Item: ICollectable): Boolean; override; - function TrueGet(Position: TCollectionPosition): IAssociation; virtual; abstract; - function TruePut(Position: TCollectionPosition; const Association: IAssociation): IAssociation; virtual; abstract; - function TrueRemove(const Item: ICollectable): ICollectable; override; - function TrueRemove2(Position: TCollectionPosition): IAssociation; virtual; abstract; - function TrueRemoveAll(const Item: ICollectable): ICollection; override; - property AssociationComparator: IAssociationComparator read FAssociationComparator; - public - constructor Create; override; - constructor Create(NaturalItemsOnly: Boolean); override; - constructor Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); overload; virtual; - constructor Create(const ItemArray: array of ICollectable); overload; override; - constructor Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; override; - constructor Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); overload; virtual; - constructor Create(const KeyArray, ItemArray: array of ICollectable); overload; virtual; - constructor Create(const KeyArray, ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; virtual; - constructor Create(const KeyArray, ItemArray: array of ICollectable; NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); overload; virtual; -// Don't use this parameter signature as it hits a compiler bug in D5. -// constructor Create(const KeyArray, ItemArray: TCollectableArray; NaturalItemsOnly: Boolean = false; NaturalKeysOnly: Boolean = true); overload; virtual; - constructor Create(const Map: IMap); overload; virtual; - destructor Destroy; override; - class function GetAlwaysNaturalKeys: Boolean; virtual; - function GetItem(const Key: ICollectable): ICollectable; virtual; - procedure SetItem(const Key, Item: ICollectable); virtual; - function GetIterator: IIterator; override; - function GetKeyComparator: IComparator; virtual; - procedure SetKeyComparator(const Value: IComparator); virtual; - function GetKeyIterator: IIterator; virtual; - function GetKeys: ISet; virtual; - function GetMapIterator: IMapIterator; virtual; - function GetMapIteratorByKey(const Filter: IFilter): IMapIterator; overload; virtual; - function GetMapIteratorByKey(FilterFunc: TCollectionFilterFunc): IMapIterator; overload; virtual; - function GetNaturalItemIID: TGUID; override; - function GetNaturalKeyIID: TGUID; virtual; - function GetNaturalKeysOnly: Boolean; virtual; - function GetType: TCollectionType; override; - function GetValues: ICollection; virtual; - function Clone: ICollection; override; - function CloneAsMap: IMap; virtual; - function ContainsKey(const Key: ICollectable): Boolean; overload; virtual; - function ContainsKey(const KeyArray: array of ICollectable): Boolean; overload; virtual; - function ContainsKey(const Collection: ICollection): Boolean; overload; virtual; - function Get(const Key: ICollectable): ICollectable; virtual; - function KeyAllowed(const Key: ICollectable): TCollectionError; virtual; - function IsNaturalKey(const Key: ICollectable): Boolean; virtual; - function IsNilAllowed: Boolean; override; - function MatchingKey(const KeyArray: array of ICollectable): ICollection; overload; virtual; - function MatchingKey(const Collection: ICollection): ICollection; overload; virtual; - function Put(const Item: ICollectable): ICollectable; overload; virtual; - function Put(const Key, Item: ICollectable): ICollectable; overload; virtual; - function Put(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function Put(const Collection: ICollection): ICollection; overload; virtual; - function Put(const Map: IMap): ICollection; overload; virtual; - function RemoveKey(const Key: ICollectable): ICollectable; overload; virtual; - function RemoveKey(const KeyArray: array of ICollectable): ICollection; overload; virtual; - function RemoveKey(const Collection: ICollection): ICollection; overload; virtual; - function RetainKey(const KeyArray: array of ICollectable): ICollection; overload; virtual; - function RetainKey(const Collection: ICollection): ICollection; overload; virtual; - property KeyComparator: IComparator read GetKeyComparator write SetKeyComparator; - property Items[const Key: ICollectable]: ICollectable read GetItem write SetItem; default; - property NaturalKeyIID: TGUID read GetNaturalKeyIID; - property NaturalKeysOnly: Boolean read GetNaturalKeysOnly; - end; - - TAbstractIntegerMap = class(TAbstractCollection, IIntegerMap) - private - FAssociationComparator: IIntegerAssociationComparator; - protected - function GetAssociationIterator: IIntegerMapIterator; virtual; abstract; - function GetKeyPosition(const Key: Integer): TCollectionPosition; virtual; abstract; - function TrueAdd(const Item: ICollectable): Boolean; override; - function TrueContains(const Item: ICollectable): Boolean; override; - function TrueGet(Position: TCollectionPosition): IIntegerAssociation; virtual; abstract; - function TruePut(Position: TCollectionPosition; const Association: IIntegerAssociation): IIntegerAssociation; virtual; abstract; - function TrueRemove(const Item: ICollectable): ICollectable; override; - function TrueRemove2(Position: TCollectionPosition): IIntegerAssociation; virtual; abstract; - function TrueRemoveAll(const Item: ICollectable): ICollection; override; - property AssociationComparator: IIntegerAssociationComparator read FAssociationComparator; - public - constructor Create(NaturalItemsOnly: Boolean); override; - constructor Create(const ItemArray: array of ICollectable); overload; override; - constructor Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; override; - constructor Create(const KeyArray: array of Integer; const ItemArray: array of ICollectable); overload; virtual; - constructor Create(const KeyArray: array of Integer; const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; virtual; - constructor Create(const Map: IIntegerMap); overload; virtual; - destructor Destroy; override; - function GetItem(const Key: Integer): ICollectable; virtual; - procedure SetItem(const Key: Integer; const Item: ICollectable); virtual; - function GetIterator: IIterator; override; - function GetKeys: ISet; virtual; - function GetMapIterator: IIntegerMapIterator; virtual; - function GetNaturalItemIID: TGUID; override; - function GetType: TCollectionType; override; - function GetValues: ICollection; virtual; - function Clone: ICollection; override; - function CloneAsIntegerMap: IIntegerMap; virtual; - function ContainsKey(const Key: Integer): Boolean; overload; virtual; - function ContainsKey(const KeyArray: array of Integer): Boolean; overload; virtual; - function Get(const Key: Integer): ICollectable; virtual; - function IsNilAllowed: Boolean; override; - function Put(const Item: ICollectable): ICollectable; overload; virtual; - function Put(const Key: Integer; const Item: ICollectable): ICollectable; overload; virtual; - function Put(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function Put(const Collection: ICollection): ICollection; overload; virtual; - function Put(const Map: IIntegerMap): ICollection; overload; virtual; - function RemoveKey(const Key: Integer): ICollectable; overload; virtual; - function RemoveKey(const KeyArray: array of Integer): ICollection; overload; virtual; - function RetainKey(const KeyArray: array of Integer): ICollection; overload; virtual; - property Items[const Key: Integer]: ICollectable read GetItem write SetItem; default; - end; - - TAbstractStringMap = class(TAbstractCollection, IStringMap) - private - FAssociationComparator: IStringAssociationComparator; - protected - function GetAssociationIterator: IStringMapIterator; virtual; abstract; - function GetKeyPosition(const Key: String): TCollectionPosition; virtual; abstract; - function TrueAdd(const Item: ICollectable): Boolean; override; - function TrueContains(const Item: ICollectable): Boolean; override; - function TrueGet(Position: TCollectionPosition): IStringAssociation; virtual; abstract; - function TruePut(Position: TCollectionPosition; const Association: IStringAssociation): IStringAssociation; virtual; abstract; - function TrueRemove(const Item: ICollectable): ICollectable; override; - function TrueRemove2(Position: TCollectionPosition): IStringAssociation; virtual; abstract; - function TrueRemoveAll(const Item: ICollectable): ICollection; override; - property AssociationComparator: IStringAssociationComparator read FAssociationComparator; - public - constructor Create(NaturalItemsOnly: Boolean); override; - constructor Create(const ItemArray: array of ICollectable); overload; override; - constructor Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; override; - constructor Create(const KeyArray: array of String; const ItemArray: array of ICollectable); overload; virtual; - constructor Create(const KeyArray: array of String; const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); overload; virtual; - constructor Create(const Map: IStringMap); overload; virtual; - destructor Destroy; override; - function GetItem(const Key: String): ICollectable; virtual; - procedure SetItem(const Key: String; const Item: ICollectable); virtual; - function GetIterator: IIterator; override; - function GetKeys: ISet; virtual; - function GetMapIterator: IStringMapIterator; virtual; - function GetNaturalItemIID: TGUID; override; - function GetType: TCollectionType; override; - function GetValues: ICollection; virtual; - function Clone: ICollection; override; - function CloneAsStringMap: IStringMap; virtual; - function ContainsKey(const Key: String): Boolean; overload; virtual; - function ContainsKey(const KeyArray: array of String): Boolean; overload; virtual; - function Get(const Key: String): ICollectable; virtual; - function IsNilAllowed: Boolean; override; - function Put(const Item: ICollectable): ICollectable; overload; virtual; - function Put(const Key: String; const Item: ICollectable): ICollectable; overload; virtual; - function Put(const ItemArray: array of ICollectable): ICollection; overload; virtual; - function Put(const Collection: ICollection): ICollection; overload; virtual; - function Put(const Map: IStringMap): ICollection; overload; virtual; - function RemoveKey(const Key: String): ICollectable; overload; virtual; - function RemoveKey(const KeyArray: array of String): ICollection; overload; virtual; - function RetainKey(const KeyArray: array of String): ICollection; overload; virtual; - property Items[const Key: String]: ICollectable read GetItem write SetItem; default; - end; - - TAbstractCollectionClass = class of TAbstractCollection; - TAbstractBagClass = class of TAbstractBag; - TAbstractSetClass = class of TAbstractSet; - TAbstractListClass = class of TAbstractList; - TAbstractMapClass = class of TAbstractMap; - TAbstractIntegerMapClass = class of TAbstractIntegerMap; - TAbstractStringMapClass = class of TAbstractStringMap; - - TAbstractIterator = class(TInterfacedObject, IIterator) - private - FAllowRemoval: Boolean; - FEOF: Boolean; - FItem: ICollectable; - protected - constructor Create(AllowRemoval: Boolean = true); - function TrueFirst: ICollectable; virtual; abstract; - function TrueNext: ICollectable; virtual; abstract; - procedure TrueRemove; virtual; abstract; - public - procedure AfterConstruction; override; - function GetAllowRemoval: Boolean; virtual; - function CurrentItem: ICollectable; virtual; - function EOF: Boolean; virtual; - function First: ICollectable; virtual; - function Next: ICollectable; virtual; - function Remove: Boolean; virtual; - property AllowRemoval: Boolean read GetAllowRemoval; - end; - - TAbstractListIterator = class(TAbstractIterator) - private - FCollection: TAbstractList; - FIndex: Integer; - protected - constructor Create(Collection: TAbstractList); - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - end; - - TAbstractMapIterator = class(TAbstractIterator, IMapIterator) - public - function CurrentKey: ICollectable; virtual; abstract; - end; - - TAbstractAssociationIterator = class(TInterfacedObject, IIterator, IMapIterator) - private - FAllowRemoval: Boolean; - FEOF: Boolean; - FAssociation: IAssociation; - protected - constructor Create(AllowRemoval: Boolean = true); - function TrueFirst: IAssociation; virtual; abstract; - function TrueNext: IAssociation; virtual; abstract; - procedure TrueRemove; virtual; abstract; - public - procedure AfterConstruction; override; - function GetAllowRemoval: Boolean; virtual; - function CurrentKey: ICollectable; virtual; - function CurrentItem: ICollectable; virtual; - function EOF: Boolean; virtual; - function First: ICollectable; virtual; - function Next: ICollectable; virtual; - function Remove: Boolean; virtual; - property AllowRemoval: Boolean read GetAllowRemoval; - end; - - TAbstractIntegerAssociationIterator = class(TInterfacedObject, IIterator, IIntegerMapIterator) - private - FAllowRemoval: Boolean; - FEOF: Boolean; - FAssociation: IIntegerAssociation; - protected - constructor Create(AllowRemoval: Boolean = true); - function TrueFirst: IIntegerAssociation; virtual; abstract; - function TrueNext: IIntegerAssociation; virtual; abstract; - procedure TrueRemove; virtual; abstract; - public - procedure AfterConstruction; override; - function GetAllowRemoval: Boolean; virtual; - function CurrentKey: Integer; virtual; - function CurrentItem: ICollectable; virtual; - function EOF: Boolean; virtual; - function First: ICollectable; virtual; - function Next: ICollectable; virtual; - function Remove: Boolean; virtual; - property AllowRemoval: Boolean read GetAllowRemoval; - end; - - TAbstractStringAssociationIterator = class(TInterfacedObject, IIterator, IStringMapIterator) - private - FAllowRemoval: Boolean; - FEOF: Boolean; - FAssociation: IStringAssociation; - protected - constructor Create(AllowRemoval: Boolean = true); - function TrueFirst: IStringAssociation; virtual; abstract; - function TrueNext: IStringAssociation; virtual; abstract; - procedure TrueRemove; virtual; abstract; - public - procedure AfterConstruction; override; - function GetAllowRemoval: Boolean; virtual; - function CurrentKey: String; virtual; - function CurrentItem: ICollectable; virtual; - function EOF: Boolean; virtual; - function First: ICollectable; virtual; - function Next: ICollectable; virtual; - function Remove: Boolean; virtual; - property AllowRemoval: Boolean read GetAllowRemoval; - end; - - TAssociationIterator = class(TAbstractIterator, IMapIterator) - private - FIterator: IIterator; - protected - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - public - constructor Create(const Iterator: IIterator); - destructor Destroy; override; - function CurrentItem: ICollectable; override; - function CurrentKey: ICollectable; virtual; - end; - - TAssociationKeyIterator = class(TAbstractIterator) - private - FIterator: IMapIterator; - protected - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - public - constructor Create(const Iterator: IMapIterator); - destructor Destroy; override; - end; - - TAbstractFilter = class(TInterfacedObject, IFilter) - public - function Accept(const Item: ICollectable): Boolean; virtual; abstract; - end; - - TFilterIterator = class(TAbstractIterator) - private - FIterator: IIterator; - FFilter: IFilter; - protected - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - public - constructor Create(const Iterator: IIterator; const Filter: IFilter; AllowRemoval: Boolean = true); virtual; - destructor Destroy; override; - end; - - TFilterFuncIterator = class(TAbstractIterator) - private - FIterator: IIterator; - FFilterFunc: TCollectionFilterFunc; - protected - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - public - constructor Create(const Iterator: IIterator; FilterFunc: TCollectionFilterFunc; AllowRemoval: Boolean = true); virtual; - destructor Destroy; override; - end; - - TKeyFilterMapIterator = class(TAbstractMapIterator) - private - FIterator: IMapIterator; - FFilter: IFilter; - protected - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - public - constructor Create(const Iterator: IMapIterator; const Filter: IFilter; AllowRemoval: Boolean = true); virtual; - destructor Destroy; override; - function CurrentKey: ICollectable; override; - end; - - TKeyFilterFuncMapIterator = class(TAbstractMapIterator) - private - FIterator: IMapIterator; - FFilterFunc: TCollectionFilterFunc; - protected - function TrueFirst: ICollectable; override; - function TrueNext: ICollectable; override; - procedure TrueRemove; override; - public - constructor Create(const Iterator: IMapIterator; FilterFunc: TCollectionFilterFunc; AllowRemoval: Boolean = true); virtual; - destructor Destroy; override; - function CurrentKey: ICollectable; override; - end; - - - ECollectionError = class(Exception) - private - FCollection: ICollection; - FErrorType: TCollectionError; - public - constructor Create(const Msg: String; const Collection: ICollection; ErrorType: TCollectionError); - property Collection: ICollection read FCollection; - property ErrorType: TCollectionError read FErrorType; - end; - -implementation - -uses - Math, - CollArray, CollHash, CollList, CollPArray, CollWrappers; - -var - FDefaultComparator: IComparator; - FNaturalComparator: IComparator; - FReverseNaturalComparator: IComparator; - -{ TCollectionPosition } -constructor TCollectionPosition.Create(Found: Boolean); -begin - FFound := Found; -end; - -{ TAbstractComparator } -class function TAbstractComparator.GetDefaultComparator: IComparator; -begin - if FDefaultComparator = nil then - FDefaultComparator := TDefaultComparator.Create; - Result := FDefaultComparator; -end; - -class function TAbstractComparator.GetNaturalComparator: IComparator; -begin - if FNaturalComparator = nil then - FNaturalComparator := TNaturalComparator.Create; - Result := FNaturalComparator; -end; - -class function TAbstractComparator.GetReverseNaturalComparator: IComparator; -begin - if FReverseNaturalComparator = nil then - FReverseNaturalComparator := TReverseNaturalComparator.Create; - Result := FReverseNaturalComparator; -end; - -function TAbstractComparator.GetInstance: TObject; -begin - Result := Self; -end; - -function TAbstractComparator.Equals(const Comparator: IComparator): Boolean; -begin - Result := (Self = Comparator.GetInstance); -end; - -{ TDefaultComparator } -constructor TDefaultComparator.Create; -begin - // Empty -end; - -function TDefaultComparator.Compare(const Item1, Item2: ICollectable): Integer; -var - Value1, Value2: Integer; -begin - if Item1 <> nil then - Value1 := Integer(Pointer(Item1)) - else - Value1 := Low(Integer); - if Item2 <> nil then - Value2 := Integer(Pointer(Item2)) - else - Value2 := Low(Integer); - if (Value1 < Value2) then - Result := -1 - else if (Value1 > Value2) then - Result := 1 - else - Result := 0; -end; - -function TDefaultComparator.Equals(const Item1, Item2: ICollectable): Boolean; -begin - Result := (Item1 = Item2); -end; - -{ TNaturalComparator } -constructor TNaturalComparator.Create; -begin - // Empty -end; - -function TNaturalComparator.Compare(const Item1, Item2: ICollectable): Integer; -begin - if (Item1 = nil) and (Item2 <> nil) then - Result := -1 - else if (Item1 <> nil) and (Item2 = nil) then - Result := 1 - else if (Item1 = nil) and (Item2 = nil) then - Result := 0 - else - Result := (Item1 as IComparable).CompareTo(Item2); -end; - -function TNaturalComparator.Equals(const Item1, Item2: ICollectable): Boolean; -begin - if (Item1 = nil) or (Item2 = nil) then - Result := (Item1 = Item2) - else - begin - Result := (Item1 as IEquatable).Equals(Item2); - end; -end; - -{ TReverseNaturalComparator } -constructor TReverseNaturalComparator.Create; -begin - // Empty -end; - -function TReverseNaturalComparator.Compare(const Item1, Item2: ICollectable): Integer; -begin - if (Item1 = nil) and (Item2 <> nil) then - Result := 1 - else if (Item1 <> nil) and (Item2 = nil) then - Result := -1 - else if (Item1 = nil) and (Item2 = nil) then - Result := 0 - else - Result := -(Item1 as IComparable).CompareTo(Item2); -end; - -function TReverseNaturalComparator.Equals(const Item1, Item2: ICollectable): Boolean; -begin - if (Item1 = nil) or (Item2 = nil) then - Result := (Item1 = Item2) - else - Result := (Item1 as IEquatable).Equals(Item2); -end; - -{ TAssociation } -constructor TAssociation.Create(const Key, Value: ICollectable); -begin - FKey := Key; - FValue := Value; -end; - -destructor TAssociation.Destroy; -begin - FKey := nil; - FValue := nil; - inherited Destroy; -end; - -function TAssociation.GetInstance: TObject; -begin - Result := Self; -end; - -function TAssociation.GetKey: ICollectable; -begin - Result := FKey; -end; - -function TAssociation.GetValue: ICollectable; -begin - Result := FValue; -end; - - -{ TIntegerAssociation } -constructor TIntegerAssociation.Create(const Key: Integer; const Value: ICollectable); -begin - FKey := Key; - FValue := Value; -end; - -destructor TIntegerAssociation.Destroy; -begin - FValue := nil; - inherited Destroy; -end; - -function TIntegerAssociation.GetInstance: TObject; -begin - Result := Self; -end; - -function TIntegerAssociation.GetKey: Integer; -begin - Result := FKey; -end; - -function TIntegerAssociation.GetValue: ICollectable; -begin - Result := FValue; -end; - - -{ TStringAssociation } -constructor TStringAssociation.Create(const Key: String; const Value: ICollectable); -begin - FKey := Key; - FValue := Value; -end; - -destructor TStringAssociation.Destroy; -begin - FValue := nil; - inherited Destroy; -end; - -function TStringAssociation.GetInstance: TObject; -begin - Result := Self; -end; - -function TStringAssociation.GetKey: String; -begin - Result := FKey; -end; - -function TStringAssociation.GetValue: ICollectable; -begin - Result := FValue; -end; - - -{ TAbstractIterator } -constructor TAbstractIterator.Create(AllowRemoval: Boolean); -begin - inherited Create; - FAllowRemoval := AllowRemoval; - FEOF := true; - FItem := nil; -end; - -procedure TAbstractIterator.AfterConstruction; -begin - inherited AfterConstruction; - First; -end; - -function TAbstractIterator.GetAllowRemoval: Boolean; -begin - Result := FAllowRemoval; -end; - -function TAbstractIterator.CurrentItem: ICollectable; -begin - Result := FItem; -end; - -function TAbstractIterator.EOF: Boolean; -begin - Result := FEOF; -end; - -function TAbstractIterator.First: ICollectable; -begin - FEOF := false; - FItem := TrueFirst; - if FItem = nil then - FEOF := true; - Result := FItem; -end; - -function TAbstractIterator.Next: ICollectable; -begin - if not FEOF then - begin - FItem := TrueNext; - if FItem = nil then - FEOF := true; - end; - Result := FItem; -end; - -function TAbstractIterator.Remove: Boolean; -begin - if (FItem <> nil) and FAllowRemoval then - begin - TrueRemove; - FItem := nil; - Result := true; - end - else - Result := false; -end; - -{ TAbstractAssociationIterator } -constructor TAbstractAssociationIterator.Create(AllowRemoval: Boolean); -begin - inherited Create; - FAllowRemoval := AllowRemoval; - FEOF := true; - FAssociation := nil; -end; - -procedure TAbstractAssociationIterator.AfterConstruction; -begin - inherited AfterConstruction; - First; -end; - -function TAbstractAssociationIterator.GetAllowRemoval: Boolean; -begin - Result := FAllowRemoval; -end; - -function TAbstractAssociationIterator.CurrentKey: ICollectable; -begin - if FAssociation <> nil then - Result := FAssociation.GetKey - else - Result := nil; -end; - -function TAbstractAssociationIterator.CurrentItem: ICollectable; -begin - if FAssociation <> nil then - Result := FAssociation.GetValue - else - Result := nil; -end; - -function TAbstractAssociationIterator.EOF: Boolean; -begin - Result := FEOF; -end; - -function TAbstractAssociationIterator.First: ICollectable; -begin - FAssociation := TrueFirst; - if FAssociation <> nil then - begin - Result := FAssociation.GetValue; - FEOF := false; - end - else - begin - Result := nil; - FEOF := true; - end; -end; - -function TAbstractAssociationIterator.Next: ICollectable; -begin - if not FEOF then - begin - FAssociation := TrueNext; - if FAssociation <> nil then - Result := FAssociation.GetValue - else - begin - Result := nil; - FEOF := true; - end; - end; -end; - -function TAbstractAssociationIterator.Remove: Boolean; -begin - if (FAssociation <> nil) and FAllowRemoval then - begin - TrueRemove; - FAssociation := nil; - Result := true; - end - else - Result := false; -end; - -{ TAbstractIntegerAssociationIterator } -constructor TAbstractIntegerAssociationIterator.Create(AllowRemoval: Boolean); -begin - inherited Create; - FAllowRemoval := AllowRemoval; - FEOF := true; - FAssociation := nil; -end; - -procedure TAbstractIntegerAssociationIterator.AfterConstruction; -begin - inherited AfterConstruction; - First; -end; - -function TAbstractIntegerAssociationIterator.GetAllowRemoval: Boolean; -begin - Result := FAllowRemoval; -end; - -function TAbstractIntegerAssociationIterator.CurrentKey: Integer; -begin - if FAssociation <> nil then - Result := FAssociation.GetKey - else - Result := 0; -end; - -function TAbstractIntegerAssociationIterator.CurrentItem: ICollectable; -begin - if FAssociation <> nil then - Result := FAssociation.GetValue - else - Result := nil; -end; - -function TAbstractIntegerAssociationIterator.EOF: Boolean; -begin - Result := FEOF; -end; - -function TAbstractIntegerAssociationIterator.First: ICollectable; -begin - FAssociation := TrueFirst; - if FAssociation <> nil then - begin - Result := FAssociation.GetValue; - FEOF := false; - end - else - begin - Result := nil; - FEOF := true; - end; -end; - -function TAbstractIntegerAssociationIterator.Next: ICollectable; -begin - if not FEOF then - begin - FAssociation := TrueNext; - if FAssociation <> nil then - Result := FAssociation.GetValue - else - begin - Result := nil; - FEOF := true; - end; - end; -end; - -function TAbstractIntegerAssociationIterator.Remove: Boolean; -begin - if (FAssociation <> nil) and FAllowRemoval then - begin - TrueRemove; - FAssociation := nil; - Result := true; - end - else - Result := false; -end; - -{ TAbstractStringAssociationIterator } -constructor TAbstractStringAssociationIterator.Create(AllowRemoval: Boolean); -begin - inherited Create; - FAllowRemoval := AllowRemoval; - FEOF := true; - FAssociation := nil; -end; - -procedure TAbstractStringAssociationIterator.AfterConstruction; -begin - inherited AfterConstruction; - First; -end; - -function TAbstractStringAssociationIterator.GetAllowRemoval: Boolean; -begin - Result := FAllowRemoval; -end; - -function TAbstractStringAssociationIterator.CurrentKey: String; -begin - if FAssociation <> nil then - Result := FAssociation.GetKey - else - Result := ''; -end; - -function TAbstractStringAssociationIterator.CurrentItem: ICollectable; -begin - if FAssociation <> nil then - Result := FAssociation.GetValue - else - Result := nil; -end; - -function TAbstractStringAssociationIterator.EOF: Boolean; -begin - Result := FEOF; -end; - -function TAbstractStringAssociationIterator.First: ICollectable; -begin - FAssociation := TrueFirst; - if FAssociation <> nil then - begin - Result := FAssociation.GetValue; - FEOF := false; - end - else - begin - Result := nil; - FEOF := true; - end; -end; - -function TAbstractStringAssociationIterator.Next: ICollectable; -begin - if not FEOF then - begin - FAssociation := TrueNext; - if FAssociation <> nil then - Result := FAssociation.GetValue - else - begin - Result := nil; - FEOF := true; - end; - end; -end; - -function TAbstractStringAssociationIterator.Remove: Boolean; -begin - if (FAssociation <> nil) and FAllowRemoval then - begin - TrueRemove; - FAssociation := nil; - Result := true; - end - else - Result := false; -end; - -{ TAssociationIterator } -constructor TAssociationIterator.Create(const Iterator: IIterator); -begin - inherited Create(Iterator.GetAllowRemoval); - FIterator := Iterator; -end; - -destructor TAssociationIterator.Destroy; -begin - FIterator := nil; - inherited Destroy; -end; - -function TAssociationIterator.TrueFirst: ICollectable; -var - Association: IAssociation; -begin - Association := FIterator.First as IAssociation; - if Association <> nil then - Result := Association.GetValue - else - Result := nil; -end; - -function TAssociationIterator.TrueNext: ICollectable; -var - Association: IAssociation; -begin - Association := (FIterator.Next as IAssociation); - if Association <> nil then - Result := Association.GetValue - else - Result := nil; -end; - -procedure TAssociationIterator.TrueRemove; -begin - FIterator.Remove; -end; - -function TAssociationIterator.CurrentItem: ICollectable; -var - Association: IAssociation; -begin - Association := FIterator.CurrentItem as IAssociation; - if Association <> nil then - Result := Association.GetValue - else - Result := nil; -end; - -function TAssociationIterator.CurrentKey: ICollectable; -var - Association: IAssociation; -begin - Association := FIterator.CurrentItem as IAssociation; - if Association <> nil then - Result := Association.GetKey - else - Result := nil; -end; - -{ TAssociationComparator } -constructor TAssociationComparator.Create(NaturalKeys: Boolean); -begin - inherited Create; - if NaturalKeys then - FKeyComparator := TAbstractComparator.GetNaturalComparator - else - FKeyComparator := TAbstractComparator.GetDefaultComparator; -end; - -destructor TAssociationComparator.Destroy; -begin - FKeyComparator := nil; - inherited Destroy; -end; - -function TAssociationComparator.GetKeyComparator: IComparator; -begin - Result := FKeyComparator; -end; - -procedure TAssociationComparator.SetKeyComparator(Value: IComparator); -begin - FKeyComparator := Value; -end; - -function TAssociationComparator.Compare(const Item1, Item2: ICollectable): Integer; -begin - Result := KeyComparator.Compare((Item1 as IAssociation).GetKey, (Item2 as IAssociation).GetKey); -end; - -function TAssociationComparator.Equals(const Item1, Item2: ICollectable): Boolean; -begin - Result := KeyComparator.Equals((Item1 as IAssociation).GetKey, (Item2 as IAssociation).GetKey); -end; - -{ TIntegerAssociationComparator } -constructor TIntegerAssociationComparator.Create; -begin - inherited Create; -end; - -destructor TIntegerAssociationComparator.Destroy; -begin - inherited Destroy; -end; - -function TIntegerAssociationComparator.Compare(const Item1, Item2: ICollectable): Integer; -var - Key1, Key2: Integer; -begin - Key1 := (Item1 as IIntegerAssociation).GetKey; - Key2 := (Item2 as IIntegerAssociation).GetKey; - if Key1 < Key2 then - Result := -1 - else if Key1 > Key2 then - Result := 1 - else - Result := 0; -end; - -function TIntegerAssociationComparator.Equals(const Item1, Item2: ICollectable): Boolean; -begin - Result := ((Item1 as IIntegerAssociation).GetKey = (Item2 as IIntegerAssociation).GetKey); -end; - -{ TStringAssociationComparator } -constructor TStringAssociationComparator.Create; -begin - inherited Create; -end; - -destructor TStringAssociationComparator.Destroy; -begin - inherited Destroy; -end; - -function TStringAssociationComparator.Compare(const Item1, Item2: ICollectable): Integer; -var - Key1, Key2: String; -begin - Key1 := (Item1 as IStringAssociation).GetKey; - Key2 := (Item2 as IStringAssociation).GetKey; - if Key1 < Key2 then - Result := -1 - else if Key1 > Key2 then - Result := 1 - else - Result := 0; -end; - -function TStringAssociationComparator.Equals(const Item1, Item2: ICollectable): Boolean; -begin - Result := ((Item1 as IStringAssociation).GetKey = (Item2 as IStringAssociation).GetKey); -end; - -{ TAssociationKeyIterator } -constructor TAssociationKeyIterator.Create(const Iterator: IMapIterator); -begin - inherited Create(Iterator.GetAllowRemoval); - FIterator := Iterator; -end; - -destructor TAssociationKeyIterator.Destroy; -begin - FIterator := nil; - inherited Destroy; -end; - -function TAssociationKeyIterator.TrueFirst: ICollectable; -begin - FIterator.First; - Result := FIterator.CurrentKey; -end; - -function TAssociationKeyIterator.TrueNext: ICollectable; -begin - FIterator.Next; - Result := FIterator.CurrentKey; -end; - -procedure TAssociationKeyIterator.TrueRemove; -begin - FIterator.Remove; -end; - -{ TFilterIterator } -constructor TFilterIterator.Create(const Iterator: IIterator; const Filter: IFilter; AllowRemoval: Boolean = true); -begin - FIterator := Iterator; - FFilter := Filter; -end; - -destructor TFilterIterator.Destroy; -begin - FIterator := nil; - FFilter := nil; -end; - -function TFilterIterator.TrueFirst: ICollectable; -var - Item: ICollectable; -begin - Item := FIterator.First; - while not FIterator.EOF do - begin - if FFilter.Accept(Item) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -function TFilterIterator.TrueNext: ICollectable; -var - Item: ICollectable; -begin - Item := FIterator.Next; - while not FIterator.EOF do - begin - if FFilter.Accept(Item) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -procedure TFilterIterator.TrueRemove; -begin - FIterator.Remove; -end; - -{ TFilterFuncIterator } -constructor TFilterFuncIterator.Create(const Iterator: IIterator; FilterFunc: TCollectionFilterFunc; AllowRemoval: Boolean = true); -begin - FIterator := Iterator; - FFilterFunc := FilterFunc; -end; - -destructor TFilterFuncIterator.Destroy; -begin - FIterator := nil; - FFilterFunc := nil; -end; - -function TFilterFuncIterator.TrueFirst: ICollectable; -var - Item: ICollectable; -begin - Item := FIterator.First; - while not FIterator.EOF do - begin - if FFilterFunc(Item) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -function TFilterFuncIterator.TrueNext: ICollectable; -var - Item: ICollectable; -begin - Item := FIterator.Next; - while not FIterator.EOF do - begin - if FFilterFunc(Item) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -procedure TFilterFuncIterator.TrueRemove; -begin - FIterator.Remove; -end; - -{ TKeyFilterMapIterator } -constructor TKeyFilterMapIterator.Create(const Iterator: IMapIterator; const Filter: IFilter; AllowRemoval: Boolean = true); -begin - FIterator := Iterator; - FFilter := Filter; -end; - -destructor TKeyFilterMapIterator.Destroy; -begin - FIterator := nil; - FFilter := nil; -end; - -function TKeyFilterMapIterator.TrueFirst: ICollectable; -var - Key, Item: ICollectable; -begin - Item := FIterator.First; - while not FIterator.EOF do - begin - Key := FIterator.CurrentKey; - if FFilter.Accept(Key) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -function TKeyFilterMapIterator.TrueNext: ICollectable; -var - Key, Item: ICollectable; -begin - Item := FIterator.Next; - while not FIterator.EOF do - begin - Key := FIterator.CurrentKey; - if FFilter.Accept(Key) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -procedure TKeyFilterMapIterator.TrueRemove; -begin - FIterator.Remove; -end; - -function TKeyFilterMapIterator.CurrentKey: ICollectable; -begin - Result := FIterator.CurrentKey; -end; - -{ TKeyFilterFuncMapIterator } -constructor TKeyFilterFuncMapIterator.Create(const Iterator: IMapIterator; FilterFunc: TCollectionFilterFunc; AllowRemoval: Boolean = true); -begin - FIterator := Iterator; - FFilterFunc := FilterFunc; -end; - -destructor TKeyFilterFuncMapIterator.Destroy; -begin - FIterator := nil; - FFilterFunc := nil; -end; - -function TKeyFilterFuncMapIterator.TrueFirst: ICollectable; -var - Key, Item: ICollectable; -begin - Item := FIterator.First; - while not FIterator.EOF do - begin - Key := FIterator.CurrentKey; - if FFilterFunc(Key) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -function TKeyFilterFuncMapIterator.TrueNext: ICollectable; -var - Key, Item: ICollectable; -begin - Item := FIterator.Next; - while not FIterator.EOF do - begin - Key := FIterator.CurrentKey; - if FFilterFunc(Key) then - break - else - Item := FIterator.Next; - end; - Result := Item; -end; - -procedure TKeyFilterFuncMapIterator.TrueRemove; -begin - FIterator.Remove; -end; - -function TKeyFilterFuncMapIterator.CurrentKey: ICollectable; -begin - Result := FIterator.CurrentKey; -end; - - -{ TAbstractCollection } -constructor TAbstractCollection.Create; -begin - Create(false); -end; - -constructor TAbstractCollection.Create(NaturalItemsOnly: Boolean); -begin - FCreated := false; - inherited Create; - FNaturalItemsOnly := NaturalItemsOnly or GetAlwaysNaturalItems; - if FNaturalItemsOnly then - FComparator := TAbstractComparator.GetNaturalComparator - else - FComparator := TAbstractComparator.GetDefaultComparator; - FIgnoreErrors := [ceDuplicate]; -end; - -constructor TAbstractCollection.Create(const ItemArray: array of ICollectable); -begin - Create(ItemArray, false); -end; - -// Fixed size collections must override this. -constructor TAbstractCollection.Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -var - I: Integer; -begin - Create(NaturalItemsOnly); - if not FixedSize then - begin - Capacity := Length(ItemArray); - for I := Low(ItemArray) to High(ItemArray) do - begin - Add(ItemArray[I]); - end; - end; -end; - -// Fixed size collections must override this. -constructor TAbstractCollection.Create(const Collection: ICollection); -var - Iterator: IIterator; -begin - Create(Collection.GetNaturalItemsOnly); - InitFrom(Collection); - if not FixedSize then - begin - Capacity := Collection.GetSize; - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Add(Iterator.CurrentItem); - Iterator.Next; - end; - end; -end; - -destructor TAbstractCollection.Destroy; -begin - FCreated := false; - FComparator := nil; - inherited Destroy; -end; - -procedure TAbstractCollection.CollectionError(ErrorType: TCollectionError); -var - Msg: String; -begin - if not (ErrorType in FIgnoreErrors) then - begin - case ErrorType of - ceDuplicate: Msg := 'Collection does not allow duplicates.'; - ceDuplicateKey: Msg := 'Collection does not allow duplicate keys.'; - ceFixedSize: Msg := 'Collection has fixed size.'; - ceNilNotAllowed: Msg := 'Collection does not allow nil.'; - ceNotNaturalItem: Msg := 'Collection only accepts natural items.'; - ceOutOfRange: Msg := 'Index out of collection range.'; - end; - // If exception is thrown during construction, collection cannot be - // passed to it as destructor is automatically called and this leaves an - // interface reference to a destroyed object and crashes. - if FCreated then - raise ECollectionError.Create(Msg, Self, ErrorType) - else - raise ECollectionError.Create(Msg, nil, ErrorType); - end; -end; - -procedure TAbstractCollection.InitFrom(const Collection: ICollection); -begin - Comparator := Collection.GetComparator; - IgnoreErrors := Collection.GetIgnoreErrors; -end; - -// Implementations should override this if possible -function TAbstractCollection.TrueItemCount(const Item: ICollectable): Integer; -var - Iterator: IIterator; - Total: Integer; -begin - Total := 0; - Iterator := GetIterator; - while not Iterator.EOF do - begin - if FComparator.Equals(Item, Iterator.CurrentItem) then - Inc(Total); - Iterator.Next; - end; - Result := Total; -end; - -class function TAbstractCollection.GetAlwaysNaturalItems: Boolean; -begin - Result := false; -end; - -function TAbstractCollection.GetAsArray: TCollectableArray; -var - Iterator: IIterator; - Working: TCollectableArray; - I: Integer; -begin - SetLength(Working, Size); - I := 0; - Iterator := GetIterator; - while not Iterator.EOF do - begin - Working[I] := Iterator.CurrentItem; - Inc(I); - Iterator.Next; - end; - Result := Working; -end; - -function TAbstractCollection.GetComparator: IComparator; -begin - Result := FComparator; -end; - -function TAbstractCollection.GetDuplicates: Boolean; -begin - Result := true; // Sets and lists override this. -end; - -procedure TAbstractCollection.SetComparator(const Value: IComparator); -begin - if Value = nil then - begin - if NaturalItemsOnly then - FComparator := TAbstractComparator.GetNaturalComparator - else - FComparator := TAbstractComparator.GetDefaultComparator; - end - else - FComparator := Value; -end; - -function TAbstractCollection.GetFixedSize: Boolean; -begin - Result := false; -end; - -function TAbstractCollection.GetIgnoreErrors: TCollectionErrors; -begin - Result := FIgnoreErrors; -end; - -procedure TAbstractCollection.SetIgnoreErrors(Value: TCollectionErrors); -begin - FIgnoreErrors := Value; -end; - -function TAbstractCollection.GetInstance: TObject; -begin - Result := Self; -end; - -function TAbstractCollection.GetIterator(const Filter: IFilter): IIterator; -var - Iterator: IIterator; -begin - Iterator := GetIterator; - Result := TFilterIterator.Create(Iterator, Filter, Iterator.GetAllowRemoval); -end; - -function TAbstractCollection.GetIterator(FilterFunc: TCollectionFilterFunc): IIterator; -var - Iterator: IIterator; -begin - Iterator := GetIterator; - Result := TFilterFuncIterator.Create(Iterator, FilterFunc, Iterator.GetAllowRemoval); -end; - -function TAbstractCollection.GetNaturalItemsOnly: Boolean; -begin - Result := FNaturalItemsOnly; -end; - -function TAbstractCollection.Add(const Item: ICollectable): Boolean; -var - ItemError: TCollectionError; - Success: Boolean; -begin - ItemError := ItemAllowed(Item); // Can be natural items only error or nil not allowed error - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Success := false; - end - else if FixedSize then - begin - CollectionError(ceFixedSize); - Success := false; - end - else - begin - Success := TrueAdd(Item); - end; - Result := Success; -end; - -function TAbstractCollection.Add(const ItemArray: array of ICollectable): Integer; -var - Item: ICollectable; - ItemError: TCollectionError; - I, Count: Integer; - Success: Boolean; -begin - Count := 0; - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else - begin - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := ItemArray[I]; - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Success := false; - end - else - begin - Success := TrueAdd(Item); - end; - if Success then - Inc(Count); - end; - end; - Result := Count; -end; - -function TAbstractCollection.Add(const Collection: ICollection): Integer; -var - Iterator: IIterator; - Item: ICollectable; - ItemError: TCollectionError; - Count: Integer; - Success: Boolean; -begin - Count := 0; - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem; - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Success := false; - end - else if FixedSize then - begin - CollectionError(ceFixedSize); - Success := false; - end - else - begin - Success := TrueAdd(Item); - end; - if Success then - Inc(Count); - Iterator.Next; - end; - Result := Count; -end; - -procedure TAbstractCollection.AfterConstruction; -begin - inherited AfterConstruction; - FCreated := true; -end; - -procedure TAbstractCollection.BeforeDestruction; -begin - if not FixedSize then - TrueClear; - inherited BeforeDestruction; -end; - -function TAbstractCollection.Clear: Integer; -begin - if not FixedSize then - begin - Result := Size; - TrueClear; - end - else - begin - CollectionError(ceFixedSize); - Result := 0; - end; -end; - -function TAbstractCollection.Clone: ICollection; -begin - Result := (TAbstractCollectionClass(ClassType)).Create(Self); -end; - -function TAbstractCollection.Contains(const Item: ICollectable): Boolean; -var - ItemError: TCollectionError; - Success: Boolean; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Success := false; - end - else - begin - Success := TrueContains(Item); - end; - Result := Success; -end; - -function TAbstractCollection.Contains(const ItemArray: array of ICollectable): Boolean; -var - I: Integer; - Success: Boolean; -begin - Success := true; - for I := Low(ItemArray) to High(ItemArray) do - begin - Success := Success and Contains(ItemArray[I]); - if not Success then - break; - end; - Result := Success; -end; - -function TAbstractCollection.Contains(const Collection: ICollection): Boolean; -var - Iterator: IIterator; - Success: Boolean; -begin - Success := true; - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Success := Success and Contains(Iterator.CurrentItem); - if not Success then - break; - Iterator.Next; - end; - Result := Success; -end; - -function TAbstractCollection.Equals(const Collection: ICollection): Boolean; -var - Iterator: IIterator; - Success: Boolean; -begin - if Collection.GetType <> GetType then - Result := false - else if Collection.Size <> Size then - Result := false - else if not Collection.Comparator.Equals(Comparator) then - Result := false - else if not Collection.GetDuplicates and not GetDuplicates then - begin - // Not equal if any item not found in parameter collection - Success := true; - Iterator := GetIterator; - while not Iterator.EOF and Success do - begin - Success := Collection.Contains(Iterator.CurrentItem); - Iterator.Next; - end; - Result := Success; - end - else - begin - // Not equal if any item count not equal to item count in parameter collection - Success := true; - Iterator := GetIterator; - while not Iterator.EOF and Success do - begin - Success := (ItemCount(Iterator.CurrentItem) = Collection.ItemCount(Iterator.CurrentItem)); - Iterator.Next; - end; - Result := Success; - end; -end; - -function TAbstractCollection.Find(const Filter: IFilter): ICollectable; -begin - Result := GetIterator(Filter).First; -end; - -function TAbstractCollection.Find(FilterFunc: TCollectionFilterFunc): ICollectable; -begin - Result := GetIterator(FilterFunc).First; -end; - -function TAbstractCollection.FindAll(const Filter: IFilter): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Self.GetIterator(Filter); - while not Iterator.EOF do - begin - ResultCollection.Add(Iterator.CurrentItem); - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractCollection.FindAll(FilterFunc: TCollectionFilterFunc): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Self.GetIterator(FilterFunc); - while not Iterator.EOF do - begin - ResultCollection.Add(Iterator.CurrentItem); - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractCollection.IsEmpty: Boolean; -begin - Result := (Size = 0); -end; - -function TAbstractCollection.IsNaturalItem(const Item: ICollectable): Boolean; -var - Temp: IUnknown; -begin - if Item <> nil then - Result := (Item.QueryInterface(NaturalItemIID, Temp) <> E_NOINTERFACE) - else - Result := false; -end; - -function TAbstractCollection.ItemAllowed(const Item: ICollectable): TCollectionError; -begin - if NaturalItemsOnly and not IsNaturalItem(Item) then - Result := ceNotNaturalItem - else if not IsNilAllowed and (Item = nil) then - Result := ceNilNotAllowed - else - Result := ceOK; -end; - -function TAbstractCollection.ItemCount(const Item: ICollectable): Integer; -var - ItemError: TCollectionError; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := 0; - end - else if GetDuplicates then - begin - Result := TrueItemCount(Item); - end - else - begin - // Where duplicates are not allowed, TrueContains will be faster than TrueItemCount. - if TrueContains(Item) then - Result := 1 - else - Result := 0; - end; -end; - -function TAbstractCollection.ItemCount(const ItemArray: array of ICollectable): Integer; -var - I: Integer; - Total: Integer; -begin - Total := 0; - for I := Low(ItemArray) to High(ItemArray) do - begin - Total := Total + ItemCount(ItemArray[I]); - end; - Result := Total; -end; - -function TAbstractCollection.ItemCount(const Collection: ICollection): Integer; -var - Iterator: IIterator; - Total: Integer; -begin - Total := 0; - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Total := Total + ItemCount(Iterator.CurrentItem); - Iterator.Next; - end; - Result := Total; -end; - -function TAbstractCollection.Matching(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(ItemArray) to High(ItemArray) do - begin - if Contains(ItemArray[I]) then - ResultCollection.Add(ItemArray[I]); - end; - Result := ResultCollection; -end; - -function TAbstractCollection.Matching(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - if Contains(Iterator.CurrentItem) then - ResultCollection.Add(Iterator.CurrentItem); - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractCollection.Remove(const Item: ICollectable): ICollectable; -var - ItemError: TCollectionError; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := nil; - end - else if FixedSize then - begin - CollectionError(ceFixedSize); - Result := nil; - end - else - begin - Result := TrueRemove(Item); - end; -end; - -function TAbstractCollection.Remove(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(ItemArray) to High(ItemArray) do - begin - ResultCollection.Add(Remove(ItemArray[I])); - end; - Result := ResultCollection; -end; - -function TAbstractCollection.Remove(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - ResultCollection.Add(Remove(Iterator.CurrentItem)); - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractCollection.RemoveAll(const Item: ICollectable): ICollection; -var - ItemError: TCollectionError; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := nil; - end - else if FixedSize then - begin - CollectionError(ceFixedSize); - Result := nil; - end - else - begin - Result := TrueRemoveAll(Item); - end; -end; - -function TAbstractCollection.RemoveAll(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(ItemArray) to High(ItemArray) do - begin - ResultCollection.Add(RemoveAll(ItemArray[I])); - end; - Result := ResultCollection; -end; - -function TAbstractCollection.RemoveAll(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - ResultCollection.Add(RemoveAll(Iterator.CurrentItem)); - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractCollection.Retain(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; - Item: ICollectable; - I: Integer; - Found, Success: Boolean; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := GetIterator; - while not Iterator.EOF do - begin - // Converting the array to a map would be faster but I don't want to - // couple base class code to a complex collection. - Found := false; - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := Iterator.CurrentItem; - Found := Comparator.Equals(Item, ItemArray[I]); - if Found then - break; - end; - if not Found then - begin - Success := Iterator.Remove; - if Success then - ResultCollection.Add(Item); - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractCollection.Retain(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; - Item: ICollectable; - Success: Boolean; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem; - if not Collection.Contains(Item) then - begin - Success := Iterator.Remove; - if Success then - ResultCollection.Add(Item); - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -{ TAbstractBag } -function TAbstractBag.CloneAsBag: IBag; -begin - Result := (TAbstractBagClass(ClassType)).Create(Self); -end; - -function TAbstractBag.GetNaturalItemIID: TGUID; -begin - Result := EquatableIID; -end; - -function TAbstractBag.GetType: TCollectionType; -begin - Result := ctBag; -end; - -function TAbstractBag.IsNilAllowed: Boolean; -begin - Result := true; -end; - -{ TAbstractSet } -function TAbstractSet.TrueAdd(const Item: ICollectable): Boolean; -var - Position: TCollectionPosition; -begin - // Adds if not already present otherwise fails - Position := GetPosition(Item); - try - if Position.Found then - begin - CollectionError(ceDuplicate); - Result := false; - end - else - begin - TrueAdd2(Position, Item); - Result := true; - end; - finally - Position.Free; - end; -end; - -function TAbstractSet.TrueContains(const Item: ICollectable): Boolean; -var - Position: TCollectionPosition; -begin - Position := GetPosition(Item); - try - Result := Position.Found; - finally - Position.Free; - end; -end; - -function TAbstractSet.TrueRemove(const Item: ICollectable): ICollectable; -var - Position: TCollectionPosition; -begin - Position := GetPosition(Item); - try - if Position.Found then - begin - Result := TrueGet(Position); - TrueRemove2(Position); - end - else - Result := nil; - finally - Position.Free; - end; -end; - -function TAbstractSet.TrueRemoveAll(const Item: ICollectable): ICollection; -var - ResultCollection: ICollection; - RemovedItem: ICollectable; -begin - ResultCollection := TPArrayBag.Create; - RemovedItem := TrueRemove(Item); - if RemovedItem <> nil then - ResultCollection.Add(RemovedItem); - Result := ResultCollection; -end; - -function TAbstractSet.GetDuplicates: Boolean; -begin - Result := false; -end; - -function TAbstractSet.GetNaturalItemIID: TGUID; -begin - Result := EquatableIID; -end; - -function TAbstractSet.GetType: TCollectionType; -begin - Result := ctSet; -end; - -function TAbstractSet.CloneAsSet: ISet; -begin - Result := (TAbstractSetClass(ClassType)).Create(Self); -end; - -function TAbstractSet.Complement(const Universe: ISet): ISet; -var - ResultSet: ISet; - Iterator: IIterator; - Item: ICollectable; -begin - // Return items in universe not found in self. - ResultSet := TAbstractSetClass(ClassType).Create(NaturalItemsOnly); - Iterator := Universe.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem; - if not Contains(Item) then - ResultSet.Add(Item); - Iterator.Next; - end; - Result := ResultSet; -end; - -function TAbstractSet.Intersect(const Set2: ISet): ISet; -var - ResultSet: ISet; - Iterator: IIterator; - Item: ICollectable; -begin - // Return items found in self and parameter. - ResultSet := TAbstractSetClass(ClassType).Create(NaturalItemsOnly); - Iterator := GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem; - if Contains(Item) and Set2.Contains(Item) then - ResultSet.Add(Iterator.CurrentItem); - Iterator.Next; - end; - Result := ResultSet; -end; - -function TAbstractSet.IsNilAllowed: Boolean; -begin - Result := false; -end; - -function TAbstractSet.Union(const Set2: ISet): ISet; -var - ResultSet: ISet; - Iterator: IIterator; - Item: ICollectable; -begin - // Return items found in self or parameter. - ResultSet := CloneAsSet; - Iterator := Set2.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem; - if not Contains(Item) and Set2.Contains(Item) then - ResultSet.Add(Iterator.CurrentItem); - Iterator.Next; - end; - Result := ResultSet; -end; - -{ TAbstractList } -constructor TAbstractList.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FDuplicates := true; - FSorted := false; -end; - -procedure TAbstractList.InitFrom(const Collection: ICollection); -var - List: IList; -begin - inherited InitFrom(Collection); - if Collection.QueryInterface(IList, List) = S_OK then - begin - FDuplicates := List.GetDuplicates; - FSorted := List.GetSorted; - end; -end; - -function TAbstractList.TrueAdd(const Item: ICollectable): Boolean; -var - SearchResult: TSearchResult; -begin - Result := True; - if Sorted then - begin - // Insert in appropriate place to maintain sort order, unless duplicate - // not allowed. - SearchResult := BinarySearch(Item); - case SearchResult.ResultType of - srBeforeIndex: TrueInsert(SearchResult.Index, Item); - srFoundAtIndex: begin - if Duplicates then - TrueInsert(SearchResult.Index, Item) - else - begin - CollectionError(ceDuplicate); - Result := false; - end; - end; - srAfterEnd: TrueAppend(Item); - end; - end - else - begin - // Add to end, unless duplicate not allowed. - if not Duplicates and (SequentialSearch(Item, Comparator).ResultType = srFoundAtIndex) then - begin - CollectionError(ceDuplicate); - Result := false; - end - else - TrueAppend(Item); - end; -end; - -function TAbstractList.TrueContains(const Item: ICollectable): Boolean; -begin - if Sorted then - Result := BinarySearch(Item).ResultType = srFoundAtIndex - else - Result := SequentialSearch(Item, Comparator).ResultType = srFoundAtIndex -end; - -function TAbstractList.TrueItemCount(const Item: ICollectable): Integer; -var - SearchResult: TSearchResult; - Count: Integer; -begin - if Sorted then - begin - // If sorted, use binary search. - Count := 0; - SearchResult := BinarySearch(Item); - if SearchResult.ResultType = srFoundAtIndex then - begin - repeat - Inc(Count); - until not Comparator.Equals(Item, Items[SearchResult.Index]); - end; - Result := Count; - end - else - // Resort to sequential search for unsorted - Result := inherited TrueItemCount(Item); -end; - -function TAbstractList.TrueRemove(const Item: ICollectable): ICollectable; -var - SearchResult: TSearchResult; -begin - Result := nil; - if Sorted then - begin - SearchResult := BinarySearch(Item); - if SearchResult.ResultType = srFoundAtIndex then - begin - Result := TrueDelete(SearchResult.Index); - end; - end - else - begin - SearchResult := SequentialSearch(Item); - if SearchResult.ResultType = srFoundAtIndex then - Result := TrueDelete(SearchResult.Index); - end; -end; - -function TAbstractList.TrueRemoveAll(const Item: ICollectable): ICollection; -var - ResultCollection: ICollection; - SearchResult: TSearchResult; - I: Integer; -begin - ResultCollection := TPArrayBag.Create; - if Sorted then - begin - SearchResult := BinarySearch(Item); - if SearchResult.ResultType = srFoundAtIndex then - begin - repeat - ResultCollection.Add(TrueDelete(SearchResult.Index)); - until not Comparator.Equals(Item, Items[SearchResult.Index]); - end; - end - else - begin - I := 0; - while I < Size do - begin - if Comparator.Equals(Item, Items[I]) then - begin - ResultCollection.Add(TrueDelete(I)); - end - else - Inc(I); - end; - end; - Result := ResultCollection; -end; - -procedure TAbstractList.QuickSort(Lo, Hi: Integer; const Comparator: IComparator); -var - I, J, Mid: Integer; -begin - repeat - I := Lo; - J := Hi; - Mid := (Lo + Hi) div 2; - repeat - while Comparator.Compare(Items[I], Items[Mid]) < 0 do - Inc(I); - while Comparator.Compare(Items[J], Items[Mid]) > 0 do - Dec(J); - if I <= J then - begin - Exchange(I, J); - if Mid = I then - Mid := J - else if Mid = J then - Mid := I; - Inc(I); - Dec(J); - end; - until I > J; - if Lo < J then - QuickSort(Lo, J, Comparator); - Lo := I; - until I >= Hi; -end; - -procedure TAbstractList.QuickSort(Lo, Hi: Integer; CompareFunc: TCollectionCompareFunc); -var - I, J, Mid: Integer; -begin - repeat - I := Lo; - J := Hi; - Mid := (Lo + Hi) div 2; - repeat - while CompareFunc(Items[I], Items[Mid]) < 0 do - Inc(I); - while CompareFunc(Items[J], Items[Mid]) > 0 do - Dec(J); - if I <= J then - begin - Exchange(I, J); - if Mid = I then - Mid := J - else if Mid = J then - Mid := I; - Inc(I); - Dec(J); - end; - until I > J; - if Lo < J then - QuickSort(Lo, J, CompareFunc); - Lo := I; - until I >= Hi; -end; - -function TAbstractList.GetDuplicates: Boolean; -begin - Result := FDuplicates; -end; - -procedure TAbstractList.SetDuplicates(Value: Boolean); -var - Iterator: IIterator; - Failed: Boolean; -begin - Failed := false; - // If trying to set no duplicates, check there are no existing duplicates. - if not Value then - begin - Iterator := GetIterator; - while not Iterator.EOF and not Failed do - begin - Failed := (ItemCount(Iterator.CurrentItem) > 1); - Iterator.Next; - end; - if Failed then - CollectionError(ceDuplicate); - end; - if not Failed then - FDuplicates := Value; -end; - -function TAbstractList.GetItem(Index: Integer): ICollectable; -begin - if (Index < 0) or (Index >= Size) then - begin - CollectionError(ceOutOfRange); - Result := nil; - end - else - Result := TrueGetItem(Index); -end; - -procedure TAbstractList.SetItem(Index: Integer; const Item: ICollectable); -var - SearchResult: TSearchResult; -begin - if (Index < 0) or (Index >= Size) then - begin - CollectionError(ceOutOfRange) - end - else if not Duplicates then - begin - // Find any duplicates - if Sorted then - begin - SearchResult := BinarySearch(Item); - case SearchResult.ResultType of - srBeforeIndex, srAfterEnd: begin // If item is not present - FSorted := false; - TrueSetItem(Index, Item); - end; - srFoundAtIndex: begin // If item is already present - CollectionError(ceDuplicate); - end; - end; - end - else - begin - // If item is already present - if SequentialSearch(Item, Comparator).ResultType = srFoundAtIndex then - begin - CollectionError(ceDuplicate); - end - else - begin - TrueSetItem(Index, Item); - end; - end; - end - else - begin - FSorted := false; - TrueSetItem(Index, Item); - end; -end; - -function TAbstractList.GetIterator: IIterator; -begin - Result := TAbstractListIterator.Create(Self); -end; - -function TAbstractList.GetNaturalItemIID: TGUID; -begin - Result := ComparableIID; -end; - -function TAbstractList.GetSorted: Boolean; -begin - Result := FSorted; -end; - -procedure TAbstractList.SetSorted(Value: Boolean); -begin - if Value then - Sort; -end; - -function TAbstractList.GetType: TCollectionType; -begin - Result := ctList; -end; - -function TAbstractList.BinarySearch(const Item: ICollectable): TSearchResult; -var - Lo, Hi, Mid: Integer; - CompareResult: Integer; - Success: Boolean; -begin - if Size = 0 then - begin - Result.ResultType := srAfterEnd; - Exit; - end; - Lo := 0; - Hi := Size - 1; - Success := false; - repeat - Mid := (Lo + Hi) div 2; - CompareResult := Comparator.Compare(Item, Items[Mid]); - if CompareResult = 0 then - Success := true - else if CompareResult > 0 then - Lo := Mid + 1 - else - Hi := Mid - 1; - until (Lo > Hi) or Success; - if Success then - begin - // Move index back if in cluster of duplicates - while (Mid > 0) and Comparator.Equals(Item, Items[Mid - 1]) do - Dec(Mid); - Result.ResultType := srFoundAtIndex; - Result.Index := Mid; - end - else if CompareResult < 0 then - begin - Result.ResultType := srBeforeIndex; - Result.Index := Mid; - end - else if Hi < Size - 1 then - begin - Result.ResultType := srBeforeIndex; - Result.Index := Mid + 1; - end - else - Result.ResultType := srAfterEnd; -end; - -function TAbstractList.CloneAsList: IList; -begin - Result := (TAbstractListClass(ClassType)).Create(Self); -end; - -function TAbstractList.Delete(Index: Integer): ICollectable; -begin - if FixedSize then - begin - CollectionError(ceFixedSize); - Result := nil; - end - else if (Index < 0) or (Index >= Size) then - begin - CollectionError(ceOutOfRange); - Result := nil; - end - else - begin - Result := TrueDelete(Index); - end; -end; - -procedure TAbstractList.Exchange(Index1, Index2: Integer); -var - Item: ICollectable; -begin - if (Index1 < 0) or (Index1 >= Size) then - CollectionError(ceOutOfRange); - if (Index2 < 0) or (Index2 >= Size) then - CollectionError(ceOutOfRange); - FSorted := false; - Item := ICollectable(Items[Index1]); - Items[Index1] := Items[Index2]; - Items[Index2] := Item; -end; - -function TAbstractList.First: ICollectable; -begin - if Size > 0 then - Result := Items[0] - else - Result := nil; -end; - -function TAbstractList.IndexOf(const Item: ICollectable): Integer; -var - SearchResult: TSearchResult; -begin - if Sorted then - SearchResult := BinarySearch(Item) - else - SearchResult := SequentialSearch(Item, Comparator); - if SearchResult.ResultType = srFoundAtIndex then - Result := SearchResult.Index - else - Result := -1; -end; - -function TAbstractList.Insert(Index: Integer; const Item: ICollectable): Boolean; -var - ItemError: TCollectionError; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := false; - end - else if FixedSize then - begin - CollectionError(ceFixedSize); - Result := false; - end - else if (Index < 0) or (Index > Size) then - begin - CollectionError(ceOutOfRange); - Result := false; - end - else - begin - FSorted := false; - if Index = Size then - TrueAdd(Item) - else - TrueInsert(Index, Item); - Result := true; - end; -end; - -function TAbstractList.Insert(Index: Integer; const ItemArray: array of ICollectable): Integer; -var - Item: ICollectable; - ItemError: TCollectionError; - I, NewIndex, Count: Integer; - Success: Boolean; -begin - Count := 0; - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else if (Index < 0) or (Index > Size) then - begin - CollectionError(ceOutOfRange); - end - else - begin - // Insert entire array in place in correct order - NewIndex := Index; - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := ItemArray[I]; - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - end - else - begin - Success := Insert(NewIndex, Item); - if Success then - begin - Inc(NewIndex); - Inc(Count); - end; - end; - end; - end; - Result := Count; -end; - -function TAbstractList.Insert(Index: Integer; const Collection: ICollection): Integer; -var - Iterator: IIterator; - Item: ICollectable; - ItemError: TCollectionError; - NewIndex, Count: Integer; - Success: Boolean; -begin - Count := 0; - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else if (Index < 0) or (Index > Size) then - begin - CollectionError(ceOutOfRange); - end - else - begin - // Insert entire collection in place in correct order - NewIndex := Index; - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem; - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - end - else - begin - Success := Insert(NewIndex, Item); - if Success then - begin - Inc(NewIndex); - Inc(Count); - end; - end; - Iterator.Next; - end; - end; - Result := Count; -end; - -function TAbstractList.IsNilAllowed: Boolean; -begin - Result := true; -end; - -function TAbstractList.Last: ICollectable; -begin - if Size > 0 then - Result := Items[Size - 1] - else - Result := nil; -end; - -function TAbstractList.Search(const Item: ICollectable; const SearchComparator: IComparator = nil): TSearchResult; -begin - if Sorted and (SearchComparator = nil) then - Result := BinarySearch(Item) - else - Result := SequentialSearch(Item, SearchComparator); -end; - -function TAbstractList.SequentialSearch(const Item: ICollectable; const SearchComparator: IComparator): TSearchResult; -var - WorkingComparator: IComparator; - I: Integer; - Success: Boolean; -begin - if SearchComparator = nil then - WorkingComparator := Comparator - else - WorkingComparator := SearchComparator; - Result.ResultType := srNotFound; - I := 0; - Success := false; - while (I < Size) and not Success do - begin - if WorkingComparator.Equals(Item, Items[I]) then - begin - Result.ResultType := srFoundAtIndex; - Result.Index := I; - Success := true; - end - else - Inc(I); - end; -end; - -procedure TAbstractList.Sort(const SortComparator: IComparator); -begin - if SortComparator = nil then - begin - if Size > 0 then - QuickSort(0, Size - 1, Comparator); - FSorted := true; - end - else - begin - if Size > 0 then - QuickSort(0, Size - 1, SortComparator); - FSorted := false; - end; -end; - -procedure TAbstractList.Sort(CompareFunc: TCollectionCompareFunc); -begin - if Size > 0 then - QuickSort(0, Size - 1, CompareFunc); - FSorted := false; -end; - -{ TAbstractMap } -constructor TAbstractMap.Create; -begin - Create(false, true); -end; - -constructor TAbstractMap.Create(NaturalItemsOnly: Boolean); -begin - Create(NaturalItemsOnly, true); -end; - -constructor TAbstractMap.Create(NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FNaturalKeysOnly := NaturalKeysOnly or GetAlwaysNaturalKeys; - FAssociationComparator := TAssociationComparator.Create(FNaturalKeysOnly); - if FNaturalKeysOnly then - FKeyComparator := TAbstractComparator.GetNaturalComparator - else - FKeyComparator := TAbstractComparator.GetDefaultComparator; -end; - -constructor TAbstractMap.Create(const ItemArray: array of ICollectable); -begin - Create(ItemArray, true, true); -end; - -constructor TAbstractMap.Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -begin - Create(ItemArray, true, true); -end; - -constructor TAbstractMap.Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); -var - I: Integer; -begin - Create(true, NaturalKeysOnly); - if not FixedSize then - begin - Capacity := Length(ItemArray); - for I := Low(ItemArray) to High(ItemArray) do - begin - Add(ItemArray[I]); - end; - end; -end; - -constructor TAbstractMap.Create(const KeyArray, ItemArray: array of ICollectable); -begin - Create(KeyArray, ItemArray, false, true); -end; - -constructor TAbstractMap.Create(const KeyArray, ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -begin - Create(KeyArray, ItemArray, NaturalItemsOnly, true); -end; - -constructor TAbstractMap.Create(const KeyArray, ItemArray: array of ICollectable; NaturalItemsOnly: Boolean; NaturalKeysOnly: Boolean); -var - I, Lo, Hi: Integer; -begin - Create(NaturalItemsOnly, NaturalKeysOnly); - if not FixedSize then - begin - Capacity := Min(Length(KeyArray), Length(ItemArray)); - Lo := Max(Low(KeyArray), Low(ItemArray)); - Hi := Min(High(KeyArray), High(ItemArray)); - for I := Lo to Hi do - begin - Put(KeyArray[I], ItemArray[I]); - end; - end; -end; - -constructor TAbstractMap.Create(const Map: IMap); -var - MapIterator: IMapIterator; -begin - Create(Map.GetNaturalItemsOnly, Map.GetNaturalKeysOnly); - InitFrom(Map); - if not FixedSize then - begin - Capacity := Map.GetSize; - MapIterator := Map.GetMapIterator; - while not MapIterator.EOF do - begin - Put(MapIterator.CurrentKey, MapIterator.CurrentItem); - MapIterator.Next; - end; - end; -end; - -destructor TAbstractMap.Destroy; -begin - FKeyComparator := nil; - FAssociationComparator := nil; - inherited Destroy; -end; - -procedure TAbstractMap.InitFrom(const Collection: ICollection); -var - Map: IMap; -begin - inherited InitFrom(Collection); - if Collection.QueryInterface(IMap, Map) = S_OK then - begin - FNaturalKeysOnly := Map.GetNaturalKeysOnly or GetAlwaysNaturalKeys; - KeyComparator := Map.GetKeyComparator; - end; -end; - -function TAbstractMap.TrueAdd(const Item: ICollectable): Boolean; -var - Position: TCollectionPosition; - Mappable: IMappable; -begin - if IsNaturalItem(Item) then - begin - Mappable := Item as IMappable; - Position := GetKeyPosition(Mappable.GetKey); - try - if Position.Found then - begin - CollectionError(ceDuplicateKey); - Result := false; - end - else - begin - TruePut(Position, TAssociation.Create(Mappable.GetKey, Item)); - Result := true; - end; - finally - Position.Free; - end; - end - else - begin - CollectionError(ceNotNaturalItem); - Result := false; - end; -end; - -function TAbstractMap.TrueContains(const Item: ICollectable): Boolean; -var - Item2: ICollectable; - Success: Boolean; - Iterator: IIterator; -begin - Iterator := GetIterator; - Success := false; - while not Iterator.EOF and not Success do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - Success := true; - Iterator.Next; - end; - Result := Success; -end; - -function TAbstractMap.TrueRemove(const Item: ICollectable): ICollectable; -var - Item2: ICollectable; - Iterator: IMapIterator; - Found: Boolean; -begin - // Sequential search - Found := false; - Result := nil; - Iterator := GetAssociationIterator; - while not Iterator.EOF and not Found do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - begin - Result := Item2; - Iterator.Remove; - Found := true; - end; - Iterator.Next; - end; -end; - -function TAbstractMap.TrueRemoveAll(const Item: ICollectable): ICollection; -var - ResultCollection: ICollection; - Item2: ICollectable; - Iterator: IMapIterator; -begin - // Sequential search - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := GetAssociationIterator; - while not Iterator.EOF do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - begin - ResultCollection.Add(Item2); - Iterator.Remove; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -class function TAbstractMap.GetAlwaysNaturalKeys: Boolean; -begin - Result := false; -end; - -function TAbstractMap.GetItem(const Key: ICollectable): ICollectable; -begin - Result := Get(Key); -end; - -procedure TAbstractMap.SetItem(const Key, Item: ICollectable); -begin - Put(Key, Item); -end; - -function TAbstractMap.GetIterator: IIterator; -begin - Result := GetAssociationIterator; -end; - -function TAbstractMap.GetKeyComparator: IComparator; -begin - Result := FKeyComparator; -end; - -procedure TAbstractMap.SetKeyComparator(const Value: IComparator); -begin - FKeyComparator := Value; - FAssociationComparator.KeyComparator := Value; -end; - -function TAbstractMap.GetKeyIterator: IIterator; -begin - Result := TAssociationKeyIterator.Create(GetAssociationIterator); -end; - -function TAbstractMap.GetKeys: ISet; -var - ResultCollection: TPArraySet; - KeyIterator: IIterator; -begin - ResultCollection := TPArraySet.Create(NaturalKeysOnly); - ResultCollection.SetComparator(GetKeyComparator); - KeyIterator := GetKeyIterator; - while not KeyIterator.EOF do - begin - ResultCollection.Add(KeyIterator.CurrentItem); - KeyIterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractMap.GetMapIterator: IMapIterator; -begin - Result := GetAssociationIterator; -end; - -function TAbstractMap.GetMapIteratorByKey(const Filter: IFilter): IMapIterator; -var - Iterator: IMapIterator; -begin - Iterator := GetMapIterator; - Result := TKeyFilterMapIterator.Create(Iterator, Filter, Iterator.GetAllowRemoval); -end; - -function TAbstractMap.GetMapIteratorByKey(FilterFunc: TCollectionFilterFunc): IMapIterator; -var - Iterator: IMapIterator; -begin - Iterator := GetMapIterator; - Result := TKeyFilterFuncMapIterator.Create(Iterator, FilterFunc, Iterator.GetAllowRemoval); -end; - -function TAbstractMap.GetNaturalItemIID: TGUID; -begin - Result := MappableIID; -end; - -function TAbstractMap.GetNaturalKeyIID: TGUID; -begin - Result := EquatableIID; -end; - -function TAbstractMap.GetNaturalKeysOnly: Boolean; -begin - Result := FNaturalKeysOnly; -end; - -function TAbstractMap.GetType: TCollectionType; -begin - Result := ctMap; -end; - -function TAbstractMap.GetValues: ICollection; -var - ResultCollection: ICollection; - ValueIterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - ValueIterator := GetIterator; - while not ValueIterator.EOF do - begin - ResultCollection.Add(ValueIterator.CurrentItem); - ValueIterator.Next; - end; - Result := ResultCollection; -end; - -// Overrides TAbstractCollection function, otherwise Create(ICollection) is -// called, which cannot access keys. -function TAbstractMap.Clone: ICollection; -begin - Result := (TAbstractMapClass(ClassType)).Create(Self); -end; - -function TAbstractMap.CloneAsMap: IMap; -begin - Result := (TAbstractMapClass(ClassType)).Create(Self); -end; - -function TAbstractMap.ContainsKey(const Key: ICollectable): Boolean; -var - Position: TCollectionPosition; -begin - Position := GetKeyPosition(Key); - try - Result := Position.Found; - finally - Position.Free; - end; -end; - -function TAbstractMap.ContainsKey(const KeyArray: array of ICollectable): Boolean; -var - I: Integer; - Success: Boolean; -begin - Success := true; - for I := Low(KeyArray) to High(KeyArray) do - begin - Success := Success and ContainsKey(KeyArray[I]); - if not Success then - break; - end; - Result := Success; -end; - -function TAbstractMap.ContainsKey(const Collection: ICollection): Boolean; -var - Iterator: IIterator; - Success: Boolean; -begin - Success := true; - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Success := Success and ContainsKey(Iterator.CurrentItem); - if not Success then - break; - Iterator.Next; - end; - Result := Success; -end; - -function TAbstractMap.Get(const Key: ICollectable): ICollectable; -var - KeyError: TCollectionError; - Position: TCollectionPosition; -begin - KeyError := KeyAllowed(Key); - if KeyError <> ceOK then - begin - CollectionError(KeyError); - Result := nil; - end - else - begin - Position := GetKeyPosition(Key); - try - if Position.Found then - Result := TrueGet(Position).GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractMap.KeyAllowed(const Key: ICollectable): TCollectionError; -begin - if NaturalKeysOnly and not IsNaturalKey(Key) then - Result := ceNotNaturalItem - else if Key = nil then - Result := ceNilNotAllowed - else - Result := ceOK; -end; - -function TAbstractMap.IsNaturalKey(const Key: ICollectable): Boolean; -var - Temp: IUnknown; -begin - if Key.QueryInterface(NaturalKeyIID, Temp) <> E_NOINTERFACE then - Result := true - else - Result := false; -end; - -function TAbstractMap.IsNilAllowed: Boolean; -begin - Result := true; -end; - -function TAbstractMap.MatchingKey(const KeyArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(KeyArray) to High(KeyArray) do - begin - if ContainsKey(KeyArray[I]) then - ResultCollection.Add(KeyArray[I]); - end; - Result := ResultCollection; -end; - -function TAbstractMap.MatchingKey(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - if ContainsKey(Iterator.CurrentItem) then - ResultCollection.Add(Iterator.CurrentItem); - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractMap.Put(const Item: ICollectable): ICollectable; -var - Mappable: IMappable; - OldAssociation, NewAssociation: IAssociation; - Position: TCollectionPosition; -begin - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - Result := nil; - end - else - begin - Item.QueryInterface(IMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - Result := OldAssociation.GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractMap.Put(const Key, Item: ICollectable): ICollectable; -var - OldAssociation, NewAssociation: IAssociation; - ItemError, KeyError: TCollectionError; - Position: TCollectionPosition; -begin - ItemError := ItemAllowed(Item); - KeyError := KeyAllowed(Key); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := nil; - end - else if KeyError <> ceOK then - begin - CollectionError(KeyError); - Result := nil; - end - else - begin - // Find appropriate place, then place key-item association there - Position := GetKeyPosition(Key); - try - NewAssociation := TAssociation.Create(Key, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - Result := OldAssociation.GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractMap.Put(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - Mappable: IMappable; - OldAssociation, NewAssociation: IAssociation; - Position: TCollectionPosition; - Item: ICollectable; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := ItemArray[I]; - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - end - else - begin - // Find appropriate place, then place key-item association there - Item.QueryInterface(IMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - end; - Result := ResultCollection; -end; - -function TAbstractMap.Put(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Mappable: IMappable; - OldAssociation, NewAssociation: IAssociation; - Position: TCollectionPosition; - Iterator: IIterator; - Item: ICollectable; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem;; - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - end - else - begin - // Find appropriate place, then place key-item association there - Item.QueryInterface(IMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractMap.Put(const Map: IMap): ICollection; -var - ResultCollection: ICollection; - OldAssociation, NewAssociation: IAssociation; - ItemError, KeyError: TCollectionError; - Position: TCollectionPosition; - MapIterator: IMapIterator; - Key, Item: ICollectable; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - MapIterator := Map.GetMapIterator; - while not MapIterator.EOF do - begin - Key := MapIterator.CurrentKey; - Item := MapIterator.CurrentItem; - - ItemError := ItemAllowed(Item); - KeyError := KeyAllowed(Key); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - end - else if KeyError <> ceOK then - begin - CollectionError(KeyError); - end - else - begin - // Find appropriate place, then place key-item association there - Position := GetKeyPosition(Key); - try - NewAssociation := TAssociation.Create(Key, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - MapIterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractMap.RemoveKey(const Key: ICollectable): ICollectable; -var - KeyError: TCollectionError; - Position: TCollectionPosition; - OldAssociation: IAssociation; -begin - KeyError := KeyAllowed(Key); - if KeyError <> ceOK then - begin - CollectionError(KeyError); - Result := nil; - end - else - begin - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - Result := OldAssociation.GetValue - end - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractMap.RemoveKey(const KeyArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - OldAssociation: IAssociation; - KeyError: TCollectionError; - Position: TCollectionPosition; - Key: ICollectable; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(KeyArray) to High(KeyArray) do - begin - Key := KeyArray[I]; - KeyError := KeyAllowed(Key); - if KeyError <> ceOK then - begin - CollectionError(KeyError); - end - else - begin - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - ResultCollection.Add(OldAssociation.GetValue); - end; - finally - Position.Free; - end; - end; - end; - Result := ResultCollection; -end; - -function TAbstractMap.RemoveKey(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - OldAssociation: IAssociation; - KeyError: TCollectionError; - Position: TCollectionPosition; - Key: ICollectable; - Iterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Key := Iterator.CurrentItem; - KeyError := KeyAllowed(Key); - if KeyError <> ceOK then - begin - CollectionError(KeyError); - end - else - begin - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - ResultCollection.Add(OldAssociation.GetValue); - end; - finally - Position.Free; - end; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractMap.RetainKey(const KeyArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - MapIterator: IMapIterator; - I: Integer; - Found: Boolean; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else - begin - MapIterator := GetMapIterator; - while not MapIterator.EOF do - begin - // Converting the array to a map would be faster but I don't want to - // couple base class code to a complex collection. - Found := false; - for I := Low(KeyArray) to High(KeyArray) do - begin - Found := KeyComparator.Equals(MapIterator.CurrentKey, KeyArray[I]); - if Found then - break; - end; - if not Found then - begin - ResultCollection.Add(MapIterator.CurrentItem); - MapIterator.Remove; - end; - MapIterator.Next; - end; - Result := ResultCollection; - end; -end; - -function TAbstractMap.RetainKey(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - MapIterator: IMapIterator; - Key: ICollectable; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else - begin - MapIterator := GetMapIterator; - while not MapIterator.EOF do - begin - Key := MapIterator.CurrentKey; - if not Collection.Contains(Key) then - begin - ResultCollection.Add(MapIterator.CurrentItem); - MapIterator.Remove; - end; - MapIterator.Next; - end; - end; - Result := ResultCollection; -end; - - -{ TAbstractIntegerMap } -constructor TAbstractIntegerMap.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FAssociationComparator := TIntegerAssociationComparator.Create; -end; - -constructor TAbstractIntegerMap.Create(const ItemArray: array of ICollectable); -begin - Create(ItemArray, true); -end; - -constructor TAbstractIntegerMap.Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -begin - inherited Create(ItemArray, true); -end; - -constructor TAbstractIntegerMap.Create(const KeyArray: array of Integer; const ItemArray: array of ICollectable); -begin - Create(KeyArray, ItemArray, false); -end; - -constructor TAbstractIntegerMap.Create(const KeyArray: array of Integer; const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -var - I, Lo, Hi: Integer; -begin - Create(NaturalItemsOnly); - Capacity := Min(Length(KeyArray), Length(ItemArray)); - if not FixedSize then - begin - Lo := Max(Low(KeyArray), Low(ItemArray)); - Hi := Min(High(KeyArray), High(ItemArray)); - for I := Lo to Hi do - begin - Put(KeyArray[I], ItemArray[I]); - end; - end; -end; - -constructor TAbstractIntegerMap.Create(const Map: IIntegerMap); -var - MapIterator: IIntegerMapIterator; -begin - Create(Map.GetNaturalItemsOnly); - InitFrom(Map); - Capacity := Map.GetSize; - if not FixedSize then - begin - MapIterator := Map.GetMapIterator; - while not MapIterator.EOF do - begin - Put(MapIterator.CurrentKey, MapIterator.CurrentItem); - MapIterator.Next; - end; - end; -end; - -destructor TAbstractIntegerMap.Destroy; -begin - FAssociationComparator := nil; - inherited Destroy; -end; - -function TAbstractIntegerMap.TrueAdd(const Item: ICollectable): Boolean; -var - Position: TCollectionPosition; - Mappable: IIntegerMappable; -begin - if IsNaturalItem(Item) then - begin - Mappable := Item as IIntegerMappable; - Position := GetKeyPosition(Mappable.GetKey); - try - if Position.Found then - begin - CollectionError(ceDuplicateKey); - Result := false; - end - else - begin - TruePut(Position, TIntegerAssociation.Create(Mappable.GetKey, Item)); - Result := true; - end; - finally - Position.Free; - end; - end - else - begin - CollectionError(ceNotNaturalItem); - Result := false; - end; -end; - -function TAbstractIntegerMap.TrueContains(const Item: ICollectable): Boolean; -var - Item2: ICollectable; - Success: Boolean; - Iterator: IIterator; -begin - Iterator := GetIterator; - Success := false; - while not Iterator.EOF and not Success do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - Success := true; - Iterator.Next; - end; - Result := Success; -end; - -function TAbstractIntegerMap.TrueRemove(const Item: ICollectable): ICollectable; -var - Item2: ICollectable; - Iterator: IIntegerMapIterator; - Found: Boolean; -begin - // Sequential search - Found := false; - Result := nil; - Iterator := GetAssociationIterator; - while not Iterator.EOF and not Found do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - begin - Result := Item2; - Iterator.Remove; - Found := true; - end; - Iterator.Next; - end; -end; - -function TAbstractIntegerMap.TrueRemoveAll(const Item: ICollectable): ICollection; -var - ResultCollection: ICollection; - Item2: ICollectable; - Iterator: IIntegerMapIterator; -begin - // Sequential search - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := GetAssociationIterator; - while not Iterator.EOF do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - begin - ResultCollection.Add(Item2); - Iterator.Remove; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractIntegerMap.GetItem(const Key: Integer): ICollectable; -begin - Result := Get(Key); -end; - -procedure TAbstractIntegerMap.SetItem(const Key: Integer; const Item: ICollectable); -begin - Put(Key, Item); -end; - -function TAbstractIntegerMap.GetIterator: IIterator; -begin - Result := GetAssociationIterator; -end; - -function TAbstractIntegerMap.GetKeys: ISet; -var - ResultCollection: TPArraySet; - MapIterator: IIntegerMapIterator; -begin - ResultCollection := TPArraySet.Create(true); - MapIterator := GetMapIterator; - while not MapIterator.EOF do - begin - ResultCollection.Add(TIntegerWrapper.Create(MapIterator.CurrentKey) as ICollectable); - MapIterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractIntegerMap.GetMapIterator: IIntegerMapIterator; -begin - Result := GetAssociationIterator; -end; - -function TAbstractIntegerMap.GetNaturalItemIID: TGUID; -begin - Result := IntegerMappableIID; -end; - -function TAbstractIntegerMap.GetType: TCollectionType; -begin - Result := ctIntegerMap; -end; - -function TAbstractIntegerMap.GetValues: ICollection; -var - ResultCollection: ICollection; - ValueIterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - ValueIterator := GetIterator; - while not ValueIterator.EOF do - begin - ResultCollection.Add(ValueIterator.CurrentItem); - ValueIterator.Next; - end; - Result := ResultCollection; -end; - -// Overrides TAbstractCollection function, otherwise Create(ICollection) is -// called, which cannot access keys. -function TAbstractIntegerMap.Clone: ICollection; -begin - Result := (TAbstractIntegerMapClass(ClassType)).Create(Self); -end; - -function TAbstractIntegerMap.CloneAsIntegerMap: IIntegerMap; -begin - Result := (TAbstractIntegerMapClass(ClassType)).Create(Self); -end; - -function TAbstractIntegerMap.ContainsKey(const Key: Integer): Boolean; -var - Position: TCollectionPosition; -begin - Position := GetKeyPosition(Key); - try - Result := Position.Found; - finally - Position.Free; - end; -end; - -function TAbstractIntegerMap.ContainsKey(const KeyArray: array of Integer): Boolean; -var - I: Integer; - Success: Boolean; -begin - Success := true; - for I := Low(KeyArray) to High(KeyArray) do - begin - Success := Success and ContainsKey(KeyArray[I]); - if not Success then - break; - end; - Result := Success; -end; - -function TAbstractIntegerMap.Get(const Key: Integer): ICollectable; -var - Position: TCollectionPosition; -begin - Position := GetKeyPosition(Key); - try - if Position.Found then - Result := TrueGet(Position).GetValue - else - Result := nil; - finally - Position.Free; - end; -end; - -function TAbstractIntegerMap.IsNilAllowed: Boolean; -begin - Result := true; -end; - -function TAbstractIntegerMap.Put(const Item: ICollectable): ICollectable; -var - Mappable: IIntegerMappable; - OldAssociation, NewAssociation: IIntegerAssociation; - Position: TCollectionPosition; -begin - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - Result := nil; - end - else - begin - Item.QueryInterface(IIntegerMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TIntegerAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - Result := OldAssociation.GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractIntegerMap.Put(const Key: Integer; const Item: ICollectable): ICollectable; -var - OldAssociation, NewAssociation: IIntegerAssociation; - ItemError: TCollectionError; - Position: TCollectionPosition; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := nil; - end - else - begin - Position := GetKeyPosition(Key); - try - NewAssociation := TIntegerAssociation.Create(Key, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - Result := OldAssociation.GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractIntegerMap.Put(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - Mappable: IIntegerMappable; - OldAssociation, NewAssociation: IIntegerAssociation; - Position: TCollectionPosition; - Item: ICollectable; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := ItemArray[I]; - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - end - else - begin - Item.QueryInterface(IIntegerMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TIntegerAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - end; - Result := ResultCollection; -end; - -function TAbstractIntegerMap.Put(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Mappable: IIntegerMappable; - OldAssociation, NewAssociation: IIntegerAssociation; - Position: TCollectionPosition; - Iterator: IIterator; - Item: ICollectable; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem;; - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - end - else - begin - Item.QueryInterface(IIntegerMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TIntegerAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractIntegerMap.Put(const Map: IIntegerMap): ICollection; -var - ResultCollection: ICollection; - OldAssociation, NewAssociation: IIntegerAssociation; - ItemError: TCollectionError; - Position: TCollectionPosition; - MapIterator: IIntegerMapIterator; - Item: ICollectable; - Key: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - MapIterator := Map.GetMapIterator; - while not MapIterator.EOF do - begin - Key := MapIterator.CurrentKey; - Item := MapIterator.CurrentItem; - - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - end - else - begin - Position := GetKeyPosition(Key); - try - NewAssociation := TIntegerAssociation.Create(Key, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - MapIterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractIntegerMap.RemoveKey(const Key: Integer): ICollectable; -var - Position: TCollectionPosition; - OldAssociation: IIntegerAssociation; -begin - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - Result := OldAssociation.GetValue - end - else - Result := nil; - finally - Position.Free; - end; -end; - -function TAbstractIntegerMap.RemoveKey(const KeyArray: array of Integer): ICollection; -var - ResultCollection: ICollection; - OldAssociation: IIntegerAssociation; - Position: TCollectionPosition; - Key: Integer; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(KeyArray) to High(KeyArray) do - begin - Key := KeyArray[I]; - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - ResultCollection.Add(OldAssociation.GetValue); - end; - finally - Position.Free; - end; - end; - Result := ResultCollection; -end; - -function TAbstractIntegerMap.RetainKey(const KeyArray: array of Integer): ICollection; -var - ResultCollection: ICollection; - MapIterator: IIntegerMapIterator; - I: Integer; - Found: Boolean; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else - begin - MapIterator := GetMapIterator; - while not MapIterator.EOF do - begin - // Converting the array to a map would be faster but I don't want to - // couple base class code to a complex collection. - Found := false; - for I := Low(KeyArray) to High(KeyArray) do - begin - Found := (MapIterator.CurrentKey = KeyArray[I]); - if Found then - break; - end; - if not Found then - begin - ResultCollection.Add(MapIterator.CurrentItem); - MapIterator.Remove; - end; - MapIterator.Next; - end; - Result := ResultCollection; - end; -end; - - -{ TAbstractStringMap } -constructor TAbstractStringMap.Create(NaturalItemsOnly: Boolean); -begin - inherited Create(NaturalItemsOnly); - FAssociationComparator := TStringAssociationComparator.Create; -end; - -constructor TAbstractStringMap.Create(const ItemArray: array of ICollectable); -begin - Create(ItemArray, true); -end; - -constructor TAbstractStringMap.Create(const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -begin - inherited Create(ItemArray, true); -end; - -constructor TAbstractStringMap.Create(const KeyArray: array of String; const ItemArray: array of ICollectable); -begin - Create(KeyArray, ItemArray, false); -end; - -constructor TAbstractStringMap.Create(const KeyArray: array of String; const ItemArray: array of ICollectable; NaturalItemsOnly: Boolean); -var - I, Lo, Hi: Integer; -begin - Create(NaturalItemsOnly); - Capacity := Min(Length(KeyArray), Length(ItemArray)); - if not FixedSize then - begin - Lo := Max(Low(KeyArray), Low(ItemArray)); - Hi := Min(High(KeyArray), High(ItemArray)); - for I := Lo to Hi do - begin - Put(KeyArray[I], ItemArray[I]); - end; - end; -end; - -constructor TAbstractStringMap.Create(const Map: IStringMap); -var - MapIterator: IStringMapIterator; -begin - Create(Map.GetNaturalItemsOnly); - InitFrom(Map); - Capacity := Map.GetSize; - if not FixedSize then - begin - MapIterator := Map.GetMapIterator; - while not MapIterator.EOF do - begin - Put(MapIterator.CurrentKey, MapIterator.CurrentItem); - MapIterator.Next; - end; - end; -end; - -destructor TAbstractStringMap.Destroy; -begin - FAssociationComparator := nil; - inherited Destroy; -end; - -function TAbstractStringMap.TrueAdd(const Item: ICollectable): Boolean; -var - Position: TCollectionPosition; - Mappable: IStringMappable; -begin - if IsNaturalItem(Item) then - begin - Mappable := Item as IStringMappable; - Position := GetKeyPosition(Mappable.GetKey); - try - if Position.Found then - begin - CollectionError(ceDuplicateKey); - Result := false; - end - else - begin - TruePut(Position, TStringAssociation.Create(Mappable.GetKey, Item)); - Result := true; - end; - finally - Position.Free; - end; - end - else - begin - CollectionError(ceNotNaturalItem); - Result := false; - end; -end; - -function TAbstractStringMap.TrueContains(const Item: ICollectable): Boolean; -var - Item2: ICollectable; - Success: Boolean; - Iterator: IIterator; -begin - Iterator := GetIterator; - Success := false; - while not Iterator.EOF and not Success do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - Success := true; - Iterator.Next; - end; - Result := Success; -end; - -function TAbstractStringMap.TrueRemove(const Item: ICollectable): ICollectable; -var - Item2: ICollectable; - Iterator: IStringMapIterator; - Found: Boolean; -begin - // Sequential search - Found := false; - Result := nil; - Iterator := GetAssociationIterator; - while not Iterator.EOF and not Found do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - begin - Result := Item2; - Iterator.Remove; - Found := true; - end; - Iterator.Next; - end; -end; - -function TAbstractStringMap.TrueRemoveAll(const Item: ICollectable): ICollection; -var - ResultCollection: ICollection; - Item2: ICollectable; - Iterator: IIterator; -begin - // Sequential search - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := GetAssociationIterator; - while not Iterator.EOF do - begin - Item2 := Iterator.CurrentItem; - if Comparator.Equals(Item, Item2) then - begin - ResultCollection.Add(Item2); - Iterator.Remove; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractStringMap.GetItem(const Key: String): ICollectable; -begin - Result := Get(Key); -end; - -procedure TAbstractStringMap.SetItem(const Key: String; const Item: ICollectable); -begin - Put(Key, Item); -end; - -function TAbstractStringMap.GetIterator: IIterator; -begin - Result := GetAssociationIterator; -end; - -function TAbstractStringMap.GetKeys: ISet; -var - ResultCollection: TPArraySet; - MapIterator: IStringMapIterator; -begin - ResultCollection := TPArraySet.Create(true); - MapIterator := GetMapIterator; - while not MapIterator.EOF do - begin - ResultCollection.Add(TStringWrapper.Create(MapIterator.CurrentKey) as ICollectable); - MapIterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractStringMap.GetMapIterator: IStringMapIterator; -begin - Result := GetAssociationIterator; -end; - -function TAbstractStringMap.GetNaturalItemIID: TGUID; -begin - Result := StringMappableIID; -end; - -function TAbstractStringMap.GetType: TCollectionType; -begin - Result := ctStringMap; -end; - -function TAbstractStringMap.GetValues: ICollection; -var - ResultCollection: ICollection; - ValueIterator: IIterator; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - ValueIterator := GetIterator; - while not ValueIterator.EOF do - begin - ResultCollection.Add(ValueIterator.CurrentItem); - ValueIterator.Next; - end; - Result := ResultCollection; -end; - -// Overrides TAbstractCollection function, otherwise Create(ICollection) is -// called, which cannot access keys. -function TAbstractStringMap.Clone: ICollection; -begin - Result := (TAbstractStringMapClass(ClassType)).Create(Self); -end; - -function TAbstractStringMap.CloneAsStringMap: IStringMap; -begin - Result := (TAbstractStringMapClass(ClassType)).Create(Self); -end; - -function TAbstractStringMap.ContainsKey(const Key: String): Boolean; -var - Position: TCollectionPosition; -begin - Position := GetKeyPosition(Key); - try - Result := Position.Found; - finally - Position.Free; - end; -end; - -function TAbstractStringMap.ContainsKey(const KeyArray: array of String): Boolean; -var - I: Integer; - Success: Boolean; -begin - Success := true; - for I := Low(KeyArray) to High(KeyArray) do - begin - Success := Success and ContainsKey(KeyArray[I]); - if not Success then - break; - end; - Result := Success; -end; - -function TAbstractStringMap.Get(const Key: String): ICollectable; -var - Position: TCollectionPosition; -begin - Position := GetKeyPosition(Key); - try - if Position.Found then - Result := TrueGet(Position).GetValue - else - Result := nil; - finally - Position.Free; - end; -end; - -function TAbstractStringMap.IsNilAllowed: Boolean; -begin - Result := true; -end; - -function TAbstractStringMap.Put(const Item: ICollectable): ICollectable; -var - Mappable: IStringMappable; - OldAssociation, NewAssociation: IStringAssociation; - Position: TCollectionPosition; -begin - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - Result := nil; - end - else - begin - Item.QueryInterface(IStringMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TStringAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - Result := OldAssociation.GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractStringMap.Put(const Key: String; const Item: ICollectable): ICollectable; -var - OldAssociation, NewAssociation: IStringAssociation; - ItemError: TCollectionError; - Position: TCollectionPosition; -begin - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - Result := nil; - end - else - begin - Position := GetKeyPosition(Key); - try - NewAssociation := TStringAssociation.Create(Key, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - Result := OldAssociation.GetValue - else - Result := nil; - finally - Position.Free; - end; - end; -end; - -function TAbstractStringMap.Put(const ItemArray: array of ICollectable): ICollection; -var - ResultCollection: ICollection; - Mappable: IStringMappable; - OldAssociation, NewAssociation: IStringAssociation; - Position: TCollectionPosition; - Item: ICollectable; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(ItemArray) to High(ItemArray) do - begin - Item := ItemArray[I]; - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - end - else - begin - Item.QueryInterface(IStringMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TStringAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - end; - Result := ResultCollection; -end; - -function TAbstractStringMap.Put(const Collection: ICollection): ICollection; -var - ResultCollection: ICollection; - Mappable: IStringMappable; - OldAssociation, NewAssociation: IStringAssociation; - Position: TCollectionPosition; - Iterator: IIterator; - Item: ICollectable; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - Iterator := Collection.GetIterator; - while not Iterator.EOF do - begin - Item := Iterator.CurrentItem;; - if not IsNaturalItem(Item) then - begin - CollectionError(ceNotNaturalItem); - end - else - begin - Item.QueryInterface(IStringMappable, Mappable); - Position := GetKeyPosition(Mappable.GetKey); - try - NewAssociation := TStringAssociation.Create(Mappable.GetKey, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - Iterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractStringMap.Put(const Map: IStringMap): ICollection; -var - ResultCollection: ICollection; - OldAssociation, NewAssociation: IStringAssociation; - ItemError: TCollectionError; - Position: TCollectionPosition; - MapIterator: IStringMapIterator; - Item: ICollectable; - Key: String; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - MapIterator := Map.GetMapIterator; - while not MapIterator.EOF do - begin - Key := MapIterator.CurrentKey; - Item := MapIterator.CurrentItem; - - ItemError := ItemAllowed(Item); - if ItemError <> ceOK then - begin - CollectionError(ItemError); - end - else - begin - Position := GetKeyPosition(Key); - try - NewAssociation := TStringAssociation.Create(Key, Item); - OldAssociation := TruePut(Position, NewAssociation); - if OldAssociation <> nil then - ResultCollection.Add(OldAssociation.GetValue); - finally - Position.Free; - end; - end; - MapIterator.Next; - end; - Result := ResultCollection; -end; - -function TAbstractStringMap.RemoveKey(const Key: String): ICollectable; -var - Position: TCollectionPosition; - OldAssociation: IStringAssociation; -begin - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - Result := OldAssociation.GetValue - end - else - Result := nil; - finally - Position.Free; - end; -end; - -function TAbstractStringMap.RemoveKey(const KeyArray: array of String): ICollection; -var - ResultCollection: ICollection; - OldAssociation: IStringAssociation; - Position: TCollectionPosition; - Key: String; - I: Integer; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - for I := Low(KeyArray) to High(KeyArray) do - begin - Key := KeyArray[I]; - Position := GetKeyPosition(Key); - try - if Position.Found then - begin - OldAssociation := TrueRemove2(Position); - ResultCollection.Add(OldAssociation.GetValue); - end; - finally - Position.Free; - end; - end; - Result := ResultCollection; -end; - -function TAbstractStringMap.RetainKey(const KeyArray: array of String): ICollection; -var - ResultCollection: ICollection; - MapIterator: IStringMapIterator; - I: Integer; - Found: Boolean; -begin - ResultCollection := TPArrayBag.Create(NaturalItemsOnly); - if FixedSize then - begin - CollectionError(ceFixedSize); - end - else - begin - MapIterator := GetMapIterator; - while not MapIterator.EOF do - begin - // Converting the array to a map would be faster but I don't want to - // couple base class code to a complex collection. - Found := false; - for I := Low(KeyArray) to High(KeyArray) do - begin - Found := (MapIterator.CurrentKey = KeyArray[I]); - if Found then - break; - end; - if not Found then - begin - ResultCollection.Add(MapIterator.CurrentItem); - MapIterator.Remove; - end; - MapIterator.Next; - end; - Result := ResultCollection; - end; -end; - - -{ ECollectionError } -constructor ECollectionError.Create(const Msg: String; const Collection: ICollection; ErrorType: TCollectionError); -begin - inherited Create(Msg); - FCollection := Collection; - FErrorType := ErrorType; -end; - -{ TAbstractListIterator } -constructor TAbstractListIterator.Create(Collection: TAbstractList); -begin - inherited Create(true); - FCollection := Collection; - First; -end; - -function TAbstractListIterator.TrueFirst: ICollectable; -begin - FIndex := 0; - if FIndex < FCollection.GetSize then - Result := FCollection.GetItem(FIndex) - else - Result := nil; -end; - -function TAbstractListIterator.TrueNext: ICollectable; -begin - Inc(FIndex); - if FIndex < FCollection.GetSize then - Result := FCollection.GetItem(FIndex) - else - Result := nil; -end; - -procedure TAbstractListIterator.TrueRemove; -begin - FCollection.Delete(FIndex); - Dec(FIndex); -end; - -end. diff --git a/src/lib/ctypes/ctypes.pas b/src/lib/ctypes/ctypes.pas deleted file mode 100644 index 694552dc..00000000 --- a/src/lib/ctypes/ctypes.pas +++ /dev/null @@ -1,72 +0,0 @@ -{ - This file is part of the Free Pascal run time library. - Copyright (c) 2004 by Marco van de Voort, member of the - Free Pascal development team - - Implements C types for in header conversions - - See the file COPYING.FPC, included in this distribution, - for details about the copyright. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. - - - **********************************************************************} - -unit ctypes; - -interface - -type - qword = int64; // Keep h2pas "uses ctypes" headers working with delphi. - - { the following type definitions are compiler dependant } - { and system dependant } - - cint8 = shortint; pcint8 = ^cint8; - cuint8 = byte; pcuint8 = ^cuint8; - cchar = cint8; pcchar = ^cchar; - cschar = cint8; pcschar = ^cschar; - cuchar = cuint8; pcuchar = ^cuchar; - - cint16 = smallint; pcint16 = ^cint16; - cuint16 = word; pcuint16 = ^cuint16; - cshort = cint16; pcshort = ^cshort; - csshort = cint16; pcsshort = ^csshort; - cushort = cuint16; pcushort = ^cushort; - - cint32 = longint; pcint32 = ^cint32; - cuint32 = longword; pcuint32 = ^cuint32; - cint = cint32; pcint = ^cint; { minimum range is : 32-bit } - csint = cint32; pcsint = ^csint; { minimum range is : 32-bit } - cuint = cuint32; pcuint = ^cuint; { minimum range is : 32-bit } - csigned = cint; pcsigned = ^csigned; - cunsigned = cuint; pcunsigned = ^cunsigned; - - cint64 = int64; pcint64 = ^cint64; - cuint64 = qword; pcuint64 = ^cuint64; - clonglong = cint64; pclonglong = ^clonglong; - cslonglong = cint64; pcslonglong = ^cslonglong; - culonglong = cuint64; pculonglong = ^culonglong; - - cbool = longbool; pcbool = ^cbool; - -{$if defined(cpu64) and not(defined(win64) and defined(cpux86_64))} - clong = int64; pclong = ^clong; - cslong = int64; pcslong = ^cslong; - culong = qword; pculong = ^culong; -{$else} - clong = longint; pclong = ^clong; - cslong = longint; pcslong = ^cslong; - culong = cardinal; pculong = ^culong; -{$ifend} - - cfloat = single; pcfloat = ^cfloat; - cdouble = double; pcdouble = ^cdouble; - clongdouble = extended; pclongdouble = ^clongdouble; - -implementation - -end. diff --git a/src/lib/ffmpeg/avcodec.pas b/src/lib/ffmpeg/avcodec.pas deleted file mode 100644 index 72cbee93..00000000 --- a/src/lib/ffmpeg/avcodec.pas +++ /dev/null @@ -1,4533 +0,0 @@ -(* - * copyright (c) 2001 Fabrice Bellard - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversion of libavcodec/avcodec.h - * Min. version: 51.16.0, revision 6577, Sat Oct 7 15:30:46 2006 UTC - * Max. version: 52.11.0, revision 16912, Sun Feb 1 02:00:19 2009 UTC - *) -{ - * update to - * Max. version: 52.42.0, Sun Dec 6 19:20:00 2009 CET - * MiSchi -} - -unit avcodec; - -{$IFDEF FPC} - {$MODE DELPHI } - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$IFDEF DARWIN} - {$linklib libavcodec} -{$ENDIF} - -interface - -uses - ctypes, - avutil, - rational, - opt, - SysUtils, - {$IFDEF UNIX} - BaseUnix, - {$ENDIF} - UConfig; - -const - (* Max. supported version by this header *) - LIBAVCODEC_MAX_VERSION_MAJOR = 52; - LIBAVCODEC_MAX_VERSION_MINOR = 42; - LIBAVCODEC_MAX_VERSION_RELEASE = 0; - LIBAVCODEC_MAX_VERSION = (LIBAVCODEC_MAX_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVCODEC_MAX_VERSION_MINOR * VERSION_MINOR) + - (LIBAVCODEC_MAX_VERSION_RELEASE * VERSION_RELEASE); - - (* Min. supported version by this header *) - LIBAVCODEC_MIN_VERSION_MAJOR = 51; - LIBAVCODEC_MIN_VERSION_MINOR = 16; - LIBAVCODEC_MIN_VERSION_RELEASE = 0; - LIBAVCODEC_MIN_VERSION = (LIBAVCODEC_MIN_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVCODEC_MIN_VERSION_MINOR * VERSION_MINOR) + - (LIBAVCODEC_MIN_VERSION_RELEASE * VERSION_RELEASE); - -(* Check if linked versions are supported *) -{$IF (LIBAVCODEC_VERSION < LIBAVCODEC_MIN_VERSION)} - {$MESSAGE Error 'Linked version of libavcodec is too old!'} -{$IFEND} - -(* Check if linked version is supported *) -{$IF (LIBAVCODEC_VERSION > LIBAVCODEC_MAX_VERSION)} - {$MESSAGE Error 'Linked version of libavcodec is not yet supported!'} -{$IFEND} - -const - AV_NOPTS_VALUE: cint64 = $8000000000000000; - AV_TIME_BASE = 1000000; - AV_TIME_BASE_Q: TAVRational = (num: 1; den: AV_TIME_BASE); - -(** - * Identifies the syntax and semantics of the bitstream. - * The principle is roughly: - * Two decoders with the same ID can decode the same streams. - * Two encoders with the same ID can encode compatible streams. - * There may be slight deviations from the principle due to implementation - * details. - * - * If you add a codec ID to this list, add it so that - * 1. no value of a existing codec ID changes (that would break ABI), - * 2. it is as close as possible to similar codecs. - *) -type - TCodecID = ( - CODEC_ID_NONE, - - (* video codecs *) - CODEC_ID_MPEG1VIDEO, - CODEC_ID_MPEG2VIDEO, //* prefered ID for MPEG Video 1/2 decoding */ - CODEC_ID_MPEG2VIDEO_XVMC, - CODEC_ID_H261, - CODEC_ID_H263, - CODEC_ID_RV10, - CODEC_ID_RV20, - CODEC_ID_MJPEG, - CODEC_ID_MJPEGB, - CODEC_ID_LJPEG, - CODEC_ID_SP5X, - CODEC_ID_JPEGLS, - CODEC_ID_MPEG4, - CODEC_ID_RAWVIDEO, - CODEC_ID_MSMPEG4V1, - CODEC_ID_MSMPEG4V2, - CODEC_ID_MSMPEG4V3, - CODEC_ID_WMV1, - CODEC_ID_WMV2, - CODEC_ID_H263P, - CODEC_ID_H263I, - CODEC_ID_FLV1, - CODEC_ID_SVQ1, - CODEC_ID_SVQ3, - CODEC_ID_DVVIDEO, - CODEC_ID_HUFFYUV, - CODEC_ID_CYUV, - CODEC_ID_H264, - CODEC_ID_INDEO3, - CODEC_ID_VP3, - CODEC_ID_THEORA, - CODEC_ID_ASV1, - CODEC_ID_ASV2, - CODEC_ID_FFV1, - CODEC_ID_4XM, - CODEC_ID_VCR1, - CODEC_ID_CLJR, - CODEC_ID_MDEC, - CODEC_ID_ROQ, - CODEC_ID_INTERPLAY_VIDEO, - CODEC_ID_XAN_WC3, - CODEC_ID_XAN_WC4, - CODEC_ID_RPZA, - CODEC_ID_CINEPAK, - CODEC_ID_WS_VQA, - CODEC_ID_MSRLE, - CODEC_ID_MSVIDEO1, - CODEC_ID_IDCIN, - CODEC_ID_8BPS, - CODEC_ID_SMC, - CODEC_ID_FLIC, - CODEC_ID_TRUEMOTION1, - CODEC_ID_VMDVIDEO, - CODEC_ID_MSZH, - CODEC_ID_ZLIB, - CODEC_ID_QTRLE, - CODEC_ID_SNOW, - CODEC_ID_TSCC, - CODEC_ID_ULTI, - CODEC_ID_QDRAW, - CODEC_ID_VIXL, - CODEC_ID_QPEG, - CODEC_ID_XVID, - CODEC_ID_PNG, - CODEC_ID_PPM, - CODEC_ID_PBM, - CODEC_ID_PGM, - CODEC_ID_PGMYUV, - CODEC_ID_PAM, - CODEC_ID_FFVHUFF, - CODEC_ID_RV30, - CODEC_ID_RV40, - CODEC_ID_VC1, - CODEC_ID_WMV3, - CODEC_ID_LOCO, - CODEC_ID_WNV1, - CODEC_ID_AASC, - CODEC_ID_INDEO2, - CODEC_ID_FRAPS, - CODEC_ID_TRUEMOTION2, - CODEC_ID_BMP, - CODEC_ID_CSCD, - CODEC_ID_MMVIDEO, - CODEC_ID_ZMBV, - CODEC_ID_AVS, - CODEC_ID_SMACKVIDEO, - CODEC_ID_NUV, - CODEC_ID_KMVC, - CODEC_ID_FLASHSV, - CODEC_ID_CAVS, - CODEC_ID_JPEG2000, - CODEC_ID_VMNC, - CODEC_ID_VP5, - CODEC_ID_VP6, - CODEC_ID_VP6F, - CODEC_ID_TARGA, - CODEC_ID_DSICINVIDEO, - CODEC_ID_TIERTEXSEQVIDEO, - CODEC_ID_TIFF, - CODEC_ID_GIF, - CODEC_ID_FFH264, - CODEC_ID_DXA, - CODEC_ID_DNXHD, - CODEC_ID_THP, - CODEC_ID_SGI, - CODEC_ID_C93, - CODEC_ID_BETHSOFTVID, - CODEC_ID_PTX, - CODEC_ID_TXD, - CODEC_ID_VP6A, - CODEC_ID_AMV, - CODEC_ID_VB, - CODEC_ID_PCX, - CODEC_ID_SUNRAST, - CODEC_ID_INDEO4, - CODEC_ID_INDEO5, - CODEC_ID_MIMIC, - CODEC_ID_RL2, - CODEC_ID_8SVX_EXP, - CODEC_ID_8SVX_FIB, - CODEC_ID_ESCAPE124, - CODEC_ID_DIRAC, - CODEC_ID_BFI, - CODEC_ID_CMV, - CODEC_ID_MOTIONPIXELS, - CODEC_ID_TGV, - CODEC_ID_TGQ, -{$IF LIBAVCODEC_VERSION >= 52012000} // >= 52.12.0 - CODEC_ID_TQI, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52022002} // >= 52.22.2 - CODEC_ID_AURA, - CODEC_ID_AURA2, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52027000} // >= 52.27.0 - CODEC_ID_V210X, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52028000} // >= 52.28.0 - CODEC_ID_TMV, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52029000} // >= 52.29.0 - CODEC_ID_V210, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52030002} // >= 52.30.2 - CODEC_ID_DPX, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52031002} // >= 52.31.2 - CODEC_ID_MAD, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 - CODEC_ID_FRWU, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52041000} // >= 52.41.0 - CODEC_ID_FLASHSV2, -{$IFEND} - - //* various PCM "codecs" */ - CODEC_ID_PCM_S16LE= $10000, - CODEC_ID_PCM_S16BE, - CODEC_ID_PCM_U16LE, - CODEC_ID_PCM_U16BE, - CODEC_ID_PCM_S8, - CODEC_ID_PCM_U8, - CODEC_ID_PCM_MULAW, - CODEC_ID_PCM_ALAW, - CODEC_ID_PCM_S32LE, - CODEC_ID_PCM_S32BE, - CODEC_ID_PCM_U32LE, - CODEC_ID_PCM_U32BE, - CODEC_ID_PCM_S24LE, - CODEC_ID_PCM_S24BE, - CODEC_ID_PCM_U24LE, - CODEC_ID_PCM_U24BE, - CODEC_ID_PCM_S24DAUD, - CODEC_ID_PCM_ZORK, - CODEC_ID_PCM_S16LE_PLANAR, - CODEC_ID_PCM_DVD, - CODEC_ID_PCM_F32BE, - CODEC_ID_PCM_F32LE, - CODEC_ID_PCM_F64BE, - CODEC_ID_PCM_F64LE, -{$IF LIBAVCODEC_VERSION >= 52034000} // >= 52.34.0 - CODEC_ID_PCM_BLURAY, -{$IFEND} - - //* various ADPCM codecs */ - CODEC_ID_ADPCM_IMA_QT= $11000, - CODEC_ID_ADPCM_IMA_WAV, - CODEC_ID_ADPCM_IMA_DK3, - CODEC_ID_ADPCM_IMA_DK4, - CODEC_ID_ADPCM_IMA_WS, - CODEC_ID_ADPCM_IMA_SMJPEG, - CODEC_ID_ADPCM_MS, - CODEC_ID_ADPCM_4XM, - CODEC_ID_ADPCM_XA, - CODEC_ID_ADPCM_ADX, - CODEC_ID_ADPCM_EA, - CODEC_ID_ADPCM_G726, - CODEC_ID_ADPCM_CT, - CODEC_ID_ADPCM_SWF, - CODEC_ID_ADPCM_YAMAHA, - CODEC_ID_ADPCM_SBPRO_4, - CODEC_ID_ADPCM_SBPRO_3, - CODEC_ID_ADPCM_SBPRO_2, - CODEC_ID_ADPCM_THP, - CODEC_ID_ADPCM_IMA_AMV, - CODEC_ID_ADPCM_EA_R1, - CODEC_ID_ADPCM_EA_R3, - CODEC_ID_ADPCM_EA_R2, - CODEC_ID_ADPCM_IMA_EA_SEAD, - CODEC_ID_ADPCM_IMA_EA_EACS, - CODEC_ID_ADPCM_EA_XAS, - CODEC_ID_ADPCM_EA_MAXIS_XA, - CODEC_ID_ADPCM_IMA_ISS, - - //* AMR */ - CODEC_ID_AMR_NB= $12000, - CODEC_ID_AMR_WB, - - //* RealAudio codecs*/ - CODEC_ID_RA_144= $13000, - CODEC_ID_RA_288, - - //* various DPCM codecs */ - CODEC_ID_ROQ_DPCM= $14000, - CODEC_ID_INTERPLAY_DPCM, - CODEC_ID_XAN_DPCM, - CODEC_ID_SOL_DPCM, - - (* audio codecs *) - CODEC_ID_MP2= $15000, - CODEC_ID_MP3, ///< preferred ID for decoding MPEG audio layer 1, 2 or 3 - CODEC_ID_AAC, - {$IF LIBAVCODEC_VERSION < 52000000} // < 52.0.0 - _CODEC_ID_MPEG4AAC, // will be redefined to CODEC_ID_AAC below - {$IFEND} - CODEC_ID_AC3, - CODEC_ID_DTS, - CODEC_ID_VORBIS, - CODEC_ID_DVAUDIO, - CODEC_ID_WMAV1, - CODEC_ID_WMAV2, - CODEC_ID_MACE3, - CODEC_ID_MACE6, - CODEC_ID_VMDAUDIO, - CODEC_ID_SONIC, - CODEC_ID_SONIC_LS, - CODEC_ID_FLAC, - CODEC_ID_MP3ADU, - CODEC_ID_MP3ON4, - CODEC_ID_SHORTEN, - CODEC_ID_ALAC, - CODEC_ID_WESTWOOD_SND1, - CODEC_ID_GSM, ///< as in Berlin toast format - CODEC_ID_QDM2, - CODEC_ID_COOK, - CODEC_ID_TRUESPEECH, - CODEC_ID_TTA, - CODEC_ID_SMACKAUDIO, - CODEC_ID_QCELP, - CODEC_ID_WAVPACK, - CODEC_ID_DSICINAUDIO, - CODEC_ID_IMC, - CODEC_ID_MUSEPACK7, - CODEC_ID_MLP, - CODEC_ID_GSM_MS, { as found in WAV } - CODEC_ID_ATRAC3, - CODEC_ID_VOXWARE, - CODEC_ID_APE, - CODEC_ID_NELLYMOSER, - CODEC_ID_MUSEPACK8, - CODEC_ID_SPEEX, - CODEC_ID_WMAVOICE, - CODEC_ID_WMAPRO, - CODEC_ID_WMALOSSLESS, - CODEC_ID_ATRAC3P, - CODEC_ID_EAC3, - CODEC_ID_SIPR, - CODEC_ID_MP1, -{$IF LIBAVCODEC_VERSION >= 52020000} // >= 52.20.0 - CODEC_ID_TWINVQ, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52022000} // >= 52.22.0 - CODEC_ID_TRUEHD, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52026000} // >= 52.26.0 - CODEC_ID_MP4ALS, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52035000} // >= 52.35.0 - CODEC_ID_ATRAC1, -{$IFEND} - - //* subtitle codecs */ - CODEC_ID_DVD_SUBTITLE= $17000, - CODEC_ID_DVB_SUBTITLE, - CODEC_ID_TEXT, ///< raw UTF-8 text - CODEC_ID_XSUB, - CODEC_ID_SSA, - CODEC_ID_MOV_TEXT, -{$IF LIBAVCODEC_VERSION >= 52033000} // >= 52.33.0 - CODEC_ID_HDMV_PGS_SUBTITLE, -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52037001} // >= 52.37.1 - CODEC_ID_DVB_TELETEXT, -{$IFEND} - - (* other specific kind of codecs (generally used for attachments) *) - CODEC_ID_TTF= $18000, - - CODEC_ID_PROBE= $19000, ///< codec_id is not known (like CODEC_ID_NONE) but lavf should attempt to identify it - - CODEC_ID_MPEG2TS= $20000, {*< _FAKE_ codec to indicate a raw MPEG-2 TS - * stream (only used by libavformat) *} - __CODEC_ID_4BYTE = $FFFFF // ensure 4-byte enum - ); - -{$IF LIBAVCODEC_VERSION < 52000000} // < 52.0.0 -{* CODEC_ID_MP3LAME is obsolete *} -const - CODEC_ID_MP3LAME = CODEC_ID_MP3; - CODEC_ID_MPEG4AAC = CODEC_ID_AAC; -{$IFEND} - -type - TCodecType = ( - CODEC_TYPE_UNKNOWN = -1, - CODEC_TYPE_VIDEO, - CODEC_TYPE_AUDIO, - CODEC_TYPE_DATA, - CODEC_TYPE_SUBTITLE, - CODEC_TYPE_ATTACHMENT, - CODEC_TYPE_NB - ); - -{** - * all in native endian - *} -type - TSampleFormat = ( - SAMPLE_FMT_NONE = -1, - SAMPLE_FMT_U8, ///< unsigned 8 bits - SAMPLE_FMT_S16, ///< signed 16 bits - SAMPLE_FMT_S32, ///< signed 32 bits - SAMPLE_FMT_FLT, ///< float - SAMPLE_FMT_DBL, ///< double - SAMPLE_FMT_NB ///< Number of sample formats. DO NOT USE if dynamically linking to libavcodec - ); - _TSampleFormatArray = array [0 .. MaxInt div SizeOf(TSampleFormat)-1] of TSampleFormat; - PSampleFormatArray = ^_TSampleFormatArray; - -const - {* Audio channel masks *} - CH_FRONT_LEFT = $00000001; - CH_FRONT_RIGHT = $00000002; - CH_FRONT_CENTER = $00000004; - CH_LOW_FREQUENCY = $00000008; - CH_BACK_LEFT = $00000010; - CH_BACK_RIGHT = $00000020; - CH_FRONT_LEFT_OF_CENTER = $00000040; - CH_FRONT_RIGHT_OF_CENTER = $00000080; - CH_BACK_CENTER = $00000100; - CH_SIDE_LEFT = $00000200; - CH_SIDE_RIGHT = $00000400; - CH_TOP_CENTER = $00000800; - CH_TOP_FRONT_LEFT = $00001000; - CH_TOP_FRONT_CENTER = $00002000; - CH_TOP_FRONT_RIGHT = $00004000; - CH_TOP_BACK_LEFT = $00008000; - CH_TOP_BACK_CENTER = $00010000; - CH_TOP_BACK_RIGHT = $00020000; - CH_STEREO_LEFT = $20000000; ///< Stereo downmix. - CH_STEREO_RIGHT = $40000000; ///< See CH_STEREO_LEFT. -{** Channel mask value used for AVCodecContext.request_channel_layout - * to indicate that the user requests the channel order of the decoder output - * to be the native codec channel order. - *} -{$IF LIBAVCODEC_VERSION >= 52038001} // >= 52.38.1 - CH_LAYOUT_NATIVE = $8000000000000000; -{$IFEND} - {* Audio channel convenience macros *} - CH_LAYOUT_MONO = (CH_FRONT_CENTER); - CH_LAYOUT_STEREO = (CH_FRONT_LEFT or CH_FRONT_RIGHT); - CH_LAYOUT_SURROUND = (CH_LAYOUT_STEREO or CH_FRONT_CENTER); -{$IF LIBAVCODEC_VERSION >= 52027000} // >= 52.27.0 - CH_LAYOUT_2_1 = (CH_LAYOUT_STEREO or CH_BACK_CENTER); - CH_LAYOUT_4POINT0 = (CH_LAYOUT_SURROUND or CH_BACK_CENTER); - CH_LAYOUT_2_2 = (CH_LAYOUT_STEREO or CH_SIDE_LEFT or CH_SIDE_RIGHT); -{$IFEND} - CH_LAYOUT_QUAD = (CH_LAYOUT_STEREO or CH_BACK_LEFT or CH_BACK_RIGHT); - CH_LAYOUT_5POINT0 = (CH_LAYOUT_SURROUND or CH_SIDE_LEFT or CH_SIDE_RIGHT); - CH_LAYOUT_5POINT1 = (CH_LAYOUT_5POINT0 or CH_LOW_FREQUENCY); -{$IF LIBAVCODEC_VERSION >= 52025000} // >= 52.25.0 - CH_LAYOUT_5POINT0_BACK = (CH_LAYOUT_SURROUND or CH_BACK_LEFT or - CH_BACK_RIGHT); - CH_LAYOUT_5POINT1_BACK = (CH_LAYOUT_5POINT0_BACK or CH_LOW_FREQUENCY); -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52034000} // >= 52.34.0 - CH_LAYOUT_7POINT0 = (CH_LAYOUT_5POINT0 or CH_BACK_LEFT or CH_BACK_RIGHT); -{$IFEND} - CH_LAYOUT_7POINT1 = (CH_LAYOUT_5POINT1 or CH_BACK_LEFT or CH_BACK_RIGHT); -{$IF LIBAVCODEC_VERSION < 52025000} // < 52.25.0 - CH_LAYOUT_7POINT1_WIDE = (CH_LAYOUT_SURROUND or CH_LOW_FREQUENCY or - CH_BACK_LEFT or CH_BACK_RIGHT or -{$ELSE} - CH_LAYOUT_7POINT1_WIDE = (CH_LAYOUT_5POINT1_BACK or -{$IFEND} - CH_FRONT_LEFT_OF_CENTER or - CH_FRONT_RIGHT_OF_CENTER); - CH_LAYOUT_STEREO_DOWNMIX = (CH_STEREO_LEFT or CH_STEREO_RIGHT); - - -const - {* in bytes *} - AVCODEC_MAX_AUDIO_FRAME_SIZE = 192000; // 1 second of 48khz 32bit audio - -{** - * Required number of additionally allocated bytes at the end of the input bitstream for decoding. - * This is mainly needed because some optimized bitstream readers read - * 32 or 64 bit at once and could read over the end.
- * Note: If the first 23 bits of the additional bytes are not 0, then damaged - * MPEG bitstreams could cause overread and segfault. - *} - FF_INPUT_BUFFER_PADDING_SIZE = 8; - -{** - * minimum encoding buffer size. - * Used to avoid some checks during header writing. - *} - FF_MIN_BUFFER_SIZE = 16384; - -type -{* - * motion estimation type. - *} - TMotion_Est_ID = ( - ME_ZERO = 1, ///< no search, that is use 0,0 vector whenever one is needed - ME_FULL, - ME_LOG, - ME_PHODS, - ME_EPZS, ///< enhanced predictive zonal search - ME_X1, ///< reserved for experiments - ME_HEX, ///< hexagon based search - ME_UMH, ///< uneven multi-hexagon search - ME_ITER, ///< iterative search - ME_TESA ///< transformed exhaustive search algorithm - ); - - TAVDiscard = ( - {* We leave some space between them for extensions (drop some - * keyframes for intra-only or drop just some bidir frames). - *} - AVDISCARD_NONE = -16, ///< discard nothing - AVDISCARD_DEFAULT = 0, ///< discard useless packets like 0 size packets in avi - AVDISCARD_NONREF = 8, ///< discard all non reference - AVDISCARD_BIDIR = 16, ///< discard all bidirectional frames - AVDISCARD_NONKEY = 32, ///< discard all frames except keyframes - AVDISCARD_ALL = 48 ///< discard all - ); - -{$IF LIBAVCODEC_VERSION >= 52028000} // >= 52.28.0 - TAVColorPrimaries = ( - AVCOL_PRI_BT709 = 1, ///< also ITU-R BT1361 / IEC 61966-2-4 / SMPTE RP177 Annex B - AVCOL_PRI_UNSPECIFIED = 2, - AVCOL_PRI_BT470M = 4, - AVCOL_PRI_BT470BG = 5, ///< also ITU-R BT601-6 625 / ITU-R BT1358 625 / ITU-R BT1700 625 PAL & SECAM - AVCOL_PRI_SMPTE170M = 6, ///< also ITU-R BT601-6 525 / ITU-R BT1358 525 / ITU-R BT1700 NTSC - AVCOL_PRI_SMPTE240M = 7, ///< functionally identical to above - AVCOL_PRI_FILM = 8, - AVCOL_PRI_NB ///< Not part of ABI - ); - - TAVColorTransferCharacteristic = ( - AVCOL_TRC_BT709 = 1, ///< also ITU-R BT1361 - AVCOL_TRC_UNSPECIFIED = 2, - AVCOL_TRC_GAMMA22 = 4, ///< also ITU-R BT470M / ITU-R BT1700 625 PAL & SECAM - AVCOL_TRC_GAMMA28 = 5, ///< also ITU-R BT470BG - AVCOL_TRC_NB ///< Not part of ABI - ); - - TAVColorSpace = ( - AVCOL_SPC_RGB = 0, - AVCOL_SPC_BT709 = 1, ///< also ITU-R BT1361 / IEC 61966-2-4 xvYCC709 / SMPTE RP177 Annex B - AVCOL_SPC_UNSPECIFIED = 2, - AVCOL_SPC_FCC = 4, - AVCOL_SPC_BT470BG = 5, ///< also ITU-R BT601-6 625 / ITU-R BT1358 625 / ITU-R BT1700 625 PAL & SECAM / IEC 61966-2-4 xvYCC601 - AVCOL_SPC_SMPTE170M = 6, ///< also ITU-R BT601-6 525 / ITU-R BT1358 525 / ITU-R BT1700 NTSC / functionally identical to above - AVCOL_SPC_SMPTE240M = 7, - AVCOL_SPC_NB ///< Not part of ABI - ); - - TAVColorRange = ( - AVCOL_RANGE_UNSPECIFIED = 0, - AVCOL_RANGE_MPEG = 1, ///< the normal 219*2^(n-8) "MPEG" YUV ranges - AVCOL_RANGE_JPEG = 2, ///< the normal 2^n-1 "JPEG" YUV ranges - AVCOL_RANGE_NB ///< Not part of ABI - ); - -(** - * X X 3 4 X X are luma samples, - * 1 2 1-6 are possible chroma positions - * X X 5 6 X 0 is undefined/unknown position - *) - TAVChromaLocation = ( - AVCHROMA_LOC_UNSPECIFIED = 0, - AVCHROMA_LOC_LEFT = 1, ///< mpeg2/4, h264 default - AVCHROMA_LOC_CENTER = 2, ///< mpeg1, jpeg, h263 - AVCHROMA_LOC_TOPLEFT = 3, ///< DV - AVCHROMA_LOC_TOP = 4, - AVCHROMA_LOC_BOTTOMLEFT = 5, - AVCHROMA_LOC_BOTTOM = 6, - AVCHROMA_LOC_NB ///< Not part of ABI - ); -{$IFEND} - - PRcOverride = ^TRcOverride; - TRcOverride = record {16} - start_frame: cint; - end_frame: cint; - qscale: cint; // if this is 0 then quality_factor will be used instead - quality_factor: cfloat; - end; - -const - FF_MAX_B_FRAMES = 16; - -{* encoding support - These flags can be passed in AVCodecContext.flags before initialization. - Note: Not everything is supported yet. -*} - - CODEC_FLAG_QSCALE = $0002; ///< Use fixed qscale. - CODEC_FLAG_4MV = $0004; ///< 4 MV per MB allowed / advanced prediction for H263. - CODEC_FLAG_QPEL = $0010; ///< use qpel MC. - CODEC_FLAG_GMC = $0020; ///< use GMC. - CODEC_FLAG_MV0 = $0040; ///< always try a MB with MV=<0,0>. - CODEC_FLAG_PART = $0080; ///< Use data partitioning. - {** - * The parent program guarantees that the input for B-frames containing - * streams is not written to for at least s->max_b_frames+1 frames, if - * this is not set the input will be copied. - *} - CODEC_FLAG_INPUT_PRESERVED = $0100; - CODEC_FLAG_PASS1 = $0200; ///< use internal 2pass ratecontrol in first pass mode - CODEC_FLAG_PASS2 = $0400; ///< use internal 2pass ratecontrol in second pass mode - CODEC_FLAG_EXTERN_HUFF = $1000; ///< use external huffman table (for mjpeg) - CODEC_FLAG_GRAY = $2000; ///< only decode/encode grayscale - CODEC_FLAG_EMU_EDGE = $4000; ///< don't draw edges - CODEC_FLAG_PSNR = $8000; ///< error[?] variables will be set during encoding - CODEC_FLAG_TRUNCATED = $00010000; //** input bitstream might be truncated at a random location instead - // of only at frame boundaries */ - CODEC_FLAG_NORMALIZE_AQP = $00020000; ///< normalize adaptive quantization - CODEC_FLAG_INTERLACED_DCT = $00040000; ///< use interlaced dct - CODEC_FLAG_LOW_DELAY = $00080000; ///< force low delay - CODEC_FLAG_ALT_SCAN = $00100000; ///< use alternate scan - {$IF LIBAVCODEC_VERSION < 52000000} // < 52.0.0 - CODEC_FLAG_TRELLIS_QUANT = $00200000; ///< use trellis quantization - {$IFEND} - CODEC_FLAG_GLOBAL_HEADER = $00400000; ///< place global headers in extradata instead of every keyframe - CODEC_FLAG_BITEXACT = $00800000; ///< use only bitexact stuff (except (i)dct) - {* Fx : Flag for h263+ extra options *} - {$IF LIBAVCODEC_VERSION < 52000000} // < 52.0.0 - CODEC_FLAG_H263P_AIC = $01000000; ///< H263 Advanced intra coding / MPEG4 AC prediction (remove this) - {$IFEND} - CODEC_FLAG_AC_PRED = $01000000; ///< H263 Advanced intra coding / MPEG4 AC prediction - CODEC_FLAG_H263P_UMV = $02000000; ///< Unlimited motion vector - CODEC_FLAG_CBP_RD = $04000000; ///< use rate distortion optimization for cbp - CODEC_FLAG_QP_RD = $08000000; ///< use rate distortion optimization for qp selectioon - CODEC_FLAG_H263P_AIV = $00000008; ///< H263 Alternative inter vlc - CODEC_FLAG_OBMC = $00000001; ///< OBMC - CODEC_FLAG_LOOP_FILTER = $00000800; ///< loop filter - CODEC_FLAG_H263P_SLICE_STRUCT = $10000000; - CODEC_FLAG_INTERLACED_ME = $20000000; ///< interlaced motion estimation - CODEC_FLAG_SVCD_SCAN_OFFSET = $40000000; ///< will reserve space for SVCD scan offset user data - CODEC_FLAG_CLOSED_GOP = $80000000; - CODEC_FLAG2_FAST = $00000001; ///< allow non spec compliant speedup tricks - CODEC_FLAG2_STRICT_GOP = $00000002; ///< strictly enforce GOP size - CODEC_FLAG2_NO_OUTPUT = $00000004; ///< skip bitstream encoding - CODEC_FLAG2_LOCAL_HEADER = $00000008; ///< place global headers at every keyframe instead of in extradata - CODEC_FLAG2_BPYRAMID = $00000010; ///< H.264 allow b-frames to be used as references - CODEC_FLAG2_WPRED = $00000020; ///< H.264 weighted biprediction for b-frames - CODEC_FLAG2_MIXED_REFS = $00000040; ///< H.264 multiple references per partition - CODEC_FLAG2_8X8DCT = $00000080; ///< H.264 high profile 8x8 transform - CODEC_FLAG2_FASTPSKIP = $00000100; ///< H.264 fast pskip - CODEC_FLAG2_AUD = $00000200; ///< H.264 access unit delimiters - CODEC_FLAG2_BRDO = $00000400; ///< b-frame rate-distortion optimization - CODEC_FLAG2_INTRA_VLC = $00000800; ///< use MPEG-2 intra VLC table - CODEC_FLAG2_MEMC_ONLY = $00001000; ///< only do ME/MC (I frames -> ref, P frame -> ME+MC) - CODEC_FLAG2_DROP_FRAME_TIMECODE = $00002000; ///< timecode is in drop frame format. - CODEC_FLAG2_SKIP_RD = $00004000; ///< RD optimal MB level residual skipping - CODEC_FLAG2_CHUNKS = $00008000; ///< Input bitstream might be truncated at a packet boundaries instead of only at frame boundaries. - CODEC_FLAG2_NON_LINEAR_QUANT = $00010000; ///< Use MPEG-2 nonlinear quantizer. - CODEC_FLAG2_BIT_RESERVOIR = $00020000; ///< Use a bit reservoir when encoding if possible - -(* Unsupported options : - * Syntax Arithmetic coding (SAC) - * Reference Picture Selection - * Independant Segment Decoding *) -(* /Fx *) -(* codec capabilities *) - -const - CODEC_CAP_DRAW_HORIZ_BAND = $0001; ///< decoder can use draw_horiz_band callback - (** - * Codec uses get_buffer() for allocating buffers. - * direct rendering method 1 - *) - CODEC_CAP_DR1 = $0002; - (* if 'parse_only' field is true, then avcodec_parse_frame() can be used *) - CODEC_CAP_PARSE_ONLY = $0004; - CODEC_CAP_TRUNCATED = $0008; - (* codec can export data for HW decoding (XvMC) *) - CODEC_CAP_HWACCEL = $0010; - (** - * codec has a non zero delay and needs to be feeded with NULL at the end to get the delayed data. - * if this is not set, the codec is guranteed to never be feeded with NULL data - *) - CODEC_CAP_DELAY = $0020; - (** - * Codec can be fed a final frame with a smaller size. - * This can be used to prevent truncation of the last audio samples. - *) - CODEC_CAP_SMALL_LAST_FRAME = $0040; - - (** - * Codec can export data for HW decoding (VDPAU). - *) - CODEC_CAP_HWACCEL_VDPAU = $0080; - - {$IF LIBAVCODEC_VERSION >= 52035000} // >= 52.35.0 - (** - * Codec can output multiple frames per AVPacket - *) - CODEC_CAP_SUBFRAMES = $0100; - {$IFEND} - - //the following defines may change, don't expect compatibility if you use them - MB_TYPE_INTRA4x4 = $001; - MB_TYPE_INTRA16x16 = $002; //FIXME h264 specific - MB_TYPE_INTRA_PCM = $004; //FIXME h264 specific - MB_TYPE_16x16 = $008; - MB_TYPE_16x8 = $010; - MB_TYPE_8x16 = $020; - MB_TYPE_8x8 = $040; - MB_TYPE_INTERLACED = $080; - MB_TYPE_DIRECT2 = $100; //FIXME - MB_TYPE_ACPRED = $200; - MB_TYPE_GMC = $400; - MB_TYPE_SKIP = $800; - MB_TYPE_P0L0 = $1000; - MB_TYPE_P1L0 = $2000; - MB_TYPE_P0L1 = $4000; - MB_TYPE_P1L1 = $8000; - MB_TYPE_L0 = (MB_TYPE_P0L0 or MB_TYPE_P1L0); - MB_TYPE_L1 = (MB_TYPE_P0L1 or MB_TYPE_P1L1); - MB_TYPE_L0L1 = (MB_TYPE_L0 or MB_TYPE_L1); - MB_TYPE_QUANT = $0010000; - MB_TYPE_CBP = $0020000; - //Note bits 24-31 are reserved for codec specific use (h264 ref0, mpeg1 0mv, ...) - -type -(** - * Pan Scan area. - * This specifies the area which should be displayed. - * Note there may be multiple such areas for one frame. - *) - PAVPanScan = ^TAVPanScan; - TAVPanScan = record {24} - (*** id. - * - encoding: set by user. - * - decoding: set by libavcodec. *) - id: cint; - - (*** width and height in 1/16 pel - * - encoding: set by user. - * - decoding: set by libavcodec. *) - width: cint; - height: cint; - - (*** position of the top left corner in 1/16 pel for up to 3 fields/frames. - * - encoding: set by user. - * - decoding: set by libavcodec. *) - position: array [0..2] of array [0..1] of smallint; - end; - -const - FF_QSCALE_TYPE_MPEG1 = 0; - FF_QSCALE_TYPE_MPEG2 = 1; - FF_QSCALE_TYPE_H264 = 2; - - FF_BUFFER_TYPE_INTERNAL = 1; - FF_BUFFER_TYPE_USER = 2; ///< Direct rendering buffers (image is (de)allocated by user) - FF_BUFFER_TYPE_SHARED = 4; ///< buffer from somewhere else, don't dealloc image (data/base), all other tables are not shared - FF_BUFFER_TYPE_COPY = 8; ///< just a (modified) copy of some other buffer, don't dealloc anything. - - - FF_I_TYPE = 1; ///< Intra - FF_P_TYPE = 2; ///< Predicted - FF_B_TYPE = 3; ///< Bi-dir predicted - FF_S_TYPE = 4; ///< S(GMC)-VOP MPEG4 - FF_SI_TYPE = 5; ///< Switching Intra - FF_SP_TYPE = 6; ///< Switching Predicted - FF_BI_TYPE = 7; - - FF_BUFFER_HINTS_VALID = $01; // Buffer hints value is meaningful (if 0 ignore) - FF_BUFFER_HINTS_READABLE = $02; // Codec will read from buffer - FF_BUFFER_HINTS_PRESERVE = $04; // User must not alter buffer content - FF_BUFFER_HINTS_REUSABLE = $08; // Codec will reuse the buffer (update) - -const - {$IF LIBAVCODEC_VERSION < 52000000} // < 52.0.0 - DEFAULT_FRAME_RATE_BASE = 1001000; - {$IFEND} - - FF_ASPECT_EXTENDED = 15; - - FF_RC_STRATEGY_XVID = 1; - - FF_BUG_AUTODETECT = 1; ///< autodetection - FF_BUG_OLD_MSMPEG4 = 2; - FF_BUG_XVID_ILACE = 4; - FF_BUG_UMP4 = 8; - FF_BUG_NO_PADDING = 16; - FF_BUG_AMV = 32; - FF_BUG_AC_VLC = 0; ///< will be removed, libavcodec can now handle these non compliant files by default - FF_BUG_QPEL_CHROMA = 64; - FF_BUG_STD_QPEL = 128; - FF_BUG_QPEL_CHROMA2 = 256; - FF_BUG_DIRECT_BLOCKSIZE = 512; - FF_BUG_EDGE = 1024; - FF_BUG_HPEL_CHROMA = 2048; - FF_BUG_DC_CLIP = 4096; - FF_BUG_MS = 8192; ///< workaround various bugs in microsofts broken decoders - //FF_BUG_FAKE_SCALABILITY = 16 //Autodetection should work 100%. - - FF_COMPLIANCE_VERY_STRICT = 2; ///< strictly conform to a older more strict version of the spec or reference software - FF_COMPLIANCE_STRICT = 1; ///< strictly conform to all the things in the spec no matter what consequences - FF_COMPLIANCE_NORMAL = 0; - FF_COMPLIANCE_INOFFICIAL = -1; ///< allow inofficial extensions - FF_COMPLIANCE_EXPERIMENTAL = -2; ///< allow non standarized experimental things - - FF_ER_CAREFUL = 1; - FF_ER_COMPLIANT = 2; - FF_ER_AGGRESSIVE = 3; - FF_ER_VERY_AGGRESSIVE = 4; - - FF_DCT_AUTO = 0; - FF_DCT_FASTINT = 1; - FF_DCT_INT = 2; - FF_DCT_MMX = 3; - FF_DCT_MLIB = 4; - FF_DCT_ALTIVEC = 5; - FF_DCT_FAAN = 6; - - FF_IDCT_AUTO = 0; - FF_IDCT_INT = 1; - FF_IDCT_SIMPLE = 2; - FF_IDCT_SIMPLEMMX = 3; - FF_IDCT_LIBMPEG2MMX = 4; - FF_IDCT_PS2 = 5; - FF_IDCT_MLIB = 6; - FF_IDCT_ARM = 7; - FF_IDCT_ALTIVEC = 8; - FF_IDCT_SH4 = 9; - FF_IDCT_SIMPLEARM = 10; - FF_IDCT_H264 = 11; - FF_IDCT_VP3 = 12; - FF_IDCT_IPP = 13; - FF_IDCT_XVIDMMX = 14; - FF_IDCT_CAVS = 15; - FF_IDCT_SIMPLEARMV5TE= 16; - FF_IDCT_SIMPLEARMV6 = 17; - FF_IDCT_SIMPLEVIS = 18; - FF_IDCT_WMV2 = 19; - FF_IDCT_FAAN = 20; - FF_IDCT_EA = 21; - FF_IDCT_SIMPLENEON = 22; - FF_IDCT_SIMPLEALPHA = 23; - - FF_EC_GUESS_MVS = 1; - FF_EC_DEBLOCK = 2; - - FF_MM_FORCE = $80000000; (* force usage of selected flags (OR) *) - (* lower 16 bits - CPU features *) - FF_MM_MMX = $0001; ///< standard MMX - FF_MM_3DNOW = $0004; ///< AMD 3DNOW - {$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} - FF_MM_MMXEXT = $0002; ///< SSE integer functions or AMD MMX ext - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52024000} // >= 52.24.0 - FF_MM_MMX2 = $0002; ///< SSE integer functions or AMD MMX ext - {$IFEND} - FF_MM_SSE = $0008; ///< SSE functions - FF_MM_SSE2 = $0010; ///< PIV SSE2 functions - FF_MM_3DNOWEXT = $0020; ///< AMD 3DNowExt - FF_MM_SSE3 = $0040; ///< Prescott SSE3 functions - FF_MM_SSSE3 = $0080; ///< Conroe SSSE3 functions - {$IF LIBAVCODEC_VERSION >= 52022003} // >= 52.22.3 - FF_MM_SSE4 = $0100; ///< Penryn SSE4.1 functions - FF_MM_SSE42 = $0200; ///< Nehalem SSE4.2 functions - {$IFEND} - FF_MM_IWMMXT = $0100; ///< XScale IWMMXT - FF_MM_ALTIVEC = $0001; ///< standard AltiVec - - FF_PRED_LEFT = 0; - FF_PRED_PLANE = 1; - FF_PRED_MEDIAN = 2; - - FF_DEBUG_PICT_INFO = 1; - FF_DEBUG_RC = 2; - FF_DEBUG_BITSTREAM = 4; - FF_DEBUG_MB_TYPE = 8; - FF_DEBUG_QP = 16; - FF_DEBUG_MV = 32; - FF_DEBUG_DCT_COEFF = $00000040; - FF_DEBUG_SKIP = $00000080; - FF_DEBUG_STARTCODE = $00000100; - FF_DEBUG_PTS = $00000200; - FF_DEBUG_ER = $00000400; - FF_DEBUG_MMCO = $00000800; - FF_DEBUG_BUGS = $00001000; - FF_DEBUG_VIS_QP = $00002000; - FF_DEBUG_VIS_MB_TYPE = $00004000; - FF_DEBUG_BUFFERS = $00008000; - - FF_DEBUG_VIS_MV_P_FOR = $00000001; //visualize forward predicted MVs of P frames - FF_DEBUG_VIS_MV_B_FOR = $00000002; //visualize forward predicted MVs of B frames - FF_DEBUG_VIS_MV_B_BACK = $00000004; //visualize backward predicted MVs of B frames - - FF_CMP_SAD = 0; - FF_CMP_SSE = 1; - FF_CMP_SATD = 2; - FF_CMP_DCT = 3; - FF_CMP_PSNR = 4; - FF_CMP_BIT = 5; - FF_CMP_RD = 6; - FF_CMP_ZERO = 7; - FF_CMP_VSAD = 8; - FF_CMP_VSSE = 9; - FF_CMP_NSSE = 10; - FF_CMP_W53 = 11; - FF_CMP_W97 = 12; - FF_CMP_DCTMAX = 13; - FF_CMP_DCT264 = 14; - FF_CMP_CHROMA = 256; - - FF_DTG_AFD_SAME = 8; - FF_DTG_AFD_4_3 = 9; - FF_DTG_AFD_16_9 = 10; - FF_DTG_AFD_14_9 = 11; - FF_DTG_AFD_4_3_SP_14_9 = 13; - FF_DTG_AFD_16_9_SP_14_9 = 14; - FF_DTG_AFD_SP_4_3 = 15; - - FF_DEFAULT_QUANT_BIAS = 999999; - - FF_LAMBDA_SHIFT = 7; - FF_LAMBDA_SCALE = (1 shl FF_LAMBDA_SHIFT); - FF_QP2LAMBDA = 118; ///< factor to convert from H.263 QP to lambda - FF_LAMBDA_MAX = (256 * 128 - 1); - - FF_QUALITY_SCALE = FF_LAMBDA_SCALE; //FIXME maybe remove - - FF_CODER_TYPE_VLC = 0; - FF_CODER_TYPE_AC = 1; - FF_CODER_TYPE_RAW = 2; - FF_CODER_TYPE_RLE = 3; - FF_CODER_TYPE_DEFLATE = 4; - - SLICE_FLAG_CODED_ORDER = $0001; ///< draw_horiz_band() is called in coded order instead of display - SLICE_FLAG_ALLOW_FIELD = $0002; ///< allow draw_horiz_band() with field slices (MPEG2 field pics) - SLICE_FLAG_ALLOW_PLANE = $0004; ///< allow draw_horiz_band() with 1 component at a time (SVQ1) - - FF_MB_DECISION_SIMPLE = 0; ///< uses mb_cmp - FF_MB_DECISION_BITS = 1; ///< chooses the one which needs the fewest bits - FF_MB_DECISION_RD = 2; ///< rate distortion - - FF_AA_AUTO = 0; - FF_AA_FASTINT = 1; //not implemented yet - FF_AA_INT = 2; - FF_AA_FLOAT = 3; - - FF_PROFILE_UNKNOWN = -99; - FF_PROFILE_AAC_MAIN = 0; - FF_PROFILE_AAC_LOW = 1; - FF_PROFILE_AAC_SSR = 2; - FF_PROFILE_AAC_LTP = 3; - - FF_LEVEL_UNKNOWN = -99; - - X264_PART_I4X4 = $001; (* Analyse i4x4 *) - X264_PART_I8X8 = $002; (* Analyse i8x8 (requires 8x8 transform) *) - X264_PART_P8X8 = $010; (* Analyse p16x8, p8x16 and p8x8 *) - X264_PART_P4X4 = $020; (* Analyse p8x4, p4x8, p4x4 *) - X264_PART_B8X8 = $100; (* Analyse b16x8, b8x16 and b8x8 *) - - FF_COMPRESSION_DEFAULT = -1; - -const - AVPALETTE_SIZE = 1024; - AVPALETTE_COUNT = 256; - -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} -type -(** - * AVPaletteControl - * This structure defines a method for communicating palette changes - * between and demuxer and a decoder. - * - * @deprecated Use AVPacket to send palette changes instead. - * This is totally broken. - *) - PAVPaletteControl = ^TAVPaletteControl; - TAVPaletteControl = record - (* demuxer sets this to 1 to indicate the palette has changed; - * decoder resets to 0 *) - palette_changed: cint; - - (* 4-byte ARGB palette entries, stored in native byte order; note that - * the individual palette components should be on a 8-bit scale; if - * the palette data comes from a IBM VGA native format, the component - * data is probably 6 bits in size and needs to be scaled *) - palette: array [0..AVPALETTE_COUNT - 1] of cuint; - end; {deprecated;} -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52023000} // >= 52.23.0 -type - PAVPacket = ^TAVPacket; - TAVPacket = record -(* - * Presentation timestamp in AVStream->time_base units; the time at which - * the decompressed packet will be presented to the user. - * Can be AV_NOPTS_VALUE if it is not stored in the file. - * pts MUST be larger or equal to dts as presentation cannot happen before - * decompression, unless one wants to view hex dumps. Some formats misuse - * the terms dts and pts/cts to mean something different. Such timestamps - * must be converted to true pts/dts before they are stored in AVPacket. - *) - pts: cint64; -(* - * Decompression timestamp in AVStream->time_base units; the time at which - * the packet is decompressed. - * Can be AV_NOPTS_VALUE if it is not stored in the file. - *) - dts: cint64; - data: PByteArray; - size: cint; - stream_index: cint; - flags: cint; -(* - * Duration of this packet in AVStream->time_base units, 0 if unknown. - * Equals next_pts - this_pts in presentation order. - *) - duration: cint; - destruct: procedure (para1: PAVPacket); cdecl; - priv: pointer; - pos: cint64; // byte position in stream, -1 if unknown - -(* - * Time difference in AVStream->time_base units from the pts of this - * packet to the point at which the output from the decoder has converged - * independent from the availability of previous frames. That is, the - * frames are virtually identical no matter if decoding started from - * the very first frame or from this keyframe. - * Is AV_NOPTS_VALUE if unknown. - * This field is not the display duration of the current packet. - * - * The purpose of this field is to allow seeking in streams that have no - * keyframes in the conventional sense. It corresponds to the - * recovery point SEI in H.264 and match_time_delta in NUT. It is also - * essential for some types of subtitle streams to ensure that all - * subtitles are correctly displayed after seeking. - *) - convergence_duration: cint64; - end; - -const - {$IF LIBAVCODEC_VERSION >= 52030002} // >= 52.30.2 - PKT_FLAG_KEY = $0001; - {$ELSE} - AV_PKT_FLAG_KEY = $0001; - {$IF LIBAVCODEC_VERSION_MAJOR < 53} - PKT_FLAG_KEY = AV_PKT_FLAG_KEY; - {$IFEND} - {$IFEND} -{$IFEND} - -type - PAVClass = ^TAVClass; {const} - PAVCodecContext = ^TAVCodecContext; - - PAVCodec = ^TAVCodec; - -{$IF LIBAVCODEC_VERSION >= 52018000} // >= 52.18.0 - PAVHWAccel = ^TAVHWAccel; -{$IFEND} - - // int[4] - PQuadIntArray = ^TQuadIntArray; - TQuadIntArray = array[0..3] of cint; - // int (*func)(struct AVCodecContext *c2, void *arg) - TExecuteFunc = function(c2: PAVCodecContext; arg: Pointer): cint; cdecl; -{$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 - // int (*func)(struct AVCodecContext *c2, void *arg, int jobnr, int threadnr) - TExecute2Func = function(c2: PAVCodecContext; arg: Pointer; jobnr: cint; threadnr: cint): cint; cdecl; -{$IFEND} - - TAVClass = record - class_name: PAnsiChar; - (* actually passing a pointer to an AVCodecContext - or AVFormatContext, which begin with an AVClass. - Needed because av_log is in libavcodec and has no visibility - of AVIn/OutputFormat *) - item_name: function(): PAnsiChar; cdecl; - option: PAVOption; - end; - - {** - * Audio Video Frame. - * New fields can be added to the end of FF_COMMON_FRAME with minor version - * bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. No fields should be added into AVFrame before or after - * FF_COMMON_FRAME! - * sizeof(AVFrame) must not be used outside libav*. - *} - PAVFrame = ^TAVFrame; - TAVFrame = record {200} - (** - * pointer to the picture planes. - * This might be different from the first allocated byte - * - encoding: - * - decoding: - *) - data: array [0..3] of pbyte; - linesize: array [0..3] of cint; - (** - * pointer to the first allocated byte of the picture. Can be used in get_buffer/release_buffer. - * This isn't used by libavcodec unless the default get/release_buffer() is used. - * - encoding: - * - decoding: - *) - base: array [0..3] of pbyte; - (** - * 1 -> keyframe, 0-> not - * - encoding: Set by libavcodec. - * - decoding: Set by libavcodec. - *) - key_frame: cint; - (** - * Picture type of the frame, see ?_TYPE below. - * - encoding: Set by libavcodec. for coded_picture (and set by user for input). - * - decoding: Set by libavcodec. - *) - pict_type: cint; - (** - * presentation timestamp in time_base units (time when frame should be shown to user) - * If AV_NOPTS_VALUE then frame_rate = 1/time_base will be assumed. - * - encoding: MUST be set by user. - * - decoding: Set by libavcodec. - *) - pts: cint64; - (** - * picture number in bitstream order - * - encoding: set by - * - decoding: Set by libavcodec. - *) - coded_picture_number: cint; - (** - * picture number in display order - * - encoding: set by - * - decoding: Set by libavcodec. - *) - display_picture_number: cint; - (** - * quality (between 1 (good) and FF_LAMBDA_MAX (bad)) - * - encoding: Set by libavcodec. for coded_picture (and set by user for input). - * - decoding: Set by libavcodec. - *) - quality: cint; - (** - * buffer age (1->was last buffer and dint change, 2->..., ...). - * Set to INT_MAX if the buffer has not been used yet. - * - encoding: unused - * - decoding: MUST be set by get_buffer(). - *) - age: cint; - (** - * is this picture used as reference - * The values for this are the same as the MpegEncContext.picture_structure - * variable, that is 1->top field, 2->bottom field, 3->frame/both fields. - * Set to 4 for delayed, non-reference frames. - * - encoding: unused - * - decoding: Set by libavcodec. (before get_buffer() call)). - *) - reference: cint; - (** - * QP table - * - encoding: unused - * - decoding: Set by libavcodec. - *) - qscale_table: PShortint; - (** - * QP store stride - * - encoding: unused - * - decoding: Set by libavcodec. - *) - qstride: cint; - (** - * mbskip_table[mb]>=1 if MB didn't change - * stride= mb_width = (width+15)>>4 - * - encoding: unused - * - decoding: Set by libavcodec. - *) - mbskip_table: pbyte; - (** - * motion vector table - * @code - * example: - * int mv_sample_log2= 4 - motion_subsample_log2; - * int mb_width= (width+15)>>4; - * int mv_stride= (mb_width << mv_sample_log2) + 1; - * motion_val[direction][x + y*mv_stride][0->mv_x, 1->mv_y]; - * @endcode - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - //int16_t (*motion_val[2])[2]; - motion_val: array [0..1] of pointer; - (** - * macroblock type table - * mb_type_base + mb_width + 2 - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - mb_type: PCuint; - (** - * log2 of the size of the block which a single vector in motion_val represents: - * (4->16x16, 3->8x8, 2-> 4x4, 1-> 2x2) - * - encoding: unused - * - decoding: Set by libavcodec. - *) - motion_subsample_log2: byte; - (** - * for some private data of the user - * - encoding: unused - * - decoding: Set by user. - *) - opaque: pointer; - (** - * error - * - encoding: Set by libavcodec. if flags&CODEC_FLAG_PSNR. - * - decoding: unused - *) - error: array [0..3] of cuint64; - (** - * type of the buffer (to keep track of who has to deallocate data[*]) - * - encoding: Set by the one who allocates it. - * - decoding: Set by the one who allocates it. - * Note: User allocated (direct rendering) & internal buffers cannot coexist currently. - *) - type_: cint; - (** - * When decoding, this signals how much the picture must be delayed. - * extra_delay = repeat_pict / (2*fps) - * - encoding: unused - * - decoding: Set by libavcodec. - *) - repeat_pict: cint; - (** - * - *) - qscale_type: cint; - (** - * The content of the picture is interlaced. - * - encoding: Set by user. - * - decoding: Set by libavcodec. (default 0) - *) - interlaced_frame: cint; - (** - * If the content is interlaced, is top field displayed first. - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - top_field_first: cint; - (** - * Pan scan. - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - pan_scan: PAVPanScan; - (** - * Tell user application that palette has changed from previous frame. - * - encoding: ??? (no palette-enabled encoder yet) - * - decoding: Set by libavcodec. (default 0). - *) - palette_has_changed: cint; - (** - * codec suggestion on buffer type if != 0 - * - encoding: unused - * - decoding: Set by libavcodec. (before get_buffer() call)). - *) - buffer_hints: cint; - (** - * DCT coefficients - * - encoding: unused - * - decoding: Set by libavcodec. - *) - dct_coeff: PsmallInt; - (** - * motion referece frame index - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - ref_index: array [0..1] of PShortint; - - {$IF LIBAVCODEC_VERSION >= 51068000} // >= 51.68.0 - (** - * reordered opaque 64bit number (generally a PTS) from AVCodecContext.reordered_opaque - * output in AVFrame.reordered_opaque - * - encoding: unused - * - decoding: Read by user. - *) - reordered_opaque: cint64; - {$IFEND} - - {$IF LIBAVCODEC_VERSION = 52021000} // = 52.21.0 - (** - * hardware accelerator private data (FFmpeg allocated) - * - encoding: unused - * - decoding: Set by libavcodec - *) - hwaccel_data_private: pointer; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52022000} // >= 52.22.0 - hwaccel_picture_private: pointer; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 51070000} // >= 51.70.0 - (** - * Bits per sample/pixel of internal libavcodec pixel/sample format. - * This field is applicable only when sample_fmt is SAMPLE_FMT_S32. - * - encoding: set by user. - * - decoding: set by libavcodec. - *) - bits_per_raw_sample: cint; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 52002000} // >= 52.2.0 - (** - * Audio channel layout. - * - encoding: set by user. - * - decoding: set by libavcodec. - *) - channel_layout: cint64; - - (** - * Request decoder to use this channel layout if it can (0 for default) - * - encoding: unused - * - decoding: Set by user. - *) - request_channel_layout: cint64; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 52004000} // >= 52.4.0 - (** - * Ratecontrol attempt to use, at maximum, of what can be used without an underflow. - * - encoding: Set by user. - * - decoding: unused. - *) - rc_max_available_vbv_use: cfloat; - - (** - * Ratecontrol attempt to use, at least, times the amount needed to prevent a vbv overflow. - * - encoding: Set by user. - * - decoding: unused. - *) - rc_min_vbv_overflow_use: cfloat; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52018000} // >= 52.18.0 - (** - * Hardware accelerator in use - * - encoding: unused. - * - decoding: Set by libavcodec - *) - hwaccel: PAVHWAccel; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52020000} // >= 52.20.0 - (** - * For some codecs, the time base is closer to the field rate than the frame rate. - * Most notably, H.264 and MPEG-2 specify time_base as half of frame duration - * if no telecine is used ... - * - * Set to time_base ticks per frame. Default 1, e.g., H.264/MPEG-2 set it to 2. - *) - ticks_per_frame: cint; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52021000} // >= 52.21.0 - (** - * Hardware accelerator context. - * For some hardware accelerators, a global context needs to be - * provided by the user. In that case, this holds display-dependent - * data FFmpeg cannot instantiate itself. Please refer to the - * FFmpeg HW accelerator documentation to know how to fill this - * is. e.g. for VA API, this is a struct vaapi_context. - * - encoding: unused - * - decoding: Set by user - *) - hwaccel_context: pointer; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52028000} // >= 52.28.0 - (** - * Chromaticity coordinates of the source primaries. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - color_primaries: TAVColorPrimaries; - - (** - * Color Transfer Characteristic. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - color_trc: TAVColorTransferCharacteristic; - - (** - * YUV colorspace type. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - colorspace: TAVColorSpace; - - (** - * MPEG vs JPEG YUV range. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - color_range: TAVColorRange; - - (** - * This defines the location of chroma samples. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - chroma_sample_location: TAVChromaLocation; - {$IFEND} - end; - - (** - * main external API structure. - * New fields can be added to the end with minor version bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. - * sizeof(AVCodecContext) must not be used outside libav*. - *) - TAVCodecContext = record {720} - (** - * information on struct for av_log - * - set by avcodec_alloc_context - *) - av_class: PAVClass; - (** - * the average bitrate - * - encoding: Set by user; unused for constant quantizer encoding. - * - decoding: Set by libavcodec. 0 or some bitrate if this info is available in the stream. - *) - bit_rate: cint; - - (** - * number of bits the bitstream is allowed to diverge from the reference. - * the reference can be CBR (for CBR pass1) or VBR (for pass2) - * - encoding: Set by user; unused for constant quantizer encoding. - * - decoding: unused - *) - bit_rate_tolerance: cint; - - (** - * CODEC_FLAG_*. - * - encoding: Set by user. - * - decoding: Set by user. - *) - flags: cint; - - (** - * Some codecs need additional format info. It is stored here. - * If any muxer uses this then ALL demuxers/parsers AND encoders for the - * specific codec MUST set it correctly otherwise stream copy breaks. - * In general use of this field by muxers is not recommanded. - * - encoding: Set by libavcodec. - * - decoding: Set by libavcodec. (FIXME: Is this OK?) - *) - sub_id: cint; - - (** - * Motion estimation algorithm used for video coding. - * 1 (zero), 2 (full), 3 (log), 4 (phods), 5 (epzs), 6 (x1), 7 (hex), - * 8 (umh), 9 (iter), 10 (tesa) [7, 8, 10 are x264 specific, 9 is snow specific] - * - encoding: MUST be set by user. - * - decoding: unused - *) - me_method: cint; - - (** - * some codecs need / can use extradata like Huffman tables. - * mjpeg: Huffman tables - * rv10: additional flags - * mpeg4: global headers (they can be in the bitstream or here) - * The allocated memory should be FF_INPUT_BUFFER_PADDING_SIZE bytes larger - * than extradata_size to avoid prolems if it is read with the bitstream reader. - * The bytewise contents of extradata must not depend on the architecture or CPU endianness. - * - encoding: Set/allocated/freed by libavcodec. - * - decoding: Set/allocated/freed by user. - *) - extradata: pbyte; - extradata_size: cint; - - (** - * This is the fundamental unit of time (in seconds) in terms - * of which frame timestamps are represented. For fixed-fps content, - * timebase should be 1/framerate and timestamp increments should be - * identically 1. - * - encoding: MUST be set by user. - * - decoding: Set by libavcodec. - *) - time_base: TAVRational; - - (* video only *) - (** - * picture width / height. - * - encoding: MUST be set by user. - * - decoding: Set by libavcodec. - * Note: For compatibility it is possible to set this instead of - * coded_width/height before decoding. - *) - width, height: cint; - - (** - * the number of pictures in a group of pictures, or 0 for intra_only - * - encoding: Set by user. - * - decoding: unused - *) - gop_size: cint; - - (** - * Pixel format, see PIX_FMT_xxx. - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - pix_fmt: TAVPixelFormat; - - (** - * Frame rate emulation. If not zero, the lower layer (i.e. format handler) - * has to read frames at native frame rate. - * - encoding: Set by user. - * - decoding: unused - *) - rate_emu: cint; - - (** - * If non NULL, 'draw_horiz_band' is called by the libavcodec - * decoder to draw a horizontal band. It improves cache usage. Not - * all codecs can do that. You must check the codec capabilities - * beforehand. - * The function is also used by hardware acceleration APIs. - * It is called at least once during frame decoding to pass - * the data needed for hardware render. - * In that mode instead of pixel data, AVFrame points to - * a structure specific to the acceleration API. The application - * reads the structure and can change some fields to indicate progress - * or mark state. - * - encoding: unused - * - decoding: Set by user. - * @param height the height of the slice - * @param y the y position of the slice - * @param type 1->top field, 2->bottom field, 3->frame - * @param offset offset into the AVFrame.data from which the slice should be read - *) - draw_horiz_band: procedure (s: PAVCodecContext; - src: {const} PAVFrame; offset: PQuadIntArray; - y: cint; type_: cint; height: cint); cdecl; - - (* audio only *) - sample_rate: cint; ///< samples per second - channels: cint; ///< number of audio channels - - (** - * audio sample format - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - sample_fmt: TSampleFormat; ///< sample format - - (* The following data should not be initialized. *) - (** - * Samples per packet, initialized when calling 'init'. - *) - frame_size: cint; - frame_number: cint; ///< audio or video frame number -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} - real_pict_num: cint; ///< returns the real picture number of previous encoded frame -{$IFEND} - - (** - * Number of frames the decoded output will be delayed relative to - * the encoded input. - * - encoding: Set by libavcodec. - * - decoding: unused - *) - delay: cint; - - (* - encoding parameters *) - qcompress: cfloat; ///< amount of qscale change between easy & hard scenes (0.0-1.0) - qblur: cfloat; ///< amount of qscale smoothing over time (0.0-1.0) - - (** - * minimum quantizer - * - encoding: Set by user. - * - decoding: unused - *) - qmin: cint; - - (** - * maximum quantizer - * - encoding: Set by user. - * - decoding: unused - *) - qmax: cint; - - (** - * maximum quantizer difference between frames - * - encoding: Set by user. - * - decoding: unused - *) - max_qdiff: cint; - - (** - * maximum number of B-frames between non-B-frames - * Note: The output will be delayed by max_b_frames+1 relative to the input. - * - encoding: Set by user. - * - decoding: unused - *) - max_b_frames: cint; - - (** - * qscale factor between IP and B-frames - * If > 0 then the last P-frame quantizer will be used (q= lastp_q*factor+offset). - * If < 0 then normal ratecontrol will be done (q= -normal_q*factor+offset). - * - encoding: Set by user. - * - decoding: unused - *) - b_quant_factor: cfloat; - - (** obsolete FIXME remove *) - rc_strategy: cint; - - b_frame_strategy: cint; - - (** - * hurry up amount - * - encoding: unused - * - decoding: Set by user. 1-> Skip B-frames, 2-> Skip IDCT/dequant too, 5-> Skip everything except header - * @deprecated Deprecated in favor of skip_idct and skip_frame. - *) - hurry_up: cint; - - codec: PAVCodec; - - priv_data: pointer; - - {$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 - (* unused, FIXME remove*) - rtp_mode: cint; - {$IFEND} - - rtp_payload_size: cint; (* The size of the RTP payload: the coder will *) - (* do it's best to deliver a chunk with size *) - (* below rtp_payload_size, the chunk will start *) - (* with a start code on some codecs like H.263 *) - (* This doesn't take account of any particular *) - (* headers inside the transmited RTP payload *) - - - (* The RTP callback: This function is called *) - (* every time the encoder has a packet to send *) - (* Depends on the encoder if the data starts *) - (* with a Start Code (it should) H.263 does. *) - (* mb_nb contains the number of macroblocks *) - (* encoded in the RTP payload *) - rtp_callback: procedure (avctx: PAVCodecContext; data: pointer; - size: cint; mb_nb: cint); cdecl; - - (* statistics, used for 2-pass encoding *) - mv_bits: cint; - header_bits: cint; - i_tex_bits: cint; - p_tex_bits: cint; - i_count: cint; - p_count: cint; - skip_count: cint; - misc_bits: cint; - - (** - * number of bits used for the previously encoded frame - * - encoding: Set by libavcodec. - * - decoding: unused - *) - frame_bits: cint; - - (** - * Private data of the user, can be used to carry app specific stuff. - * - encoding: Set by user. - * - decoding: Set by user. - *) - opaque: pointer; - - codec_name: array [0..31] of AnsiChar; - codec_type: TCodecType; (* see CODEC_TYPE_xxx *) - codec_id: TCodecID; (* see CODEC_ID_xxx *) - - (** - * fourcc (LSB first, so "ABCD" -> ('D'<<24) + ('C'<<16) + ('B'<<8) + 'A'). - * This is used to work around some encoder bugs. - * A demuxer should set this to what is stored in the field used to identify the codec. - * If there are multiple such fields in a container then the demuxer should choose the one - * which maximizes the information about the used codec. - * If the codec tag field in a container is larger then 32 bits then the demuxer should - * remap the longer ID to 32 bits with a table or other structure. Alternatively a new - * extra_codec_tag + size could be added but for this a clear advantage must be demonstrated - * first. - * - encoding: Set by user, if not then the default based on codec_id will be used. - * - decoding: Set by user, will be converted to uppercase by libavcodec during init. - *) - codec_tag: cuint; - - (** - * Work around bugs in encoders which sometimes cannot be detected automatically. - * - encoding: Set by user - * - decoding: Set by user - *) - workaround_bugs: cint; - - (** - * luma single coefficient elimination threshold - * - encoding: Set by user. - * - decoding: unused - *) - luma_elim_threshold: cint; - - (** - * chroma single coeff elimination threshold - * - encoding: Set by user. - * - decoding: unused - *) - chroma_elim_threshold: cint; - - (** - * strictly follow the standard (MPEG4, ...). - * - encoding: Set by user. - * - decoding: Set by user. - * Setting this to STRICT or higher means the encoder and decoder will - * generally do stupid things. While setting it to inofficial or lower - * will mean the encoder might use things that are not supported by all - * spec compliant decoders. Decoders make no difference between normal, - * inofficial and experimental, that is they always try to decode things - * when they can unless they are explicitly asked to behave stupid - * (=strictly conform to the specs) - *) - strict_std_compliance: cint; - - (** - * qscale offset between IP and B-frames - * - encoding: Set by user. - * - decoding: unused - *) - b_quant_offset: cfloat; - - (** - * Error recognization; higher values will detect more errors but may - * misdetect some more or less valid parts as errors. - * - encoding: unused - * - decoding: Set by user. - *) - error_recognition: cint; - - (** - * Called at the beginning of each frame to get a buffer for it. - * If pic.reference is set then the frame will be read later by libavcodec. - * avcodec_align_dimensions() should be used to find the required width and - * height, as they normally need to be rounded up to the next multiple of 16. - * if CODEC_CAP_DR1 is not set then get_buffer() must call - * avcodec_default_get_buffer() instead of providing buffers allocated by - * some other means. - * - encoding: unused - * - decoding: Set by libavcodec., user can override. - *) - get_buffer: function (c: PAVCodecContext; pic: PAVFrame): cint; cdecl; - - (** - * Called to release buffers which were allocated with get_buffer. - * A released buffer can be reused in get_buffer(). - * pic.data[*] must be set to NULL. - * - encoding: unused - * - decoding: Set by libavcodec., user can override. - *) - release_buffer: procedure (c: PAVCodecContext; pic: PAVFrame); cdecl; - - (** - * Size of the frame reordering buffer in the decoder. - * For MPEG-2 it is 1 IPB or 0 low delay IP. - * - encoding: Set by libavcodec. - * - decoding: Set by libavcodec. - *) - has_b_frames: cint; - - (** - * number of bytes per packet if constant and known or 0 - * Used by some WAV based audio codecs. - *) - block_align: cint; - - parse_only: cint; (* - decoding only: if true, only parsing is done - (function avcodec_parse_frame()). The frame - data is returned. Only MPEG codecs support this now. *) - - (** - * 0-> h263 quant 1-> mpeg quant - * - encoding: Set by user. - * - decoding: unused - *) - mpeg_quant: cint; - - (** - * pass1 encoding statistics output buffer - * - encoding: Set by libavcodec. - * - decoding: unused - *) - stats_out: PByteArray; - - (** - * pass2 encoding statistics input buffer - * Concatenated stuff from stats_out of pass1 should be placed here. - * - encoding: Allocated/set/freed by user. - * - decoding: unused - *) - stats_in: PByteArray; - - (** - * ratecontrol qmin qmax limiting method - * 0-> clipping, 1-> use a nice continous function to limit qscale wthin qmin/qmax. - * - encoding: Set by user. - * - decoding: unused - *) - rc_qsquish: cfloat; - - rc_qmod_amp: cfloat; - rc_qmod_freq: cint; - - (** - * ratecontrol override, see RcOverride - * - encoding: Allocated/set/freed by user. - * - decoding: unused - *) - rc_override: PRcOverride; - rc_override_count: cint; - - (** - * rate control equation - * - encoding: Set by user - * - decoding: unused - *) - rc_eq: {const} PByteArray; - - (** - * maximum bitrate - * - encoding: Set by user. - * - decoding: unused - *) - rc_max_rate: cint; - - (** - * minimum bitrate - * - encoding: Set by user. - * - decoding: unused - *) - rc_min_rate: cint; - - (** - * decoder bitstream buffer size - * - encoding: Set by user. - * - decoding: unused - *) - rc_buffer_size: cint; - rc_buffer_aggressivity: cfloat; - - (** - * qscale factor between P and I-frames - * If > 0 then the last p frame quantizer will be used (q= lastp_q*factor+offset). - * If < 0 then normal ratecontrol will be done (q= -normal_q*factor+offset). - * - encoding: Set by user. - * - decoding: unused - *) - i_quant_factor: cfloat; - - (** - * qscale offset between P and I-frames - * - encoding: Set by user. - * - decoding: unused - *) - i_quant_offset: cfloat; - - (** - * initial complexity for pass1 ratecontrol - * - encoding: Set by user. - * - decoding: unused - *) - rc_initial_cplx: cfloat; - - (** - * DCT algorithm, see FF_DCT_* below - * - encoding: Set by user. - * - decoding: unused - *) - dct_algo: cint; - - (** - * luminance masking (0-> disabled) - * - encoding: Set by user. - * - decoding: unused - *) - lumi_masking: cfloat; - - (** - * temporary complexity masking (0-> disabled) - * - encoding: Set by user. - * - decoding: unused - *) - temporal_cplx_masking: cfloat; - - (** - * spatial complexity masking (0-> disabled) - * - encoding: Set by user. - * - decoding: unused - *) - spatial_cplx_masking: cfloat; - - (** - * p block masking (0-> disabled) - * - encoding: Set by user. - * - decoding: unused - *) - p_masking: cfloat; - - (** - * darkness masking (0-> disabled) - * - encoding: Set by user. - * - decoding: unused - *) - dark_masking: cfloat; - - {$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 - (* for binary compatibility *) - unused: cint; - {$IFEND} - - (** - * IDCT algorithm, see FF_IDCT_* below. - * - encoding: Set by user. - * - decoding: Set by user. - *) - idct_algo: cint; - - (** - * slice count - * - encoding: Set by libavcodec. - * - decoding: Set by user (or 0). - *) - slice_count: cint; - - (** - * slice offsets in the frame in bytes - * - encoding: Set/allocated by libavcodec. - * - decoding: Set/allocated by user (or NULL). - *) - slice_offset: PCint; - - (** - * error concealment flags - * - encoding: unused - * - decoding: Set by user. - *) - error_concealment: cint; - - (** - * dsp_mask could be add used to disable unwanted CPU features - * CPU features (i.e. MMX, SSE. ...) - * - * With the FORCE flag you may instead enable given CPU features. - * (Dangerous: Usable in case of misdetection, improper usage however will - * result into program crash.) - *) - dsp_mask: cuint; - - (** - * bits per sample/pixel from the demuxer (needed for huffyuv). - * - encoding: Set by libavcodec. - * - decoding: Set by user. - *) - bits_per_coded_sample: cint; - - (** - * prediction method (needed for huffyuv) - * - encoding: Set by user. - * - decoding: unused - *) - prediction_method: cint; - - (** - * sample aspect ratio (0 if unknown) - * That is the width of a pixel divided by the height of the pixel. - * Numerator and denominator must be relatively prime and smaller than 256 for some video standards. - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - sample_aspect_ratio: TAVRational; - - (** - * the picture in the bitstream - * - encoding: Set by libavcodec. - * - decoding: Set by libavcodec. - *) - coded_frame: PAVFrame; - - (** - * debug - * - encoding: Set by user. - * - decoding: Set by user. - *) - debug: cint; - - (** - * debug - * - encoding: Set by user. - * - decoding: Set by user. - *) - debug_mv: cint; - - (** - * error - * - encoding: Set by libavcodec if flags&CODEC_FLAG_PSNR. - * - decoding: unused - *) - error: array [0..3] of cuint64; - - (** - * minimum MB quantizer - * - encoding: unused - * - decoding: unused - *) - mb_qmin: cint; - - (** - * maximum MB quantizer - * - encoding: unused - * - decoding: unused - *) - mb_qmax: cint; - - (** - * motion estimation comparison function - * - encoding: Set by user. - * - decoding: unused - *) - me_cmp: cint; - - (** - * subpixel motion estimation comparison function - * - encoding: Set by user. - * - decoding: unused - *) - me_sub_cmp: cint; - (** - * macroblock comparison function (not supported yet) - * - encoding: Set by user. - * - decoding: unused - *) - mb_cmp: cint; - (** - * interlaced DCT comparison function - * - encoding: Set by user. - * - decoding: unused - *) - ildct_cmp: cint; - - (** - * ME diamond size & shape - * - encoding: Set by user. - * - decoding: unused - *) - dia_size: cint; - - (** - * amount of previous MV predictors (2a+1 x 2a+1 square) - * - encoding: Set by user. - * - decoding: unused - *) - last_predictor_count: cint; - - (** - * prepass for motion estimation - * - encoding: Set by user. - * - decoding: unused - *) - pre_me: cint; - - (** - * motion estimation prepass comparison function - * - encoding: Set by user. - * - decoding: unused - *) - me_pre_cmp: cint; - - (** - * ME prepass diamond size & shape - * - encoding: Set by user. - * - decoding: unused - *) - pre_dia_size: cint; - - (** - * subpel ME quality - * - encoding: Set by user. - * - decoding: unused - *) - me_subpel_quality: cint; - - (** - * callback to negotiate the pixelFormat - * @param fmt is the list of formats which are supported by the codec, - * it is terminated by -1 as 0 is a valid format, the formats are ordered by quality. - * The first is always the native one. - * @return the chosen format - * - encoding: unused - * - decoding: Set by user, if not set the native format will be chosen. - *) - get_format: function (s: PAVCodecContext; fmt: {const} PAVPixelFormat): TAVPixelFormat; cdecl; - - (** - * DTG active format information (additional aspect ratio - * information only used in DVB MPEG-2 transport streams) - * 0 if not set. - * - * - encoding: unused - * - decoding: Set by decoder. - *) - dtg_active_format: cint; - - (** - * maximum motion estimation search range in subpel units - * If 0 then no limit. - * - * - encoding: Set by user. - * - decoding: unused - *) - me_range: cint; - - (** - * intra quantizer bias - * - encoding: Set by user. - * - decoding: unused - *) - intra_quant_bias: cint; - - (** - * inter quantizer bias - * - encoding: Set by user. - * - decoding: unused - *) - inter_quant_bias: cint; - - (** - * color table ID - * - encoding: unused - * - decoding: Which clrtable should be used for 8bit RGB images. - * Tables have to be stored somewhere. FIXME - *) - color_table_id: cint; - - (** - * internal_buffer count - * Don't touch, used by libavcodec default_get_buffer(). - *) - internal_buffer_count: cint; - - (** - * internal_buffers - * Don't touch, used by libavcodec default_get_buffer(). - *) - internal_buffer: pointer; - - (** - * Global quality for codecs which cannot change it per frame. - * This should be proportional to MPEG-1/2/4 qscale. - * - encoding: Set by user. - * - decoding: unused - *) - global_quality: cint; - - (** - * coder type - * - encoding: Set by user. - * - decoding: unused - *) - coder_type: cint; - - (** - * context model - * - encoding: Set by user. - * - decoding: unused - *) - context_model: cint; - - { - (** - * - * - encoding: unused - * - decoding: Set by user. - *) - realloc: function (s: PAVCodecContext; buf: Pbyte; buf_size: cint): Pbyte; cdecl; - } - - (** - * slice flags - * - encoding: unused - * - decoding: Set by user. - *) - slice_flags: cint; - - (** - * XVideo Motion Acceleration - * - encoding: forbidden - * - decoding: set by decoder - *) - xvmc_acceleration: cint; - - (** - * macroblock decision mode - * - encoding: Set by user. - * - decoding: unused - *) - mb_decision: cint; - - (** - * custom intra quantization matrix - * - encoding: Set by user, can be NULL. - * - decoding: Set by libavcodec. - *) - intra_matrix: PWord; - - (** - * custom inter quantization matrix - * - encoding: Set by user, can be NULL. - * - decoding: Set by libavcodec. - *) - inter_matrix: PWord; - - (** - * fourcc from the AVI stream header (LSB first, so "ABCD" -> ('D'<<24) + ('C'<<16) + ('B'<<8) + 'A'). - * This is used to work around some encoder bugs. - * - encoding: unused - * - decoding: Set by user, will be converted to uppercase by libavcodec during init. - *) - stream_codec_tag: array [0..3] of AnsiChar; //cuint; - - (** - * scene change detection threshold - * 0 is default, larger means fewer detected scene changes. - * - encoding: Set by user. - * - decoding: unused - *) - scenechange_threshold: cint; - - (** - * minimum Lagrange multipler - * - encoding: Set by user. - * - decoding: unused - *) - lmin: cint; - - (** - * maximum Lagrange multipler - * - encoding: Set by user. - * - decoding: unused - *) - lmax: cint; - - (** - * palette control structure - * - encoding: ??? (no palette-enabled encoder yet) - * - decoding: Set by user. - *) - palctrl: PAVPaletteControl; - - (** - * noise reduction strength - * - encoding: Set by user. - * - decoding: unused - *) - noise_reduction: cint; - - (** - * Called at the beginning of a frame to get cr buffer for it. - * Buffer type (size, hints) must be the same. libavcodec won't check it. - * libavcodec will pass previous buffer in pic, function should return - * same buffer or new buffer with old frame "painted" into it. - * If pic.data[0] == NULL must behave like get_buffer(). - * if CODEC_CAP_DR1 is not set then reget_buffer() must call - * avcodec_default_reget_buffer() instead of providing buffers allocated by - * some other means. - * - encoding: unused - * - decoding: Set by libavcodec., user can override - *) - reget_buffer: function (c: PAVCodecContext; pic: PAVFrame): cint; cdecl; - - (** - * Number of bits which should be loaded into the rc buffer before decoding starts. - * - encoding: Set by user. - * - decoding: unused - *) - rc_initial_buffer_occupancy: cint; - - (** - * - * - encoding: Set by user. - * - decoding: unused - *) - inter_threshold: cint; - - (** - * CODEC_FLAG2_* - * - encoding: Set by user. - * - decoding: Set by user. - *) - flags2: cint; - - (** - * Simulates errors in the bitstream to test error concealment. - * - encoding: Set by user. - * - decoding: unused - *) - error_rate: cint; - - (** - * MP3 antialias algorithm, see FF_AA_* below. - * - encoding: unused - * - decoding: Set by user. - *) - antialias_algo: cint; - - (** - * quantizer noise shaping - * - encoding: Set by user. - * - decoding: unused - *) - quantizer_noise_shaping: cint; - - (** - * thread count - * is used to decide how many independent tasks should be passed to execute() - * - encoding: Set by user. - * - decoding: Set by user. - *) - thread_count: cint; - - (** - * The codec may call this to execute several independent things. - * It will return only after finishing all tasks. - * The user may replace this with some multithreaded implementation, - * the default implementation will execute the parts serially. - * @param count the number of things to execute - * - encoding: Set by libavcodec, user can override. - * - decoding: Set by libavcodec, user can override. - *) - {$IF LIBAVCODEC_VERSION < 52004000} // < 52.4.0 - execute: function (c: PAVCodecContext; func: TExecuteFunc; arg: PPointer; ret: PCint; count: cint): cint; cdecl; - {$ELSE} - execute: function (c: PAVCodecContext; func: TExecuteFunc; arg: Pointer; ret: PCint; count: cint; size: cint): cint; cdecl; - {$IFEND} - - (** - * thread opaque - * Can be used by execute() to store some per AVCodecContext stuff. - * - encoding: set by execute() - * - decoding: set by execute() - *) - thread_opaque: pointer; - - (** - * Motion estimation threshold below which no motion estimation is - * performed, but instead the user specified motion vectors are used. - * - * - encoding: Set by user. - * - decoding: unused - *) - me_threshold: cint; - - (** - * Macroblock threshold below which the user specified macroblock types will be used. - * - encoding: Set by user. - * - decoding: unused - *) - mb_threshold: cint; - - (** - * precision of the intra DC coefficient - 8 - * - encoding: Set by user. - * - decoding: unused - *) - intra_dc_precision: cint; - - (** - * noise vs. sse weight for the nsse comparsion function - * - encoding: Set by user. - * - decoding: unused - *) - nsse_weight: cint; - - (** - * Number of macroblock rows at the top which are skipped. - * - encoding: unused - * - decoding: Set by user. - *) - skip_top: cint; - - (** - * Number of macroblock rows at the bottom which are skipped. - * - encoding: unused - * - decoding: Set by user. - *) - skip_bottom: cint; - - (** - * profile - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - profile: cint; - - (** - * level - * - encoding: Set by user. - * - decoding: Set by libavcodec. - *) - level: cint; - - (** - * low resolution decoding, 1-> 1/2 size, 2->1/4 size - * - encoding: unused - * - decoding: Set by user. - *) - lowres: cint; - - (** - * Bitstream width / height, may be different from width/height if lowres - * or other things are used. - * - encoding: unused - * - decoding: Set by user before init if known. Codec should override / dynamically change if needed. - *) - coded_width, coded_height: cint; - - (** - * frame skip threshold - * - encoding: Set by user. - * - decoding: unused - *) - frame_skip_threshold: cint; - - (** - * frame skip factor - * - encoding: Set by user. - * - decoding: unused - *) - frame_skip_factor: cint; - - (** - * frame skip exponent - * - encoding: Set by user. - * - decoding: unused - *) - frame_skip_exp: cint; - - (** - * frame skip comparison function - * - encoding: Set by user. - * - decoding: unused - *) - frame_skip_cmp: cint; - - (** - * Border processing masking, raises the quantizer for mbs on the borders - * of the picture. - * - encoding: Set by user. - * - decoding: unused - *) - border_masking: cfloat; - - (** - * minimum MB lagrange multipler - * - encoding: Set by user. - * - decoding: unused - *) - mb_lmin: cint; - - (** - * maximum MB lagrange multipler - * - encoding: Set by user. - * - decoding: unused - *) - mb_lmax: cint; - - (** - * - * - encoding: Set by user. - * - decoding: unused - *) - me_penalty_compensation: cint; - - (** - * - * - encoding: unused - * - decoding: Set by user. - *) - skip_loop_filter: TAVDiscard; - - (** - * - * - encoding: unused - * - decoding: Set by user. - *) - skip_idct: TAVDiscard; - - (** - * - * - encoding: unused - * - decoding: Set by user. - *) - skip_frame: TAVDiscard; - - (** - * - * - encoding: Set by user. - * - decoding: unused - *) - bidir_refine: cint; - - (** - * - * - encoding: Set by user. - * - decoding: unused - *) - brd_scale: cint; - - (** - * constant rate factor - quality-based VBR - values ~correspond to qps - * - encoding: Set by user. - * - decoding: unused - *) - {$IF LIBAVCODEC_VERSION >= 51021000} // 51.21.0 - crf: cfloat; - {$ELSE} - crf: cint; - {$IFEND} - - (** - * constant quantization parameter rate control method - * - encoding: Set by user. - * - decoding: unused - *) - cqp: cint; - - (** - * minimum GOP size - * - encoding: Set by user. - * - decoding: unused - *) - keyint_min: cint; - - (** - * number of reference frames - * - encoding: Set by user. - * - decoding: Set by lavc. - *) - refs: cint; - - (** - * chroma qp offset from luma - * - encoding: Set by user. - * - decoding: unused - *) - chromaoffset: cint; - - (** - * Influences how often B-frames are used. - * - encoding: Set by user. - * - decoding: unused - *) - bframebias: cint; - - (** - * trellis RD quantization - * - encoding: Set by user. - * - decoding: unused - *) - trellis: cint; - - (** - * Reduce fluctuations in qp (before curve compression). - * - encoding: Set by user. - * - decoding: unused - *) - complexityblur: cfloat; - - (** - * in-loop deblocking filter alphac0 parameter - * alpha is in the range -6...6 - * - encoding: Set by user. - * - decoding: unused - *) - deblockalpha: cint; - - (** - * in-loop deblocking filter beta parameter - * beta is in the range -6...6 - * - encoding: Set by user. - * - decoding: unused - *) - deblockbeta: cint; - - (** - * macroblock subpartition sizes to consider - p8x8, p4x4, b8x8, i8x8, i4x4 - * - encoding: Set by user. - * - decoding: unused - *) - partitions: cint; - - (** - * direct MV prediction mode - 0 (none), 1 (spatial), 2 (temporal), 3 (auto) - * - encoding: Set by user. - * - decoding: unused - *) - directpred: cint; - - (** - * Audio cutoff bandwidth (0 means "automatic") - * - encoding: Set by user. - * - decoding: unused - *) - cutoff: cint; - - (** - * Multiplied by qscale for each frame and added to scene_change_score. - * - encoding: Set by user. - * - decoding: unused - *) - scenechange_factor: cint; - - (** - * - * Note: Value depends upon the compare function used for fullpel ME. - * - encoding: Set by user. - * - decoding: unused - *) - mv0_threshold: cint; - - (** - * Adjusts sensitivity of b_frame_strategy 1. - * - encoding: Set by user. - * - decoding: unused - *) - b_sensitivity: cint; - - (** - * - encoding: Set by user. - * - decoding: unused - *) - compression_level: cint; - - (** - * Sets whether to use LPC mode - used by FLAC encoder. - * - encoding: Set by user. - * - decoding: unused - *) - use_lpc: cint; - - (** - * LPC coefficient precision - used by FLAC encoder - * - encoding: Set by user. - * - decoding: unused - *) - lpc_coeff_precision: cint; - - (** - * - encoding: Set by user. - * - decoding: unused - *) - min_prediction_order: cint; - - (** - * - encoding: Set by user. - * - decoding: unused - *) - max_prediction_order: cint; - - (** - * search method for selecting prediction order - * - encoding: Set by user. - * - decoding: unused - *) - prediction_order_method: cint; - - (** - * - encoding: Set by user. - * - decoding: unused - *) - min_partition_order: cint; - - (** - * - encoding: Set by user. - * - decoding: unused - *) - max_partition_order: cint; - - {$IF LIBAVCODEC_VERSION >= 51026000} // 51.26.0 - (** - * GOP timecode frame start number, in non drop frame format - * - encoding: Set by user. - * - decoding: unused - *) - timecode_frame_start: cint64; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 51042000} // 51.42.0 - {$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} - (** - * Decoder should decode to this many channels if it can (0 for default) - * - encoding: unused - * - decoding: Set by user. - * @deprecated Deprecated in favor of request_channel_layout. - *) - request_channels: cint; - {$IFEND} - {$IFEND} - - {$IF LIBAVCODEC_VERSION > 51049000} // > 51.49.0 - (** - * Percentage of dynamic range compression to be applied by the decoder. - * The default value is 1.0, corresponding to full compression. - * - encoding: unused - * - decoding: Set by user. - *) - drc_scale: cfloat; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 51068000} // 51.68.0 - (** - * opaque 64bit number (generally a PTS) that will be reordered and - * output in AVFrame.reordered_opaque - * - encoding: unused - * - decoding: Set by user. - *) - reordered_opaque: cint64; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 52028000} // 52.28.0 - (** - * This defines the location of chroma samples. - * - encoding: Set by user - * - decoding: Set by libavcodec - *) - chroma_sample_location: TAVChromaLocation; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 - (** - * The codec may call this to execute several independent things. - * It will return only after finishing all tasks. - * The user may replace this with some multithreaded implementation, - * the default implementation will execute the parts serially. - * Also see avcodec_thread_init and e.g. the --enable-pthread configure option. - * @param c context passed also to func - * @param count the number of things to execute - * @param arg2 argument passed unchanged to func - * @param ret return values of executed functions, must have space for "count" values. May be NULL. - * @param func function that will be called count times, with jobnr from 0 to count-1. - * threadnr will be in the range 0 to c->thread_count-1 < MAX_THREADS and so that no - * two instances of func executing at the same time will have the same threadnr. - * @return always 0 currently, but code should handle a future improvement where when any call to func - * returns < 0 no further calls to func may be done and < 0 is returned. - * - encoding: Set by libavcodec, user can override. - * - decoding: Set by libavcodec, user can override. - *) - execute2: function (c: PAVCodecContext; func: TExecute2Func; arg2: Pointer; ret: Pcint; count: cint): cint; cdecl; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52042000} // >= 52.42.0 - (** - * explicit P-frame weighted prediction analysis method - * 0: off - * 1: fast blind weighting (one reference duplicate with -1 offset) - * 2: smart weighting (full fade detection analysis) - * - encoding: Set by user. - * - decoding: unused - *) - weighted_p_pred: cint; - {$IFEND} - end; - -(** - * AVCodec. - *) - TAVCodec = record - name: PAnsiChar; - type_: TCodecType; - id: TCodecID; - priv_data_size: cint; - init: function (avctx: PAVCodecContext): cint; cdecl; (* typo corretion by the Creative CAT *) - encode: function (avctx: PAVCodecContext; buf: PByteArray; buf_size: cint; data: pointer): cint; cdecl; - close: function (avctx: PAVCodecContext): cint; cdecl; - decode: function (avctx: PAVCodecContext; outdata: pointer; var outdata_size: cint; - {$IF LIBAVCODEC_VERSION < 52025000} // 52.25.0 - buf: {const} PByteArray; buf_size: cint): cint; cdecl; - {$ELSE} - avpkt: PAVPacket): cint; cdecl; - {$IFEND} - (** - * Codec capabilities. - * see CODEC_CAP_* - *) - capabilities: cint; - next: PAVCodec; - (** - * Flush buffers. - * Will be called when seeking - *) - flush: procedure (avctx: PAVCodecContext); cdecl; - supported_framerates: {const} PAVRational; ///< array of supported framerates, or NULL if any, array is terminated by {0,0} - pix_fmts: {const} PAVPixelFormat; ///< array of supported pixel formats, or NULL if unknown, array is terminated by -1 - {$IF LIBAVCODEC_VERSION >= 51055000} // 51.55.0 - (** - * Descriptive name for the codec, meant to be more human readable than name. - * You should use the NULL_IF_CONFIG_SMALL() macro to define it. - *) - long_name: {const} PAnsiChar; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 51056000} // 51.56.0 - supported_samplerates: {const} PCint; ///< array of supported audio samplerates, or NULL if unknown, array is terminated by 0 - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 51062000} // 51.62.0 - sample_fmts: {const} PSampleFormatArray; ///< array of supported sample formats, or NULL if unknown, array is terminated by -1 - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52002000} // 52.2.0 - channel_layouts: {const} PCint64; ///< array of support channel layouts, or NULL if unknown. array is terminated by 0 - {$IFEND} - end; - -{$IF LIBAVCODEC_VERSION >= 52018000} // 52.18.0 -(** - * AVHWAccel. - *) - TAVHWAccel = record - (** - * Name of the hardware accelerated codec. - * The name is globally unique among encoders and among decoders (but an - * encoder and a decoder can share the same name). - *) - name: PAnsiChar; - - (** - * Type of codec implemented by the hardware accelerator. - * - * See CODEC_TYPE_xxx - *) - type_: TCodecType; - - (** - * Codec implemented by the hardware accelerator. - * - * See CODEC_ID_xxx - *) - id: TCodecID; - - (** - * Supported pixel format. - * - * Only hardware accelerated formats are supported here. - *) - pix_fmt: {const} PAVPixelFormat; - - (** - * Hardware accelerated codec capabilities. - * see FF_HWACCEL_CODEC_CAP_* - *) - capabilities: cint; - - next: PAVCodec; - - (** - * Called at the beginning of each frame or field picture. - * - * Meaningful frame information (codec specific) is guaranteed to - * be parsed at this point. This function is mandatory. - * - * Note that buf can be NULL along with buf_size set to 0. - * Otherwise, this means the whole frame is available at this point. - * - * @param avctx the codec context - * @param buf the frame data buffer base - * @param buf_size the size of the frame in bytes - * @return zero if successful, a negative value otherwise - *) - start_frame: function (avctx: PAVCodecContext; - buf: PByteArray; - buf_size: cint): cint; cdecl; - - (** - * Callback for each slice. - * - * Meaningful slice information (codec specific) is guaranteed to - * be parsed at this point. This function is mandatory. - * - * @param avctx the codec context - * @param buf the slice data buffer base - * @param buf_size the size of the slice in bytes - * @return zero if successful, a negative value otherwise - *) - decode_slice: function (avctx: PAVCodecContext; - buf: PByteArray; - buf_size: cint): cint; cdecl; - - (** - * Called at the end of each frame or field picture. - * - * The whole picture is parsed at this point and can now be sent - * to the hardware accelerator. This function is mandatory. - * - * @param avctx the codec context - * @return zero if successful, a negative value otherwise - *) - end_frame: function (avctx: PAVCodecContext): cint; cdecl; - -{$IF LIBAVCODEC_VERSION >= 52021000} // >= 52.21.0 - (** - * Size of HW accelerator private data. - * - * Private data is allocated with av_mallocz() before - * AVCodecContext.get_buffer() and deallocated after - * AVCodecContext.release_buffer(). - *) - priv_data_size: cint; -{$IFEND} - - end; -{$IFEND} - -(** - * four components are given, that's all. - * the last component is alpha - *) - PAVPicture = ^TAVPicture; - TAVPicture = record - data: array [0..3] of PByteArray; - linesize: array [0..3] of cint; ///< number of bytes per line - end; - -type - TAVSubtitleType = ( - SUBTITLE_NONE, - - SUBTITLE_BITMAP, ///< A bitmap, pict will be set - - (** - * Plain text, the text field must be set by the decoder and is - * authoritative. ass and pict fields may contain approximations. - *) - SUBTITLE_TEXT, - - (** - * Formatted text, the ass field must be set by the decoder and is - * authoritative. pict and text fields may contain approximations. - *) - SUBTITLE_ASS - ); - -type - PPAVSubtitleRect = ^PAVSubtitleRect; - PAVSubtitleRect = ^TAVSubtitleRect; - {$IF LIBAVCODEC_VERSION < 52010000} // < 52.10.0 - TAVSubtitleRect = record - x: cuint16; - y: cuint16; - w: cuint16; - h: cuint16; - nb_colors: cuint16; - linesize: cint; - rgba_palette: PCuint32; - bitmap: PCuint8; - end; - {$ELSE} - TAVSubtitleRect = record - x: cint; ///< top left corner of pict, undefined when pict is not set - y: cint; ///< top left corner of pict, undefined when pict is not set - w: cint; ///< width of pict, undefined when pict is not set - h: cint; ///< height of pict, undefined when pict is not set - nb_colors: cint; ///< number of colors in pict, undefined when pict is not set - - (** - * data+linesize for the bitmap of this subtitle. - * can be set for text/ass as well once they where rendered - *) - pict: TAVPicture; - type_: TAVSubtitleType; - - text: PAnsiChar; ///< 0 terminated plain UTF-8 text - - (** - * 0 terminated ASS/SSA compatible event line. - * The pressentation of this is unaffected by the other values in this - * struct. - *) - ass: PByteArray; - end; - {$IFEND} - - PPAVSubtitle = ^PAVSubtitle; - PAVSubtitle = ^TAVSubtitle; - TAVSubtitle = record - format: cuint16; (* 0 = graphics *) - start_display_time: cuint32; (* relative to packet pts, in ms *) - end_display_time: cuint32; (* relative to packet pts, in ms *) - num_rects: cuint; - {$IF LIBAVCODEC_VERSION < 52010000} // < 52.10.0 - rects: PAVSubtitleRect; - {$ELSE} - rects: PPAVSubtitleRect; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52032000} // >= 52.32.0 - pts: cint64; ///< Same as packet pts, in AV_TIME_BASE - {$IFEND} - end; - -{$IF LIBAVCODEC_VERSION >= 52025000} // 52.25.0 -{ packet functions } - -(** - * @deprecated use NULL instead - *) -procedure av_destruct_packet_nofree(pkt: PAVPacket); - cdecl; external av__codec; - -(* - * Default packet destructor. - *) -procedure av_destruct_packet(pkt: PAVPacket); - cdecl; external av__codec; - -(* - * Initialize optional fields of a packet with default values. - * - * @param pkt packet - *) -procedure av_init_packet(var pkt: TAVPacket); - cdecl; external av__codec; - -(* - * Allocate the payload of a packet and initialize its fields with - * default values. - * - * @param pkt packet - * @param size wanted payload size - * @return 0 if OK, AVERROR_xxx otherwise - *) -function av_new_packet(pkt: PAVPacket; size: cint): cint; - cdecl; external av__codec; - -(* - * Reduce packet size, correctly zeroing padding - * - * @param pkt packet - * @param size new size - *) -procedure av_shrink_packet(pkt: PAVPacket; size: cint); - cdecl; external av__codec; - -(* - * @warning This is a hack - the packet memory allocation stuff is broken. The - * packet is allocated if it was not really allocated. - *) -function av_dup_packet(pkt: PAVPacket): cint; - cdecl; external av__codec; - -(* - * Free a packet. - * - * @param pkt packet to free - *) -procedure av_free_packet(pkt: PAVPacket); -{$IF LIBAVCODEC_VERSION >= 52028000} // 52.28.0 - cdecl; external av__codec; -{$IFEND} -{$IFEND} - -(* resample.c *) -type - PReSampleContext = pointer; - PAVResampleContext = pointer; - PImgReSampleContext = pointer; - -function audio_resample_init (output_channels: cint; input_channels: cint; - output_rate: cint; input_rate: cint): PReSampleContext; - cdecl; external av__codec; - -function audio_resample (s: PReSampleContext; output: PSmallint; input: PSmallint; nb_samples: cint): cint; - cdecl; external av__codec; - -procedure audio_resample_close (s: PReSampleContext); - cdecl; external av__codec; - -(** - * Initializes an audio resampler. - * Note, if either rate is not an integer then simply scale both rates up so they are. - * @param filter_length length of each FIR filter in the filterbank relative to the cutoff freq - * @param log2_phase_count log2 of the number of entries in the polyphase filterbank - * @param linear If 1 then the used FIR filter will be linearly interpolated - between the 2 closest, if 0 the closest will be used - * @param cutoff cutoff frequency, 1.0 corresponds to half the output sampling rate - *) -function av_resample_init (out_rate: cint; in_rate: cint; filter_length: cint; - log2_phase_count: cint; linear: cint; cutoff: cdouble): PAVResampleContext; - cdecl; external av__codec; - -(** - * resamples. - * @param src an array of unconsumed samples - * @param consumed the number of samples of src which have been consumed are returned here - * @param src_size the number of unconsumed samples available - * @param dst_size the amount of space in samples available in dst - * @param update_ctx If this is 0 then the context will not be modified, that way several channels can be resampled with the same context. - * @return the number of samples written in dst or -1 if an error occurred - *) -function av_resample (c: PAVResampleContext; dst: PSmallint; src: PSmallint; var consumed: cint; - src_size: cint; dst_size: cint; update_ctx: cint): cint; - cdecl; external av__codec; - -(** - * Compensates samplerate/timestamp drift. The compensation is done by changing - * the resampler parameters, so no audible clicks or similar distortions occur - * @param compensation_distance distance in output samples over which the compensation should be performed - * @param sample_delta number of output samples which should be output less - * - * example: av_resample_compensate(c, 10, 500) - * here instead of 510 samples only 500 samples would be output - * - * note, due to rounding the actual compensation might be slightly different, - * especially if the compensation_distance is large and the in_rate used during init is small - *) -procedure av_resample_compensate (c: PAVResampleContext; sample_delta: cint; - compensation_distance: cint); - cdecl; external av__codec; - -procedure av_resample_close (c: PAVResampleContext); - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 -(* YUV420 format is assumed ! *) - -(** - * @deprecated Use the software scaler (swscale) instead. - *) -function img_resample_init (output_width: cint; output_height: cint; - input_width: cint; input_height: cint): PImgReSampleContext; - cdecl; external av__codec; deprecated; - -(** - * @deprecated Use the software scaler (swscale) instead. - *) -function img_resample_full_init (owidth: cint; oheight: cint; - iwidth: cint; iheight: cint; - topBand: cint; bottomBand: cint; - leftBand: cint; rightBand: cint; - padtop: cint; padbottom: cint; - padleft: cint; padright: cint): PImgReSampleContext; - cdecl; external av__codec; deprecated; - -(** - * @deprecated Use the software scaler (swscale) instead. - *) -procedure img_resample (s: PImgReSampleContext; output: PAVPicture; input: {const} PAVPicture); - cdecl; external av__codec; deprecated; - -(** - * @deprecated Use the software scaler (swscale) instead. - *) -procedure img_resample_close (s: PImgReSampleContext); - cdecl; external av__codec; deprecated; -{$IFEND} - -(** - * Allocate memory for a picture. Call avpicture_free to free it. - * - * @param picture the picture to be filled in. - * @param pix_fmt the format of the picture. - * @param width the width of the picture. - * @param height the height of the picture. - * @return Zero if successful, a negative value if not. - *) -function avpicture_alloc (picture: PAVPicture; pix_fmt: TAVPixelFormat; - width: cint; height: cint): cint; - cdecl; external av__codec; - -(** - * Free a picture previously allocated by avpicture_alloc(). - * - * @param picture the AVPicture to be freed - *) -procedure avpicture_free (picture: PAVPicture); - cdecl; external av__codec; - -(** - * Fill in the AVPicture fields. - * The fields of the given AVPicture are filled in by using the 'ptr' address - * which points to the image data buffer. Depending on the specified picture - * format, one or multiple image data pointers and line sizes will be set. - * If a planar format is specified, several pointers will be set pointing to - * the different picture planes and the line sizes of the different planes - * will be stored in the lines_sizes array. - * Call with ptr == NULL to get the required size for the ptr buffer. - * - * @param picture AVPicture whose fields are to be filled in - * @param ptr Buffer which will contain or contains the actual image data - * @param pix_fmt The format in which the picture data is stored. - * @param width the width of the image in pixels - * @param height the height of the image in pixels - * @return size of the image data in bytes - *) -function avpicture_fill (picture: PAVPicture; ptr: pointer; - pix_fmt: TAVPixelFormat; width: cint; height: cint): cint; - cdecl; external av__codec; - -function avpicture_layout (src: {const} PAVPicture; pix_fmt: TAVPixelFormat; - width: cint; height: cint; - dest: PByteArray; dest_size: cint): cint; - cdecl; external av__codec; - -(** - * Calculate the size in bytes that a picture of the given width and height - * would occupy if stored in the given picture format. - * Note that this returns the size of a compact representation as generated - * by avpicture_layout, which can be smaller than the size required for e.g. - * avpicture_fill. - * - * @param pix_fmt the given picture format - * @param width the width of the image - * @param height the height of the image - * @return Image data size in bytes or -1 on error (e.g. too large dimensions). - *) -function avpicture_get_size (pix_fmt: TAVPixelFormat; width: cint; height: cint): cint; - cdecl; external av__codec; - -procedure avcodec_get_chroma_sub_sample (pix_fmt: TAVPixelFormat; var h_shift: cint; var v_shift: cint); - cdecl; external av__codec; - -(** - * Returns the pixel format corresponding to the name \p name. - * - * If there is no pixel format with name \p name, then looks for a - * pixel format with the name corresponding to the native endian - * format of \p name. - * For example in a little-endian system, first looks for "gray16", - * then for "gray16le". - * - * Finally if no pixel format has been found, returns \c PIX_FMT_NONE. - *) -function avcodec_get_pix_fmt_name(pix_fmt: TAVPixelFormat): PAnsiChar; - cdecl; external av__codec; - -procedure avcodec_set_dimensions(s: PAVCodecContext; width: cint; height: cint); - cdecl; external av__codec; - -(** - * Returns the pixel format corresponding to the name name. - * - * If there is no pixel format with name name, then looks for a - * pixel format with the name corresponding to the native endian - * format of name. - * For example in a little-endian system, first looks for "gray16", - * then for "gray16le". - * - * Finally if no pixel format has been found, returns PIX_FMT_NONE. - *) -function avcodec_get_pix_fmt(name: {const} PAnsiChar): TAVPixelFormat; - cdecl; external av__codec; - -function avcodec_pix_fmt_to_codec_tag(p: TAVPixelFormat): cuint; - cdecl; external av__codec; - -const - FF_LOSS_RESOLUTION = $0001; {**< loss due to resolution change *} - FF_LOSS_DEPTH = $0002; {**< loss due to color depth change *} - FF_LOSS_COLORSPACE = $0004; {**< loss due to color space conversion *} - FF_LOSS_ALPHA = $0008; {**< loss of alpha bits *} - FF_LOSS_COLORQUANT = $0010; {**< loss due to color quantization *} - FF_LOSS_CHROMA = $0020; {**< loss of chroma (e.g. RGB to gray conversion) *} - -(** - * Computes what kind of losses will occur when converting from one specific - * pixel format to another. - * When converting from one pixel format to another, information loss may occur. - * For example, when converting from RGB24 to GRAY, the color information will - * be lost. Similarly, other losses occur when converting from some formats to - * other formats. These losses can involve loss of chroma, but also loss of - * resolution, loss of color depth, loss due to the color space conversion, loss - * of the alpha bits or loss due to color quantization. - * avcodec_get_fix_fmt_loss() informs you about the various types of losses - * which will occur when converting from one pixel format to another. - * - * @param[in] dst_pix_fmt destination pixel format - * @param[in] src_pix_fmt source pixel format - * @param[in] has_alpha Whether the source pixel format alpha channel is used. - * @return Combination of flags informing you what kind of losses will occur. - *) -function avcodec_get_pix_fmt_loss (dst_pix_fmt: TAVPixelFormat; src_pix_fmt: TAVPixelFormat; - has_alpha: cint): cint; - cdecl; external av__codec; - -(** - * Finds the best pixel format to convert to given a certain source pixel - * format. When converting from one pixel format to another, information loss - * may occur. For example, when converting from RGB24 to GRAY, the color - * information will be lost. Similarly, other losses occur when converting from - * some formats to other formats. avcodec_find_best_pix_fmt() searches which of - * the given pixel formats should be used to suffer the least amount of loss. - * The pixel formats from which it chooses one, are determined by the - * pix_fmt_mask parameter. - * - * @code - * src_pix_fmt = PIX_FMT_YUV420P; - * pix_fmt_mask = (1 << PIX_FMT_YUV422P) || (1 << PIX_FMT_RGB24); - * dst_pix_fmt = avcodec_find_best_pix_fmt(pix_fmt_mask, src_pix_fmt, alpha, &loss); - * @endcode - * - * @param[in] pix_fmt_mask bitmask determining which pixel format to choose from - * @param[in] src_pix_fmt source pixel format - * @param[in] has_alpha Whether the source pixel format alpha channel is used. - * @param[out] loss_ptr Combination of flags informing you what kind of losses will occur. - * @return The best pixel format to convert to or -1 if none was found. - *) -{$IF LIBAVCODEC_VERSION >= 52000000} // 52.0.0 -function avcodec_find_best_pix_fmt(pix_fmt_mask: cint64; src_pix_fmt: TAVPixelFormat; - has_alpha: cint; loss_ptr: PCint): cint; - cdecl; external av__codec; -{$ELSEIF LIBAVCODEC_VERSION < 52022001} -function avcodec_find_best_pix_fmt(pix_fmt_mask: cint; src_pix_fmt: TAVPixelFormat; - has_alpha: cint; loss_ptr: PCint): cint; - cdecl; external av__codec; -{$ELSE} -function avcodec_find_best_pix_fmt(pix_fmt_mask: cint; src_pix_fmt: TAVPixelFormat; - has_alpha: cint; loss_ptr: PCint): TAVPixelFormat; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 51041000} // 51.41.0 -(** - * Print in buf the string corresponding to the pixel format with - * number pix_fmt, or an header if pix_fmt is negative. - * - * @param[in] buf the buffer where to write the string - * @param[in] buf_size the size of buf - * @param[in] pix_fmt the number of the pixel format to print the corresponding info string, or - * a negative value to print the corresponding header. - * Meaningful values for obtaining a pixel format info vary from 0 to PIX_FMT_NB -1. - *) -{$IF LIBAVCODEC_VERSION < 52022001} // 52.22.1 -procedure avcodec_pix_fmt_string (buf: PAnsiChar; buf_size: cint; pix_fmt: cint); - cdecl; external av__codec; -{$ELSE} -procedure avcodec_pix_fmt_string (buf: PAnsiChar; buf_size: cint; pix_fmt: TAVPixelFormat); - cdecl; external av__codec; -{$IFEND} -{$IFEND} - -const - FF_ALPHA_TRANSP = $0001; {* image has some totally transparent pixels *} - FF_ALPHA_SEMI_TRANSP = $0002; {* image has some transparent pixels *} - -(** - * Tell if an image really has transparent alpha values. - * @return ored mask of FF_ALPHA_xxx constants - *) -function img_get_alpha_info (src: {const} PAVPicture; - pix_fmt: TAVPixelFormat; - width: cint; - height: cint): cint; - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 -(** - * convert among pixel formats - * @deprecated Use the software scaler (swscale) instead. - *) -function img_convert (dst: PAVPicture; dst_pix_fmt: TAVPixelFormat; - src: {const} PAVPicture; pix_fmt: TAVPixelFormat; - width: cint; height: cint): cint; - cdecl; external av__codec; deprecated; -{$IFEND} - -(* deinterlace a picture *) -(* deinterlace - if not supported return -1 *) -function avpicture_deinterlace (dst: PAVPicture; - src: {const} PAVPicture; - pix_fmt: TAVPixelFormat; - width: cint; - height: cint): cint; - cdecl; external av__codec; - -{* external high level API *} - -{$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 -{ -var - first_avcodec: PAVCodec; external av__codec; -} -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 51049000} // 51.49.0 -(** - * If c is NULL, returns the first registered codec, - * if c is non-NULL, returns the next registered codec after c, - * or NULL if c is the last one. - *) -function av_codec_next(c: PAVCodec): PAVCodec; - cdecl; external av__codec; -{$IFEND} - -(** - * Returns the LIBAVCODEC_VERSION_INT constant. - *) -function avcodec_version(): cuint; - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION < 52008000} // 52.8.0 -(* returns LIBAVCODEC_BUILD constant *) -function avcodec_build(): cuint; - cdecl; external av__codec; deprecated; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52041000} // 52.41.0 -(** - * Returns the libavcodec build-time configuration. - *) -function avcodec_configuration(): PAnsiChar; - cdecl; external av__codec; - -(** - * Returns the libavcodec license. - *) -function avcodec_license(): PAnsiChar; - cdecl; external av__codec; -{$IFEND} - -(** - * Initializes libavcodec. - * - * @warning This function must be called before any other libavcodec - * function. - *) -procedure avcodec_init(); - cdecl; external av__codec; - -(** - * Register the codec codec and initialize libavcodec. - * - * @see avcodec_init() - *) -{$IF LIBAVCODEC_VERSION >= 52014000} // 52.14.0 -procedure avcodec_register(codec: PAVCodec); - cdecl; external av__codec; -// Deprecated in favor of avcodec_register. -procedure register_avcodec(codec: PAVCodec); - cdecl; external av__codec; deprecated; -{$ELSEIF LIBAVCODEC_VERSION_MAJOR < 53} -procedure register_avcodec(codec: PAVCodec); - cdecl; external av__codec; -{$IFEND} -(** - * Finds a registered encoder with a matching codec ID. - * - * @param id CodecID of the requested encoder - * @return An encoder if one was found, NULL otherwise. - *) -function avcodec_find_encoder(id: TCodecID): PAVCodec; - cdecl; external av__codec; - -(** - * Finds a registered encoder with the specified name. - * - * @param name name of the requested encoder - * @return An encoder if one was found, NULL otherwise. - *) -function avcodec_find_encoder_by_name(name: PAnsiChar): PAVCodec; - cdecl; external av__codec; - -(** - * Finds a registered decoder with a matching codec ID. - * - * @param id CodecID of the requested decoder - * @return A decoder if one was found, NULL otherwise. - *) -function avcodec_find_decoder(id: TCodecID): PAVCodec; - cdecl; external av__codec; - -(** - * Finds a registered decoder with the specified name. - * - * @param name name of the requested decoder - * @return A decoder if one was found, NULL otherwise. - *) -function avcodec_find_decoder_by_name(name: PAnsiChar): PAVCodec; - cdecl; external av__codec; -procedure avcodec_string(buf: PAnsiChar; buf_size: cint; enc: PAVCodecContext; encode: cint); - cdecl; external av__codec; - -(** - * Sets the fields of the given AVCodecContext to default values. - * - * @param s The AVCodecContext of which the fields should be set to default values. - *) -procedure avcodec_get_context_defaults(s: PAVCodecContext); - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 -(** THIS FUNCTION IS NOT YET PART OF THE PUBLIC API! - * we WILL change its arguments and name a few times! *) -procedure avcodec_get_context_defaults2(s: PAVCodecContext; ctype: TCodecType); - cdecl; external av__codec; -{$IFEND} - -(** - * Allocates an AVCodecContext and sets its fields to default values. The - * resulting struct can be deallocated by simply calling av_free(). - * - * @return An AVCodecContext filled with default values or NULL on failure. - * @see avcodec_get_context_defaults - *) -function avcodec_alloc_context(): PAVCodecContext; - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 -(** THIS FUNCTION IS NOT YET PART OF THE PUBLIC API! - * we WILL change its arguments and name a few times! *) -function avcodec_alloc_context2(ctype: TCodecType): PAVCodecContext; - cdecl; external av__codec; -{$IFEND} - -(** - * Sets the fields of the given AVFrame to default values. - * - * @param pic The AVFrame of which the fields should be set to default values. - *) -procedure avcodec_get_frame_defaults (pic: PAVFrame); - cdecl; external av__codec; - -(** - * Allocates an AVFrame and sets its fields to default values. The resulting - * struct can be deallocated by simply calling av_free(). - * - * @return An AVFrame filled with default values or NULL on failure. - * @see avcodec_get_frame_defaults - *) -function avcodec_alloc_frame(): PAVFrame; - cdecl; external av__codec; - -function avcodec_default_get_buffer (s: PAVCodecContext; pic: PAVFrame): cint; - cdecl; external av__codec; -procedure avcodec_default_release_buffer (s: PAVCodecContext; pic: PAVFrame); - cdecl; external av__codec; -function avcodec_default_reget_buffer (s: PAVCodecContext; pic: PAVFrame): cint; - cdecl; external av__codec; -procedure avcodec_align_dimensions(s: PAVCodecContext; width: PCint; height: PCint); - cdecl; external av__codec; - -(** - * Checks if the given dimension of a picture is valid, meaning that all - * bytes of the picture can be addressed with a signed int. - * - * @param[in] w Width of the picture. - * @param[in] h Height of the picture. - * @return Zero if valid, a negative value if invalid. - *) -function avcodec_check_dimensions(av_log_ctx: pointer; w: cuint; h: cuint): cint; - cdecl; external av__codec; -function avcodec_default_get_format(s: PAVCodecContext; fmt: {const} PAVPixelFormat): TAVPixelFormat; - cdecl; external av__codec; - -function avcodec_thread_init(s: PAVCodecContext; thread_count: cint): cint; - cdecl; external av__codec; -procedure avcodec_thread_free(s: PAVCodecContext); - cdecl; external av__codec; - - -{$IF LIBAVCODEC_VERSION < 52004000} // < 52.4.0 -function avcodec_thread_execute(s: PAVCodecContext; func: TExecuteFunc; arg: PPointer; var ret: cint; count: cint): cint; - cdecl; external av__codec; -{$ELSE} -function avcodec_thread_execute(s: PAVCodecContext; func: TExecuteFunc; arg: Pointer; var ret: cint; count: cint; size: cint): cint; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION < 52004000} // < 52.4.0 -function avcodec_default_execute(s: PAVCodecContext; func: TExecuteFunc; arg: PPointer; var ret: cint; count: cint): cint; - cdecl; external av__codec; -{$ELSE} -function avcodec_default_execute(s: PAVCodecContext; func: TExecuteFunc; arg: Pointer; var ret: cint; count: cint; size: cint): cint; - cdecl; external av__codec; -{$IFEND} -{$IF LIBAVCODEC_VERSION >= 52037000} // >= 52.37.0 -function avcodec_default_execute2(s: PAVCodecContext; func: TExecuteFunc; arg: Pointer; var ret: cint; count: cint): cint; - cdecl; external av__codec; -{$IFEND} -//FIXME func typedef - -(** - * Initializes the AVCodecContext to use the given AVCodec. Prior to using this - * function the context has to be allocated. - * - * The functions avcodec_find_decoder_by_name(), avcodec_find_encoder_by_name(), - * avcodec_find_decoder() and avcodec_find_encoder() provide an easy way for - * retrieving a codec. - * - * @warning This function is not thread safe! - * - * @code - * avcodec_register_all(); - * codec = avcodec_find_decoder(CODEC_ID_H264); - * if (!codec) - * exit(1); - * - * context = avcodec_alloc_context(); - * - * if (avcodec_open(context, codec) < 0) - * exit(1); - * @endcode - * - * @param avctx The context which will be set up to use the given codec. - * @param codec The codec to use within the context. - * @return zero on success, a negative value on error - * @see avcodec_alloc_context, avcodec_find_decoder, avcodec_find_encoder - *) -function avcodec_open(avctx: PAVCodecContext; codec: PAVCodec): cint; - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION < 52000000} // < 52.0.0 -(** - * @deprecated Use avcodec_decode_audio2 instead. - *) -function avcodec_decode_audio(avctx: PAVCodecContext; samples: PSmallint; - var frame_size_ptr: cint; - buf: {const} PByteArray; buf_size: cint): cint; - cdecl; external av__codec; {deprecated;} -{$IFEND} - -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} -{$IF LIBAVCODEC_VERSION >= 51030000} // 51.30.0 -(** - * Decodes an audio frame from buf into samples. - * Wrapper function which calls avcodec_decode_audio3. - * - * @deprecated Use avcodec_decode_audio3 instead. - * @param avctx the codec context - * @param[out] samples the output buffer, sample type in avctx->sample_fmt - * @param[in,out] frame_size_ptr the output buffer size in bytes - * @param[in] buf the input buffer - * @param[in] buf_size the input buffer size in bytes - * @return On error a negative value is returned, otherwise the number of bytes - * used or zero if no frame could be decompressed. - *) -function avcodec_decode_audio2(avctx: PAVCodecContext; samples: PSmallint; - var frame_size_ptr: cint; - buf: {const} PByteArray; buf_size: cint): cint; - cdecl; external av__codec; {deprecated;} -{$IFEND} -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52025000} // 52.25.0 -(** - * Decodes the audio frame of size avpkt->size from avpkt->data into samples. - * Some decoders may support multiple frames in a single AVPacket, such - * decoders would then just decode the first frame. In this case, - * avcodec_decode_audio3 has to be called again with an AVPacket that contains - * the remaining data in order to decode the second frame etc. - * If no frame - * could be outputted, frame_size_ptr is zero. Otherwise, it is the - * decompressed frame size in bytes. - * - * @warning You must set frame_size_ptr to the allocated size of the - * output buffer before calling avcodec_decode_audio3(). - * - * @warning The input buffer must be FF_INPUT_BUFFER_PADDING_SIZE larger than - * the actual read bytes because some optimized bitstream readers read 32 or 64 - * bits at once and could read over the end. - * - * @warning The end of the input buffer avpkt->data should be set to 0 to ensure that - * no overreading happens for damaged MPEG streams. - * - * @note You might have to align the input buffer avpkt->data and output buffer - * samples. The alignment requirements depend on the CPU: On some CPUs it isn't - * necessary at all, on others it won't work at all if not aligned and on others - * * it will work but it will have an impact on performance. - * - * In practice, avpkt->data should have 4 byte alignment at minimum and - * samples should be 16 byte aligned unless the CPU doesn't need it - * (AltiVec and SSE do). - * - * @note Some codecs have a delay between input and output, these need to be - * feeded with avpkt->data=NULL, avpkt->size=0 at the end to return the remaining frames. - * - * @param avctx the codec context - * @param[out] samples the output buffer - * @param[in,out] frame_size_ptr the output buffer size in bytes - * @param[in] avpkt The input AVPacket containing the input buffer. - * You can create such packet with av_init_packet() and by then setting - * data and size, some decoders might in addition need other fields. - * All decoders are designed to use the least fields possible though. - * @return On error a negative value is returned, otherwise the number of bytes - * used or zero if no frame data was decompressed (used) from the input AVPacket. - *) -function avcodec_decode_audio3(avctx: PAVCodecContext; samples: PSmallint; - var frame_size_ptr: cint; - avpkt: PAVPacket): cint; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} -(** - * Decodes a video frame from buf into picture. - * Wrapper function which calls avcodec_decode_video2. - * - * @deprecated Use avcodec_decode_video2 instead. - * @param avctx the codec context - * @param[out] picture The AVFrame in which the decoded video frame will be stored. - * @param[in] buf the input buffer - * @param[in] buf_size the size of the input buffer in bytes - * @param[in,out] got_picture_ptr Zero if no frame could be decompressed, otherwise, it is nonzero. - * @return On error a negative value is returned, otherwise the number of bytes - * used or zero if no frame could be decompressed. - *) -function avcodec_decode_video(avctx: PAVCodecContext; picture: PAVFrame; - var got_picture_ptr: cint; - buf: {const} PByteArray; buf_size: cint): cint; - cdecl; external av__codec; {deprecated;} -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52025000} // 52.25.0 -(** - * Decodes the video frame of size avpkt->size from avpkt->data into picture. - * Some decoders may support multiple frames in a single AVPacket, such - * decoders would then just decode the first frame. - * - * @warning The input buffer must be FF_INPUT_BUFFER_PADDING_SIZE larger than - * the actual read bytes because some optimized bitstream readers read 32 or 64 - * bits at once and could read over the end. - * - * @warning The end of the input buffer buf should be set to 0 to ensure that - * no overreading happens for damaged MPEG streams. - * - * @note You might have to align the input buffer avpkt->data. - * The alignment requirements depend on the CPU: on some CPUs it isn't - * necessary at all, on others it won't work at all if not aligned and on others - * it will work but it will have an impact on performance. - * - * In practice, avpkt->data should have 4 byte alignment at minimum. - * - * @param avctx the codec context - * @param[out] picture The AVFrame in which the decoded video frame will be stored. - * @param[in] avpkt The input AVpacket containing the input buffer. - * You can create such packet with av_init_packet() and by then setting - * data and size, some decoders might in addition need other fields like - * flags&PKT_FLAG_KEY. All decoders are designed to use the least - * fields possible. - * @param[in,out] got_picture_ptr Zero if no frame could be decompressed, otherwise, it is nonzero. - * @return On error a negative value is returned, otherwise the number of bytes - * used or zero if no frame could be decompressed. - *) -function avcodec_decode_video2(avctx: PAVCodecContext; picture: PAVFrame; - var got_picture_ptr: cint; - avpkt: PAVPacket): cint; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} -(* Decode a subtitle message. Return -1 if error, otherwise return the - * number of bytes used. If no subtitle could be decompressed, - * got_sub_ptr is zero. Otherwise, the subtitle is stored in*sub. - *) -function avcodec_decode_subtitle(avctx: PAVCodecContext; sub: PAVSubtitle; - var got_sub_ptr: cint; - buf: {const} PByteArray; buf_size: cint): cint; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52025000} // 52.25.0 -(* Decodes a subtitle message. - * Returns a negative value on error, otherwise returns the number of bytes used. - * If no subtitle could be decompressed, got_sub_ptr is zero. - * Otherwise, the subtitle is stored in sub. - * - * @param avctx the codec context - * @param[out] sub The AVSubtitle in which the decoded subtitle will be stored. - * @param[in,out] got_sub_ptr Zero if no subtitle could be decompressed, otherwise, it is nonzero. - * @param[in] avpkt The input AVPacket containing the input buffer. - *) -function avcodec_decode_subtitle2(avctx: PAVCodecContext; sub: PAVSubtitle; - var got_sub_ptr: cint; - avpkt: PAVPacket): cint; - cdecl; external av__codec; -{$IFEND} - -function avcodec_parse_frame(avctx: PAVCodecContext; pdata: PPointer; - data_size_ptr: PCint; - buf: PByteArray; buf_size: cint): cint; - cdecl; external av__codec; - -(** - * Encodes an audio frame from samples into buf. - * - * @note The output buffer should be at least FF_MIN_BUFFER_SIZE bytes large. - * However, for PCM audio the user will know how much space is needed - * because it depends on the value passed in buf_size as described - * below. In that case a lower value can be used. - * - * @param avctx the codec context - * @param[out] buf the output buffer - * @param[in] buf_size the output buffer size - * @param[in] samples the input buffer containing the samples - * The number of samples read from this buffer is frame_size*channels, - * both of which are defined in avctx. - * For PCM audio the number of samples read from samples is equal to - * buf_size * input_sample_size / output_sample_size. - * @return On error a negative value is returned, on success zero or the number - * of bytes used to encode the data read from the input buffer. - *) -function avcodec_encode_audio(avctx: PAVCodecContext; buf: PByte; - buf_size: cint; samples: {const} PSmallint): cint; - cdecl; external av__codec; - -(** - * Encodes a video frame from pict into buf. - * The input picture should be - * stored using a specific format, namely avctx.pix_fmt. - * - * @param avctx the codec context - * @param[out] buf the output buffer for the bitstream of encoded frame - * @param[in] buf_size the size of the output buffer in bytes - * @param[in] pict the input picture to encode - * @return On error a negative value is returned, on success zero or the number - * of bytes used from the output buffer. - *) -function avcodec_encode_video(avctx: PAVCodecContext; buf: PByte; - buf_size: cint; pict: PAVFrame): cint; - cdecl; external av__codec; -function avcodec_encode_subtitle(avctx: PAVCodecContext; buf: PByteArray; - buf_size: cint; sub: {const} PAVSubtitle): cint; - cdecl; external av__codec; - -function avcodec_close(avctx: PAVCodecContext): cint; - cdecl; external av__codec; - -(** - * Register all the codecs, parsers and bitstream filters which were enabled at - * configuration time. If you do not call this function you can select exactly - * which formats you want to support, by using the individual registration - * functions. - * - * @see register_avcodec - * @see avcodec_register - * @see av_register_codec_parser - * @see av_register_bitstream_filter - *) -procedure avcodec_register_all(); - cdecl; external av__codec; - -(** - * Flush buffers, should be called when seeking or when switching to a different stream. - *) -procedure avcodec_flush_buffers(avctx: PAVCodecContext); - cdecl; external av__codec; - -procedure avcodec_default_free_buffers(s: PAVCodecContext); - cdecl; external av__codec; - -(* misc useful functions *) - -(** - * Returns a single letter to describe the given picture type pict_type. - * - * @param[in] pict_type the picture type - * @return A single character representing the picture type. - *) -function av_get_pict_type_char(pict_type: cint): AnsiChar; - cdecl; external av__codec; - -(** - * Returns codec bits per sample. - * - * @param[in] codec_id the codec - * @return Number of bits per sample or zero if unknown for the given codec. - *) -function av_get_bits_per_sample(codec_id: TCodecID): cint; - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 51041000} // 51.41.0 -(** - * Returns sample format bits per sample. - * - * @param[in] sample_fmt the sample format - * @return Number of bits per sample or zero if unknown for the given sample format. - *) -function av_get_bits_per_sample_format(sample_fmt: TSampleFormat): cint; - cdecl; external av__codec; -{$IFEND} - -const - AV_PARSER_PTS_NB = 4; - PARSER_FLAG_COMPLETE_FRAMES = $0001; - -type - {* frame parsing *} - PAVCodecParserContext = ^TAVCodecParserContext; - PAVCodecParser = ^TAVCodecParser; - - TAVCodecParserContext = record - priv_data: pointer; - parser: PAVCodecParser; - frame_offset: cint64; (* offset of the current frame *) - cur_offset: cint64; (* current offset (incremented by each av_parser_parse()) *) - next_frame_offset: cint64; (* offset of the next frame *) - (* video info *) - pict_type: cint; (* XXX: put it back in AVCodecContext *) - (** - * This field is used for proper frame duration computation in lavf. - * It signals, how much longer the frame duration of the current frame - * is compared to normal frame duration. - * - * frame_duration = (1 + repeat_pict) * time_base - * - * It is used by codecs like H.264 to display telecined material. - *) - repeat_pict: cint; (* XXX: put it back in AVCodecContext *) - pts: cint64; (* pts of the current frame *) - dts: cint64; (* dts of the current frame *) - - (* private data *) - last_pts: cint64; - last_dts: cint64; - fetch_timestamp: cint; - - cur_frame_start_index: cint; - cur_frame_offset: array [0..AV_PARSER_PTS_NB - 1] of cint64; - cur_frame_pts: array [0..AV_PARSER_PTS_NB - 1] of cint64; - cur_frame_dts: array [0..AV_PARSER_PTS_NB - 1] of cint64; - - flags: cint; - - {$IF LIBAVCODEC_VERSION >= 51040003} // 51.40.3 - offset: cint64; ///< byte offset from starting packet start - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 51057001} // 51.57.1 - cur_frame_end: array [0..AV_PARSER_PTS_NB - 1] of cint64; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52016000} // 52.16.0 - (*! - * Set by parser to 1 for key frames and 0 for non-key frames. - * It is initialized to -1, so if the parser doesn't set this flag, - * old-style fallback using FF_I_TYPE picture type as key frames - * will be used. - *) - key_frame: cint; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52018000} // 52.18.0 - (** - * Time difference in stream time base units from the pts of this - * packet to the point at which the output from the decoder has converged - * independent from the availability of previous frames. That is, the - * frames are virtually identical no matter if decoding started from - * the very first frame or from this keyframe. - * Is AV_NOPTS_VALUE if unknown. - * This field is not the display duration of the current frame. - * - * The purpose of this field is to allow seeking in streams that have no - * keyframes in the conventional sense. It corresponds to the - * recovery point SEI in H.264 and match_time_delta in NUT. It is also - * essential for some types of subtitle streams to ensure that all - * subtitles are correctly displayed after seeking. - *) - convergence_duration: cint64; - {$IFEND} - {$IF LIBAVCODEC_VERSION >= 52019000} // 52.19.0 - // Timestamp generation support: - (** - * Synchronization point for start of timestamp generation. - * - * Set to >0 for sync point, 0 for no sync point and <0 for undefined - * (default). - * - * For example, this corresponds to presence of H.264 buffering period - * SEI message. - *) - dts_sync_point: cint; - - (** - * Offset of the current timestamp against last timestamp sync point in - * units of AVCodecContext.time_base. - * - * Set to INT_MIN when dts_sync_point unused. Otherwise, it must - * contain a valid timestamp offset. - * - * Note that the timestamp of sync point has usually a nonzero - * dts_ref_dts_delta, which refers to the previous sync point. Offset of - * the next frame after timestamp sync point will be usually 1. - * - * For example, this corresponds to H.264 cpb_removal_delay. - *) - dts_ref_dts_delta: cint; - - (** - * Presentation delay of current frame in units of AVCodecContext.time_base. - * - * Set to INT_MIN when dts_sync_point unused. Otherwise, it must - * contain valid non-negative timestamp delta (presentation time of a frame - * must not lie in the past). - * - * This delay represents the difference between decoding and presentation - * time of the frame. - * - * For example, this corresponds to H.264 dpb_output_delay. - *) - pts_dts_delta: cint; - {$IFEND} - - {$IF LIBAVCODEC_VERSION >= 52021000} // 52.21.0 - (** - * Position of the packet in file. - * - * Analogous to cur_frame_pts/dts - *) - cur_frame_pos: array [0..AV_PARSER_PTS_NB - 1] of cint64; - - (** - * Byte position of currently parsed frame in stream. - *) - pos: cint64; - - (** - * Previous frame byte position. - *) - last_pos: cint64; - {$IFEND} - end; - - TAVCodecParser = record - codec_ids: array [0..4] of cint; (* several codec IDs are permitted *) - priv_data_size: cint; - parser_init: function(s: PAVCodecParserContext): cint; cdecl; - parser_parse: function(s: PAVCodecParserContext; avctx: PAVCodecContext; - poutbuf: {const} PPointer; poutbuf_size: PCint; - buf: {const} PByteArray; buf_size: cint): cint; cdecl; - parser_close: procedure(s: PAVCodecParserContext); cdecl; - split: function(avctx: PAVCodecContext; buf: {const} PByteArray; - buf_size: cint): cint; cdecl; - next: PAVCodecParser; - end; - - -{$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 -{ -var - av_first_parser: PAVCodecParser; external av__codec; -} -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 51049000} // 51.49.0 -function av_parser_next(c: PAVCodecParser): PAVCodecParser; - cdecl; external av__codec; -{$IFEND} - -procedure av_register_codec_parser(parser: PAVCodecParser); - cdecl; external av__codec; - -function av_parser_init(codec_id: cint): PAVCodecParserContext; - cdecl; external av__codec; - -{$IF LIBAVCODEC_MAX_VERSION_MAJOR < 53} -function av_parser_parse(s: PAVCodecParserContext; - avctx: PAVCodecContext; - poutbuf: PPointer; - poutbuf_size: PCint; - buf: {const} PByteArray; - buf_size: cint; - pts: cint64; - dts: cint64): cint; - cdecl; external av__codec; deprecated; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52021000} // 52.21.0 -(** - * Parse a packet. - * - * @param s parser context. - * @param avctx codec context. - * @param poutbuf set to pointer to parsed buffer or NULL if not yet finished. - * @param poutbuf_size set to size of parsed buffer or zero if not yet finished. - * @param buf input buffer. - * @param buf_size input length, to signal EOF, this should be 0 (so that the last frame can be output). - * @param pts input presentation timestamp. - * @param dts input decoding timestamp. - * @param pos input byte position in stream. - * @return the number of bytes of the input bitstream used. - * - * Example: - * @code - * while (in_len) do - * begin - * len := av_parser_parse2(myparser, AVCodecContext, data, size, - * in_data, in_len, - * pts, dts, pos); - * in_data := in_data + len; - * in_len := in_len - len; - * - * if (size) then - * decode_frame(data, size); - * end; - * @endcode - *) -function av_parser_parse2(s: PAVCodecParserContext; - avctx: PAVCodecContext; - poutbuf: PPointer; - poutbuf_size: PCint; - buf: {const} PByteArray; - buf_size: cint; - pts: cint64; - dts: cint64; - pos: cint64): cint; - cdecl; external av__codec; -{$IFEND} - -function av_parser_change(s: PAVCodecParserContext; - avctx: PAVCodecContext; - poutbuf: PPointer; poutbuf_size: PCint; - buf: {const} PByteArray; buf_size: cint; keyframe: cint): cint; - cdecl; external av__codec; -procedure av_parser_close(s: PAVCodecParserContext); - cdecl; external av__codec; - -type - PAVBitStreamFilterContext = ^TAVBitStreamFilterContext; - PAVBitStreamFilter = ^TAVBitStreamFilter; - - TAVBitStreamFilterContext = record - priv_data: pointer; - filter: PAVBitStreamFilter; - parser: PAVCodecParserContext; - next: PAVBitStreamFilterContext; - end; - - TAVBitStreamFilter = record - name: PAnsiChar; - priv_data_size: cint; - filter: function(bsfc: PAVBitStreamFilterContext; - avctx: PAVCodecContext; args: PByteArray; - poutbuf: PPointer; poutbuf_size: PCint; - buf: PByte; buf_size: cint; keyframe: cint): cint; cdecl; - {$IF LIBAVCODEC_VERSION >= 51043000} // 51.43.0 - close: procedure(bsfc: PAVBitStreamFilterContext); - {$IFEND} - next: PAVBitStreamFilter; - end; - -procedure av_register_bitstream_filter(bsf: PAVBitStreamFilter); - cdecl; external av__codec; - -function av_bitstream_filter_init(name: PAnsiChar): PAVBitStreamFilterContext; - cdecl; external av__codec; - -function av_bitstream_filter_filter(bsfc: PAVBitStreamFilterContext; - avctx: PAVCodecContext; args: PByteArray; - poutbuf: PPointer; poutbuf_size: PCint; - buf: PByte; buf_size: cint; keyframe: cint): cint; - cdecl; external av__codec; -procedure av_bitstream_filter_close(bsf: PAVBitStreamFilterContext); - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 51049000} // 51.49.0 -function av_bitstream_filter_next(f: PAVBitStreamFilter): PAVBitStreamFilter; - cdecl; external av__codec; -{$IFEND} - -(* memory *) - -(** - * Reallocates the given block if it is not large enough, otherwise it - * does nothing. - * - * @see av_realloc - *) -procedure av_fast_realloc(ptr: pointer; size: PCuint; min_size: cuint); - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 52025000} // >= 52.25.0 -(** - * Allocates a buffer, reusing the given one if large enough. - * - * Contrary to av_fast_realloc the current buffer contents might not be - * preserved and on error the old buffer is freed, thus no special - * handling to avoid memleaks is necessary. - * - * @param ptr pointer to pointer to already allocated buffer, overwritten with pointer to new buffer - * @param size size of the buffer *ptr points to - * @param min_size minimum size of *ptr buffer after returning, *ptr will be NULL and - * *size 0 if an error occurred. - *) -procedure av_fast_malloc(ptr: pointer; size: PCuint; min_size: cuint); - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION < 51057000} // 51.57.0 -(* for static data only *) - -(** - * Frees all static arrays and resets their pointers to 0. - * Call this function to release all statically allocated tables. - * - * @deprecated. Code which uses av_free_static is broken/misdesigned - * and should correctly use static arrays - * - *) -procedure av_free_static(); - cdecl; external av__codec; deprecated; - -(** - * Allocation of static arrays. - * - * @warning Do not use for normal allocation. - * - * @param[in] size The amount of memory you need in bytes. - * @return block of memory of the requested size - * @deprecated. Code which uses av_mallocz_static is broken/misdesigned - * and should correctly use static arrays - *) -procedure av_mallocz_static(size: cuint); - cdecl; external av__codec; deprecated; {av_malloc_attrib av_alloc_size(1)} -{$IFEND} - -{$IF LIBAVCODEC_VERSION < 51035000} // 51.35.0 -procedure av_realloc_static(ptr: pointer; size: cuint); - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 -(** - * Copy image 'src' to 'dst'. - *) -procedure av_picture_copy(dst: PAVPicture; - src: {const} PAVPicture; -{$IF LIBAVCODEC_VERSION < 52022001} // 52.22.1 - pix_fmt: cint; -{$ELSE} - pix_fmt: TAVPixelFormat; -{$IFEND} - width: cint; - height: cint); - cdecl; external av__codec; - -(** - * Crop image top and left side. - *) -function av_picture_crop(dst: PAVPicture; - src: {const} PAVPicture; -{$IF LIBAVCODEC_VERSION < 52022001} // 52.22.1 - pix_fmt: cint; -{$ELSE} - pix_fmt: TAVPixelFormat; -{$IFEND} - top_band: cint; - left_band: cint): cint; - cdecl; external av__codec; - -(** - * Pad image. - *) -function av_picture_pad(dst: PAVPicture; - src: {const} PAVPicture; - height: cint; - width: cint; -{$IF LIBAVCODEC_VERSION < 52022001} // 52.22.1 - pix_fmt: cint; -{$ELSE} - pix_fmt: TAVPixelFormat; -{$IFEND} - padtop: cint; - padbottom: cint; - padleft: cint; - padright: - cint; - color: PCint): cint; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION < 52000000} // 52.0.0 -(** - * @deprecated Use the software scaler (swscale) instead. - *) -procedure img_copy(dst: PAVPicture; src: {const} PAVPicture; - pix_fmt: TAVPixelFormat; width: cint; height: cint); - cdecl; external av__codec; deprecated; - -(** - * @deprecated Use the software scaler (swscale) instead. - *) -function img_crop(dst: PAVPicture; src: {const} PAVPicture; - pix_fmt: TAVPixelFormat; top_band, left_band: cint): cint; - cdecl; external av__codec; deprecated; - -(** - * @deprecated Use the software scaler (swscale) instead. - *) -function img_pad(dst: PAVPicture; src: {const} PAVPicture; height, width: cint; - pix_fmt: TAVPixelFormat; padtop, padbottom, padleft, padright: cint; - color: PCint): cint; - cdecl; external av__codec; deprecated; -{$IFEND} - -function av_xiphlacing(s: PByte; v: cuint): cuint; - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 51041000} // 51.41.0 -(** - * Parses str and put in width_ptr and height_ptr the detected values. - * - * @return 0 in case of a successful parsing, a negative value otherwise - * @param[in] str the string to parse: it has to be a string in the format - * x or a valid video frame size abbreviation. - * @param[in,out] width_ptr pointer to the variable which will contain the detected - * frame width value - * @param[in,out] height_ptr pointer to the variable which will contain the detected - * frame height value - *) -function av_parse_video_frame_size(width_ptr: PCint; height_ptr: PCint; str: {const} PAnsiChar): cint; - cdecl; external av__codec; - -(** - * Parses str and put in frame_rate the detected values. - * - * @return 0 in case of a successful parsing, a negative value otherwise - * @param[in] str the string to parse: it has to be a string in the format - * /, a float number or a valid video rate abbreviation - * @param[in,out] frame_rate pointer to the AVRational which will contain the detected - * frame rate - *) -function av_parse_video_frame_rate(frame_rate: PAVRational; str: {const} PAnsiChar): cint; - cdecl; external av__codec; -{$IFEND} - -{* error handling *} - -const -{$IFDEF UNIX} - ENOENT = ESysENOENT; - EIO = ESysEIO; - ENOMEM = ESysENOMEM; - EINVAL = ESysEINVAL; - EDOM = ESysEDOM; - ENOSYS = ESysENOSYS; - EILSEQ = ESysEILSEQ; - EPIPE = ESysEPIPE; -{$ELSE} - ENOENT = 2; - EIO = 5; - ENOMEM = 12; - EINVAL = 22; - EPIPE = 32; // just an assumption. needs to be checked. - EDOM = 33; - {$IFDEF MSWINDOWS} - // Note: we assume that ffmpeg was compiled with MinGW. - // This must be changed if DLLs were compiled with cygwin. - ENOSYS = 40; // MSVC/MINGW: 40, CYGWIN: 88, LINUX/FPC: 38 - EILSEQ = 42; // MSVC/MINGW: 42, CYGWIN: 138, LINUX/FPC: 84 - {$ENDIF} -{$ENDIF} - -const -{$IF EINVAL > 0} - AVERROR_SIGN = -1; -{$ELSE} - {* Some platforms have E* and errno already negated. *} - AVERROR_SIGN = 1; -{$IFEND} - -(* -#if EINVAL > 0 -#define AVERROR(e) (-(e)) {**< Returns a negative error code from a POSIX error code, to return from library functions. *} -#define AVUNERROR(e) (-(e)) {**< Returns a POSIX error code from a library function error return value. *} -#else -{* Some platforms have E* and errno already negated. *} -#define AVERROR(e) (e) -#define AVUNERROR(e) (e) -#endif -*) - -const - AVERROR_UNKNOWN = AVERROR_SIGN * EINVAL; (**< unknown error *) - AVERROR_IO = AVERROR_SIGN * EIO; (**< I/O error *) - AVERROR_NUMEXPECTED = AVERROR_SIGN * EDOM; (**< Number syntax expected in filename. *) - AVERROR_INVALIDDATA = AVERROR_SIGN * EINVAL; (**< invalid data found *) - AVERROR_NOMEM = AVERROR_SIGN * ENOMEM; (**< not enough memory *) - AVERROR_NOFMT = AVERROR_SIGN * EILSEQ; (**< unknown format *) - AVERROR_NOTSUPP = AVERROR_SIGN * ENOSYS; (**< Operation not supported. *) - AVERROR_NOENT = AVERROR_SIGN * ENOENT; (**< No such file or directory. *) -{$IF LIBAVCODEC_VERSION >= 52017000} // 52.17.0 - AVERROR_EOF = AVERROR_SIGN * EPIPE; (**< End of file. *) -{$IFEND} - // Note: function calls as constant-initializers are invalid - //AVERROR_PATCHWELCOME = -MKTAG('P','A','W','E'); {**< Not yet implemented in FFmpeg. Patches welcome. *} - AVERROR_PATCHWELCOME = -(ord('P') or (ord('A') shl 8) or (ord('W') shl 16) or (ord('E') shl 24)); - -{$IF LIBAVCODEC_VERSION >= 52032000} // >= 52.32.0 -(** - * Logs a generic warning message about a missing feature. This function is - * intended to be used internally by FFmpeg (libavcodec, libavformat, etc.) - * only, and would normally not be used by applications. - * @param[in] avc a pointer to an arbitrary struct of which the first field is - * a pointer to an AVClass struct - * @param[in] feature string containing the name of the missing feature - * @param[in] want_sample indicates if samples are wanted which exhibit this feature. - * If want_sample is non-zero, additional verbage will be added to the log - * message which tells the user how to report samples to the development - * mailing list. - *) -procedure av_log_missing_feature(avc: Pointer; feature: {const} Pchar; want_sample: cint); - cdecl; external av__codec; - -(** - * Logs a generic warning message asking for a sample. This function is - * intended to be used internally by FFmpeg (libavcodec, libavformat, etc.) - * only, and would normally not be used by applications. - * @param[in] avc a pointer to an arbitrary struct of which the first field is - * a pointer to an AVClass struct - * @param[in] msg string containing an optional message, or NULL if no message - *) -procedure av_log_ask_for_sample(avc: Pointer; msg: {const} Pchar); - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52018000} // 52.18.0 -(** - * Registers the hardware accelerator hwaccel. - *) -procedure av_register_hwaccel (hwaccel: PAVHWAccel) - cdecl; external av__codec; - -(** - * If hwaccel is NULL, returns the first registered hardware accelerator, - * if hwaccel is non-NULL, returns the next registered hardware accelerator - * after hwaccel, or NULL if hwaccel is the last one. - *) -function av_hwaccel_next (hwaccel: PAVHWAccel): PAVHWAccel; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52030000} // 52.30.0 -(** - * Lock operation used by lockmgr - *) -type - TAVLockOp = ( - AV_LOCK_CREATE, ///< Create a mutex - AV_LOCK_OBTAIN, ///< Lock the mutex - AV_LOCK_RELEASE, ///< Unlock the mutex - AV_LOCK_DESTROY ///< Free mutex resources - ); - -(** - * Register a user provided lock manager supporting the operations - * specified by AVLockOp. mutex points to a (void) where the - * lockmgr should store/get a pointer to a user allocated mutex. It's - * NULL upon AV_LOCK_CREATE and != NULL for all other ops. - * - * @param cb User defined callback. Note: FFmpeg may invoke calls to this - * callback during the call to av_lockmgr_register(). - * Thus, the application must be prepared to handle that. - * If cb is set to NULL the lockmgr will be unregistered. - * Also note that during unregistration the previously registered - * lockmgr callback may also be invoked. - *) -// ToDo: Implement and test this -//function av_lockmgr_register(cb: function (mutex: pointer; op: TAVLockOp)): cint; -// cdecl; external av__codec; -{$IFEND} - -implementation - -{$IF (LIBAVCODEC_VERSION >= 52025000) and (LIBAVCODEC_VERSION <= 52027000)} // 52.25.0 - 52.27.0 -procedure av_free_packet(pkt: PAVPacket);{$IFDEF HASINLINE} inline; {$ENDIF} -begin - if assigned(pkt) then - begin - if assigned(pkt^.destruct) then - pkt^.destruct(pkt); - pkt^.data := NIL; - pkt^.size := 0; - end; -end; -{$IFEND} - -end. diff --git a/src/lib/ffmpeg/avformat.pas b/src/lib/ffmpeg/avformat.pas deleted file mode 100644 index 9c5170f5..00000000 --- a/src/lib/ffmpeg/avformat.pas +++ /dev/null @@ -1,1750 +0,0 @@ -(* - * copyright (c) 2001 Fabrice Bellard - * - * FFmpeg is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * FFmpeg is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with FFmpeg; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversion of libavformat/avformat.h - * Min. version: 50.5.0 , revision 6577, Sat Oct 7 15:30:46 2006 UTC - * Max. version: 52.25.0, revision 16986, Wed Feb 4 05:56:39 2009 UTC - *) -{ - * update to - * Max. version: 52.41.0, Sun Dec 6 20:15:00 2009 CET - * MiSchi -} - -unit avformat; - -{$IFDEF FPC} - {$MODE DELPHI } - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$I switches.inc} (* for the HasInline define *) - -{$IFDEF DARWIN} - {$linklib libavformat} -{$ENDIF} - -interface - -uses - ctypes, - avcodec, - avutil, - avio, - rational, - SysUtils, - UConfig; - -const - (* Max. supported version by this header *) - LIBAVFORMAT_MAX_VERSION_MAJOR = 52; - LIBAVFORMAT_MAX_VERSION_MINOR = 41; - LIBAVFORMAT_MAX_VERSION_RELEASE = 0; - LIBAVFORMAT_MAX_VERSION = (LIBAVFORMAT_MAX_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVFORMAT_MAX_VERSION_MINOR * VERSION_MINOR) + - (LIBAVFORMAT_MAX_VERSION_RELEASE * VERSION_RELEASE); - - (* Min. supported version by this header *) - LIBAVFORMAT_MIN_VERSION_MAJOR = 50; - LIBAVFORMAT_MIN_VERSION_MINOR = 5; - LIBAVFORMAT_MIN_VERSION_RELEASE = 0; - LIBAVFORMAT_MIN_VERSION = (LIBAVFORMAT_MIN_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVFORMAT_MIN_VERSION_MINOR * VERSION_MINOR) + - (LIBAVFORMAT_MIN_VERSION_RELEASE * VERSION_RELEASE); - -(* Check if linked versions are supported *) -{$IF (LIBAVFORMAT_VERSION < LIBAVFORMAT_MIN_VERSION)} - {$MESSAGE Error 'Linked version of libavformat is too old!'} -{$IFEND} - -(* Check if linked versions are supported *) -{$IF (LIBAVFORMAT_VERSION > LIBAVFORMAT_MAX_VERSION)} - {$MESSAGE Error 'Linked version of libavformat is not yet supported!'} -{$IFEND} - -{$IF LIBAVFORMAT_VERSION >= 52020000} // 52.20.0 -(** - * Returns the LIBAVFORMAT_VERSION_INT constant. - *) -function avformat_version(): cuint; - cdecl; external av__format; -{$IFEND} - -{$IF LIBAVFORMAT_VERSION >= 52039002} // 52.39.2 -(** - * Returns the libavformat build-time configuration. - *) -function avformat_configuration(): {const} PansiChar; - cdecl; external av__format; - -(** - * Returns the libavformat license. - *) -function avformat_license(): {const} PansiChar; - cdecl; external av__format; -{$IFEND} - -type - PAVFile = Pointer; - -(* - * Public Metadata API. - * The metadata API allows libavformat to export metadata tags to a client - * application using a sequence of key/value pairs. - * Important concepts to keep in mind: - * 1. Keys are unique; there can never be 2 tags with the same key. This is - * also meant semantically, i.e., a demuxer should not knowingly produce - * several keys that are literally different but semantically identical. - * E.g., key=Author5, key=Author6. In this example, all authors must be - * placed in the same tag. - * 2. Metadata is flat, not hierarchical; there are no subtags. If you - * want to store, e.g., the email address of the child of producer Alice - * and actor Bob, that could have key=alice_and_bobs_childs_email_address. - * 3. A tag whose value is localized for a particular language is appended - * with a dash character ('-') and the ISO 639-2/B 3-letter language code. - * For example: Author-ger=Michael, Author-eng=Mike - * The original/default language is in the unqualified "Author" tag. - * A demuxer should set a default if it sets any translated tag. - *) -const - AV_METADATA_MATCH_CASE = 1; - AV_METADATA_IGNORE_SUFFIX = 2; - -type - PAVMetadataTag = ^TAVMetadataTag; - TAVMetadataTag = record - key: PAnsiChar; - value: PAnsiChar; - end; - - PAVMetadata = Pointer; - -{$IF LIBAVFORMAT_VERSION > 52024001} // > 52.24.1 -(** - * Gets a metadata element with matching key. - * @param prev Set to the previous matching element to find the next. - * @param flags Allows case as well as suffix-insensitive comparisons. - * @return Found tag or NULL, changing key or value leads to undefined behavior. - *) -function av_metadata_get(m: PAVMetadata; key: {const} PAnsiChar; - prev: {const} PAVMetadataTag ; flags: cint): PAVMetadataTag; - cdecl; external av__format; - -(** - * Sets the given tag in m, overwriting an existing tag. - * @param key tag key to add to m (will be av_strduped) - * @param value tag value to add to m (will be av_strduped) - * @return >= 0 on success otherwise an error code <0 - *) -function av_metadata_set(var pm: PAVMetadata; key: {const} PAnsiChar; value: {const} PAnsiChar): cint; - cdecl; external av__format; - -(** - * Frees all the memory allocated for an AVMetadata struct. - *) -procedure av_metadata_free(var m: PAVMetadata); - cdecl; external av__format; -{$IFEND} - -(* packet functions *) - -{$IF LIBAVCODEC_VERSION < 52032000} // < 52.32.0 -type - PAVPacket = ^TAVPacket; - TAVPacket = record - (** - * Presentation timestamp in time_base units; the time at which the - * decompressed packet will be presented to the user. - * Can be AV_NOPTS_VALUE if it is not stored in the file. - * pts MUST be larger or equal to dts as presentation can not happen before - * decompression, unless one wants to view hex dumps. Some formats misuse - * the terms dts and pts/cts to mean something different. Such timestamps - * must be converted to true pts/dts before they are stored in AVPacket. - *) - pts: cint64; - (** - * Decompression timestamp in time_base units; the time at which the - * packet is decompressed. - * Can be AV_NOPTS_VALUE if it is not stored in the file. - *) - dts: cint64; - data: PByteArray; - size: cint; - stream_index: cint; - flags: cint; - (** - * Duration of this packet in time_base units, 0 if unknown. - * Equals next_pts - this_pts in presentation order. - *) - duration: cint; - destruct: procedure (p: PAVPacket); cdecl; - priv: pointer; - pos: cint64; ///< byte position in stream, -1 if unknown - - {$IF LIBAVFORMAT_VERSION >= 52022000} // 52.22.0 - (** - * Time difference in stream time base units from the pts of this - * packet to the point at which the output from the decoder has converged - * independent from the availability of previous frames. That is, the - * frames are virtually identical no matter if decoding started from - * the very first frame or from this keyframe. - * Is AV_NOPTS_VALUE if unknown. - * This field is not the display duration of the current packet. - * - * The purpose of this field is to allow seeking in streams that have no - * keyframes in the conventional sense. It corresponds to the - * recovery point SEI in H.264 and match_time_delta in NUT. It is also - * essential for some types of subtitle streams to ensure that all - * subtitles are correctly displayed after seeking. - *) - convergence_duration: cint64; - {$IFEND} - end; - -const - PKT_FLAG_KEY = $0001; - -procedure av_destruct_packet_nofree(var pkt: TAVPacket); - cdecl; external av__format; - -(** - * Default packet destructor. - *) -procedure av_destruct_packet(var pkt: TAVPacket); - cdecl; external av__format; - -(** - * Initialize optional fields of a packet with default values. - * - * @param pkt packet - *) -procedure av_init_packet(var pkt: TAVPacket); -{$IF LIBAVFORMAT_VERSION >= 51012002} // 51.12.2 - cdecl; external av__format; -{$IFEND} - -(** - * Allocate the payload of a packet and initialize its fields with - * default values. - * - * @param pkt packet - * @param size wanted payload size - * @return 0 if OK, AVERROR_xxx otherwise - *) -function av_new_packet(var pkt: TAVPacket; size: cint): cint; - cdecl; external av__format; -{$IFEND} - -(** - * Allocate and read the payload of a packet and initialize its fields with - * default values. - * - * @param pkt packet - * @param size desired payload size - * @return >0 (read size) if OK, AVERROR_xxx otherwise - *) -function av_get_packet(s: PByteIOContext; var pkt: TAVPacket; size: cint): cint; - cdecl; external av__format; - -{$IF LIBAVCODEC_VERSION < 52032000} // < 52.32.0 -(** - * @warning This is a hack - the packet memory allocation stuff is broken. The - * packet is allocated if it was not really allocated. - *) -function av_dup_packet(pkt: PAVPacket): cint; - cdecl; external av__format; - -(** - * Free a packet. - * - * @param pkt packet to free - *) -procedure av_free_packet(pkt: PAVPacket); {$IFDEF HasInline}inline;{$ENDIF} -{$IFEND} - -(*************************************************) -(* fractional numbers for exact pts handling *) - -type - (** - * The exact value of the fractional number is: 'val + num / den'. - * num is assumed to be 0 <= num < den. - *) - PAVFrac = ^TAVFrac; - TAVFrac = record - val, num, den: cint64; - end; - -(*************************************************) -(* input/output formats *) - -type - (** This structure contains the data a format has to probe a file. *) - TAVProbeData = record - filename: PAnsiChar; - buf: PByteArray; (**< Buffer must have AVPROBE_PADDING_SIZE of extra allocated bytes filled with zero. *) - buf_size: cint; (**< Size of buf except extra allocated bytes *) - end; - -const - AVPROBE_SCORE_MAX = 100; ///< Maximum score, half of that is used for file-extension-based detection - AVPROBE_PADDING_SIZE = 32; ///< extra allocated bytes at the end of the probe buffer - - //! Demuxer will use url_fopen, no opened file should be provided by the caller. - AVFMT_NOFILE = $0001; - AVFMT_NEEDNUMBER = $0002; (**< Needs '%d' in filename. *) - AVFMT_SHOW_IDS = $0008; (**< Show format stream IDs numbers. *) - AVFMT_RAWPICTURE = $0020; (**< Format wants AVPicture structure for - raw picture data. *) - AVFMT_GLOBALHEADER = $0040; (**< Format wants global header. *) - AVFMT_NOTIMESTAMPS = $0080; (**< Format does not need / have any timestamps. *) - AVFMT_GENERIC_INDEX = $0100; (**< Use generic index building code. *) - AVFMT_TS_DISCONT = $0200; (**< Format allows timestamp discontinuities. *) - {$IF LIBAVFORMAT_VERSION >= 52029002} // 52.29.2 - AVFMT_VARIABLE_FPS = $0400; (**< Format allows variable fps. *) - {$IFEND} - - // used by AVIndexEntry - AVINDEX_KEYFRAME = $0001; - - AVFMTCTX_NOHEADER = $0001; (**< signal that no header is present - (streams are added dynamically) *) - MAX_STREAMS = 20; - - AVFMT_NOOUTPUTLOOP = -1; - AVFMT_INFINITEOUTPUTLOOP = 0; - AVFMT_FLAG_GENPTS = $0001; ///< Generate missing pts even if it requires parsing future frames. - AVFMT_FLAG_IGNIDX = $0002; ///< Ignore index. - AVFMT_FLAG_NONBLOCK = $0004; ///< Do not block when reading packets from input. - - // used by AVStream - MAX_REORDER_DELAY = 16; - - // used by TAVProgram - AV_PROGRAM_RUNNING = 1; - - - AV_DISPOSITION_DEFAULT = $0001; - AV_DISPOSITION_DUB = $0002; - AV_DISPOSITION_ORIGINAL = $0004; - AV_DISPOSITION_COMMENT = $0008; - AV_DISPOSITION_LYRICS = $0010; - AV_DISPOSITION_KARAOKE = $0020; - - // used by TAVFormatContext.debug - FF_FDEBUG_TS = 0001; - - {$IF LIBAVFORMAT_VERSION >= 52034000} // >= 52.34.0 - {$IF LIBAVFORMAT_VERSION < 52039000} // < 52.39.0 - MAX_PROBE_PACKETS = 100; - {$ELSE} - MAX_PROBE_PACKETS = 2500; - {$IFEND} - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52035000} // >= 52.35.0 - {$IF LIBAVFORMAT_VERSION < 52039000} // < 52.39.0 - RAW_PACKET_BUFFER_SIZE = 32000; - {$ELSE} - RAW_PACKET_BUFFER_SIZE = 2500000; - {$IFEND} - {$IFEND} - -type - PPAVCodecTag = ^PAVCodecTag; - PAVCodecTag = Pointer; - - PPAVFormatContext = ^PAVFormatContext; - PAVFormatContext = ^TAVFormatContext; - - PAVFormatParameters = ^TAVFormatParameters; - - PAVOutputFormat = ^TAVOutputFormat; - PAVProbeData = ^TAVProbeData; - - PAVInputFormat = ^TAVInputFormat; - PAVIndexEntry = ^TAVIndexEntry; - - PAVStream = ^TAVStream; - PAVPacketList = ^TAVPacketList; - - PPAVProgram = ^PAVProgram; - PAVProgram = ^TAVProgram; - - {$IF LIBAVFORMAT_VERSION < 51006000} // 51.6.0 - PAVImageFormat = ^TAVImageFormat; - PAVImageInfo = ^TAVImageInfo; - {$IFEND} - -{$IF LIBAVFORMAT_VERSION >= 52030001} // >= 52.30.1 -(** - * Convert all the metadata sets from ctx according to the source and - * destination conversion tables. - * @param d_conv destination tags format conversion table - * @param s_conv source tags format conversion table - *) - PAVMetadataConv = ^TAVMetadataConv; - TAVMetadataConv = record - ctx: PAVFormatContext; - d_conv: {const} PAVMetadataConv; - s_conv: {const} PAVMetadataConv; - end; -{$IFEND} - - PAVChapter = ^TAVChapter; - TAVChapter = record - id: cint; ///< unique ID to identify the chapter - time_base: TAVRational; ///< time base in which the start/end timestamps are specified - start, end_: cint64; ///< chapter start/end time in time_base units - {$IF LIBAVFORMAT_VERSION < 53000000} // 53.00.0 - title: PAnsiChar; ///< chapter title - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52024001} // 52.24.1 - metadata: PAVMetadata; - {$IFEND} - end; - TAVChapterArray = array[0..(MaxInt div SizeOf(TAVChapter))-1] of TAVChapter; - PAVChapterArray = ^TAVChapterArray; - - TAVFormatParameters = record - time_base: TAVRational; - sample_rate: cint; - channels: cint; - width: cint; - height: cint; - pix_fmt: TAVPixelFormat; - {$IF LIBAVFORMAT_VERSION < 51006000} // 51.6.0 - image_format: PAVImageFormat; - {$IFEND} - channel: cint; (**< Used to select DV channel. *) - {$IF LIBAVFORMAT_VERSION_MAJOR < 52} - device: PAnsiChar; (* video, audio or DV device, if LIBAVFORMAT_VERSION_INT < (52<<16) *) - {$IFEND} - standard: PAnsiChar; (**< TV standard, NTSC, PAL, SECAM *) - { Delphi does not support bit fields -> use bf_flags instead - unsigned int mpeg2ts_raw:1; (**< Force raw MPEG-2 transport stream output, if possible. *) - unsigned int mpeg2ts_compute_pcr:1; (**< Compute exact PCR for each transport - stream packet (only meaningful if - mpeg2ts_raw is TRUE). *) - unsigned int initial_pause:1; (**< Do not begin to play the stream - immediately (RTSP only). *) - unsigned int prealloced_context:1; - } - bf_flags: byte; // 0:mpeg2ts_raw/1:mpeg2ts_compute_pcr/2:initial_pause/3:prealloced_context - {$IF LIBAVFORMAT_VERSION_MAJOR < 53} - video_codec_id: TCodecID; - audio_codec_id: TCodecID; - {$IFEND} - end; - - TAVOutputFormat = record - name: PAnsiChar; - (** - * Descriptive name for the format, meant to be more human-readable - * than name. You should use the NULL_IF_CONFIG_SMALL() macro - * to define it. - *) - long_name: PAnsiChar; - mime_type: PAnsiChar; - extensions: PAnsiChar; (**< comma-separated filename extensions *) - (** size of private data so that it can be allocated in the wrapper *) - priv_data_size: cint; - (* output support *) - audio_codec: TCodecID; (**< default audio codec *) - video_codec: TCodecID; (**< default video codec *) - write_header: function (c: PAVFormatContext): cint; cdecl; - write_packet: function (c: PAVFormatContext; pkt: PAVPacket): cint; cdecl; - write_trailer: function (c: PAVFormatContext): cint; cdecl; - (** can use flags: AVFMT_NOFILE, AVFMT_NEEDNUMBER, AVFMT_GLOBALHEADER *) - flags: cint; - (** Currently only used to set pixel format if not YUV420P. *) - set_parameters: function (c: PAVFormatContext; f: PAVFormatParameters): cint; cdecl; - interleave_packet: function (s: PAVFormatContext; out_: PAVPacket; - in_: PAVPacket; flush: cint): cint; cdecl; - - {$IF LIBAVFORMAT_VERSION >= 51008000} // 51.8.0 - (** - * List of supported codec_id-codec_tag pairs, ordered by "better - * choice first". The arrays are all terminated by CODEC_ID_NONE. - *) - codec_tag: {const} PPAVCodecTag; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 51012002} // 51.12.2 - subtitle_codec: TCodecID; (**< default subtitle codec *) - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52030001} // 52.30.1 - {const} metadata_conv: PAVMetadataConv; - {$IFEND} - - (* private fields *) - next: PAVOutputFormat; - end; - - TAVInputFormat = record - name: PAnsiChar; - (** - * Descriptive name for the format, meant to be more human-readable - * than name. You should use the NULL_IF_CONFIG_SMALL() macro - * to define it. - *) - long_name: PAnsiChar; - (** Size of private data so that it can be allocated in the wrapper. *) - priv_data_size: cint; - (** - * Tell if a given file has a chance of being parsed as this format. - * The buffer provided is guaranteed to be AVPROBE_PADDING_SIZE bytes - * big so you do not have to check for that unless you need more. - *) - read_probe: function (p: PAVProbeData): cint; cdecl; - (** Read the format header and initialize the AVFormatContext - structure. Return 0 if OK. 'ap' if non-NULL contains - additional parameters. Only used in raw format right - now. 'av_new_stream' should be called to create new streams. *) - read_header: function (c: PAVFormatContext; ap: PAVFormatParameters): cint; cdecl; - (** Read one packet and put it in 'pkt'. pts and flags are also - set. 'av_new_stream' can be called only if the flag - AVFMTCTX_NOHEADER is used. - @return 0 on success, < 0 on error. - When returning an error, pkt must not have been allocated - or must be freed before returning *) - read_packet: function (c: PAVFormatContext; var pkt: TAVPacket): cint; cdecl; - (** Close the stream. The AVFormatContext and AVStreams are not - freed by this function *) - read_close: function (c: PAVFormatContext): cint; cdecl; - -{$IF LIBAVFORMAT_VERSION_MAJOR < 53} - (** - * Seek to a given timestamp relative to the frames in - * stream component stream_index. - * @param stream_index Must not be -1. - * @param flags Selects which direction should be preferred if no exact - * match is available. - * @return >= 0 on success (but not necessarily the new offset) - *) - read_seek: function (c: PAVFormatContext; stream_index: cint; - timestamp: cint64; flags: cint): cint; cdecl; -{$IFEND} - - (** - * Gets the next timestamp in stream[stream_index].time_base units. - * @return the timestamp or AV_NOPTS_VALUE if an error occurred - *) - read_timestamp: function (s: PAVFormatContext; stream_index: cint; - pos: pint64; pos_limit: cint64): cint64; cdecl; - (** Can use flags: AVFMT_NOFILE, AVFMT_NEEDNUMBER. *) - flags: cint; - (** If extensions are defined, then no probe is done. You should - usually not use extension format guessing because it is not - reliable enough *) - extensions: PAnsiChar; - (** General purpose read-only value that the format can use. *) - value: cint; - - (** Starts/resumes playing - only meaningful if using a network-based format - (RTSP). *) - read_play: function (c: PAVFormatContext): cint; cdecl; - - (** Pauses playing - only meaningful if using a network-based format - (RTSP). *) - read_pause: function (c: PAVFormatContext): cint; cdecl; - - {$IF LIBAVFORMAT_VERSION >= 51008000} // 51.8.0 - codec_tag: {const} PPAVCodecTag; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52030000} // 52.30.0 - (** - * Seeks to timestamp ts. - * Seeking will be done so that the point from which all active streams - * can be presented successfully will be closest to ts and within min/max_ts. - * Active streams are all streams that have AVStream.discard < AVDISCARD_ALL. - *) - read_seek2: function (s: PAVFormatContext; - stream_index: cint; - min_ts: cint64; - ts: cint64; - max_ts: cint64; - flags: cint): cint; cdecl; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52030001} // 52.30.1 - {const} metadata_conv: PAVMetadataConv; - {$IFEND} - - (* private fields *) - next: PAVInputFormat; - end; - - TAVStreamParseType = ( - AVSTREAM_PARSE_NONE, - AVSTREAM_PARSE_FULL, (**< full parsing and repack *) - AVSTREAM_PARSE_HEADERS, (**< Only parse headers, do not repack. *) - AVSTREAM_PARSE_TIMESTAMPS (**< full parsing and interpolation of timestamps for frames not starting on a packet boundary *) - ); - - TAVIndexEntry = record - pos: cint64; - timestamp: cint64; - { Delphi doesn't support bitfields -> use flags_size instead - int flags:2; - int size:30; //Yeah, trying to keep the size of this small to reduce memory requirements (it is 24 vs. 32 bytes due to possible 8-byte alignment). - } - flags_size: cint; // 0..1: flags, 2..31: size - min_distance: cint; (**< Minimum distance between this and the previous keyframe, used to avoid unneeded searching. *) - end; - - (** - * Stream structure. - * New fields can be added to the end with minor version bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. - * sizeof(AVStream) must not be used outside libav*. - *) - TAVStream = record - index: cint; (**< stream index in AVFormatContext *) - id: cint; (**< format-specific stream ID *) - codec: PAVCodecContext; (**< codec context *) - (** - * Real base framerate of the stream. - * This is the lowest framerate with which all timestamps can be - * represented accurately (it is the least common multiple of all - * framerates in the stream). Note, this value is just a guess! - * For example, if the time base is 1/90000 and all frames have either - * approximately 3600 or 1800 timer ticks, then r_frame_rate will be 50/1. - *) - r_frame_rate: TAVRational; - priv_data: pointer; - - (* internal data used in av_find_stream_info() *) - first_dts: cint64; - {$IF LIBAVFORMAT_VERSION_MAJOR < 52} - codec_info_nb_frames: cint; - {$IFEND} - - (** encoding: pts generation when outputting stream *) - pts: TAVFrac; - (** - * This is the fundamental unit of time (in seconds) in terms - * of which frame timestamps are represented. For fixed-fps content, - * time base should be 1/framerate and timestamp increments should be 1. - *) - time_base: TAVRational; - pts_wrap_bits: cint; (* number of bits in pts (used for wrapping control) *) - (* ffmpeg.c private use *) - stream_copy: cint; (**< If set, just copy stream. *) - discard: TAVDiscard; ///< Selects which packets can be discarded at will and do not need to be demuxed. - //FIXME move stuff to a flags field? - (** Quality, as it has been removed from AVCodecContext and put in AVVideoFrame. - * MN:dunno if thats the right place, for it *) - quality: cfloat; - (** - * Decoding: pts of the first frame of the stream, in stream time base. - * Only set this if you are absolutely 100% sure that the value you set - * it to really is the pts of the first frame. - * This may be undefined (AV_NOPTS_VALUE). - * @note The ASF header does NOT contain a correct start_time the ASF - * demuxer must NOT set this. - *) - start_time: cint64; - (** - * Decoding: duration of the stream, in stream time base. - * If a source file does not specify a duration, but does specify - * a bitrate, this value will be estimated from bitrate and file size. - *) - duration: cint64; - - {$IF LIBAVFORMAT_VERSION_MAJOR < 53} - language: array [0..3] of PAnsiChar; (* ISO 639-2/B 3-letter language code (empty string if undefined) *) - {$IFEND} - - (* av_read_frame() support *) - need_parsing: TAVStreamParseType; - parser: PAVCodecParserContext; - - cur_dts: cint64; - last_IP_duration: cint; - last_IP_pts: cint64; - (* av_seek_frame() support *) - index_entries: PAVIndexEntry; (**< Only used if the format does not - support seeking natively. *) - nb_index_entries: cint; - index_entries_allocated_size: cuint; - - nb_frames: cint64; ///< number of frames in this stream if known or 0 - - {$IF (LIBAVFORMAT_VERSION >= 50006000) and (LIBAVFORMAT_VERSION_MAJOR < 53)} // 50.6.0 - 53.0.0 - unused: array [0..4] of cint64; - {$IFEND} - - {$IF (LIBAVFORMAT_VERSION >= 52006000) and (LIBAVFORMAT_VERSION_MAJOR < 53)} // 52.6.0 - 53.0.0 - filename: PAnsiChar; (**< source filename of the stream *) - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52008000} // 52.8.0 - disposition: cint; (**< AV_DISPOSITION_* bitfield *) - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52019000} // 52.19.0 - probe_data: TAVProbeData; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52021000} // 52.21.0 - pts_buffer: array [0..MAX_REORDER_DELAY] of cint64; - - (** - * sample aspect ratio (0 if unknown) - * - encoding: Set by user. - * - decoding: Set by libavformat. - *) - sample_aspect_ratio: TAVRational; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52024001} // 52.24.1 - metadata: PAVMetadata; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION > 52024001} // > 52.24.1 - {* av_read_frame() support *} - cur_ptr: {const} PCuint8; - cur_len: cint; - cur_pkt: TAVPacket; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52030000} // > 52.30.0 - // Timestamp generation support: - (** - * Timestamp corresponding to the last dts sync point. - * - * Initialized when AVCodecParserContext.dts_sync_point >= 0 and - * a DTS is received from the underlying container. Otherwise set to - * AV_NOPTS_VALUE by default. - *) - reference_dts: cint64; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52034000} // >= 52.34.0 - (** - * Number of packets to buffer for codec probing - * NOT PART OF PUBLIC API - *) - probe_packets: cint; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52038000} // >= 52.38.0 - (** - * last packet in packet_buffer for this stream when muxing. - * used internally, NOT PART OF PUBLIC API, dont read or write from outside of libav* - *) - last_in_packet_buffer: PAVPacketList; - {$IFEND} - end; - - (** - * Format I/O context. - * New fields can be added to the end with minor version bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. - * sizeof(AVFormatContext) must not be used outside libav*. - *) - TAVFormatContext = record - av_class: PAVClass; (**< Set by avformat_alloc_context. *) - (* Can only be iformat or oformat, not both at the same time. *) - iformat: PAVInputFormat; - oformat: PAVOutputFormat; - priv_data: pointer; - - {$IF LIBAVFORMAT_VERSION_MAJOR >= 52} - pb: PByteIOContext; - {$ELSE} - pb: TByteIOContext; - {$IFEND} - - nb_streams: cuint; - streams: array [0..MAX_STREAMS - 1] of PAVStream; - filename: array [0..1023] of AnsiChar; (* input or output filename *) - (* stream info *) - timestamp: cint64; - {$IF LIBAVFORMAT_VERSION < 53000000} // 53.00.0 - title: array [0..511] of AnsiChar; - author: array [0..511] of AnsiChar; - copyright: array [0..511] of AnsiChar; - comment: array [0..511] of AnsiChar; - album: array [0..511] of AnsiChar; - year: cint; (**< ID3 year, 0 if none *) - track: cint; (**< track number, 0 if none *) - genre: array [0..31] of AnsiChar; (**< ID3 genre *) - {$IFEND} - - ctx_flags: cint; (**< Format-specific flags, see AVFMTCTX_xx *) - (* private data for pts handling (do not modify directly). *) - (** This buffer is only needed when packets were already buffered but - not decoded, for example to get the codec parameters in MPEG - streams. *) - packet_buffer: PAVPacketList; - - (** Decoding: position of the first frame of the component, in - AV_TIME_BASE fractional seconds. NEVER set this value directly: - It is deduced from the AVStream values. *) - start_time: cint64; - (** Decoding: duration of the stream, in AV_TIME_BASE fractional - seconds. NEVER set this value directly: it is deduced from the - AVStream values. *) - duration: cint64; - (** decoding: total file size, 0 if unknown *) - file_size: cint64; - (** Decoding: total stream bitrate in bit/s, 0 if not - available. Never set it directly if the file_size and the - duration are known as ffmpeg can compute it automatically. *) - bit_rate: cint; - - (* av_read_frame() support *) - cur_st: PAVStream; - {$IF LIBAVFORMAT_VERSION_MAJOR < 53} - cur_ptr_deprecated: pbyte; - cur_len_deprecated: cint; - cur_pkt_deprecated: TAVPacket; - {$IFEND} - - (* av_seek_frame() support *) - data_offset: cint64; (* offset of the first packet *) - index_built: cint; - - mux_rate: cint; - {$IF LIBAVFORMAT_VERSION < 52034001} // < 52.34.1 - packet_size: cint; - {$ELSE} - packet_size: cuint; - {$IFEND} - preload: cint; - max_delay: cint; - - (* number of times to loop output in formats that support it *) - loop_output: cint; - - flags: cint; - loop_input: cint; - - {$IF LIBAVFORMAT_VERSION >= 50006000} // 50.6.0 - (** decoding: size of data to probe; encoding: unused. *) - probesize: cuint; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 51009000} // 51.9.0 - (** - * Maximum time (in AV_TIME_BASE units) during which the input should - * be analyzed in av_find_stream_info(). - *) - max_analyze_duration: cint; - - key: pbyte; - keylen : cint; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 51014000} // 51.14.0 - nb_programs: cuint; - programs: PPAVProgram; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52003000} // 52.3.0 - (** - * Forced video codec_id. - * Demuxing: Set by user. - *) - video_codec_id: TCodecID; - (** - * Forced audio codec_id. - * Demuxing: Set by user. - *) - audio_codec_id: TCodecID; - (** - * Forced subtitle codec_id. - * Demuxing: Set by user. - *) - subtitle_codec_id: TCodecID; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 - (** - * Maximum amount of memory in bytes to use for the index of each stream. - * If the index exceeds this size, entries will be discarded as - * needed to maintain a smaller size. This can lead to slower or less - * accurate seeking (depends on demuxer). - * Demuxers for which a full in-memory index is mandatory will ignore - * this. - * muxing : unused - * demuxing: set by user - *) - max_index_size: cuint; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52009000} // 52.9.0 - (** - * Maximum amount of memory in bytes to use for buffering frames - * obtained from realtime capture devices. - *) - max_picture_buffer: cuint; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52014000} // 52.14.0 - nb_chapters: cuint; - chapters: PAVChapterArray; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52016000} // 52.16.0 - (** - * Flags to enable debugging. - *) - debug: cint; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52019000} // 52.19.0 - (** - * Raw packets from the demuxer, prior to parsing and decoding. - * This buffer is used for buffering packets until the codec can - * be identified, as parsing cannot be done without knowing the - * codec. - *) - raw_packet_buffer: PAVPacketList; - raw_packet_buffer_end: PAVPacketList; - - packet_buffer_end: PAVPacketList; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52024001} // 52.24.1 - metadata: PAVMetadata; - {$IFEND} - - {$IF LIBAVFORMAT_VERSION >= 52035000} // 52.35.0 - (** - * Remaining size available for raw_packet_buffer, in bytes. - * NOT PART OF PUBLIC API - *) - raw_packet_buffer_remaining_size: cint; - {$IFEND} - - end; - - (** - * New fields can be added to the end with minor version bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. - * sizeof(AVProgram) must not be used outside libav*. - *) - TAVProgram = record - id : cint; - {$IF LIBAVFORMAT_VERSION < 53000000} // 53.00.0 - provider_name : PAnsiChar; ///< network name for DVB streams - name : PAnsiChar; ///< service name for DVB streams - {$IFEND} - flags : cint; - discard : TAVDiscard; ///< selects which program to discard and which to feed to the caller - {$IF LIBAVFORMAT_VERSION >= 51016000} // 51.16.0 - stream_index : PCardinal; - nb_stream_indexes : PCardinal; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52024001} // 52.24.1 - metadata: PAVMetadata; - {$IFEND} - end; - - TAVPacketList = record - pkt: TAVPacket; - next: PAVPacketList; - end; - -{$IF LIBAVFORMAT_VERSION < 51006000} // 51.6.0 - (* still image support *) - PAVInputImageContext = pointer; {deprecated} - - (* still image support *) - TAVImageInfo = record - pix_fmt: TAVPixelFormat; (* requested pixel format *) - width: cint; (* requested width *) - height: cint; (* requested height *) - interleaved: cint; (* image is interleaved (e.g. interleaved GIF) *) - pict: TAVPicture; (* returned allocated image *) - end; {deprecated} - - TAVImageFormat = record - name: PAnsiChar; - extensions: PAnsiChar; - (* tell if a given file has a chance of being parsing by this format *) - img_probe: function (d: PAVProbeData): cint; cdecl; - (* read a whole image. 'alloc_cb' is called when the image size is - known so that the caller can allocate the image. If 'allo_cb' - returns non zero, then the parsing is aborted. Return '0' if - OK. *) - img_read: function (b: PByteIOContext; alloc_cb: pointer; ptr: pointer): cint; cdecl; - (* write the image *) - supported_pixel_formats: cint; (* mask of supported formats for output *) - img_write: function (b: PByteIOContext; i: PAVImageInfo): cint; cdecl; - flags: cint; - next: PAVImageFormat; - end; {deprecated} - -procedure av_register_image_format(img_fmt: PAVImageFormat); - cdecl; external av__format; deprecated; - -function av_probe_image_format(pd: PAVProbeData): PAVImageFormat; - cdecl; external av__format; deprecated; - -function guess_image_format(filename: PAnsiChar): PAVImageFormat; - cdecl; external av__format; deprecated; - -function av_read_image(pb: PByteIOContext; filename: PAnsiChar; - fmt: PAVImageFormat; - alloc_cb: pointer; opaque: pointer): cint; - cdecl; external av__format; deprecated; - -function av_write_image(pb: PByteIOContext; fmt: PAVImageFormat; img: PAVImageInfo): cint; - cdecl; external av__format; deprecated; -{$IFEND} - -{$IF LIBAVFORMAT_VERSION_MAJOR < 53} -{ -var - first_iformat: PAVInputFormat; external av__format; - first_oformat: PAVOutputFormat; external av__format; -} -{$IFEND} - -{$IF LIBAVFORMAT_VERSION >= 52003000} // 52.3.0 -(** - * If f is NULL, returns the first registered input format, - * if f is non-NULL, returns the next registered input format after f - * or NULL if f is the last one. - *) -function av_iformat_next(f: PAVInputFormat): PAVInputFormat; - cdecl; external av__format; -(** - * If f is NULL, returns the first registered output format, - * if f is non-NULL, returns the next registered input format after f - * or NULL if f is the last one. - *) -function av_oformat_next(f: PAVOutputFormat): PAVOutputFormat; - cdecl; external av__format; -{$IFEND} - -function av_guess_image2_codec(filename: {const} PAnsiChar): TCodecID; - cdecl; external av__format; - -(* XXX: Use automatic init with either ELF sections or C file parser *) -(* modules. *) - -(* utils.c *) -procedure av_register_input_format(format: PAVInputFormat); - cdecl; external av__format; - -procedure av_register_output_format(format: PAVOutputFormat); - cdecl; external av__format; - -function guess_stream_format(short_name: PAnsiChar; - filename: PAnsiChar; - mime_type: PAnsiChar): PAVOutputFormat; - cdecl; external av__format; - -function guess_format(short_name: PAnsiChar; - filename: PAnsiChar; - mime_type: PAnsiChar): PAVOutputFormat; - cdecl; external av__format; - -(** - * Guesses the codec ID based upon muxer and filename. - *) -function av_guess_codec(fmt: PAVOutputFormat; short_name: PAnsiChar; - filename: PAnsiChar; mime_type: PAnsiChar; - type_: TCodecType): TCodecID; - cdecl; external av__format; - -(** - * Sends a nice hexadecimal dump of a buffer to the specified file stream. - * - * @param f The file stream pointer where the dump should be sent to. - * @param buf buffer - * @param size buffer size - * - * @see av_hex_dump_log, av_pkt_dump, av_pkt_dump_log - *) -procedure av_hex_dump(f: PAVFile; buf: PByteArray; size: cint); - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 51011000} // 51.11.0 -(** - * Sends a nice hexadecimal dump of a buffer to the log. - * - * @param avcl A pointer to an arbitrary struct of which the first field is a - * pointer to an AVClass struct. - * @param level The importance level of the message, lower values signifying - * higher importance. - * @param buf buffer - * @param size buffer size - * - * @see av_hex_dump, av_pkt_dump, av_pkt_dump_log - *) -procedure av_hex_dump_log(avcl: Pointer; level: cint; buf: PByteArray; size: cint); - cdecl; external av__format; -{$IFEND} - -(** - * Sends a nice dump of a packet to the specified file stream. - * - * @param f The file stream pointer where the dump should be sent to. - * @param pkt packet to dump - * @param dump_payload True if the payload must be displayed, too. - *) -procedure av_pkt_dump(f: PAVFile; pkt: PAVPacket; dump_payload: cint); - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 51011000} // 51.11.0 -(** - * Sends a nice dump of a packet to the log. - * - * @param avcl A pointer to an arbitrary struct of which the first field is a - * pointer to an AVClass struct. - * @param level The importance level of the message, lower values signifying - * higher importance. - * @param pkt packet to dump - * @param dump_payload True if the payload must be displayed, too. - *) -procedure av_pkt_dump_log(avcl: Pointer; level: cint; pkt: PAVPacket; dump_payload: cint); - cdecl; external av__format; -{$IFEND} - -(** - * Initializes libavformat and registers all the muxers, demuxers and - * protocols. If you do not call this function, then you can select - * exactly which formats you want to support. - * - * @see av_register_input_format() - * @see av_register_output_format() - * @see av_register_protocol() - *) -procedure av_register_all(); - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 51008000} // 51.8.0 -(** codec tag <-> codec id *) -function av_codec_get_id(var tags: PAVCodecTag; tag: cuint): TCodecID; - cdecl; external av__format; -function av_codec_get_tag(var tags: PAVCodecTag; id: TCodecID): cuint; - cdecl; external av__format; -{$IFEND} - -(* media file input *) - -(** - * Finds AVInputFormat based on the short name of the input format. - *) -function av_find_input_format(short_name: PAnsiChar): PAVInputFormat; - cdecl; external av__format; - -(** - * Guesses file format. - * - * @param is_opened Whether the file is already opened; determines whether - * demuxers with or without AVFMT_NOFILE are probed. - *) -function av_probe_input_format(pd: PAVProbeData; is_opened: cint): PAVInputFormat; - cdecl; external av__format; - -(** - * Allocates all the structures needed to read an input stream. - * This does not open the needed codecs for decoding the stream[s]. - *) -function av_open_input_stream(var ic_ptr: PAVFormatContext; - pb: PByteIOContext; filename: PAnsiChar; - fmt: PAVInputFormat; ap: PAVFormatParameters): cint; - cdecl; external av__format; - -(** - * Opens a media file as input. The codecs are not opened. Only the file - * header (if present) is read. - * - * @param ic_ptr The opened media file handle is put here. - * @param filename filename to open - * @param fmt If non-NULL, force the file format to use. - * @param buf_size optional buffer size (zero if default is OK) - * @param ap Additional parameters needed when opening the file - * (NULL if default). - * @return 0 if OK, AVERROR_xxx otherwise - *) -function av_open_input_file(var ic_ptr: PAVFormatContext; filename: PAnsiChar; - fmt: PAVInputFormat; buf_size: cint; - ap: PAVFormatParameters): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52026000} // 52.26.0 -(** - * Allocates an AVFormatContext. - * Can be freed with av_free() but do not forget to free everything you - * explicitly allocated as well! - *) -function avformat_alloc_context(): PAVFormatContext; - cdecl; external av__format; -{$ELSE} - {$IF LIBAVFORMAT_VERSION_MAJOR < 53} -(** - * @deprecated Use avformat_alloc_context() instead. - *) -function av_alloc_format_context(): PAVFormatContext; - cdecl; external av__format; - {$IFEND} -{$IFEND} - -(** - * Reads packets of a media file to get stream information. This - * is useful for file formats with no headers such as MPEG. This - * function also computes the real framerate in case of MPEG-2 repeat - * frame mode. - * The logical file position is not changed by this function; - * examined packets may be buffered for later processing. - * - * @param ic media file handle - * @return >=0 if OK, AVERROR_xxx on error - * @todo Let the user decide somehow what information is needed so that - * we do not waste time getting stuff the user does not need. - *) -function av_find_stream_info(ic: PAVFormatContext): cint; - cdecl; external av__format; - -(** - * Reads a transport packet from a media file. - * - * This function is obsolete and should never be used. - * Use av_read_frame() instead. - * - * @param s media file handle - * @param pkt is filled - * @return 0 if OK, AVERROR_xxx on error - *) -function av_read_packet(s: PAVFormatContext; var pkt: TAVPacket): cint; - cdecl; external av__format; - -(** - * Returns the next frame of a stream. - * - * The returned packet is valid - * until the next av_read_frame() or until av_close_input_file() and - * must be freed with av_free_packet. For video, the packet contains - * exactly one frame. For audio, it contains an cint number of - * frames if each frame has a known fixed size (e.g. PCM or ADPCM - * data). If the audio frames have a variable size (e.g. MPEG audio), - * then it contains one frame. - * - * pkt->pts, pkt->dts and pkt->duration are always set to correct - * values in AVStream.time_base units (and guessed if the format cannot - * provide them). pkt->pts can be AV_NOPTS_VALUE if the video format - * has B-frames, so it is better to rely on pkt->dts if you do not - * decompress the payload. - * - * @return 0 if OK, < 0 on error or end of file - *) -function av_read_frame(s: PAVFormatContext; var pkt: TAVPacket): cint; - cdecl; external av__format; - -(** - * Seeks to the keyframe at timestamp. - * 'timestamp' in 'stream_index'. - * @param stream_index If stream_index is (-1), a default - * stream is selected, and timestamp is automatically converted - * from AV_TIME_BASE units to the stream specific time_base. - * @param timestamp Timestamp in AVStream.time_base units - * or, if no stream is specified, in AV_TIME_BASE units. - * @param flags flags which select direction and seeking mode - * @return >= 0 on success - *) -function av_seek_frame(s: PAVFormatContext; stream_index: cint; timestamp: cint64; - flags: cint): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52026000} // 52.26.0 -(** - * Seeks to timestamp ts. - * Seeking will be done so that the point from which all active streams - * can be presented successfully will be closest to ts and within min/max_ts. - * Active streams are all streams that have AVStream.discard < AVDISCARD_ALL. - * - * If flags contain AVSEEK_FLAG_BYTE, then all timestamps are in byte and - * are the file position (this may not be supported by all demuxers). - * If flags contain AVSEEK_FLAG_FRAME then all timestamps are in frames - * in the stream with stream_index (this may not be supported by all demuxers). - * Otherwise all timestamps are in units of the stream selected by stream_index - * or if stream_index is -1, in AV_TIME_BASE units. - * If flags contain AVSEEK_FLAG_ANY, then non-keyframes are treated as - * keyframes (this may not be supported by all demuxers). - * - * @param stream_index index of the stream which is used as time base reference. - * @param min_ts smallest acceptable timestamp - * @param ts target timestamp - * @param max_ts largest acceptable timestamp - * @param flags flags - * @returns >=0 on success, error code otherwise - * - * @NOTE This is part of the new seek API which is still under construction. - * Thus do not use this yet. It may change at any time, do not expect - * ABI compatibility yet! - *) -function avformat_seek_file(s: PAVFormatContext; - stream_index: cint; - min_ts: cint64; - ts: cint64; - max_ts: cint64; - flags: cint): cint; - cdecl; external av__format; -{$IFEND} - -(** - * Starts playing a network-based stream (e.g. RTSP stream) at the - * current position. - *) -function av_read_play(s: PAVFormatContext): cint; - cdecl; external av__format; - -(** - * Pauses a network-based stream (e.g. RTSP stream). - * - * Use av_read_play() to resume it. - *) -function av_read_pause(s: PAVFormatContext): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52003000} // 52.3.0 -(** - * Frees a AVFormatContext allocated by av_open_input_stream. - * @param s context to free - *) -procedure av_close_input_stream(s: PAVFormatContext); - cdecl; external av__format; -{$IFEND} - -(** - * Closes a media file (but not its codecs). - * - * @param s media file handle - *) -procedure av_close_input_file(s: PAVFormatContext); - cdecl; external av__format; - -(** - * Adds a new stream to a media file. - * - * Can only be called in the read_header() function. If the flag - * AVFMTCTX_NOHEADER is in the format context, then new streams - * can be added in read_packet too. - * - * @param s media file handle - * @param id file-format-dependent stream ID - *) -function av_new_stream(s: PAVFormatContext; id: cint): PAVStream; - cdecl; external av__format; -{$IF LIBAVFORMAT_VERSION >= 51014000} // 51.14.0 -function av_new_program(s: PAVFormatContext; id: cint): PAVProgram; - cdecl; external av__format; -{$IFEND} - -{$IF LIBAVFORMAT_VERSION >= 52014000} // 52.14.0 -(** - * Adds a new chapter. - * This function is NOT part of the public API - * and should ONLY be used by demuxers. - * - * @param s media file handle - * @param id unique ID for this chapter - * @param start chapter start time in time_base units - * @param end chapter end time in time_base units - * @param title chapter title - * - * @return AVChapter or NULL on error - *) -function ff_new_chapter(s: PAVFormatContext; id: cint; time_base: TAVRational; - start, end_: cint64; title: {const} PAnsiChar): PAVChapter; - cdecl; external av__format; -{$IFEND} - -(** - * Sets the pts for a given stream. - * - * @param s stream - * @param pts_wrap_bits number of bits effectively used by the pts - * (used for wrap control, 33 is the value for MPEG) - * @param pts_num numerator to convert to seconds (MPEG: 1) - * @param pts_den denominator to convert to seconds (MPEG: 90000) - *) -procedure av_set_pts_info(s: PAVStream; pts_wrap_bits: cint; -{$IF LIBAVFORMAT_VERSION < 52036000} // < 52.36.0 - pts_num: cint; pts_den: cint); -{$ELSE} - pts_num: cuint; pts_den: cuint); -{$IFEND} - cdecl; external av__format; - -const - AVSEEK_FLAG_BACKWARD = 1; ///< seek backward - AVSEEK_FLAG_BYTE = 2; ///< seeking based on position in bytes - AVSEEK_FLAG_ANY = 4; ///< seek to any frame, even non-keyframes -{$IF LIBAVFORMAT_VERSION >= 52037000} // >= 52.37.0 - AVSEEK_FLAG_FRAME = 8; -{$IFEND} - -function av_find_default_stream_index(s: PAVFormatContext): cint; - cdecl; external av__format; - -(** - * Gets the index for a specific timestamp. - * @param flags if AVSEEK_FLAG_BACKWARD then the returned index will correspond - * to the timestamp which is <= the requested one, if backward - * is 0, then it will be >= - * if AVSEEK_FLAG_ANY seek to any frame, only keyframes otherwise - * @return < 0 if no such timestamp could be found - *) -function av_index_search_timestamp(st: PAVStream; timestamp: cint64; flags: cint): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 -(** - * Ensures the index uses less memory than the maximum specified in - * AVFormatContext.max_index_size by discarding entries if it grows - * too large. - * This function is not part of the public API and should only be called - * by demuxers. - *) -procedure ff_reduce_index(s: PAVFormatContext; stream_index: cint); - cdecl; external av__format; -{$IFEND} - -(** - * Adds an index entry into a sorted list. Updates the entry if the list - * already contains it. - * - * @param timestamp timestamp in the timebase of the given stream - *) -function av_add_index_entry(st: PAVStream; pos: cint64; timestamp: cint64; - size: cint; distance: cint; flags: cint): cint; - cdecl; external av__format; - -(** - * Does a binary search using av_index_search_timestamp() and - * AVCodec.read_timestamp(). - * This is not supposed to be called directly by a user application, - * but by demuxers. - * @param target_ts target timestamp in the time base of the given stream - * @param stream_index stream number - *) -function av_seek_frame_binary(s: PAVFormatContext; stream_index: cint; - target_ts: cint64; flags: cint): cint; - cdecl; external av__format; - - -(** - * Updates cur_dts of all streams based on the given timestamp and AVStream. - * - * Stream ref_st unchanged, others set cur_dts in their native time base. - * Only needed for timestamp wrapping or if (dts not set and pts!=dts). - * @param timestamp new dts expressed in time_base of param ref_st - * @param ref_st reference stream giving time_base of param timestamp - *) -procedure av_update_cur_dts(s: PAVFormatContext; ref_st: PAVStream; - timestamp: cint64); - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 51007000} // 51.7.0 -type - TReadTimestampFunc = function (pavfc: PAVFormatContext; - arg2: cint; arg3: Pint64; arg4: cint64): cint64; cdecl; - -(** - * Does a binary search using read_timestamp(). - * This is not supposed to be called directly by a user application, - * but by demuxers. - * @param target_ts target timestamp in the time base of the given stream - * @param stream_index stream number - *) -function av_gen_search(s: PAVFormatContext; stream_index: cint; - target_ts: cint64; pos_min: cint64; - pos_max: cint64; pos_limit: cint64; - ts_min: cint64; ts_max: cint64; - flags: cint; ts_ret: Pint64; - read_timestamp: TReadTimestampFunc): cint64; - cdecl; external av__format; -{$IFEND} - -(* media file output *) -function av_set_parameters(s: PAVFormatContext; ap: PAVFormatParameters): cint; - cdecl; external av__format; - -(** - * Allocates the stream private data and writes the stream header to an - * output media file. - * - * @param s media file handle - * @return 0 if OK, AVERROR_xxx on error - *) -function av_write_header(s: PAVFormatContext): cint; - cdecl; external av__format; - -(** - * Writes a packet to an output media file. - * - * The packet shall contain one audio or video frame. - * The packet must be correctly interleaved according to the container - * specification, if not then av_interleaved_write_frame must be used. - * - * @param s media file handle - * @param pkt The packet, which contains the stream_index, buf/buf_size, - * dts/pts, ... - * @return < 0 on error, = 0 if OK, 1 if end of stream wanted - *) -function av_write_frame(s: PAVFormatContext; var pkt: TAVPacket): cint; - cdecl; external av__format; - -(** - * Writes a packet to an output media file ensuring correct interleaving. - * - * The packet must contain one audio or video frame. - * If the packets are already correctly interleaved, the application should - * call av_write_frame() instead as it is slightly faster. It is also important - * to keep in mind that completely non-interleaved input will need huge amounts - * of memory to interleave with this, so it is preferable to interleave at the - * demuxer level. - * - * @param s media file handle - * @param pkt The packet, which contains the stream_index, buf/buf_size, - * dts/pts, ... - * @return < 0 on error, = 0 if OK, 1 if end of stream wanted - *) -function av_interleaved_write_frame(s: PAVFormatContext; var pkt: TAVPacket): cint; - cdecl; external av__format; - -(** - * Interleaves a packet per dts in an output media file. - * - * Packets with pkt->destruct == av_destruct_packet will be freed inside this - * function, so they cannot be used after it. Note that calling av_free_packet() - * on them is still safe. - * - * @param s media file handle - * @param out the interleaved packet will be output here - * @param in the input packet - * @param flush 1 if no further packets are available as input and all - * remaining packets should be output - * @return 1 if a packet was output, 0 if no packet could be output, - * < 0 if an error occurred - *) -function av_interleave_packet_per_dts(s: PAVFormatContext; _out: PAVPacket; - pkt: PAVPacket; flush: cint): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52025000} // 52.25.0 -(** - * Add packet to AVFormatContext->packet_buffer list, determining its - * interleaved position using compare() function argument. - * - * This function is not part of the public API and should only be called - * by muxers using their own interleave function. - *) -{ -procedure ff_interleave_add_packet(s: PAVFormatContext; - pkt: PAVPacket; - compare: function(para1: PAVFormatContext; - para2: PAVPacket; - para3: PAVPacket): cint); - cdecl; external av__format; -} -{$IFEND} - -(** - * Writes the stream trailer to an output media file and frees the - * file private data. - * - * May only be called after a successful call to av_write_header. - * - * @param s media file handle - * @return 0 if OK, AVERROR_xxx on error - *) -function av_write_trailer(s: pAVFormatContext): cint; - cdecl; external av__format; - -procedure dump_format(ic: PAVFormatContext; index: cint; url: PAnsiChar; - is_output: cint); - cdecl; external av__format; - -(** - * Parses width and height out of string str. - * @deprecated Use av_parse_video_frame_size instead. - *) -function parse_image_size(width_ptr: PCint; height_ptr: PCint; - str: PAnsiChar): cint; - cdecl; external av__format; deprecated; - -{$IF LIBAVFORMAT_VERSION_MAJOR < 53} -(** - * Converts framerate from a string to a fraction. - * @deprecated Use av_parse_video_frame_rate instead. - *) -function parse_frame_rate(frame_rate: PCint; frame_rate_base: PCint; - arg: PByteArray): cint; - cdecl; external av__format; deprecated; -{$IFEND} - -(** - * Parses datestr and returns a corresponding number of microseconds. - * @param datestr String representing a date or a duration. - * - If a date the syntax is: - * @code - * [{YYYY-MM-DD|YYYYMMDD}]{T| }{HH[:MM[:SS[.m...]]][Z]|HH[MM[SS[.m...]]][Z]} - * @endcode - * Time is localtime unless Z is appended, in which case it is - * interpreted as UTC. - * If the year-month-day part is not specified it takes the current - * year-month-day. - * Returns the number of microseconds since 1st of January, 1970 up to - * the time of the parsed date or INT64_MIN if datestr cannot be - * successfully parsed. - * - If a duration the syntax is: - * @code - * [-]HH[:MM[:SS[.m...]]] - * [-]S+[.m...] - * @endcode - * Returns the number of microseconds contained in a time interval - * with the specified duration or INT64_MIN if datestr cannot be - * successfully parsed. - * @param duration Flag which tells how to interpret datestr, if - * not zero datestr is interpreted as a duration, otherwise as a - * date. - *) -function parse_date(datestr: PAnsiChar; duration: cint): cint64; - cdecl; external av__format; - -(** Gets the current time in microseconds. *) -function av_gettime(): cint64; - cdecl; external av__format; - -(* ffm-specific for ffserver *) -const - FFM_PACKET_SIZE = 4096; - -function ffm_read_write_index(fd: cint): cint64; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION < 52027000} // 52.27.0 -procedure ffm_write_write_index(fd: cint; pos: cint64); -{$ELSE} -function ffm_write_write_index(fd: cint; pos: cint64): cint; -{$IFEND} - cdecl; external av__format; - -procedure ffm_set_write_index(s: PAVFormatContext; pos: cint64; file_size: cint64); - cdecl; external av__format; - -(** - * Attempts to find a specific tag in a URL. - * - * syntax: '?tag1=val1&tag2=val2...'. Little URL decoding is done. - * Return 1 if found. - *) -function find_info_tag(arg: PAnsiChar; arg_size: cint; tag1: PAnsiChar; info: PAnsiChar): cint; - cdecl; external av__format; - -(** - * Returns in 'buf' the path with '%d' replaced by a number. - * - * Also handles the '%0nd' format where 'n' is the total number - * of digits and '%%'. - * - * @param buf destination buffer - * @param buf_size destination buffer size - * @param path numbered sequence string - * @param number frame number - * @return 0 if OK, -1 on format error - *) -function av_get_frame_filename(buf: PAnsiChar; buf_size: cint; - path: PAnsiChar; number: cint): cint; - cdecl; external av__format - {$IF LIBAVFORMAT_VERSION <= 50006000} // 50.6.0 - name 'get_frame_filename' - {$IFEND}; - -(** - * Checks whether filename actually is a numbered sequence generator. - * - * @param filename possible numbered sequence string - * @return 1 if a valid numbered sequence string, 0 otherwise - *) -function av_filename_number_test(filename: PAnsiChar): cint; - cdecl; external av__format - {$IF LIBAVFORMAT_VERSION <= 50006000} // 50.6.0 - name 'filename_number_test' - {$IFEND}; - -{$IF LIBAVFORMAT_VERSION >= 51012002} // 51.12.2 -(** - * Generates an SDP for an RTP session. - * - * @param ac array of AVFormatContexts describing the RTP streams. If the - * array is composed by only one context, such context can contain - * multiple AVStreams (one AVStream per RTP stream). Otherwise, - * all the contexts in the array (an AVCodecContext per RTP stream) - * must contain only one AVStream. - * @param n_files number of AVCodecContexts contained in ac - * @param buff buffer where the SDP will be stored (must be allocated by - * the caller) - * @param size the size of the buffer - * @return 0 if OK, AVERROR_xxx on error - *) -function avf_sdp_create(ac: PPAVFormatContext; n_files: cint; buff: PByteArray; size: cint): cint; - cdecl; external av__format; -{$IFEND} - -implementation - -{$IF LIBAVFORMAT_VERSION < 51012002} // 51.12.2 -procedure av_init_packet(var pkt: TAVPacket); -begin - with pkt do begin - pts := AV_NOPTS_VALUE; - dts := AV_NOPTS_VALUE; - pos := -1; - duration := 0; - flags := 0; - stream_index := 0; - destruct := @av_destruct_packet_nofree - end -end; -{$IFEND} - -{$IF LIBAVCODEC_VERSION < 52032000} // < 52.32.0 -procedure av_free_packet(pkt: PAVPacket); -begin - if ((pkt <> nil) and (@pkt^.destruct <> nil)) then - pkt^.destruct(pkt); -end; -{$IFEND} - -end. diff --git a/src/lib/ffmpeg/avio.pas b/src/lib/ffmpeg/avio.pas deleted file mode 100644 index 73c90b69..00000000 --- a/src/lib/ffmpeg/avio.pas +++ /dev/null @@ -1,590 +0,0 @@ -(* - * unbuffered io for ffmpeg system - * copyright (c) 2001 Fabrice Bellard - * - * FFmpeg is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * FFmpeg is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with FFmpeg; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversion of libavformat/avio.h - * unbuffered I/O operations - * revision 16100, Sat Dec 13 13:39:13 2008 UTC - * update Tue, Jun 10 01:00:00 2009 UTC - * - * @warning This file has to be considered an internal but installed - * header, so it should not be directly included in your projects. - *) - -{ - * update to - * Max. avformat version: 52.41.0, Sun Dec 6 20:15:00 2009 CET - * MiSchi -} - -unit avio; - -{$IFDEF FPC} - {$MODE DELPHI } - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$I switches.inc} - -interface - -uses - ctypes, - avutil, - avcodec, - SysUtils, - UConfig; - -(* unbuffered I/O *) - -const - URL_RDONLY = 0; - URL_WRONLY = 1; - URL_RDWR = 2; - - (** - * Passing this as the "whence" parameter to a seek function causes it to - * return the filesize without seeking anywhere. Supporting this is optional. - * If it is not supported then the seek function will return <0. - *) - AVSEEK_SIZE = $10000; - -type - TURLInterruptCB = function (): cint; cdecl; - -type - PURLProtocol = ^TURLProtocol; - - (** - * URL Context. - * New fields can be added to the end with minor version bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. - * sizeof(URLContext) must not be used outside libav*. - *) - PURLContext = ^TURLContext; - TURLContext = record - {$IF LIBAVFORMAT_VERSION_MAJOR >= 53} - av_class: {const} PAVClass; ///< information for av_log(). Set by url_open(). - {$IFEND} - prot: PURLProtocol; - flags: cint; - is_streamed: cint; (**< true if streamed (no seek possible), default = false *) - max_packet_size: cint; (**< if non zero, the stream is packetized with this max packet size *) - priv_data: pointer; - filename: PAnsiChar; (**< specified filename *) - end; - PPURLContext = ^PURLContext; - - PURLPollEntry = ^TURLPollEntry; - TURLPollEntry = record - handle: PURLContext; - events: cint; - revents: cint; - end; - - TURLProtocol = record - name: PAnsiChar; - url_open: function (h: PURLContext; filename: {const} PAnsiChar; flags: cint): cint; cdecl; - url_read: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; - {$IF LIBAVFORMAT_VERSION >= 52034001} // 52.34.1 - url_read_complete: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; - {$IFEND} - url_write: function (h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; - url_seek: function (h: PURLContext; pos: cint64; whence: cint): cint64; cdecl; - url_close: function (h: PURLContext): cint; cdecl; - next: PURLProtocol; - {$IF (LIBAVFORMAT_VERSION >= 52001000) and (LIBAVFORMAT_VERSION < 52004000)} // 52.1.0 .. 52.4.0 - url_read_play: function (h: PURLContext): cint; cdecl; - url_read_pause: function (h: PURLContext): cint; cdecl; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 - url_read_pause: function (h: PURLContext; pause: cint): cint; cdecl; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52001000} // 52.1.0 - url_read_seek: function (h: PURLContext; stream_index: cint; - timestamp: cint64; flags: cint): cint64; cdecl; - {$IFEND} - end; - - (** - * Bytestream IO Context. - * New fields can be added to the end with minor version bumps. - * Removal, reordering and changes to existing fields require a major - * version bump. - * sizeof(ByteIOContext) must not be used outside libav*. - *) - PByteIOContext = ^TByteIOContext; - TByteIOContext = record - buffer: PByteArray; - buffer_size: cint; - buf_ptr: PByteArray; - buf_end: PByteArray; - opaque: pointer; - read_packet: function (opaque: pointer; buf: PByteArray; buf_size: cint): cint; cdecl; - write_packet: function (opaque: pointer; buf: PByteArray; buf_size: cint): cint; cdecl; - seek: function (opaque: pointer; offset: cint64; whence: cint): cint64; cdecl; - pos: cint64; (* position in the file of the current buffer *) - must_flush: cint; (* true if the next seek should flush *) - eof_reached: cint; (* true if eof reached *) - write_flag: cint; (* true if open for writing *) - is_streamed: cint; - max_packet_size: cint; - checksum: culong; - checksum_ptr: PByteArray; - update_checksum: function (checksum: culong; buf: {const} PByteArray; size: cuint): culong; cdecl; - error: cint; ///< contains the error code or 0 if no error happened - {$IF (LIBAVFORMAT_VERSION >= 52001000) and (LIBAVFORMAT_VERSION < 52004000)} // 52.1.0 .. 52.4.0 - read_play: function(opaque: Pointer): cint; cdecl; - read_pause: function(opaque: Pointer): cint; cdecl; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 - read_pause: function(opaque: Pointer; pause: cint): cint; cdecl; - {$IFEND} - {$IF LIBAVFORMAT_VERSION >= 52001000} // 52.1.0 - read_seek: function(opaque: Pointer; stream_index: cint; - timestamp: cint64; flags: cint): cint64; cdecl; - {$IFEND} - end; - - -{$IF LIBAVFORMAT_VERSION >= 52021000} // 52.21.0 -function url_open_protocol(puc: PPURLContext; up: PURLProtocol; - filename: {const} PAnsiChar; flags: cint): cint; - cdecl; external av__format; -{$IFEND} -function url_open(h: PPointer; filename: {const} PAnsiChar; flags: cint): cint; - cdecl; external av__format; -function url_read (h: PURLContext; buf: PByteArray; size: cint): cint; - cdecl; external av__format; -function url_write (h: PURLContext; buf: PByteArray; size: cint): cint; - cdecl; external av__format; -function url_seek (h: PURLContext; pos: cint64; whence: cint): cint64; - cdecl; external av__format; -function url_close (h: PURLContext): cint; - cdecl; external av__format; -function url_exist(filename: {const} PAnsiChar): cint; - cdecl; external av__format; -function url_filesize (h: PURLContext): cint64; - cdecl; external av__format; -{ - * Return the file descriptor associated with this URL. For RTP, this - * will return only the RTP file descriptor, not the RTCP file descriptor. - * To get both, use rtp_get_file_handles(). - * - * @return the file descriptor associated with this URL, or <0 on error. -} -(* not implemented *) -function url_get_file_handle(h: PURLContext): cint; - cdecl; external av__format; - -(** - * Return the maximum packet size associated to packetized file - * handle. If the file is not packetized (stream like HTTP or file on - * disk), then 0 is returned. - * - * @param h file handle - * @return maximum packet size in bytes - *) -function url_get_max_packet_size(h: PURLContext): cint; - cdecl; external av__format; -procedure url_get_filename(h: PURLContext; buf: PAnsiChar; buf_size: cint); - cdecl; external av__format; - -(** - * The callback is called in blocking functions to test regulary if - * asynchronous interruption is needed. AVERROR(EINTR) is returned - * in this case by the interrupted function. 'NULL' means no interrupt - * callback is given. - *) -procedure url_set_interrupt_cb (interrupt_cb: TURLInterruptCB); - cdecl; external av__format; - -(* not implemented *) -function url_poll(poll_table: PURLPollEntry; n: cint; timeout: cint): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 -(** - * Pause and resume playing - only meaningful if using a network streaming - * protocol (e.g. MMS). - * @param pause 1 for pause, 0 for resume - *) -function av_url_read_pause(h: PURLContext; pause: cint): cint; - cdecl; external av__format; -{$IFEND} - -{$IF LIBAVFORMAT_VERSION >= 52001000} // 52.1.0 -(** - * Seek to a given timestamp relative to some component stream. - * Only meaningful if using a network streaming protocol (e.g. MMS.). - * @param stream_index The stream index that the timestamp is relative to. - * If stream_index is (-1) the timestamp should be in AV_TIME_BASE - * units from the beginning of the presentation. - * If a stream_index >= 0 is used and the protocol does not support - * seeking based on component streams, the call will fail with ENOTSUP. - * @param timestamp timestamp in AVStream.time_base units - * or if there is no stream specified then in AV_TIME_BASE units. - * @param flags Optional combination of AVSEEK_FLAG_BACKWARD, AVSEEK_FLAG_BYTE - * and AVSEEK_FLAG_ANY. The protocol may silently ignore - * AVSEEK_FLAG_BACKWARD and AVSEEK_FLAG_ANY, but AVSEEK_FLAG_BYTE will - * fail with ENOTSUP if used and not supported. - * @return >= 0 on success - * @see AVInputFormat::read_seek - *) -function av_url_read_seek(h: PURLContext; stream_index: cint; - timestamp: cint64; flags: cint): cint64; - cdecl; external av__format; -{$IFEND} - -(** -var -{$IF LIBAVFORMAT_VERSION_MAJOR < 53} - first_protocol: PURLProtocol; external av__format; -{$IFEND} - url_interrupt_cb: PURLInterruptCB; external av__format; -**) - -{ -* If protocol is NULL, returns the first registered protocol, -* if protocol is non-NULL, returns the next registered protocol after protocol, -* or NULL if protocol is the last one. -} -{$IF LIBAVFORMAT_VERSION >= 52002000} // 52.2.0 -function av_protocol_next(p: PURLProtocol): PURLProtocol; - cdecl; external av__format; -{$IFEND} - -{$IF LIBAVFORMAT_VERSION <= 52028000} // 52.28.0 -(** - * @deprecated Use av_register_protocol() instead. - *) -function register_protocol(protocol: PURLProtocol): cint; - cdecl; external av__format; -(** Alias for register_protocol() *) -function av_register_protocol(protocol: PURLProtocol): cint; - cdecl; external av__format name 'register_protocol'; -{$ELSE} -function av_register_protocol(protocol: PURLProtocol): cint; - cdecl; external av__format; -{$IFEND} - -type - TReadWriteFunc = function(opaque: Pointer; buf: PByteArray; buf_size: cint): cint; cdecl; - TSeekFunc = function(opaque: Pointer; offset: cint64; whence: cint): cint64; cdecl; - -function init_put_byte(s: PByteIOContext; - buffer: PByteArray; - buffer_size: cint; write_flag: cint; - opaque: pointer; - read_packet: TReadWriteFunc; - write_packet: TReadWriteFunc; - seek: TSeekFunc): cint; - cdecl; external av__format; -{$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 -function av_alloc_put_byte( - buffer: PByteArray; - buffer_size: cint; - write_flag: cint; - opaque: Pointer; - read_packet: TReadWriteFunc; - write_packet: TReadWriteFunc; - seek: TSeekFunc): PByteIOContext; - cdecl; external av__format; -{$IFEND} - -procedure put_byte(s: PByteIOContext; b: cint); - cdecl; external av__format; -procedure put_buffer (s: PByteIOContext; buf: {const} PByteArray; size: cint); - cdecl; external av__format; -procedure put_le64(s: PByteIOContext; val: cuint64); - cdecl; external av__format; -procedure put_be64(s: PByteIOContext; val: cuint64); - cdecl; external av__format; -procedure put_le32(s: PByteIOContext; val: cuint); - cdecl; external av__format; -procedure put_be32(s: PByteIOContext; val: cuint); - cdecl; external av__format; -procedure put_le24(s: PByteIOContext; val: cuint); - cdecl; external av__format; -procedure put_be24(s: PByteIOContext; val: cuint); - cdecl; external av__format; -procedure put_le16(s: PByteIOContext; val: cuint); - cdecl; external av__format; -procedure put_be16(s: PByteIOContext; val: cuint); - cdecl; external av__format; -procedure put_tag(s: PByteIOContext; tag: {const} PAnsiChar); - cdecl; external av__format; - -procedure put_strz(s: PByteIOContext; buf: {const} PAnsiChar); - cdecl; external av__format; - -(** - * fseek() equivalent for ByteIOContext. - * @return new position or AVERROR. - *) -function url_fseek(s: PByteIOContext; offset: cint64; whence: cint): cint64; - cdecl; external av__format; - -(** - * Skip given number of bytes forward. - * @param offset number of bytes - *) -procedure url_fskip(s: PByteIOContext; offset: cint64); - cdecl; external av__format; - -(** - * ftell() equivalent for ByteIOContext. - * @return position or AVERROR. - *) -function url_ftell(s: PByteIOContext): cint64; - cdecl; external av__format; - -(** - * Gets the filesize. - * @return filesize or AVERROR - *) -function url_fsize(s: PByteIOContext): cint64; - cdecl; external av__format; - -(** - * feof() equivalent for ByteIOContext. - * @return non zero if and only if end of file - *) -function url_feof(s: PByteIOContext): cint; - cdecl; external av__format; - -function url_ferror(s: PByteIOContext): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52004000} // 52.4.0 -function av_url_read_fpause(h: PByteIOContext; pause: cint): cint; - cdecl; external av__format; -{$IFEND} -{$IF LIBAVFORMAT_VERSION >= 52001000} // 52.1.0 -function av_url_read_fseek(h: PByteIOContext; stream_index: cint; - timestamp: cint64; flags: cint): cint64; - cdecl; external av__format; -{$IFEND} - -const - URL_EOF = -1; -(** @note return URL_EOF (-1) if EOF *) -function url_fgetc(s: PByteIOContext): cint; - cdecl; external av__format; - -(** @warning currently size is limited *) -function url_fprintf(s: PByteIOContext; fmt: {const} PAnsiChar; args: array of const): cint; - cdecl; external av__format; - -(** @note unlike fgets, the EOL character is not returned and a whole - line is parsed. return NULL if first char read was EOF *) -function url_fgets(s: PByteIOContext; buf: PAnsiChar; buf_size: cint): PAnsiChar; - cdecl; external av__format; - -procedure put_flush_packet (s: PByteIOContext); - cdecl; external av__format; - - -(** - * Reads size bytes from ByteIOContext into buf. - * @returns number of bytes read or AVERROR - *) -function get_buffer(s: PByteIOContext; buf: PByteArray; size: cint): cint; - cdecl; external av__format; - -(** - * Reads size bytes from ByteIOContext into buf. - * This reads at most 1 packet. If that is not enough fewer bytes will be - * returned. - * @returns number of bytes read or AVERROR - *) -function get_partial_buffer(s: PByteIOContext; buf: PByteArray; size: cint): cint; - cdecl; external av__format; - -(** @note return 0 if EOF, so you cannot use it if EOF handling is - necessary *) -function get_byte(s: PByteIOContext): cint; - cdecl; external av__format; -function get_le24(s: PByteIOContext): cuint; - cdecl; external av__format; -function get_le32(s: PByteIOContext): cuint; - cdecl; external av__format; -function get_le64(s: PByteIOContext): cuint64; - cdecl; external av__format; -function get_le16(s: PByteIOContext): cuint; - cdecl; external av__format; - -function get_strz(s: PByteIOContext; buf: PAnsiChar; maxlen: cint): PAnsiChar; - cdecl; external av__format; -function get_be16(s: PByteIOContext): cuint; - cdecl; external av__format; -function get_be24(s: PByteIOContext): cuint; - cdecl; external av__format; -function get_be32(s: PByteIOContext): cuint; - cdecl; external av__format; -function get_be64(s: PByteIOContext): cuint64; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 51017001} // 51.17.1 -function ff_get_v(bc: PByteIOContext): cuint64; - cdecl; external av__format; -{$IFEND} - -function url_is_streamed(s: PByteIOContext): cint; {$IFDEF HasInline}inline;{$ENDIF} - -(** @note when opened as read/write, the buffers are only used for - writing *) -{$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 -function url_fdopen (var s: PByteIOContext; h: PURLContext): cint; -{$ELSE} -function url_fdopen (s: PByteIOContext; h: PURLContext): cint; -{$IFEND} - cdecl; external av__format; - -(** @warning must be called before any I/O *) -function url_setbufsize (s: PByteIOContext; buf_size: cint): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION_MAJOR < 53} -{$IF LIBAVFORMAT_VERSION >= 51015000} // 51.15.0 -(** Reset the buffer for reading or writing. - * @note Will drop any data currently in the buffer without transmitting it. - * @param flags URL_RDONLY to set up the buffer for reading, or URL_WRONLY - * to set up the buffer for writing. *) -function url_resetbuf(s: PByteIOContext; flags: cint): cint; - cdecl; external av__format; -{$IFEND} -{$IFEND} - -(** @note when opened as read/write, the buffers are only used for - writing *) -{$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 -function url_fopen(var s: PByteIOContext; filename: {const} PAnsiChar; flags: cint): cint; -{$ELSE} -function url_fopen(s: PByteIOContext; filename: {const} PAnsiChar; flags: cint): cint; -{$IFEND} - cdecl; external av__format; -function url_fclose(s: PByteIOContext): cint; - cdecl; external av__format; -function url_fileno(s: PByteIOContext): PURLContext; - cdecl; external av__format; - -(** - * Return the maximum packet size associated to packetized buffered file - * handle. If the file is not packetized (stream like http or file on - * disk), then 0 is returned. - * - * @param s buffered file handle - * @return maximum packet size in bytes - *) -function url_fget_max_packet_size (s: PByteIOContext): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 -function url_open_buf(var s: PByteIOContext; buf: PAnsiChar; buf_size: cint; flags: cint): cint; -{$ELSE} -function url_open_buf(s: PByteIOContext; buf: PAnsiChar; buf_size: cint; flags: cint): cint; -{$IFEND} - cdecl; external av__format; - -(** return the written or read size *) -function url_close_buf(s: PByteIOContext): cint; - cdecl; external av__format; - -(** - * Open a write only memory stream. - * - * @param s new IO context - * @return zero if no error. - *) -{$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 -function url_open_dyn_buf(var s: PByteIOContext): cint; -{$ELSE} -function url_open_dyn_buf(s: PByteIOContext): cint; -{$IFEND} - cdecl; external av__format; - -(** - * Open a write only packetized memory stream with a maximum packet - * size of 'max_packet_size'. The stream is stored in a memory buffer - * with a big endian 4 byte header giving the packet size in bytes. - * - * @param s new IO context - * @param max_packet_size maximum packet size (must be > 0) - * @return zero if no error. - *) -{$IF LIBAVFORMAT_VERSION >= 52000000} // 52.0.0 -function url_open_dyn_packet_buf(var s: PByteIOContext; max_packet_size: cint): cint; -{$ELSE} -function url_open_dyn_packet_buf(s: PByteIOContext; max_packet_size: cint): cint; -{$IFEND} - cdecl; external av__format; - -(** - * Return the written size and a pointer to the buffer. The buffer - * must be freed with av_free(). - * @param s IO context - * @param pbuffer pointer to a byte buffer - * @return the length of the byte buffer - *) -function url_close_dyn_buf(s: PByteIOContext; pbuffer:PPointer): cint; - cdecl; external av__format; - -{$IF LIBAVFORMAT_VERSION >= 51017001} // 51.17.1 -function ff_crc04C11DB7_update(checksum: culong; buf: {const} PByteArray; - len: cuint): culong; - cdecl; external av__format; -{$IFEND} -function get_checksum(s: PByteIOContext): culong; - cdecl; external av__format; -procedure init_gsum(s: PByteIOContext; - update_checksum: pointer; - checksum: culong); - cdecl; external av__format; - -(* udp.c *) -function udp_set_remote_url(h: PURLContext; uri: {const} PAnsiChar): cint; - cdecl; external av__format; -function udp_get_local_port(h: PURLContext): cint; - cdecl; external av__format; -{$IF LIBAVFORMAT_VERSION_MAJOR <= 52} -function udp_get_file_handle(h: PURLContext): cint; - cdecl; external av__format; -{$IFEND} - -implementation - -function url_is_streamed(s: PByteIOContext): cint; -begin - Result := s^.is_streamed; -end; - -end. diff --git a/src/lib/ffmpeg/avutil.pas b/src/lib/ffmpeg/avutil.pas deleted file mode 100644 index 55bab601..00000000 --- a/src/lib/ffmpeg/avutil.pas +++ /dev/null @@ -1,420 +0,0 @@ -(* - * copyright (c) 2006 Michael Niedermayer - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversions of - * - * libavutil/avutil.h: - * Min. version: 49.0.1, revision 6577, Sat Oct 7 15:30:46 2006 UTC - * Max. version: 49.14.0, revision 16912, Sun Feb 1 02:00:19 2009 UTC - * - * libavutil/mem.h: - * revision 16590, Tue Jan 13 23:44:16 2009 UTC - * - * libavutil/log.h: - * revision 16571, Tue Jan 13 00:14:43 2009 UTC - *) -{ - Update changes auf avutil.h, mem.h and log.h - Max. version 50.05.1, Sun, Dec 6 24:00:00 2009 UTC - include/keep pixfmt.h (change in revision 50.01.0) - Maybe, the pixelformats are not needed, but it has not been checked. - log.h is only partial. -} - -unit avutil; - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$IFDEF DARWIN} - {$linklib libavutil} -{$ENDIF} - -interface - -uses - ctypes, - mathematics, - rational, - UConfig; - -const - (* Max. supported version by this header *) - LIBAVUTIL_MAX_VERSION_MAJOR = 50; - LIBAVUTIL_MAX_VERSION_MINOR = 5; - LIBAVUTIL_MAX_VERSION_RELEASE = 1; - LIBAVUTIL_MAX_VERSION = (LIBAVUTIL_MAX_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVUTIL_MAX_VERSION_MINOR * VERSION_MINOR) + - (LIBAVUTIL_MAX_VERSION_RELEASE * VERSION_RELEASE); - - (* Min. supported version by this header *) - LIBAVUTIL_MIN_VERSION_MAJOR = 49; - LIBAVUTIL_MIN_VERSION_MINOR = 0; - LIBAVUTIL_MIN_VERSION_RELEASE = 1; - LIBAVUTIL_MIN_VERSION = (LIBAVUTIL_MIN_VERSION_MAJOR * VERSION_MAJOR) + - (LIBAVUTIL_MIN_VERSION_MINOR * VERSION_MINOR) + - (LIBAVUTIL_MIN_VERSION_RELEASE * VERSION_RELEASE); - -(* Check if linked versions are supported *) -{$IF (LIBAVUTIL_VERSION < LIBAVUTIL_MIN_VERSION)} - {$MESSAGE Error 'Linked version of libavutil is too old!'} -{$IFEND} - -{$IF (LIBAVUTIL_VERSION > LIBAVUTIL_MAX_VERSION)} - {$MESSAGE Error 'Linked version of libavutil is not yet supported!'} -{$IFEND} - -{$IF LIBAVUTIL_VERSION >= 49008000} // 49.8.0 -(** - * Returns the LIBAVUTIL_VERSION_INT constant. - *) -function avutil_version(): cuint; - cdecl; external av__format; -{$IFEND} - -{$IF LIBAVUTIL_VERSION >= 50004000} // >= 50.4.0 -(** - * Returns the libavutil build-time configuration. - *) -function avutil_configuration(): PAnsiChar; - cdecl; external av__format; - -(** - * Returns the libavutil license. - *) -function avutil_license(): PAnsiChar; - cdecl; external av__format; -{$IFEND} - -type -(** - * Pixel format. Notes: - * - * PIX_FMT_RGB32 is handled in an endian-specific manner. An RGBA - * color is put together as: - * (A << 24) | (R << 16) | (G << 8) | B - * This is stored as BGRA on little-endian CPU architectures and ARGB on - * big-endian CPUs. - * - * When the pixel format is palettized RGB (PIX_FMT_PAL8), the palettized - * image data is stored in AVFrame.data[0]. The palette is transported in - * AVFrame.data[1], is 1024 bytes long (256 4-byte entries) and is - * formatted the same as in PIX_FMT_RGB32 described above (i.e., it is - * also endian-specific). Note also that the individual RGB palette - * components stored in AVFrame.data[1] should be in the range 0..255. - * This is important as many custom PAL8 video codecs that were designed - * to run on the IBM VGA graphics adapter use 6-bit palette components. - * - * For all the 8bit per pixel formats, an RGB32 palette is in data[1] like - * for pal8. This palette is filled in automatically by the function - * allocating the picture. - * - * Note, make sure that all newly added big endian formats have pix_fmt&1==1 - * and that all newly added little endian formats have pix_fmt&1==0 - * this allows simpler detection of big vs little endian. - *) - - PAVPixelFormat = ^TAVPixelFormat; - TAVPixelFormat = ( - PIX_FMT_NONE= -1, - PIX_FMT_YUV420P, ///< planar YUV 4:2:0, 12bpp, (1 Cr & Cb sample per 2x2 Y samples) - PIX_FMT_YUYV422, ///< packed YUV 4:2:2, 16bpp, Y0 Cb Y1 Cr - PIX_FMT_RGB24, ///< packed RGB 8:8:8, 24bpp, RGBRGB... - PIX_FMT_BGR24, ///< packed RGB 8:8:8, 24bpp, BGRBGR... - PIX_FMT_YUV422P, ///< planar YUV 4:2:2, 16bpp, (1 Cr & Cb sample per 2x1 Y samples) - PIX_FMT_YUV444P, ///< planar YUV 4:4:4, 24bpp, (1 Cr & Cb sample per 1x1 Y samples) -{$IF LIBAVUTIL_VERSION <= 50001000} // 50.01.0 - PIX_FMT_RGB32, ///< packed RGB 8:8:8, 32bpp, (msb)8A 8R 8G 8B(lsb), in CPU endianness -{$IFEND} - PIX_FMT_YUV410P, ///< planar YUV 4:1:0, 9bpp, (1 Cr & Cb sample per 4x4 Y samples) - PIX_FMT_YUV411P, ///< planar YUV 4:1:1, 12bpp, (1 Cr & Cb sample per 4x1 Y samples) -{$IF LIBAVUTIL_VERSION <= 50000000} // 50.00.0 - PIX_FMT_RGB565, ///< packed RGB 5:6:5, 16bpp, (msb) 5R 6G 5B(lsb), in CPU endianness - PIX_FMT_RGB555, ///< packed RGB 5:5:5, 16bpp, (msb)1A 5R 5G 5B(lsb), in CPU endianness, most significant bit to 0 -{$IFEND} - PIX_FMT_GRAY8, ///< Y , 8bpp - PIX_FMT_MONOWHITE, ///< Y , 1bpp, 0 is white, 1 is black - PIX_FMT_MONOBLACK, ///< Y , 1bpp, 0 is black, 1 is white - PIX_FMT_PAL8, ///< 8 bit with PIX_FMT_RGB32 palette - PIX_FMT_YUVJ420P, ///< planar YUV 4:2:0, 12bpp, full scale (JPEG) - PIX_FMT_YUVJ422P, ///< planar YUV 4:2:2, 16bpp, full scale (JPEG) - PIX_FMT_YUVJ444P, ///< planar YUV 4:4:4, 24bpp, full scale (JPEG) - PIX_FMT_XVMC_MPEG2_MC,///< XVideo Motion Acceleration via common packet passing - PIX_FMT_XVMC_MPEG2_IDCT, - PIX_FMT_UYVY422, ///< packed YUV 4:2:2, 16bpp, Cb Y0 Cr Y1 - PIX_FMT_UYYVYY411, ///< packed YUV 4:1:1, 12bpp, Cb Y0 Y1 Cr Y2 Y3 -{$IF LIBAVUTIL_VERSION <= 50001000} // 50.01.0 - PIX_FMT_BGR32, ///< packed RGB 8:8:8, 32bpp, (msb)8A 8B 8G 8R(lsb), in CPU endianness -{$IFEND} -{$IF LIBAVUTIL_VERSION <= 50000000} // 50.00.0 - PIX_FMT_BGR565, ///< packed RGB 5:6:5, 16bpp, (msb) 5B 6G 5R(lsb), in CPU endianness - PIX_FMT_BGR555, ///< packed RGB 5:5:5, 16bpp, (msb)1A 5B 5G 5R(lsb), in CPU endianness, most significant bit to 1 -{$IFEND} - PIX_FMT_BGR8, ///< packed RGB 3:3:2, 8bpp, (msb)2B 3G 3R(lsb) - PIX_FMT_BGR4, ///< packed RGB 1:2:1, 4bpp, (msb)1B 2G 1R(lsb) - PIX_FMT_BGR4_BYTE, ///< packed RGB 1:2:1, 8bpp, (msb)1B 2G 1R(lsb) - PIX_FMT_RGB8, ///< packed RGB 3:3:2, 8bpp, (msb)2R 3G 3B(lsb) - PIX_FMT_RGB4, ///< packed RGB 1:2:1, 4bpp, (msb)1R 2G 1B(lsb) - PIX_FMT_RGB4_BYTE, ///< packed RGB 1:2:1, 8bpp, (msb)1R 2G 1B(lsb) - PIX_FMT_NV12, ///< planar YUV 4:2:0, 12bpp, 1 plane for Y and 1 for UV - PIX_FMT_NV21, ///< as above, but U and V bytes are swapped -{$IF LIBAVUTIL_VERSION <= 50001000} // 50.01.0 - PIX_FMT_RGB32_1, ///< packed RGB 8:8:8, 32bpp, (msb)8R 8G 8B 8A(lsb), in CPU endianness - PIX_FMT_BGR32_1, ///< packed RGB 8:8:8, 32bpp, (msb)8B 8G 8R 8A(lsb), in CPU endianness -{$ELSE} // 50.02.0 - PIX_FMT_ARGB, ///< packed ARGB 8:8:8:8, 32bpp, ARGBARGB... - PIX_FMT_RGBA, ///< packed RGBA 8:8:8:8, 32bpp, RGBARGBA... - PIX_FMT_ABGR, ///< packed ABGR 8:8:8:8, 32bpp, ABGRABGR... - PIX_FMT_BGRA, ///< packed BGRA 8:8:8:8, 32bpp, BGRABGRA... -{$IFEND} - PIX_FMT_GRAY16BE, ///< Y , 16bpp, big-endian - PIX_FMT_GRAY16LE, ///< Y , 16bpp, little-endian - PIX_FMT_YUV440P, ///< planar YUV 4:4:0 (1 Cr & Cb sample per 1x2 Y samples) - PIX_FMT_YUVJ440P, ///< planar YUV 4:4:0 full scale (JPEG) - PIX_FMT_YUVA420P, ///< planar YUV 4:2:0, 20bpp, (1 Cr & Cb sample per 2x2 Y & A samples) - PIX_FMT_VDPAU_H264,///< H.264 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers - PIX_FMT_VDPAU_MPEG1,///< MPEG-1 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers - PIX_FMT_VDPAU_MPEG2,///< MPEG-2 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers - PIX_FMT_VDPAU_WMV3,///< WMV3 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers - PIX_FMT_VDPAU_VC1, ///< VC-1 HW decoding with VDPAU, data[0] contains a vdpau_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers -{$IF LIBAVUTIL_VERSION >= 49015000} // 49.15.0 - PIX_FMT_RGB48BE, ///< packed RGB 16:16:16, 48bpp, 16R, 16G, 16B, big-endian - PIX_FMT_RGB48LE, ///< packed RGB 16:16:16, 48bpp, 16R, 16G, 16B, little-endian -{$IFEND} -{$IF LIBAVUTIL_VERSION >= 50001000} // 50.01.0 - PIX_FMT_RGB565BE, ///< packed RGB 5:6:5, 16bpp, (msb) 5R 6G 5B(lsb), big-endian - PIX_FMT_RGB565LE, ///< packed RGB 5:6:5, 16bpp, (msb) 5R 6G 5B(lsb), little-endian - PIX_FMT_RGB555BE, ///< packed RGB 5:5:5, 16bpp, (msb)1A 5R 5G 5B(lsb), big-endian, most significant bit to 0 - PIX_FMT_RGB555LE, ///< packed RGB 5:5:5, 16bpp, (msb)1A 5R 5G 5B(lsb), little-endian, most significant bit to 0 - - PIX_FMT_BGR565BE, ///< packed BGR 5:6:5, 16bpp, (msb) 5B 6G 5R(lsb), big-endian - PIX_FMT_BGR565LE, ///< packed BGR 5:6:5, 16bpp, (msb) 5B 6G 5R(lsb), little-endian - PIX_FMT_BGR555BE, ///< packed BGR 5:5:5, 16bpp, (msb)1A 5B 5G 5R(lsb), big-endian, most significant bit to 1 - PIX_FMT_BGR555LE, ///< packed BGR 5:5:5, 16bpp, (msb)1A 5B 5G 5R(lsb), little-endian, most significant bit to 1 - - PIX_FMT_VAAPI_MOCO, ///< HW acceleration through VA API at motion compensation entry-point, Picture.data[3] contains a vaapi_render_state struct which contains macroblocks as well as various fields extracted from headers - PIX_FMT_VAAPI_IDCT, ///< HW acceleration through VA API at IDCT entry-point, Picture.data[3] contains a vaapi_render_state struct which contains fields extracted from headers - PIX_FMT_VAAPI_VLD, ///< HW decoding through VA API, Picture.data[3] contains a vaapi_render_state struct which contains the bitstream of the slices as well as various fields extracted from headers -{$IFEND} - PIX_FMT_NB ///< number of pixel formats, DO NOT USE THIS if you want to link with shared libav* because the number of formats might differ between versions - ); - -const -{$ifdef WORDS_BIGENDIAN} - {$IF LIBAVUTIL_VERSION <= 50001000} // 50.01.0 - PIX_FMT_RGBA = PIX_FMT_RGB32_1; - PIX_FMT_BGRA = PIX_FMT_BGR32_1; - PIX_FMT_ARGB = PIX_FMT_RGB32; - PIX_FMT_ABGR = PIX_FMT_BGR32; - {$ELSE} // 50.02.0 - PIX_FMT_RGB32 = PIX_FMT_ARGB; - PIX_FMT_RGB32_1 = PIX_FMT_RGBA; - PIX_FMT_BGR32 = PIX_FMT_ABGR; - PIX_FMT_BGR32_1 = PIX_FMT_BGRA; - {$IFEND} - PIX_FMT_GRAY16 = PIX_FMT_GRAY16BE; - {$IF LIBAVUTIL_VERSION >= 49015000} // 49.15.0 - PIX_FMT_RGB48 = PIX_FMT_RGB48BE; - {$IFEND} - {$IF LIBAVUTIL_VERSION >= 50001000} // 50.01.0 - PIX_FMT_RGB565 = PIX_FMT_RGB565BE; - PIX_FMT_RGB555 = PIX_FMT_RGB555BE; - PIX_FMT_BGR565 = PIX_FMT_BGR565BE; - PIX_FMT_BGR555 = PIX_FMT_BGR555BE - {$IFEND} -{$else} - {$IF LIBAVUTIL_VERSION <= 50001000} // 50.01.0 - PIX_FMT_RGBA = PIX_FMT_BGR32; - PIX_FMT_BGRA = PIX_FMT_RGB32; - PIX_FMT_ARGB = PIX_FMT_BGR32_1; - PIX_FMT_ABGR = PIX_FMT_RGB32_1; - {$ELSE} // 50.02.0 - PIX_FMT_RGB32 = PIX_FMT_BGRA; - PIX_FMT_RGB32_1 = PIX_FMT_ABGR; - PIX_FMT_BGR32 = PIX_FMT_RGBA; - PIX_FMT_BGR32_1 = PIX_FMT_ARGB; - {$IFEND} - PIX_FMT_GRAY16 = PIX_FMT_GRAY16LE; - {$IF LIBAVUTIL_VERSION >= 49015000} // 49.15.0 - PIX_FMT_RGB48 = PIX_FMT_RGB48LE; - {$IFEND} - {$IF LIBAVUTIL_VERSION >= 50001000} // 50.01.0 - PIX_FMT_RGB565 = PIX_FMT_RGB565LE; - PIX_FMT_RGB555 = PIX_FMT_RGB555LE; - PIX_FMT_BGR565 = PIX_FMT_BGR565LE; - PIX_FMT_BGR555 = PIX_FMT_BGR555LE; - {$IFEND} -{$ENDIF} - -{$IF LIBAVUTIL_VERSION_MAJOR < 50} // 50.0.0 - PIX_FMT_UYVY411 = PIX_FMT_UYYVYY411; - PIX_FMT_RGBA32 = PIX_FMT_RGB32; - PIX_FMT_YUV422 = PIX_FMT_YUYV422; -{$IFEND} - -(* libavutil/common.h *) // until now MKTAG is all from common.h KMS 9/6/2009 - -function MKTAG(a, b, c, d: AnsiChar): integer; - -(* libavutil/mem.h *) -(* memory handling functions *) - -(** - * Allocates a block of size bytes with alignment suitable for all - * memory accesses (including vectors if available on the CPU). - * @param size Size in bytes for the memory block to be allocated. - * @return Pointer to the allocated block, NULL if the block cannot - * be allocated. - * @see av_mallocz() - *) -function av_malloc(size: cuint): pointer; - cdecl; external av__util; {av_malloc_attrib av_alloc_size(1)} - -(** - * Allocates or reallocates a block of memory. - * If ptr is NULL and size > 0, allocates a new block. If - * size is zero, frees the memory block pointed to by ptr. - * @param size Size in bytes for the memory block to be allocated or - * reallocated. - * @param ptr Pointer to a memory block already allocated with - * av_malloc(z)() or av_realloc() or NULL. - * @return Pointer to a newly reallocated block or NULL if the block - * cannot be allocated or the function is used to free the memory block. - * @see av_fast_realloc() - *) -function av_realloc(ptr: pointer; size: cuint): pointer; - cdecl; external av__util; {av_alloc_size(2)} - -(** - * Frees a memory block which has been allocated with av_malloc(z)() or - * av_realloc(). - * @param ptr Pointer to the memory block which should be freed. - * @note ptr = NULL is explicitly allowed. - * @note It is recommended that you use av_freep() instead. - * @see av_freep() - *) -procedure av_free(ptr: pointer); - cdecl; external av__util; - -(** - * Allocates a block of size bytes with alignment suitable for all - * memory accesses (including vectors if available on the CPU) and - * zeroes all the bytes of the block. - * @param size Size in bytes for the memory block to be allocated. - * @return Pointer to the allocated block, NULL if it cannot be allocated. - * @see av_malloc() - *) -function av_mallocz(size: cuint): pointer; - cdecl; external av__util; {av_malloc_attrib av_alloc_size(1)} - -(** - * Duplicates the string s. - * @param s string to be duplicated. - * @return Pointer to a newly allocated string containing a - * copy of s or NULL if the string cannot be allocated. - *) -function av_strdup({const} s: PAnsiChar): PAnsiChar; - cdecl; external av__util; {av_malloc_attrib} - -(** - * Frees a memory block which has been allocated with av_malloc(z)() or - * av_realloc() and set the pointer pointing to it to NULL. - * @param ptr Pointer to the pointer to the memory block which should - * be freed. - * @see av_free() - *) -procedure av_freep (ptr: pointer); - cdecl; external av__util; - -(* libavutil/log.h *) - -const -{$IF LIBAVUTIL_VERSION_MAJOR < 50} - AV_LOG_QUIET = -1; - AV_LOG_FATAL = 0; - AV_LOG_ERROR = 0; - AV_LOG_WARNING = 1; - AV_LOG_INFO = 1; - AV_LOG_VERBOSE = 1; - AV_LOG_DEBUG = 2; -{$ELSE} - AV_LOG_QUIET = -8; - -(** - * Something went really wrong and we will crash now. - *) - AV_LOG_PANIC = 0; - -(** - * Something went wrong and recovery is not possible. - * For example, no header was found for a format which depends - * on headers or an illegal combination of parameters is used. - *) - AV_LOG_FATAL = 8; - -(** - * Something went wrong and cannot losslessly be recovered. - * However, not all future data is affected. - *) - AV_LOG_ERROR = 16; - -(** - * Something somehow does not look correct. This may or may not - * lead to problems. An example would be the use of '-vstrict -2'. - *) - AV_LOG_WARNING = 24; - - AV_LOG_INFO = 32; - AV_LOG_VERBOSE = 40; - -(** - * Stuff which is only useful for libav* developers. - *) - AV_LOG_DEBUG = 48; -{$IFEND} - -function av_log_get_level(): cint; - cdecl; external av__util; -procedure av_log_set_level(level: cint); - cdecl; external av__util; - - -implementation - -(* libavutil/common.h *) - -function MKTAG(a, b, c, d: AnsiChar): integer; -begin - Result := (ord(a) or (ord(b) shl 8) or (ord(c) shl 16) or (ord(d) shl 24)); -end; - -end. diff --git a/src/lib/ffmpeg/mathematics.pas b/src/lib/ffmpeg/mathematics.pas deleted file mode 100644 index f3a307b6..00000000 --- a/src/lib/ffmpeg/mathematics.pas +++ /dev/null @@ -1,104 +0,0 @@ -(* - * copyright (c) 2005 Michael Niedermayer - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversion of libavutil/mathematics.h - * revision 16844, Wed Jan 28 08:50:10 2009 UTC - * - * update, MiSchi, no code change - * Fri Jun 12 2009 21:50:00 UTC - *) -{ - * update to - * avutil max. version 50.05.1, Sun, Dec 6 24:00:00 2009 UTC - * MiSchi -} - -unit mathematics; - -{$IFDEF FPC} - {$MODE DELPHI } - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -interface - -uses - ctypes, - rational, - UConfig; - -const - M_E = 2.7182818284590452354; // e - M_LN2 = 0.69314718055994530942; // log_e 2 - M_LN10 = 2.30258509299404568402; // log_e 10 - M_PI = 3.14159265358979323846; // pi - M_SQRT1_2 = 0.70710678118654752440; // 1/sqrt(2) -{$IF LIBAVUTIL_VERSION >= 50005001} // >= 50.5.1 - NAN = 0.0/0.0; - INFINITY = 1.0/0.0; -{$IFEND} - -type - TAVRounding = ( - AV_ROUND_ZERO = 0, ///< Round toward zero. - AV_ROUND_INF = 1, ///< Round away from zero. - AV_ROUND_DOWN = 2, ///< Round toward -infinity. - AV_ROUND_UP = 3, ///< Round toward +infinity. - AV_ROUND_NEAR_INF = 5 ///< Round to nearest and halfway cases away from zero. - ); - -{$IF LIBAVUTIL_VERSION >= 49013000} // 49.13.0 -function av_gcd(a: cint64; b: cint64): cint64; - cdecl; external av__util; {av_const} -{$IFEND} - -(** - * Rescales a 64-bit integer with rounding to nearest. - * A simple a*b/c isn't possible as it can overflow. - *) -function av_rescale (a, b, c: cint64): cint64; - cdecl; external av__util; {av_const} - -(** - * Rescales a 64-bit integer with specified rounding. - * A simple a*b/c isn't possible as it can overflow. - *) -function av_rescale_rnd (a, b, c: cint64; enum: TAVRounding): cint64; - cdecl; external av__util; {av_const} - -(** - * Rescales a 64-bit integer by 2 rational numbers. - *) -function av_rescale_q (a: cint64; bq, cq: TAVRational): cint64; - cdecl; external av__util; {av_const} - -implementation - -end. diff --git a/src/lib/ffmpeg/opt.pas b/src/lib/ffmpeg/opt.pas deleted file mode 100644 index 86144598..00000000 --- a/src/lib/ffmpeg/opt.pas +++ /dev/null @@ -1,272 +0,0 @@ -(* - * AVOptions - * copyright (c) 2005 Michael Niedermayer - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversion of libavcodec/opt.h - * revision 16912, Sun Feb 1 02:00:19 2009 UTC - * - * update, MiSchi, no code change - * Fri Jun 12 2009 21:50:00 UTC - *) -{ - * update to - * Max. version: 52.42.0, Sun Dec 6 19:20:00 2009 CET - * MiSchi -} - -unit opt; - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -interface - -uses - ctypes, - rational, - UConfig; - -type - TAVOptionType = ( - FF_OPT_TYPE_FLAGS, - FF_OPT_TYPE_INT, - FF_OPT_TYPE_INT64, - FF_OPT_TYPE_DOUBLE, - FF_OPT_TYPE_FLOAT, - FF_OPT_TYPE_STRING, - FF_OPT_TYPE_RATIONAL, - FF_OPT_TYPE_BINARY, ///< offset must point to a pointer immediately followed by an int for the length - FF_OPT_TYPE_CONST = 128 - ); - -const - AV_OPT_FLAG_ENCODING_PARAM = 1; ///< a generic parameter which can be set by the user for muxing or encoding - AV_OPT_FLAG_DECODING_PARAM = 2; ///< a generic parameter which can be set by the user for demuxing or decoding - AV_OPT_FLAG_METADATA = 4; ///< some data extracted or inserted into the file like title, comment, ... - AV_OPT_FLAG_AUDIO_PARAM = 8; - AV_OPT_FLAG_VIDEO_PARAM = 16; - AV_OPT_FLAG_SUBTITLE_PARAM = 32; - -type - (** - * AVOption - *) - PAVOption = ^TAVOption; - TAVOption = record - name: {const} PAnsiChar; - - (** - * short English help text - * @todo What about other languages? - *) - help: {const} PAnsiChar; - - (** - * The offset relative to the context structure where the option - * value is stored. It should be 0 for named constants. - *) - offset: cint; - type_: TAVOptionType; - - (** - * the default value for scalar options - *) - default_val: cdouble; - min: cdouble; ///< minimum valid value for the option - max: cdouble; ///< maximum valid value for the option - - flags: cint; -//FIXME think about enc-audio, ... style flags - - (** - * The logical unit to which the option belongs. Non-constant - * options and corresponding named constants share the same - * unit. May be NULL. - *) - unit_: {const} PAnsiChar; - end; - -{$IF LIBAVCODEC_VERSION >= 52042000} // >= 52.42.0 -(** - * AVOption2. - * THIS IS NOT PART OF THE API/ABI YET! - * This is identical to AVOption except that default_val was replaced by - * an union, it should be compatible with AVOption on normal platforms. - *) -type - PAVOption2 = ^TAVOption2; - TAVOption2 = record - name : {const} PAnsiChar; - - (** - * short English help text - * @todo What about other languages? - *) - help : {const} PAnsiChar; - - (** - * The offset relative to the context structure where the option - * value is stored. It should be 0 for named constants. - *) - offset : cint; - type_ : TAVOptionType; - - (** - * the default value for scalar options - *) - default_val : record - case cint of - 0 : (dbl: cdouble); - 1 : (str: PAnsiChar); - end; - min : cdouble; - max : cdouble; - flags : cint; -//FIXME think about enc-audio, ... style flags - - (** - * The logical unit to which the option belongs. Non-constant - * options and corresponding named constants share the same - * unit. May be NULL. - *) - unit_: {const} PAnsiChar; - end; -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 -(** - * Looks for an option in obj. Looks only for the options which - * have the flags set as specified in mask and flags (that is, - * for which it is the case that opt->flags & mask == flags). - * - * @param[in] obj a pointer to a struct whose first element is a - * pointer to an AVClass - * @param[in] name the name of the option to look for - * @param[in] unit the unit of the option to look for, or any if NULL - * @return a pointer to the option found, or NULL if no option - * has been found - *) -function av_find_opt(obj: Pointer; {const} name: {const} PAnsiChar; {const} unit_: PAnsiChar; mask: cint; flags: cint): {const} PAVOption; - cdecl; external av__codec; -{$IFEND} - -{$IF LIBAVCODEC_VERSION_MAJOR < 53} - -(** - * @see av_set_string2() - *) -function av_set_string(obj: pointer; name: {const} PAnsiChar; val: {const} PAnsiChar): {const} PAVOption; - cdecl; external av__codec; deprecated; - -{$IF LIBAVCODEC_VERSION >= 51059000} // 51.59.0 -(** - * @return a pointer to the AVOption corresponding to the field set or - * NULL if no matching AVOption exists, or if the value val is not - * valid - * @see av_set_string3() - *) -function av_set_string2(obj: Pointer; name: {const} PAnsiChar; val: {const} PAnsiChar; alloc: cint): {const} PAVOption; - cdecl; external av__codec; deprecated; -{$IFEND} - -{$IFEND} - -{$IF LIBAVCODEC_VERSION >= 52007000} // 52.7.0 -(** - * Sets the field of obj with the given name to value. - * - * @param[in] obj A struct whose first element is a pointer to an - * AVClass. - * @param[in] name the name of the field to set - * @param[in] val The value to set. If the field is not of a string - * type, then the given string is parsed. - * SI postfixes and some named scalars are supported. - * If the field is of a numeric type, it has to be a numeric or named - * scalar. Behavior with more than one scalar and +- infix operators - * is undefined. - * If the field is of a flags type, it has to be a sequence of numeric - * scalars or named flags separated by '+' or '-'. Prefixing a flag - * with '+' causes it to be set without affecting the other flags; - * similarly, '-' unsets a flag. - * @param[out] o_out if non-NULL put here a pointer to the AVOption - * found - * @param alloc when 1 then the old value will be av_freed() and the - * new av_strduped() - * when 0 then no av_free() nor av_strdup() will be used - * @return 0 if the value has been set, or an AVERROR code in case of - * error: - * AVERROR(ENOENT) if no matching option exists - * AVERROR(ERANGE) if the value is out of range - * AVERROR(EINVAL) if the value is not valid - *) -function av_set_string3(obj: Pointer; name: {const} PAnsiChar; val: {const} PAnsiChar; alloc: cint; out o_out: {const} PAVOption): cint; - cdecl; external av__codec; -{$IFEND} - -function av_set_double(obj: pointer; name: {const} PAnsiChar; n: cdouble): PAVOption; - cdecl; external av__codec; - -function av_set_q(obj: pointer; name: {const} PAnsiChar; n: TAVRational): PAVOption; - cdecl; external av__codec; - -function av_set_int(obj: pointer; name: {const} PAnsiChar; n: cint64): PAVOption; - cdecl; external av__codec; - -function av_get_double(obj: pointer; name: {const} PAnsiChar; var o_out: PAVOption): cdouble; - cdecl; external av__codec; - -function av_get_q(obj: pointer; name: {const} PAnsiChar; var o_out: PAVOption): TAVRational; - cdecl; external av__codec; - -function av_get_int(obj: pointer; name: {const} PAnsiChar; var o_out: {const} PAVOption): cint64; - cdecl; external av__codec; - -function av_get_string(obj: pointer; name: {const} PAnsiChar; var o_out: {const} PAVOption; buf: PAnsiChar; buf_len: cint): PAnsiChar; - cdecl; external av__codec; - -function av_next_option(obj: pointer; last: {const} PAVOption): PAVOption; - cdecl; external av__codec; - -function av_opt_show(obj: pointer; av_log_obj: pointer): cint; - cdecl; external av__codec; - -procedure av_opt_set_defaults(s: pointer); - cdecl; external av__codec; - -{$IF LIBAVCODEC_VERSION >= 51039000} // 51.39.0 -procedure av_opt_set_defaults2(s: Pointer; mask: cint; flags: cint); - cdecl; external av__codec; -{$IFEND} - -implementation - -end. diff --git a/src/lib/ffmpeg/rational.pas b/src/lib/ffmpeg/rational.pas deleted file mode 100644 index 4b8a2dc8..00000000 --- a/src/lib/ffmpeg/rational.pas +++ /dev/null @@ -1,179 +0,0 @@ -(* - * rational numbers - * Copyright (c) 2003 Michael Niedermayer - * - * This library is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2 of the License, or (at your option) any later version. - * - * This library is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with this library; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * This is a part of Pascal porting of ffmpeg. - * - Originally by Victor Zinetz for Delphi and Free Pascal on Windows. - * - For Mac OS X, some modifications were made by The Creative CAT, denoted as CAT - * in the source codes. - * - Changes and updates by the UltraStar Deluxe Team - *) - -(* - * Conversion of libavutil/rational.h - * revision 16912, Sun Feb 1 02:00:19 2009 UTC - * - * update, MiSchi, no code change - * Fri Jun 12 2009 22:20:00 UTC - * - * update, MiSchi, no code change needed - * Sun Dec 6 2009 22:20:00 UTC - *) - -unit rational; - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$I switches.inc} - -interface - -uses - ctypes, - UConfig; - -type - (* - * rational number numerator/denominator - *) - PAVRational = ^TAVRational; - TAVRational = record - num: cint; ///< numerator - den: cint; ///< denominator - end; - - TAVRationalArray = array[0 .. (MaxInt div SizeOf(TAVRational))-1] of TAVRational; - PAVRationalArray = ^TAVRationalArray; - -(** - * Compares two rationals. - * @param a first rational - * @param b second rational - * @return 0 if a==b, 1 if a>b and -1 if a= 49011000} // 49.11.0 -(** - * @return 1 if q1 is nearer to q than q2, -1 if q2 is nearer - * than q1, 0 if they have the same distance. - *) -function av_nearer_q(q, q1, q2: TAVRational): cint; - cdecl; external av__util; - -(** - * Finds the nearest value in q_list to q. - * @param q_list an array of rationals terminated by {0, 0} - * @return the index of the nearest value found in the array - *) -function av_find_nearest_q_idx(q: TAVRational; q_list: {const} PAVRationalArray): cint; - cdecl; external av__util; -{$IFEND} - -implementation - -function av_cmp_q (a: TAVRational; b: TAVRational): cint; -var - tmp: cint64; -begin - tmp := a.num * cint64(b.den) - b.num * cint64(a.den); - - if (tmp <> 0) then - Result := (tmp shr 63) or 1 - else - Result := 0 -end; - -function av_q2d(a: TAVRational): cdouble; -begin - Result := a.num / a.den; -end; - -end. diff --git a/src/lib/ffmpeg/swscale.pas b/src/lib/ffmpeg/swscale.pas deleted file mode 100644 index 595e16ba..00000000 --- a/src/lib/ffmpeg/swscale.pas +++ /dev/null @@ -1,355 +0,0 @@ -(* - * Copyright (C) 2001-2003 Michael Niedermayer - * - * FFmpeg is free software; you can redistribute it and/or - * modify it under the terms of the GNU Lesser General Public - * License as published by the Free Software Foundation; either - * version 2.1 of the License, or (at your option) any later version. - * - * FFmpeg is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU - * Lesser General Public License for more details. - * - * You should have received a copy of the GNU Lesser General Public - * License along with FFmpeg; if not, write to the Free Software - * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA - *) - -(* - * FFmpeg Pascal port - * - Ported by the UltraStar Deluxe Team - *) - -(* - * Conversion of libswscale/swscale.h - * revision 27592, Fri Sep 12 21:46:53 2008 UTC - *) -{ - * update to - * Max. version: 0.7.2, Sun Dec 6 22:20:00 2009 CET - * MiSchi -} - -unit swscale; - -{$IFDEF FPC} - {$MODE DELPHI } - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$IFDEF DARWIN} - {$linklib libswscale} -{$ENDIF} - -interface - -uses - ctypes, - avutil, - avcodec, - UConfig; - -const - (* Max. supported version by this header *) - LIBSWSCALE_MAX_VERSION_MAJOR = 0; - LIBSWSCALE_MAX_VERSION_MINOR = 7; - LIBSWSCALE_MAX_VERSION_RELEASE = 2; - LIBSWSCALE_MAX_VERSION = (LIBSWSCALE_MAX_VERSION_MAJOR * VERSION_MAJOR) + - (LIBSWSCALE_MAX_VERSION_MINOR * VERSION_MINOR) + - (LIBSWSCALE_MAX_VERSION_RELEASE * VERSION_RELEASE); - -(* Check if linked versions are supported *) -{$IF (LIBSWSCALE_VERSION > LIBSWSCALE_MAX_VERSION)} - {$MESSAGE Error 'Linked version of libswscale is not yet supported!'} -{$IFEND} - -type - TQuadCintArray = array[0..3] of cint; - PQuadCintArray = ^TQuadCintArray; - TCintArray = array[0..0] of cint; - PCintArray = ^TCintArray; - TPCuint8Array = array[0..0] of PCuint8; - PPCuint8Array = ^TPCuint8Array; - -{$IF LIBSWSCALE_VERSION >= 000006001} // 0.6.1 -(** - * Returns the LIBSWSCALE_VERSION_INT constant. - *) -function swscale_version(): cuint; - cdecl; external sw__scale; -{$IFEND} - -{$IF LIBSWSCALE_VERSION >= 000007002} // 0.7.2 -(** - * Returns the libswscale build-time configuration. - *) -function swscale_configuration(): PAnsiChar; - cdecl; external sw__scale; - -(** - * Returns the libswscale license. - *) -function swscale_license(): PAnsiChar; - cdecl; external sw__scale; -{$IFEND} - -const - (* values for the flags, the stuff on the command line is different *) - SWS_FAST_BILINEAR = 1; - SWS_BILINEAR = 2; - SWS_BICUBIC = 4; - SWS_X = 8; - SWS_POINT = $10; - SWS_AREA = $20; - SWS_BICUBLIN = $40; - SWS_GAUSS = $80; - SWS_SINC = $100; - SWS_LANCZOS = $200; - SWS_SPLINE = $400; - - SWS_SRC_V_CHR_DROP_MASK = $30000; - SWS_SRC_V_CHR_DROP_SHIFT = 16; - - SWS_PARAM_DEFAULT = 123456; - - SWS_PRINT_INFO = $1000; - - // the following 3 flags are not completely implemented - // internal chrominace subsampling info - SWS_FULL_CHR_H_INT = $2000; - // input subsampling info - SWS_FULL_CHR_H_INP = $4000; - SWS_DIRECT_BGR = $8000; - SWS_ACCURATE_RND = $40000; - SWS_BITEXACT = $80000; - - SWS_CPU_CAPS_MMX = $80000000; - SWS_CPU_CAPS_MMX2 = $20000000; - SWS_CPU_CAPS_3DNOW = $40000000; - SWS_CPU_CAPS_ALTIVEC = $10000000; - SWS_CPU_CAPS_BFIN = $01000000; - - SWS_MAX_REDUCE_CUTOFF = 0.002; - - SWS_CS_ITU709 = 1; - SWS_CS_FCC = 4; - SWS_CS_ITU601 = 5; - SWS_CS_ITU624 = 5; - SWS_CS_SMPTE170M = 5; - SWS_CS_SMPTE240M = 7; - SWS_CS_DEFAULT = 5; - -type - - // when used for filters they must have an odd number of elements - // coeffs cannot be shared between vectors - PSwsVector = ^TSwsVector; - TSwsVector = record - coeff: PCdouble; // pointer to the list of coefficients - length: cint; // number of coefficients in the vector - end; - - // vectors can be shared - PSwsFilter = ^TSwsFilter; - TSwsFilter = record - lumH: PSwsVector; - lumV: PSwsVector; - chrH: PSwsVector; - chrV: PSwsVector; - end; - - PSwsContext = ^TSwsContext; - TSwsContext = record - {internal structure} - end; - -(** - * Frees the swscaler context swsContext. - * If swsContext is NULL, then does nothing. - *) -procedure sws_freeContext(swsContext: PSwsContext); - cdecl; external sw__scale; - -(** - * Allocates and returns a SwsContext. You need it to perform - * scaling/conversion operations using sws_scale(). - * - * @param srcW the width of the source image - * @param srcH the height of the source image - * @param srcFormat the source image format - * @param dstW the width of the destination image - * @param dstH the height of the destination image - * @param dstFormat the destination image format - * @param flags specify which algorithm and options to use for rescaling - * @return a pointer to an allocated context, or NULL in case of error - *) -function sws_getContext(srcW: cint; srcH: cint; srcFormat: TAVPixelFormat; - dstW: cint; dstH: cint; dstFormat: TAVPixelFormat; - flags: cint; srcFilter: PSwsFilter; - dstFilter: PSwsFilter; param: PCdouble): PSwsContext; - cdecl; external sw__scale; - -(** - * Scales the image slice in srcSlice and puts the resulting scaled - * slice in the image in dst. A slice is a sequence of consecutive - * rows in an image. - * - * Slices have to be provided in sequential order, either in - * top-bottom or bottom-top order. If slices are provided in - * non-sequential order the behavior of the function is undefined. - * - * @param context the scaling context previously created with - * sws_getContext() - * @param srcSlice the array containing the pointers to the planes of - * the source slice - * @param srcStride the array containing the strides for each plane of - * the source image - * @param srcSliceY the position in the source image of the slice to - * process, that is the number (counted starting from - * zero) in the image of the first row of the slice - * @param srcSliceH the height of the source slice, that is the number - * of rows in the slice - * @param dst the array containing the pointers to the planes of - * the destination image - * @param dstStride the array containing the strides for each plane of - * the destination image - * @return the height of the output slice - *) -function sws_scale(context: PSwsContext; srcSlice: PPCuint8Array; srcStride: PCintArray; - srcSliceY: cint; srcSliceH: cint; dst: PPCuint8Array; dstStride: PCintArray): cint; - cdecl; external sw__scale; - -{$IF LIBSWSCALE_VERSION_MAJOR < 1} -// deprecated. Use sws_scale() instead. -function sws_scale_ordered(context: PSwsContext; src: PPCuint8Array; srcStride: PCintArray; - srcSliceY: cint; srcSliceH: cint; dst: PPCuint8Array; dstStride: PCintArray): cint; - cdecl; external sw__scale; deprecated; -{$IFEND} - -(** - * @param inv_table the yuv2rgb coefficients, normally ff_yuv2rgb_coeffs[x] - * @param fullRange if 1 then the luma range is 0..255 if 0 it is 16..235 - * @return -1 if not supported - *) -function sws_setColorspaceDetails(c: PSwsContext; inv_table: PQuadCintArray; - srcRange: cint; table: PQuadCintArray; dstRange: cint; - brightness: cint; contrast: cint; saturation: cint): cint; - cdecl; external sw__scale; - -(** - * @return -1 if not supported - *) -function sws_getColorspaceDetails(c: PSwsContext; var inv_table: PQuadCintArray; - var srcRange: cint; var table: PQuadCintArray; var dstRange: cint; - var brightness: cint; var contrast: cint; var saturation: cint): cint; - cdecl; external sw__scale; - -(** - * Returns a normalized Gaussian curve used to filter stuff - * quality=3 is high quality, lower is lower quality. - *) -function sws_getGaussianVec(variance: cdouble; quality: cdouble): PSwsVector; - cdecl; external sw__scale; - -(** - * Allocates and returns a vector with length coefficients, all - * with the same value c. - *) -function sws_getConstVec(c: cdouble; length: cint): PSwsVector; - cdecl; external sw__scale; - -(** - * Allocates and returns a vector with just one coefficient, with - * value 1.0. - *) -function sws_getIdentityVec: PSwsVector; - cdecl; external sw__scale; - -(** - * Scales all the coefficients of a by the scalar value. - *) -procedure sws_scaleVec(a: PSwsVector; scalar: cdouble); - cdecl; external sw__scale; - -(** - * Scales all the coefficients of a so that their sum equals height. - *) -procedure sws_normalizeVec(a: PSwsVector; height: cdouble); - cdecl; external sw__scale; - -procedure sws_convVec(a: PSwsVector; b: PSwsVector); - cdecl; external sw__scale; - -procedure sws_addVec(a: PSwsVector; b: PSwsVector); - cdecl; external sw__scale; - -procedure sws_subVec(a: PSwsVector; b: PSwsVector); - cdecl; external sw__scale; - -procedure sws_shiftVec(a: PSwsVector; shift: cint); - cdecl; external sw__scale; - -(** - * Allocates and returns a clone of the vector a, that is a vector - * with the same coefficients as a. - *) -function sws_cloneVec(a: PSwsVector): PSwsVector; - cdecl; external sw__scale; - -{$IF LIBSWSCALE_VERSION_MAJOR < 1} -// deprecated Use sws_printVec2() instead. - -procedure sws_printVec(a: PSwsVector); - cdecl; external sw__scale; deprecated; -{$IFEND} - -{$IF LIBSWSCALE_VERSION >= 000007000} // >= 0.7.0 -(** - * Prints with av_log() a textual representation of the vector a - * if log_level <= av_log_level. - *) -procedure sws_printVec2(a: PSwsVector; - log_ctx: PAVClass; // PAVClass is declared in avcodec.pas - log_level: cint); - cdecl; external sw__scale; -{$IFEND} - -procedure sws_freeVec(a: PSwsVector); - cdecl; external sw__scale; - -function sws_getDefaultFilter(lumaGBlur: cfloat; chromaGBlur: cfloat; - lumaSharpen: cfloat; chromaSharpen: cfloat; - chromaHShift: cfloat; chromaVShift: cfloat; - verbose: cint): PSwsFilter; - cdecl; external sw__scale; - -procedure sws_freeFilter(filter: PSwsFilter); - cdecl; external sw__scale; - -(** - * Checks if context can be reused, otherwise reallocates a new - * one. - * - * If context is NULL, just calls sws_getContext() to get a new - * context. Otherwise, checks if the parameters are the ones already - * saved in context. If that is the case, returns the current - * context. Otherwise, frees context and gets a new context with - * the new parameters. - * - * Be warned that srcFilter and dstFilter are not checked, they - * are assumed to remain the same. - *) -function sws_getCachedContext(context: PSwsContext; - srcW: cint; srcH: cint; srcFormat: TAVPixelFormat; - dstW: cint; dstH: cint; dstFormat: TAVPixelFormat; - flags: cint; srcFilter: PSwsFilter; - dstFilter: PSwsFilter; param: PCdouble): PSwsContext; - cdecl; external sw__scale; - -implementation - -end. diff --git a/src/lib/fft/UFFT.pas b/src/lib/fft/UFFT.pas deleted file mode 100644 index 5a056a8c..00000000 --- a/src/lib/fft/UFFT.pas +++ /dev/null @@ -1,602 +0,0 @@ -{********************************************************************** - - FFT.cpp - - Dominic Mazzoni - - September 2000 - -*********************************************************************** - -Fast Fourier Transform routines. - - This file contains a few FFT routines, including a real-FFT - routine that is almost twice as fast as a normal complex FFT, - and a power spectrum routine when you know you don't care - about phase information. - - Some of this code was based on a free implementation of an FFT - by Don Cross, available on the web at: - - http://www.intersrv.com/~dcross/fft.html - - The basic algorithm for his code was based on Numerican Recipes - in Fortran. I optimized his code further by reducing array - accesses, caching the bit reversal table, and eliminating - float-to-double conversions, and I added the routines to - calculate a real FFT and a real power spectrum. - -*********************************************************************** - - Salvo Ventura - November 2006 - Added more window functions: - * 4: Blackman - * 5: Blackman-Harris - * 6: Welch - * 7: Gaussian(a=2.5) - * 8: Gaussian(a=3.5) - * 9: Gaussian(a=4.5) - -*********************************************************************** - - This file is part of Audacity 1.3.4 beta (http://audacity.sourceforge.net/) - Ported to Pascal by the UltraStar Deluxe Team -} - -unit UFFT; - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // Use long strings -{$ENDIF} - -interface -type - TSingleArray = array[0 .. (MaxInt div SizeOf(Single))-1] of Single; - PSingleArray = ^TSingleArray; - - TFFTWindowFunc = ( - fwfRectangular, - fwfBartlett, - fwfHamming, - fwfHanning, - fwfBlackman, - fwfBlackman_Harris, - fwfWelch, - fwfGaussian2_5, - fwfGaussian3_5, - fwfGaussian4_5 - ); - -const - FFTWindowName: array[TFFTWindowFunc] of string = ( - 'Rectangular', - 'Bartlett', - 'Hamming', - 'Hanning', - 'Blackman', - 'Blackman-Harris', - 'Welch', - 'Gaussian(a=2.5)', - 'Gaussian(a=3.5)', - 'Gaussian(a=4.5)' - ); - -(* - * This is the function you will use the most often. - * Given an array of floats, this will compute the power - * spectrum by doing a Real FFT and then computing the - * sum of the squares of the real and imaginary parts. - * Note that the output array is half the length of the - * input array, and that NumSamples must be a power of two. - *) -procedure PowerSpectrum(NumSamples: Integer; In_, Out_: PSingleArray); - -(* - * Computes an FFT when the input data is real but you still - * want complex data as output. The output arrays are half - * the length of the input, and NumSamples must be a power of - * two. - *) -procedure RealFFT(NumSamples: integer; - RealIn, RealOut, ImagOut: PSingleArray); - -(* - * Computes a FFT of complex input and returns complex output. - * Currently this is the only function here that supports the - * inverse transform as well. - *) -procedure FFT(NumSamples: Integer; - InverseTransform: boolean; - RealIn, ImagIn, RealOut, ImagOut: PSingleArray); - -(* - * Applies a windowing function to the data in place - * - * 0: Rectangular (no window) - * 1: Bartlett (triangular) - * 2: Hamming - * 3: Hanning - * 4: Blackman - * 5: Blackman-Harris - * 6: Welch - * 7: Gaussian(a=2.5) - * 8: Gaussian(a=3.5) - * 9: Gaussian(a=4.5) - *) -procedure WindowFunc(whichFunction: TFFTWindowFunc; NumSamples: Integer; in_: PSingleArray); - -(* - * Returns the name of the windowing function (for UI display) - *) -function WindowFuncName(whichFunction: TFFTWindowFunc): string; - -(* - * Returns the number of windowing functions supported - *) -function NumWindowFuncs(): integer; - - -implementation - -uses - SysUtils; - -type TIntArray = array[0 .. (MaxInt div SizeOf(Integer))-1] of Integer; -type PIntArray = ^TIntArray; -type TIntIntArray = array[0 .. (MaxInt div SizeOf(PIntArray))-1] of PIntArray; -type PIntIntArray = ^TIntIntArray; -var gFFTBitTable: PIntIntArray; -const MaxFastBits: Integer = 16; - -function IsPowerOfTwo(x: Integer): Boolean; -begin - if (x < 2) then - result := false - else if ((x and (x - 1)) <> 0) then { Thanks to 'byang' for this cute trick! } - result := false - else - result := true; -end; - -function NumberOfBitsNeeded(PowerOfTwo: Integer): Integer; -var i: Integer; -begin - if (PowerOfTwo < 2) then begin - Writeln(ErrOutput, Format('Error: FFT called with size %d\n', [PowerOfTwo])); - Abort; - end; - - i := 0; - while(true) do begin - if (PowerOfTwo and (1 shl i) <> 0) then begin - result := i; - Exit; - end; - Inc(i); - end; -end; - -function ReverseBits(index, NumBits: Integer): Integer; -var - i, rev: Integer; -begin - rev := 0; - for i := 0 to NumBits-1 do begin - rev := (rev shl 1) or (index and 1); - index := index shr 1; - end; - - result := rev; -end; - -procedure InitFFT(); -var - len: Integer; - b, i: Integer; -begin - GetMem(gFFTBitTable, MaxFastBits * sizeof(PSingle)); - - len := 2; - for b := 1 to MaxFastBits do begin - GetMem(gFFTBitTable[b - 1], len * sizeof(Single)); - for i := 0 to len-1 do - gFFTBitTable[b - 1][i] := ReverseBits(i, b); - len := len shl 1; - end; -end; - -function FastReverseBits(i, NumBits: Integer): Integer; {$IFDEF HasInline}inline;{$ENDIF} -begin - if (NumBits <= MaxFastBits) then - result := gFFTBitTable[NumBits - 1][i] - else - result := ReverseBits(i, NumBits); -end; - -{* - * Complex Fast Fourier Transform - *} -procedure FFT(NumSamples: Integer; - InverseTransform: boolean; - RealIn, ImagIn, RealOut, ImagOut: PSingleArray); -var - NumBits: Integer; { Number of bits needed to store indices } - i, j, k, n: Integer; - BlockSize, BlockEnd: Integer; - delta_angle: Double; - angle_numerator: Double; - tr, ti: Double; { temp real, temp imaginary } - sm2, sm1, cm2, cm1: Double; - w: Double; - ar0, ar1, ar2, ai0, ai1, ai2: Double; - denom: Single; -begin - - angle_numerator := 2.0 * Pi; - - if (not IsPowerOfTwo(NumSamples)) then begin - Writeln(ErrOutput, Format('%d is not a power of two', [NumSamples])); - Abort; - end; - - if (gFFTBitTable = nil) then - InitFFT(); - - if (InverseTransform) then - angle_numerator := -angle_numerator; - - NumBits := NumberOfBitsNeeded(NumSamples); - - { - ** Do simultaneous data copy and bit-reversal ordering into outputs... - } - - for i := 0 to NumSamples-1 do begin - j := FastReverseBits(i, NumBits); - RealOut[j] := RealIn[i]; - if(ImagIn = nil) then - ImagOut[j] := 0.0 - else - ImagOut[j] := ImagIn[i]; - end; - - { - ** Do the FFT itself... - } - - BlockEnd := 1; - BlockSize := 2; - while(BlockSize <= NumSamples) do - begin - - delta_angle := angle_numerator / BlockSize; - - sm2 := sin(-2 * delta_angle); - sm1 := sin(-delta_angle); - cm2 := cos(-2 * delta_angle); - cm1 := cos(-delta_angle); - w := 2 * cm1; - - i := 0; - while(i < NumSamples) do - begin - ar2 := cm2; - ar1 := cm1; - - ai2 := sm2; - ai1 := sm1; - - j := i; - for n := 0 to BlockEnd-1 do - begin - ar0 := w * ar1 - ar2; - ar2 := ar1; - ar1 := ar0; - - ai0 := w * ai1 - ai2; - ai2 := ai1; - ai1 := ai0; - - k := j + BlockEnd; - tr := ar0 * RealOut[k] - ai0 * ImagOut[k]; - ti := ar0 * ImagOut[k] + ai0 * RealOut[k]; - - RealOut[k] := RealOut[j] - tr; - ImagOut[k] := ImagOut[j] - ti; - - RealOut[j] := RealOut[j] + tr; - ImagOut[j] := ImagOut[j] + ti; - - Inc(j); - end; - - Inc(i, BlockSize); - end; - - BlockEnd := BlockSize; - BlockSize := BlockSize shl 1; - end; - - { - ** Need to normalize if inverse transform... - } - - if (InverseTransform) then begin - denom := NumSamples; - - for i := 0 to NumSamples-1 do begin - RealOut[i] := RealOut[i] / denom; - ImagOut[i] := ImagOut[i] / denom; - end; - end; -end; - -(* - * Real Fast Fourier Transform - * - * This function was based on the code in Numerical Recipes in C. - * In Num. Rec., the inner loop is based on a single 1-based array - * of interleaved real and imaginary numbers. Because we have two - * separate zero-based arrays, our indices are quite different. - * Here is the correspondence between Num. Rec. indices and our indices: - * - * i1 <-> real[i] - * i2 <-> imag[i] - * i3 <-> real[n/2-i] - * i4 <-> imag[n/2-i] - *) -procedure RealFFT(NumSamples: integer; RealIn, RealOut, ImagOut: PSingleArray); -var - Half: Integer; - i: Integer; - theta: Single; - tmpReal, tmpImag: PSingleArray; - wtemp: Single; - wpr, wpi, wr, wi: Single; - i3: Integer; - h1r, h1i, h2r, h2i: Single; -begin - Half := NumSamples div 2; - - theta := Pi / Half; - - GetMem(tmpReal, Half * sizeof(Single)); - GetMem(tmpImag, Half * sizeof(Single)); - - for i := 0 to Half-1 do - begin - tmpReal[i] := RealIn[2 * i]; - tmpImag[i] := RealIn[2 * i + 1]; - end; - - FFT(Half, false, tmpReal, tmpImag, RealOut, ImagOut); - - wtemp := sin(0.5 * theta); - - wpr := -2.0 * wtemp * wtemp; - wpi := sin(theta); - wr := 1.0 + wpr; - wi := wpi; - - for i := 1 to (Half div 2)-1 do - begin - i3 := Half - i; - - h1r := 0.5 * (RealOut[i] + RealOut[i3]); - h1i := 0.5 * (ImagOut[i] - ImagOut[i3]); - h2r := 0.5 * (ImagOut[i] + ImagOut[i3]); - h2i := -0.5 * (RealOut[i] - RealOut[i3]); - - RealOut[i] := h1r + wr * h2r - wi * h2i; - ImagOut[i] := h1i + wr * h2i + wi * h2r; - RealOut[i3] := h1r - wr * h2r + wi * h2i; - ImagOut[i3] := -h1i + wr * h2i + wi * h2r; - - wtemp := wr; - wr := wtemp * wpr - wi * wpi + wr; - wi := wi * wpr + wtemp * wpi + wi; - end; - - h1r := RealOut[0]; - RealOut[0] := h1r + ImagOut[0]; - ImagOut[0] := h1r - ImagOut[0]; - - FreeMem(tmpReal); - FreeMem(tmpImag); -end; - -{* - * PowerSpectrum - * - * This function computes the same as RealFFT, above, but - * adds the squares of the real and imaginary part of each - * coefficient, extracting the power and throwing away the - * phase. - * - * For speed, it does not call RealFFT, but duplicates some - * of its code. - *} -procedure PowerSpectrum(NumSamples: Integer; In_, Out_: PSingleArray); -var - Half: Integer; - i: Integer; - theta: Single; - tmpReal, tmpImag, RealOut, ImagOut: PSingleArray; - wtemp: Single; - wpr, wpi, wr, wi: Single; - i3: Integer; - h1r, h1i, h2r, h2i, rt, it: Single; -begin - Half := NumSamples div 2; - - theta := Pi / Half; - - GetMem(tmpReal, Half * sizeof(Single)); - GetMem(tmpImag, Half * sizeof(Single)); - GetMem(RealOut, Half * sizeof(Single)); - GetMem(ImagOut, Half * sizeof(Single)); - - for i := 0 to Half-1 do begin - tmpReal[i] := In_[2 * i]; - tmpImag[i] := In_[2 * i + 1]; - end; - - FFT(Half, false, tmpReal, tmpImag, RealOut, ImagOut); - - wtemp := sin(0.5 * theta); - - wpr := -2.0 * wtemp * wtemp; - wpi := sin(theta); - wr := 1.0 + wpr; - wi := wpi; - - for i := 1 to (Half div 2)-1 do - begin - i3 := Half - i; - - h1r := 0.5 * (RealOut[i] + RealOut[i3]); - h1i := 0.5 * (ImagOut[i] - ImagOut[i3]); - h2r := 0.5 * (ImagOut[i] + ImagOut[i3]); - h2i := -0.5 * (RealOut[i] - RealOut[i3]); - - rt := h1r + wr * h2r - wi * h2i; - it := h1i + wr * h2i + wi * h2r; - - Out_[i] := rt * rt + it * it; - - rt := h1r - wr * h2r + wi * h2i; - it := -h1i + wr * h2i + wi * h2r; - - Out_[i3] := rt * rt + it * it; - - wtemp := wr; - wr := wtemp * wpr - wi * wpi + wr; - wi := wi * wpr + wtemp * wpi + wi; - end; - - h1r := RealOut[0]; - rt := h1r + ImagOut[0]; - it := h1r - ImagOut[0]; - Out_[0] := rt * rt + it * it; - - rt := RealOut[Half div 2]; - it := ImagOut[Half div 2]; - Out_[Half div 2] := rt * rt + it * it; - - FreeMem(tmpReal); - FreeMem(tmpImag); - FreeMem(RealOut); - FreeMem(ImagOut); -end; - -(* - * Windowing Functions - *) -function NumWindowFuncs(): integer; -begin - Result := Length(FFTWindowName); -end; - -function WindowFuncName(whichFunction: TFFTWindowFunc): string; -begin - Result := FFTWindowName[whichFunction]; -end; - -procedure WindowFunc(whichFunction: TFFTWindowFunc; NumSamples: Integer; in_: PSingleArray); -var - i: Integer; - A: Single; -begin - case whichFunction of - fwfBartlett: - begin - // Bartlett (triangular) window - for i := 0 to (NumSamples div 2)-1 do - begin - in_[i] := in_[i] * (i / (NumSamples / 2)); - in_[i + (NumSamples div 2)] := - in_[i + (NumSamples div 2)] * - (1.0 - (i / (NumSamples / 2))); - end; - end; - fwfHamming: - begin - // Hamming - for i := 0 to NumSamples-1 do - begin - in_[i] := in_[i] * (0.54 - 0.46 * cos(2 * Pi * i / (NumSamples - 1))); - end; - end; - fwfHanning: - begin - // Hanning - for i := 0 to NumSamples-1 do - begin - in_[i] := in_[i] * (0.50 - 0.50 * cos(2 * Pi * i / (NumSamples - 1))); - end; - end; - fwfBlackman: - begin - // Blackman - for i := 0 to NumSamples-1 do - begin - in_[i] := in_[i] * (0.42 - 0.5 * cos (2 * Pi * i / (NumSamples - 1)) + 0.08 * cos (4 * Pi * i / (NumSamples - 1))); - end; - end; - fwfBlackman_Harris: - begin - // Blackman-Harris - for i := 0 to NumSamples-1 do - begin - in_[i] := in_[i] * (0.35875 - 0.48829 * cos(2 * Pi * i /(NumSamples-1)) + 0.14128 * cos(4 * Pi * i/(NumSamples-1)) - 0.01168 * cos(6 * Pi * i/(NumSamples-1))); - end; - end; - fwfWelch: - begin - // Welch - for i := 0 to NumSamples-1 do - begin - in_[i] := in_[i] * 4*i/NumSamples*(1-(i/NumSamples)); - end; - end; - fwfGaussian2_5: - begin - // Gaussian (a=2.5) - // Precalculate some values, and simplify the fmla to try and reduce overhead - A := -2*2.5*2.5; - - for i := 0 to NumSamples-1 do - begin - // full - // in_[i] := in_[i] * exp(-0.5*(A*((i-NumSamples/2)/NumSamples/2))*(A*((i-NumSamples/2)/NumSamples/2))); - // reduced - //in_[i] := in_[i] * exp(A*(0.25 + ((i/NumSamples)*(i/NumSamples)) - (i/NumSamples))); - end; - end; - fwfGaussian3_5: - begin - // Gaussian (a=3.5) - A := -2*3.5*3.5; - - for i := 0 to NumSamples-1 do - begin - // reduced - in_[i] := in_[i] * exp(A*(0.25 + ((i/NumSamples)*(i/NumSamples)) - (i/NumSamples))); - end; - end; - fwfGaussian4_5: - begin - // Gaussian (a=4.5) - A := -2*4.5*4.5; - - for i := 0 to NumSamples-1 do - begin - // reduced - in_[i] := in_[i] * exp(A*(0.25 + ((i/NumSamples)*(i/NumSamples)) - (i/NumSamples))); - end; - end; - end; -end; - -end. diff --git a/src/lib/freetype/demo/nehe/UFreeType.pas b/src/lib/freetype/demo/nehe/UFreeType.pas deleted file mode 100644 index c1243aae..00000000 --- a/src/lib/freetype/demo/nehe/UFreeType.pas +++ /dev/null @@ -1,326 +0,0 @@ -unit UFreeType; - -{$IFDEF FPC} - {$mode delphi}{$H+} -{$ENDIF} - -interface - -uses - FreeType, - gl, - glu, - classes, - sysutils; - -type - // This holds all of the information related to any - // freetype font that we want to create. - TFontData = class - h: single; ///< Holds the height of the font. - textures: array of GLuint; ///< Holds the texture id's - list_base: GLuint; ///< Holds the first display list id - - // The init function will create a font of - // of the height h from the file fname. - constructor Create(const fname: string; h: cardinal); - - // Free all the resources assosiated with the font. - destructor Destroy(); override; - end; - - TFreeType = class - public - // The flagship function of the library - this thing will print - // out text at window coordinates x,y, using the font ft_font. - // The current modelview matrix will also be applied to the text. - class procedure print(ft_font: TFontData; x, y: single; const str: string); - end; - - -implementation - - -// This function gets the first power of 2 >= the -// int that we pass it. -function next_p2 ( a: integer ): integer; inline; -begin - Result := 1; - while (Result < a) do - Result := Result shl 1; -end; - -type - PAGLuint = ^AGLuint; - AGLuint = array[0..High(Word)] of GLuint; - -// Create a display list coresponding to the given character. -procedure make_dlist ( face: FT_Face; ch: byte; list_base: GLuint; tex_base: PAGLuint ); -var - i, j: integer; - width, height: integer; - glyph: FT_Glyph; - bitmap_glyph: FT_BitmapGlyph; - bitmap: PFT_Bitmap; - expanded_data: array of GLubyte; - x, y: single; -begin - // The first thing we do is get FreeType to render our character - // into a bitmap. This actually requires a couple of FreeType commands: - - // Load the Glyph for our character. - if (FT_Load_Glyph( face, FT_Get_Char_Index( face, ch ), FT_LOAD_DEFAULT ) <> 0) then - raise Exception.create('FT_Load_Glyph failed'); - - // Move the face's glyph into a Glyph object. - if (FT_Get_Glyph( face^.glyph, glyph ) <> 0) then - raise Exception.create('FT_Get_Glyph failed'); - - // Convert the glyph to a bitmap. - FT_Glyph_To_Bitmap( glyph, ft_render_mode_normal, nil, 1 ); - bitmap_glyph := FT_BitmapGlyph(glyph); - - // This reference will make accessing the bitmap easier - bitmap := @bitmap_glyph^.bitmap; - - // Use our helper function to get the widths of - // the bitmap data that we will need in order to create - // our texture. - width := next_p2( bitmap.width ); - height := next_p2( bitmap.rows ); - - // Allocate memory for the texture data. - SetLength(expanded_data, 2 * width * height); - - // Here we fill in the data for the expanded bitmap. - // Notice that we are using two channel bitmap (one for - // luminocity and one for alpha), but we assign - // both luminocity and alpha to the value that we - // find in the FreeType bitmap. - // We use the ?: operator so that value which we use - // will be 0 if we are in the padding zone, and whatever - // is the the Freetype bitmap otherwise. - for j := 0 to height-1 do - begin - for i := 0 to width-1 do - begin - if ((i >= bitmap.width) or (j >= bitmap.rows)) then - expanded_data[2*(i+j*width)] := 0 - else - expanded_data[2*(i+j*width)] := byte(bitmap.buffer[i + bitmap.width*j]); - expanded_data[2*(i+j*width)+1] := expanded_data[2*(i+j*width)]; - end; - end; - - - // Now we just setup some texture paramaters. - glBindTexture( GL_TEXTURE_2D, tex_base[integer(ch)]); - glTexParameteri(GL_TEXTURE_2D,GL_TEXTURE_MAG_FILTER,GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D,GL_TEXTURE_MIN_FILTER,GL_LINEAR); - - // Here we actually create the texture itself, notice - // that we are using GL_LUMINANCE_ALPHA to indicate that - // we are using 2 channel data. - glTexImage2D( GL_TEXTURE_2D, 0, GL_RGBA, width, height, - 0, GL_LUMINANCE_ALPHA, GL_UNSIGNED_BYTE, @expanded_data[0] ); - - //With the texture created, we don't need to expanded data anymore - SetLength(expanded_data, 0); - - //So now we can create the display list - glNewList(list_base+ch, GL_COMPILE); - - glBindTexture(GL_TEXTURE_2D, tex_base[ch]); - - glPushMatrix(); - - //first we need to move over a little so that - //the character has the right amount of space - //between it and the one before it. - glTranslatef(bitmap_glyph^.left, 0, 0); - - //Now we move down a little in the case that the - //bitmap extends past the bottom of the line - //(this is only true for characters like 'g' or 'y'. - glTranslatef(0, bitmap_glyph^.top - bitmap.rows, 0); - - //Now we need to account for the fact that many of - //our textures are filled with empty padding space. - //We figure what portion of the texture is used by - //the actual character and store that information in - //the x and y variables, then when we draw the - //quad, we will only reference the parts of the texture - //that we contain the character itself. - x := bitmap.width / width; - y := bitmap.rows / height; - - //Here we draw the texturemaped quads. - //The bitmap that we got from FreeType was not - //oriented quite like we would like it to be, - //so we need to link the texture to the quad - //so that the result will be properly aligned. - glBegin(GL_QUADS); - glTexCoord2d(0, 0); glVertex2f(0, bitmap.rows); - glTexCoord2d(0, y); glVertex2f(0, 0); - glTexCoord2d(x, y); glVertex2f(bitmap.width, 0); - glTexCoord2d(x, 0); glVertex2f(bitmap.width, bitmap.rows); - glEnd(); - - glPopMatrix(); - glTranslatef(face^.glyph^.advance.x shr 6, 0, 0); - - //increment the raster position as if we were a bitmap font. - //(only needed if you want to calculate text length) - //glBitmap(0,0,0,0,face->glyph->advance.x >> 6,0,NULL); - - //Finnish the display list - glEndList(); -end; - - -constructor TFontData.Create(const fname: string; h: cardinal); -var - library_: FT_Library; - //The object in which Freetype holds information on a given - //font is called a "face". - face: FT_Face; - i: byte; -begin - //Allocate some memory to store the texture ids. - SetLength(textures, 128); - - Self.h := h; - - //Create and initilize a freetype font library. - if (FT_Init_FreeType( library_ ) <> 0) then - raise Exception.create('FT_Init_FreeType failed'); - - //This is where we load in the font information from the file. - //Of all the places where the code might die, this is the most likely, - //as FT_New_Face will die if the font file does not exist or is somehow broken. - if (FT_New_Face( library_, PChar(fname), 0, face ) <> 0) then - raise Exception.create('FT_New_Face failed (there is probably a problem with your font file)'); - - //For some twisted reason, Freetype measures font size - //in terms of 1/64ths of pixels. Thus, to make a font - //h pixels high, we need to request a size of h*64. - //(h shl 6 is just a prettier way of writting h*64) - FT_Set_Char_Size( face, h shl 6, h shl 6, 96, 96); - - //Here we ask opengl to allocate resources for - //all the textures and displays lists which we - //are about to create. - list_base := glGenLists(128); - glGenTextures( 128, @textures[0] ); - - //This is where we actually create each of the fonts display lists. - for i := 0 to 127 do - make_dlist(face, i, list_base, @textures[0]); - - //We don't need the face information now that the display - //lists have been created, so we free the assosiated resources. - FT_Done_Face(face); - - //Ditto for the library. - FT_Done_FreeType(library_); -end; - -destructor TFontData.Destroy(); -begin - glDeleteLists(list_base, 128); - glDeleteTextures(128, @textures[0]); - SetLength(textures, 0); -end; - -/// A fairly straight forward function that pushes -/// a projection matrix that will make object world -/// coordinates identical to window coordinates. -procedure pushScreenCoordinateMatrix(); inline; -var - viewport: array [0..3] of GLint; -begin - glPushAttrib(GL_TRANSFORM_BIT); - glGetIntegerv(GL_VIEWPORT, @viewport); - glMatrixMode(GL_PROJECTION); - glPushMatrix(); - glLoadIdentity(); - gluOrtho2D(viewport[0], viewport[2], viewport[1], viewport[3]); - glPopAttrib(); -end; - -/// Pops the projection matrix without changing the current -/// MatrixMode. -procedure pop_projection_matrix(); inline; -begin - glPushAttrib(GL_TRANSFORM_BIT); - glMatrixMode(GL_PROJECTION); - glPopMatrix(); - glPopAttrib(); -end; - -///Much like Nehe's glPrint function, but modified to work -///with freetype fonts. -class procedure TFreeType.print(ft_font: TFontData; x, y: single; const str: string); -var - font: GLuint; - h: single; - i: cardinal; - lines: TStringList; - modelview_matrix: array[0..15] of single; -begin - // We want a coordinate system where things coresponding to window pixels. - pushScreenCoordinateMatrix(); - - font := ft_font.list_base; - h := ft_font.h / 0.63; //We make the height about 1.5* that of - - lines := TStringList.Create(); - ExtractStrings([#13], [], PChar(str), lines); - - glPushAttrib(GL_LIST_BIT or GL_CURRENT_BIT or GL_ENABLE_BIT or GL_TRANSFORM_BIT); - glMatrixMode(GL_MODELVIEW); - glDisable(GL_LIGHTING); - glEnable(GL_TEXTURE_2D); - glDisable(GL_DEPTH_TEST); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glListBase(font); - - glGetFloatv(GL_MODELVIEW_MATRIX, @modelview_matrix); - - //This is where the text display actually happens. - //For each line of text we reset the modelview matrix - //so that the line's text will start in the correct position. - //Notice that we need to reset the matrix, rather than just translating - //down by h. This is because when each character is - //draw it modifies the current matrix so that the next character - //will be drawn immediatly after it. - for i := 0 to lines.Count-1 do - begin - glPushMatrix(); - glLoadIdentity(); - glTranslatef(x, y - h*i, 0); - glMultMatrixf(@modelview_matrix); - - // The commented out raster position stuff can be useful if you need to - // know the length of the text that you are creating. - // If you decide to use it make sure to also uncomment the glBitmap command - // in make_dlist(). - //glRasterPos2f(0,0); - glCallLists(Length(lines[i]), GL_UNSIGNED_BYTE, PChar(lines[i])); - //float rpos[4]; - //glGetFloatv(GL_CURRENT_RASTER_POSITION ,rpos); - //float len=x-rpos[0]; - - glPopMatrix(); - end; - - glPopAttrib(); - - pop_projection_matrix(); - - lines.Free(); -end; - -end. diff --git a/src/lib/freetype/freetype.pas b/src/lib/freetype/freetype.pas deleted file mode 100644 index 6aaa3b59..00000000 --- a/src/lib/freetype/freetype.pas +++ /dev/null @@ -1,1845 +0,0 @@ -(***************************************************************************) -(* *) -(* freetype.h *) -(* *) -(* FreeType high-level API and common types (specification only). *) -(* *) -(* Copyright 1996-2001, 2002, 2003, 2004, 2005, 2006, 2007 by *) -(* David Turner, Robert Wilhelm, and Werner Lemberg. *) -(* *) -(* This file is part of the FreeType project, and may only be used, *) -(* modified, and distributed under the terms of the FreeType project *) -(* license, LICENSE.TXT. By continuing to use, modify, or distribute *) -(* this file you indicate that you have read the license and *) -(* understand and accept it fully. *) -(* *) -(***************************************************************************) - -(***************************************************************************) -(* Initial Pascal port by *) -(***************************************************************************) -(* Anti-Grain Geometry - Version 2.4 (Public License) *) -(* Copyright (C) 2002-2005 Maxim Shemanarev (http://www.antigrain.com) *) -(* *) -(* Anti-Grain Geometry - Version 2.4 Release Milano 3 (AggPas 2.4 RM3) *) -(* Pascal Port By: Milan Marusinec alias Milano *) -(* milan@marusinec.sk *) -(* http://www.aggpas.org *) -(* Copyright (c) 2005-2007 *) -(* *) -(* Permission to copy, use, modify, sell and distribute this software *) -(* is granted provided this copyright notice appears in all copies. *) -(* This software is provided "as is" without express or implied *) -(* warranty, and with no claim as to its suitability for any purpose. *) -(* *) -(***************************************************************************) - -(***************************************************************************) -(* Extended by the UltraStar Deluxe Team *) -(***************************************************************************) - -unit freetype; - -interface - -{$IFDEF FPC} - {$MODE DELPHI } - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -uses - ctypes; - -const -{$IF Defined(MSWINDOWS)} - ft_lib = 'freetype6.dll'; -{$ELSEIF Defined(DARWIN)} - ft_lib = 'libfreetype.dylib'; - {$LINKLIB libfreetype} -{$ELSEIF Defined(UNIX)} - ft_lib = 'freetype.so'; -{$IFEND} - -type - (*************************************************************************) - (* *) - (* *) - (* FT_Library *) - (* *) - (* *) - (* A handle to a FreeType library instance. Each `library' is *) - (* completely independent from the others; it is the `root' of a set *) - (* of objects like fonts, faces, sizes, etc. *) - (* *) - (* It also embeds a memory manager (see @FT_Memory), as well as a *) - (* scan-line converter object (see @FT_Raster). *) - (* *) - (* *) - (* Library objects are normally created by @FT_Init_FreeType, and *) - (* destroyed with @FT_Done_FreeType. *) - (* *) - FT_Library = Pointer; - - - (*************************************************************************) - (* *) - (* *) - (* FT_FACE_FLAG_XXX *) - (* *) - (* *) - (* A list of bit flags used in the `face_flags' field of the *) - (* @FT_FaceRec structure. They inform client applications of *) - (* properties of the corresponding face. *) - (* *) - (* *) - (* FT_FACE_FLAG_SCALABLE :: *) - (* Indicates that the face provides vectorial outlines. This *) - (* doesn't prevent embedded bitmaps, i.e., a face can have both *) - (* this bit and @FT_FACE_FLAG_FIXED_SIZES set. *) - (* *) - (* FT_FACE_FLAG_FIXED_SIZES :: *) - (* Indicates that the face contains `fixed sizes', i.e., bitmap *) - (* strikes for some given pixel sizes. See the `num_fixed_sizes' *) - (* and `available_sizes' fields of @FT_FaceRec. *) - (* *) - (* FT_FACE_FLAG_FIXED_WIDTH :: *) - (* Indicates that the face contains fixed-width characters (like *) - (* Courier, Lucido, MonoType, etc.). *) - (* *) - (* FT_FACE_FLAG_SFNT :: *) - (* Indicates that the face uses the `sfnt' storage scheme. For *) - (* now, this means TrueType and OpenType. *) - (* *) - (* FT_FACE_FLAG_HORIZONTAL :: *) - (* Indicates that the face contains horizontal glyph metrics. This *) - (* should be set for all common formats. *) - (* *) - (* FT_FACE_FLAG_VERTICAL :: *) - (* Indicates that the face contains vertical glyph metrics. This *) - (* is only available in some formats, not all of them. *) - (* *) - (* FT_FACE_FLAG_KERNING :: *) - (* Indicates that the face contains kerning information. If set, *) - (* the kerning distance can be retrieved through the function *) - (* @FT_Get_Kerning. Note that if unset, this function will always *) - (* return the vector (0,0). *) - (* *) - (* FT_FACE_FLAG_FAST_GLYPHS :: *) - (* THIS FLAG IS DEPRECATED. DO NOT USE OR TEST IT. *) - (* *) - (* FT_FACE_FLAG_MULTIPLE_MASTERS :: *) - (* Indicates that the font contains multiple masters and is capable *) - (* of interpolating between them. See the multiple-masters *) - (* specific API for details. *) - (* *) - (* FT_FACE_FLAG_GLYPH_NAMES :: *) - (* Indicates that the font contains glyph names that can be *) - (* retrieved through @FT_Get_Glyph_Name. Note that some TrueType *) - (* fonts contain broken glyph name tables. Use the function *) - (* @FT_Has_PS_Glyph_Names when needed. *) - (* *) - (* FT_FACE_FLAG_EXTERNAL_STREAM :: *) - (* Used internally by FreeType to indicate that a face's stream was *) - (* provided by the client application and should not be destroyed *) - (* when @FT_Done_Face is called. Don't read or test this flag. *) - (* *) -const - FT_FACE_FLAG_SCALABLE = 1 shl 0; - FT_FACE_FLAG_KERNING = 1 shl 6; - - (*************************************************************************) - (* *) - (* *) - (* FT_Encoding *) - (* *) - (* *) - (* An enumeration used to specify encodings supported by charmaps. *) - (* Used in the @FT_Select_Charmap API function. *) - (* *) - (* *) - (* Because of 32-bit charcodes defined in Unicode (i.e., surrogates), *) - (* all character codes must be expressed as FT_Longs. *) - (* *) - (* The values of this type correspond to specific character *) - (* repertories (i.e. charsets), and not to text encoding methods *) - (* (like UTF-8, UTF-16, GB2312_EUC, etc.). *) - (* *) - (* Other encodings might be defined in the future. *) - (* *) - (* *) - (* FT_ENCODING_NONE :: *) - (* The encoding value 0 is reserved. *) - (* *) - (* FT_ENCODING_UNICODE :: *) - (* Corresponds to the Unicode character set. This value covers *) - (* all versions of the Unicode repertoire, including ASCII and *) - (* Latin-1. Most fonts include a Unicode charmap, but not all *) - (* of them. *) - (* *) - (* FT_ENCODING_MS_SYMBOL :: *) - (* Corresponds to the Microsoft Symbol encoding, used to encode *) - (* mathematical symbols in the 32..255 character code range. For *) - (* more information, see `http://www.ceviz.net/symbol.htm'. *) - (* *) - (* FT_ENCODING_SJIS :: *) - (* Corresponds to Japanese SJIS encoding. More info at *) - (* at `http://langsupport.japanreference.com/encoding.shtml'. *) - (* See note on multi-byte encodings below. *) - (* *) - (* FT_ENCODING_GB2312 :: *) - (* Corresponds to an encoding system for Simplified Chinese as used *) - (* used in mainland China. *) - (* *) - (* FT_ENCODING_BIG5 :: *) - (* Corresponds to an encoding system for Traditional Chinese as used *) - (* in Taiwan and Hong Kong. *) - (* *) - (* FT_ENCODING_WANSUNG :: *) - (* Corresponds to the Korean encoding system known as Wansung. *) - (* For more information see *) - (* `http://www.microsoft.com/typography/unicode/949.txt'. *) - (* *) - (* FT_ENCODING_JOHAB :: *) - (* The Korean standard character set (KS C-5601-1992), which *) - (* corresponds to MS Windows code page 1361. This character set *) - (* includes all possible Hangeul character combinations. *) - (* *) - (* FT_ENCODING_ADOBE_LATIN_1 :: *) - (* Corresponds to a Latin-1 encoding as defined in a Type 1 *) - (* Postscript font. It is limited to 256 character codes. *) - (* *) - (* FT_ENCODING_ADOBE_STANDARD :: *) - (* Corresponds to the Adobe Standard encoding, as found in Type 1, *) - (* CFF, and OpenType/CFF fonts. It is limited to 256 character *) - (* codes. *) - (* *) - (* FT_ENCODING_ADOBE_EXPERT :: *) - (* Corresponds to the Adobe Expert encoding, as found in Type 1, *) - (* CFF, and OpenType/CFF fonts. It is limited to 256 character *) - (* codes. *) - (* *) - (* FT_ENCODING_ADOBE_CUSTOM :: *) - (* Corresponds to a custom encoding, as found in Type 1, CFF, and *) - (* OpenType/CFF fonts. It is limited to 256 character codes. *) - (* *) - (* FT_ENCODING_APPLE_ROMAN :: *) - (* Corresponds to the 8-bit Apple roman encoding. Many TrueType and *) - (* OpenType fonts contain a charmap for this encoding, since older *) - (* versions of Mac OS are able to use it. *) - (* *) - (* FT_ENCODING_OLD_LATIN_2 :: *) - (* This value is deprecated and was never used nor reported by *) - (* FreeType. Don't use or test for it. *) - (* *) - (* FT_ENCODING_MS_SJIS :: *) - (* Same as FT_ENCODING_SJIS. Deprecated. *) - (* *) - (* FT_ENCODING_MS_GB2312 :: *) - (* Same as FT_ENCODING_GB2312. Deprecated. *) - (* *) - (* FT_ENCODING_MS_BIG5 :: *) - (* Same as FT_ENCODING_BIG5. Deprecated. *) - (* *) - (* FT_ENCODING_MS_WANSUNG :: *) - (* Same as FT_ENCODING_WANSUNG. Deprecated. *) - (* *) - (* FT_ENCODING_MS_JOHAB :: *) - (* Same as FT_ENCODING_JOHAB. Deprecated. *) - (* *) - (* *) - (* By default, FreeType automatically synthetizes a Unicode charmap *) - (* for Postscript fonts, using their glyph names dictionaries. *) - (* However, it will also report the encodings defined explicitly in *) - (* the font file, for the cases when they are needed, with the Adobe *) - (* values as well. *) - (* *) - (* FT_ENCODING_NONE is set by the BDF and PCF drivers if the charmap *) - (* is neither Unicode nor ISO-8859-1 (otherwise it is set to *) - (* FT_ENCODING_UNICODE). Use `FT_Get_BDF_Charset_ID' to find out *) - (* which encoding is really present. If, for example, the *) - (* `cs_registry' field is `KOI8' and the `cs_encoding' field is `R', *) - (* the font is encoded in KOI8-R. *) - (* *) - (* FT_ENCODING_NONE is always set (with a single exception) by the *) - (* winfonts driver. Use `FT_Get_WinFNT_Header' and examine the *) - (* `charset' field of the `FT_WinFNT_HeaderRec' structure to find out *) - (* which encoding is really present. For example, FT_WinFNT_ID_CP1251 *) - (* (204) means Windows code page 1251 (for Russian). *) - (* *) - (* FT_ENCODING_NONE is set if `platform_id' is `TT_PLATFORM_MACINTOSH' *) - (* and `encoding_id' is not `TT_MAC_ID_ROMAN' (otherwise it is set to *) - (* FT_ENCODING_APPLE_ROMAN). *) - (* *) - (* If `platform_id' is `TT_PLATFORM_MACINTOSH', use the function *) - (* `FT_Get_CMap_Language_ID' to query the Mac language ID which may be *) - (* needed to be able to distinguish Apple encoding variants. See *) - (* *) - (* http://www.unicode.org/Public/MAPPINGS/VENDORS/APPLE/README.TXT *) - (* *) - (* to get an idea how to do that. Basically, if the language ID is 0, *) - (* dont use it, otherwise subtract 1 from the language ID. Then *) - (* examine `encoding_id'. If, for example, `encoding_id' is *) - (* `TT_MAC_ID_ROMAN' and the language ID (minus 1) is *) - (* `TT_MAC_LANGID_GREEK', it is the Greek encoding, not Roman. *) - (* `TT_MAC_ID_ARABIC' with `TT_MAC_LANGID_FARSI' means the Farsi *) - (* variant the Arabic encoding. *) - (* *) -type - PFT_Encoding = ^FT_Encoding; - FT_Encoding = array[0..3] of char; -const - FT_ENCODING_NONE: FT_Encoding = (#0 ,#0 ,#0 ,#0 ); - FT_ENCODING_MS_SYMBOL: FT_Encoding = ('s', 'y', 'm', 'b' ); - FT_ENCODING_UNICODE: FT_Encoding = ('u', 'n', 'i', 'c' ); - - FT_ENCODING_SJIS: FT_Encoding = ('s', 'j', 'i', 's'); - FT_ENCODING_GB2312: FT_Encoding = ('g', 'b', ' ', ' '); - FT_ENCODING_BIG5: FT_Encoding = ('b', 'i', 'g', '5'); - FT_ENCODING_WANSUNG: FT_Encoding = ('w', 'a', 'n', 's'); - FT_ENCODING_JOHAB: FT_Encoding = ('j', 'o', 'h', 'a'); - - - (*************************************************************************) - (* *) - (* *) - (* FT_STYLE_FLAG_XXX *) - (* *) - (* *) - (* A list of bit-flags used to indicate the style of a given face. *) - (* These are used in the `style_flags' field of @FT_FaceRec. *) - (* *) - (* *) - (* FT_STYLE_FLAG_ITALIC :: *) - (* Indicates that a given face is italicized. *) - (* *) - (* FT_STYLE_FLAG_BOLD :: *) - (* Indicates that a given face is bold. *) - (* *) -const - FT_STYLE_FLAG_ITALIC = 1 shl 0; - FT_STYLE_FLAG_BOLD = 1 shl 1; - - - (*************************************************************************** - * - * @enum: - * FT_LOAD_XXX - * - * @description: - * A list of bit-field constants, used with @FT_Load_Glyph to indicate - * what kind of operations to perform during glyph loading. - * - * @values: - * FT_LOAD_DEFAULT :: - * Corresponding to 0, this value is used a default glyph load. In this - * case, the following will happen: - * - * 1. FreeType looks for a bitmap for the glyph corresponding to the - * face's current size. If one is found, the function returns. The - * bitmap data can be accessed from the glyph slot (see note below). - * - * 2. If no embedded bitmap is searched or found, FreeType looks for a - * scalable outline. If one is found, it is loaded from the font - * file, scaled to device pixels, then "hinted" to the pixel grid in - * order to optimize it. The outline data can be accessed from the - * glyph slot (see note below). - * - * Note that by default, the glyph loader doesn't render outlines into - * bitmaps. The following flags are used to modify this default - * behaviour to more specific and useful cases. - * - * FT_LOAD_NO_SCALE :: - * Don't scale the vector outline being loaded to 26.6 fractional - * pixels, but kept in font units. Note that this also disables - * hinting and the loading of embedded bitmaps. You should only use it - * when you want to retrieve the original glyph outlines in font units. - * - * FT_LOAD_NO_HINTING :: - * Don't hint glyph outlines after their scaling to device pixels. - * This generally generates "blurrier" glyphs in anti-aliased modes. - * - * This flag is ignored if @FT_LOAD_NO_SCALE is set. - * - * FT_LOAD_RENDER :: - * Render the glyph outline immediately into a bitmap before the glyph - * loader returns. By default, the glyph is rendered for the - * @FT_RENDER_MODE_NORMAL mode, which corresponds to 8-bit anti-aliased - * bitmaps using 256 opacity levels. You can use either - * @FT_LOAD_TARGET_MONO or @FT_LOAD_MONOCHROME to render 1-bit - * monochrome bitmaps. - * - * This flag is ignored if @FT_LOAD_NO_SCALE is set. - * - * FT_LOAD_NO_BITMAP :: - * Don't look for bitmaps when loading the glyph. Only scalable - * outlines will be loaded when available, and scaled, hinted, or - * rendered depending on other bit flags. - * - * This does not prevent you from rendering outlines to bitmaps - * with @FT_LOAD_RENDER, however. - * - * FT_LOAD_VERTICAL_LAYOUT :: - * Prepare the glyph image for vertical text layout. This basically - * means that `face.glyph.advance' will correspond to the vertical - * advance height (instead of the default horizontal advance width), - * and that the glyph image will be translated to match the vertical - * bearings positions. - * - * FT_LOAD_FORCE_AUTOHINT :: - * Force the use of the FreeType auto-hinter when a glyph outline is - * loaded. You shouldn't need this in a typical application, since it - * is mostly used to experiment with its algorithm. - * - * FT_LOAD_CROP_BITMAP :: - * Indicates that the glyph loader should try to crop the bitmap (i.e., - * remove all space around its black bits) when loading it. This is - * only useful when loading embedded bitmaps in certain fonts, since - * bitmaps rendered with @FT_LOAD_RENDER are always cropped by default. - * - * FT_LOAD_PEDANTIC :: - * Indicates that the glyph loader should perform pedantic - * verifications during glyph loading, rejecting invalid fonts. This - * is mostly used to detect broken glyphs in fonts. By default, - * FreeType tries to handle broken fonts also. - * - * FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH :: - * Indicates that the glyph loader should ignore the global advance - * width defined in the font. As far as we know, this is only used by - * the X-TrueType font server, in order to deal correctly with the - * incorrect metrics contained in DynaLab's TrueType CJK fonts. - * - * FT_LOAD_NO_RECURSE :: - * This flag is only used internally. It merely indicates that the - * glyph loader should not load composite glyphs recursively. Instead, - * it should set the `num_subglyph' and `subglyphs' values of the glyph - * slot accordingly, and set "glyph->format" to - * @FT_GLYPH_FORMAT_COMPOSITE. - * - * The description of sub-glyphs is not available to client - * applications for now. - * - * FT_LOAD_IGNORE_TRANSFORM :: - * Indicates that the glyph loader should not try to transform the - * loaded glyph image. This doesn't prevent scaling, hinting, or - * rendering. - * - * FT_LOAD_MONOCHROME :: - * This flag is used with @FT_LOAD_RENDER to indicate that you want - * to render a 1-bit monochrome glyph bitmap from a vectorial outline. - * - * Note that this has no effect on the hinting algorithm used by the - * glyph loader. You should better use @FT_LOAD_TARGET_MONO if you - * want to render monochrome-optimized glyph images instead. - * - * FT_LOAD_LINEAR_DESIGN :: - * Return the linearly scaled metrics expressed in original font units - * instead of the default 16.16 pixel values. - * - * FT_LOAD_NO_AUTOHINT :: - * Indicates that the auto-hinter should never be used to hint glyph - * outlines. This doesn't prevent native format-specific hinters from - * being used. This can be important for certain fonts where unhinted - * output is better than auto-hinted one. - * - * FT_LOAD_TARGET_NORMAL :: - * Use hinting for @FT_RENDER_MODE_NORMAL. - * - * FT_LOAD_TARGET_LIGHT :: - * Use hinting for @FT_RENDER_MODE_LIGHT. - * - * FT_LOAD_TARGET_MONO :: - * Use hinting for @FT_RENDER_MODE_MONO. - * - * FT_LOAD_TARGET_LCD :: - * Use hinting for @FT_RENDER_MODE_LCD. - * - * FT_LOAD_TARGET_LCD_V :: - * Use hinting for @FT_RENDER_MODE_LCD_V. - *) -const - FT_LOAD_DEFAULT = $0000; - FT_LOAD_NO_SCALE = $0001; - FT_LOAD_NO_HINTING = $0002; - FT_LOAD_RENDER = $0004; - FT_LOAD_NO_BITMAP = $0008; - FT_LOAD_VERTICAL_LAYOUT = $0010; - FT_LOAD_FORCE_AUTOHINT = $0020; - FT_LOAD_CROP_BITMAP = $0040; - FT_LOAD_PEDANTIC = $0080; - FT_LOAD_IGNORE_GLOBAL_ADVANCE_WIDTH = $0200; - FT_LOAD_NO_RECURSE = $0400; - FT_LOAD_IGNORE_TRANSFORM = $0800; - FT_LOAD_MONOCHROME = $1000; - FT_LOAD_LINEAR_DESIGN = $2000; - - (* temporary hack! *) - FT_LOAD_SBITS_ONLY = $4000; - FT_LOAD_NO_AUTOHINT = $8000; - - (*************************************************************************) - (* *) - (* *) - (* FT_Render_Mode *) - (* *) - (* *) - (* An enumeration type that lists the render modes supported by *) - (* FreeType 2. Each mode corresponds to a specific type of scanline *) - (* conversion performed on the outline, as well as specific *) - (* hinting optimizations. *) - (* *) - (* For bitmap fonts the `bitmap->pixel_mode' field in the *) - (* @FT_GlyphSlotRec structure gives the format of the returned *) - (* bitmap. *) - (* *) - (* *) - (* FT_RENDER_MODE_NORMAL :: *) - (* This is the default render mode; it corresponds to 8-bit *) - (* anti-aliased bitmaps, using 256 levels of opacity. *) - (* *) - (* FT_RENDER_MODE_LIGHT :: *) - (* This is similar to @FT_RENDER_MODE_NORMAL -- you have to use *) - (* @FT_LOAD_TARGET_LIGHT in calls to @FT_Load_Glyph to get any *) - (* effect since the rendering process no longer influences the *) - (* positioning of glyph outlines. *) - (* *) - (* The resulting glyph shapes are more similar to the original, *) - (* while being a bit more fuzzy (`better shapes' instead of `better *) - (* contrast', so to say. *) - (* *) - (* FT_RENDER_MODE_MONO :: *) - (* This mode corresponds to 1-bit bitmaps. *) - (* *) - (* FT_RENDER_MODE_LCD :: *) - (* This mode corresponds to horizontal RGB/BGR sub-pixel displays, *) - (* like LCD-screens. It produces 8-bit bitmaps that are 3 times *) - (* the width of the original glyph outline in pixels, and which use *) - (* the @FT_PIXEL_MODE_LCD mode. *) - (* *) - (* FT_RENDER_MODE_LCD_V :: *) - (* This mode corresponds to vertical RGB/BGR sub-pixel displays *) - (* (like PDA screens, rotated LCD displays, etc.). It produces *) - (* 8-bit bitmaps that are 3 times the height of the original *) - (* glyph outline in pixels and use the @FT_PIXEL_MODE_LCD_V mode. *) - (* *) - (* *) - (* The LCD-optimized glyph bitmaps produced by FT_Render_Glyph are *) - (* _not filtered_ to reduce color-fringes. It is up to the caller to *) - (* perform this pass. *) - (* *) -type - FT_Render_Mode = cint; -const - FT_RENDER_MODE_NORMAL = 0; - FT_RENDER_MODE_LIGHT = FT_RENDER_MODE_NORMAL + 1; - FT_RENDER_MODE_MONO = FT_RENDER_MODE_LIGHT + 1; - FT_RENDER_MODE_LCD = FT_RENDER_MODE_MONO + 1; - FT_RENDER_MODE_LCD_V = FT_RENDER_MODE_LCD + 1; - FT_RENDER_MODE_MAX = FT_RENDER_MODE_LCD_V + 1; - - - (*************************************************************************) - (* *) - (* *) - (* FT_GlyphSlot *) - (* *) - (* *) - (* A handle to a given `glyph slot'. A slot is a container where it *) - (* is possible to load any one of the glyphs contained in its parent *) - (* face. *) - (* *) - (* In other words, each time you call @FT_Load_Glyph or *) - (* @FT_Load_Char, the slot's content is erased by the new glyph data, *) - (* i.e. the glyph's metrics, its image (bitmap or outline), and *) - (* other control information. *) - (* *) - (* *) - (* @FT_GlyphSlotRec details the publicly accessible glyph fields. *) - (* *) -type - FT_GlyphSlot = ^FT_GlyphSlotRec; - - -{$DEFINE TYPE_DECL} -{$I ftconfig.inc} -{$I fttypes.inc} -{$I ftimage.inc} -{$I ftglyph.inc} -{$I ftstroke.inc} -{$I ftoutln.inc} -{$UNDEF TYPE_DECL} - - - (*************************************************************************) - (* *) - (* *) - (* FT_Glyph_Metrics *) - (* *) - (* *) - (* A structure used to model the metrics of a single glyph. The *) - (* values are expressed in 26.6 fractional pixel format; if the flag *) - (* FT_LOAD_NO_SCALE is used, values are returned in font units *) - (* instead. *) - (* *) - (* *) - (* width :: *) - (* The glyph's width. *) - (* *) - (* height :: *) - (* The glyph's height. *) - (* *) - (* horiBearingX :: *) - (* Left side bearing for horizontal layout. *) - (* *) - (* horiBearingY :: *) - (* Top side bearing for horizontal layout. *) - (* *) - (* horiAdvance :: *) - (* Advance width for horizontal layout. *) - (* *) - (* vertBearingX :: *) - (* Left side bearing for vertical layout. *) - (* *) - (* vertBearingY :: *) - (* Top side bearing for vertical layout. *) - (* *) - (* vertAdvance :: *) - (* Advance height for vertical layout. *) - (* *) - FT_Glyph_Metrics = record - width , - height : FT_Pos; - - horiBearingX , - horiBearingY , - horiAdvance : FT_Pos; - - vertBearingX , - vertBearingY , - vertAdvance : FT_Pos; - end; - - - (*************************************************************************) - (* *) - (* *) - (* FT_Bitmap_Size *) - (* *) - (* *) - (* This structure models the size of a bitmap strike (i.e., a bitmap *) - (* instance of the font for a given resolution) in a fixed-size font *) - (* face. It is used for the `available_sizes' field of the *) - (* @FT_FaceRec structure. *) - (* *) - (* *) - (* height :: The (vertical) baseline-to-baseline distance in pixels. *) - (* It makes most sense to define the height of a bitmap *) - (* font in this way. *) - (* *) - (* width :: The average width of the font (in pixels). Since the *) - (* algorithms to compute this value are different for the *) - (* various bitmap formats, it can only give an additional *) - (* hint if the `height' value isn't sufficient to select *) - (* the proper font. For monospaced fonts the average width *) - (* is the same as the maximum width. *) - (* *) - (* size :: The point size in 26.6 fractional format this font shall *) - (* represent (for a given vertical resolution). *) - (* *) - (* x_ppem :: The horizontal ppem value (in 26.6 fractional format). *) - (* *) - (* y_ppem :: The vertical ppem value (in 26.6 fractional format). *) - (* Usually, this is the `nominal' pixel height of the font. *) - (* *) - (* *) - (* The values in this structure are taken from the bitmap font. If *) - (* the font doesn't provide a parameter it is set to zero to indicate *) - (* that the information is not available. *) - (* *) - (* The following formula converts from dpi to ppem: *) - (* *) - (* ppem = size * dpi / 72 *) - (* *) - (* where `size' is in points. *) - (* *) - (* Windows FNT: *) - (* The `size' parameter is not reliable: There exist fonts (e.g., *) - (* app850.fon) which have a wrong size for some subfonts; x_ppem *) - (* and y_ppem are thus set equal to pixel width and height given in *) - (* in the Windows FNT header. *) - (* *) - (* TrueType embedded bitmaps: *) - (* `size', `width', and `height' values are not contained in the *) - (* bitmap strike itself. They are computed from the global font *) - (* parameters. *) - (* *) - PFT_Bitmap_Size = ^FT_Bitmap_Size; - FT_Bitmap_Size = record - height, - width : FT_Short; - - size: FT_Pos; - - x_ppem: FT_Pos; - y_ppem: FT_Pos; - end; - - PAFT_Bitmap_Size = ^AFT_Bitmap_Size; - AFT_Bitmap_Size = array[0..High(Word)] of FT_Bitmap_Size; - - - (*************************************************************************) - (* *) - (* *) - (* FT_Face *) - (* *) - (* *) - (* A handle to a given typographic face object. A face object models *) - (* a given typeface, in a given style. *) - (* *) - (* *) - (* Each face object also owns a single @FT_GlyphSlot object, as well *) - (* as one or more @FT_Size objects. *) - (* *) - (* Use @FT_New_Face or @FT_Open_Face to create a new face object from *) - (* a given filepathname or a custom input stream. *) - (* *) - (* Use @FT_Done_Face to destroy it (along with its slot and sizes). *) - (* *) - (* *) - (* The @FT_FaceRec details the publicly accessible fields of a given *) - (* face object. *) - (* *) - FT_Face = ^FT_FaceRec; - - (*************************************************************************) - (* *) - (* *) - (* FT_CharMap *) - (* *) - (* *) - (* A handle to a given character map. A charmap is used to translate *) - (* character codes in a given encoding into glyph indexes for its *) - (* parent's face. Some font formats may provide several charmaps per *) - (* font. *) - (* *) - (* Each face object owns zero or more charmaps, but only one of them *) - (* can be "active" and used by @FT_Get_Char_Index or @FT_Load_Char. *) - (* *) - (* The list of available charmaps in a face is available through the *) - (* "face->num_charmaps" and "face->charmaps" fields of @FT_FaceRec. *) - (* *) - (* The currently active charmap is available as "face->charmap". *) - (* You should call @FT_Set_Charmap to change it. *) - (* *) - (* *) - (* When a new face is created (either through @FT_New_Face or *) - (* @FT_Open_Face), the library looks for a Unicode charmap within *) - (* the list and automatically activates it. *) - (* *) - (* *) - (* The @FT_CharMapRec details the publicly accessible fields of a *) - (* given character map. *) - (* *) - PFT_CharMap = ^FT_CharMap; - FT_CharMap = ^FT_CharMapRec; - - PAFT_CharMap = ^FT_CharMap; - AFT_CharMap = array[0..High(Word)] of FT_CharMap; - - - - - - - - (*************************************************************************) - (* *) - (* *) - (* FT_SubGlyph *) - (* *) - (* *) - (* The subglyph structure is an internal object used to describe *) - (* subglyphs (for example, in the case of composites). *) - (* *) - (* *) - (* The subglyph implementation is not part of the high-level API, *) - (* hence the forward structure declaration. *) - (* *) - FT_SubGlyph = ^FT_SubGlyphRec; - FT_SubGlyphRec = record // internal - end; - - - (*************************************************************************) - (* *) - (* *) - (* FT_GlyphSlotRec *) - (* *) - (* *) - (* FreeType root glyph slot class structure. A glyph slot is a *) - (* container where individual glyphs can be loaded, be they *) - (* vectorial or bitmap/graymaps. *) - (* *) - (* *) - (* library :: A handle to the FreeType library instance *) - (* this slot belongs to. *) - (* *) - (* face :: A handle to the parent face object. *) - (* *) - (* next :: In some cases (like some font tools), several *) - (* glyph slots per face object can be a good *) - (* thing. As this is rare, the glyph slots are *) - (* listed through a direct, single-linked list *) - (* using its `next' field. *) - (* *) - (* generic :: A typeless pointer which is unused by the *) - (* FreeType library or any of its drivers. It *) - (* can be used by client applications to link *) - (* their own data to each glyph slot object. *) - (* *) - (* metrics :: The metrics of the last loaded glyph in the *) - (* slot. The returned values depend on the last *) - (* load flags (see the @FT_Load_Glyph API *) - (* function) and can be expressed either in 26.6 *) - (* fractional pixels or font units. *) - (* *) - (* Note that even when the glyph image is *) - (* transformed, the metrics are not. *) - (* *) - (* linearHoriAdvance :: For scalable formats only, this field holds *) - (* the linearly scaled horizontal advance width *) - (* for the glyph (i.e. the scaled and unhinted *) - (* value of the hori advance). This can be *) - (* important to perform correct WYSIWYG layout. *) - (* *) - (* Note that this value is expressed by default *) - (* in 16.16 pixels. However, when the glyph is *) - (* loaded with the FT_LOAD_LINEAR_DESIGN flag, *) - (* this field contains simply the value of the *) - (* advance in original font units. *) - (* *) - (* linearVertAdvance :: For scalable formats only, this field holds *) - (* the linearly scaled vertical advance height *) - (* for the glyph. See linearHoriAdvance for *) - (* comments. *) - (* *) - (* advance :: This is the transformed advance width for the *) - (* glyph. *) - (* *) - (* format :: This field indicates the format of the image *) - (* contained in the glyph slot. Typically *) - (* FT_GLYPH_FORMAT_BITMAP, *) - (* FT_GLYPH_FORMAT_OUTLINE, and *) - (* FT_GLYPH_FORMAT_COMPOSITE, but others are *) - (* possible. *) - (* *) - (* bitmap :: This field is used as a bitmap descriptor *) - (* when the slot format is *) - (* FT_GLYPH_FORMAT_BITMAP. Note that the *) - (* address and content of the bitmap buffer can *) - (* change between calls of @FT_Load_Glyph and a *) - (* few other functions. *) - (* *) - (* bitmap_left :: This is the bitmap's left bearing expressed *) - (* in integer pixels. Of course, this is only *) - (* valid if the format is *) - (* FT_GLYPH_FORMAT_BITMAP. *) - (* *) - (* bitmap_top :: This is the bitmap's top bearing expressed in *) - (* integer pixels. Remember that this is the *) - (* distance from the baseline to the top-most *) - (* glyph scanline, upwards y-coordinates being *) - (* *positive*. *) - (* *) - (* outline :: The outline descriptor for the current glyph *) - (* image if its format is *) - (* FT_GLYPH_FORMAT_OUTLINE. *) - (* *) - (* num_subglyphs :: The number of subglyphs in a composite glyph. *) - (* This field is only valid for the composite *) - (* glyph format that should normally only be *) - (* loaded with the @FT_LOAD_NO_RECURSE flag. *) - (* For now this is internal to FreeType. *) - (* *) - (* subglyphs :: An array of subglyph descriptors for *) - (* composite glyphs. There are `num_subglyphs' *) - (* elements in there. Currently internal to *) - (* FreeType. *) - (* *) - (* control_data :: Certain font drivers can also return the *) - (* control data for a given glyph image (e.g. *) - (* TrueType bytecode, Type 1 charstrings, etc.). *) - (* This field is a pointer to such data. *) - (* *) - (* control_len :: This is the length in bytes of the control *) - (* data. *) - (* *) - (* other :: Really wicked formats can use this pointer to *) - (* present their own glyph image to client apps. *) - (* Note that the app will need to know about the *) - (* image format. *) - (* *) - (* lsb_delta :: The difference between hinted and unhinted *) - (* left side bearing while autohinting is *) - (* active. Zero otherwise. *) - (* *) - (* rsb_delta :: The difference between hinted and unhinted *) - (* right side bearing while autohinting is *) - (* active. Zero otherwise. *) - (* *) - (* *) - (* If @FT_Load_Glyph is called with default flags (see *) - (* @FT_LOAD_DEFAULT) the glyph image is loaded in the glyph slot in *) - (* its native format (e.g. a vectorial outline for TrueType and *) - (* Type 1 formats). *) - (* *) - (* This image can later be converted into a bitmap by calling *) - (* @FT_Render_Glyph. This function finds the current renderer for *) - (* the native image's format then invokes it. *) - (* *) - (* The renderer is in charge of transforming the native image through *) - (* the slot's face transformation fields, then convert it into a *) - (* bitmap that is returned in `slot->bitmap'. *) - (* *) - (* Note that `slot->bitmap_left' and `slot->bitmap_top' are also used *) - (* to specify the position of the bitmap relative to the current pen *) - (* position (e.g. coordinates [0,0] on the baseline). Of course, *) - (* `slot->format' is also changed to `FT_GLYPH_FORMAT_BITMAP' . *) - (* *) - (* *) - (* Here a small pseudo code fragment which shows how to use *) - (* `lsb_delta' and `rsb_delta': *) - (* *) - (* { *) - (* FT_Pos origin_x = 0; *) - (* FT_Pos prev_rsb_delta = 0; *) - (* *) - (* *) - (* for all glyphs do *) - (* *) - (* *) - (* *) - (* *) - (* if ( prev_rsb_delta - face->glyph->lsb_delta >= 32 ) *) - (* origin_x -= 64; *) - (* else if ( prev_rsb_delta - face->glyph->lsb_delta < -32 ) *) - (* origin_x += 64; *) - (* *) - (* prev_rsb_delta = face->glyph->rsb_delta; *) - (* *) - (* *) - (* *) - (* origin_x += face->glyph->advance.x; *) - (* endfor *) - (* } *) - (* *) - FT_GlyphSlotRec = record - alibrary : FT_Library; - - face : FT_Face; - next : FT_GlyphSlot; - flags : FT_UInt; - - generic : FT_Generic; - metrics : FT_Glyph_Metrics; - - linearHoriAdvance , - linearVertAdvance : FT_Fixed; - - advance : FT_Vector; - format : FT_Glyph_Format; - bitmap : FT_Bitmap; - - bitmap_left , - bitmap_top : FT_Int; - - outline : FT_Outline; - - num_subglyphs : FT_UInt; - subglyphs : FT_SubGlyph; - - control_data : pointer; - control_len : clong; - - lsb_delta: FT_Pos; - rsb_delta: FT_Pos; - - other : pointer; - - //internal: FT_Slot_Internal; - end; - - (*************************************************************************) - (* *) - (* *) - (* FT_Size_Metrics *) - (* *) - (* *) - (* The size metrics structure returned scaled important distances for *) - (* a given size object. *) - (* *) - (* *) - (* x_ppem :: The character width, expressed in integer pixels. *) - (* This is the width of the EM square expressed in *) - (* pixels, hence the term `ppem' (pixels per EM). *) - (* *) - (* y_ppem :: The character height, expressed in integer pixels. *) - (* This is the height of the EM square expressed in *) - (* pixels, hence the term `ppem' (pixels per EM). *) - (* *) - (* x_scale :: A simple 16.16 fixed point format coefficient used *) - (* to scale horizontal distances expressed in font *) - (* units to fractional (26.6) pixel coordinates. *) - (* *) - (* y_scale :: A simple 16.16 fixed point format coefficient used *) - (* to scale vertical distances expressed in font *) - (* units to fractional (26.6) pixel coordinates. *) - (* *) - (* ascender :: The ascender, expressed in 26.6 fixed point *) - (* pixels. Positive for ascenders above the *) - (* baseline. *) - (* *) - (* descender :: The descender, expressed in 26.6 fixed point *) - (* pixels. Negative for descenders below the *) - (* baseline. *) - (* *) - (* height :: The text height, expressed in 26.6 fixed point *) - (* pixels. Always positive. *) - (* *) - (* max_advance :: Maximum horizontal advance, expressed in 26.6 *) - (* fixed point pixels. Always positive. *) - (* *) - (* *) - (* For scalable fonts, the values of `ascender', `descender', and *) - (* `height' are scaled versions of `face->ascender', *) - (* `face->descender', and `face->height', respectively. *) - (* *) - (* Unfortunately, due to glyph hinting, these values might not be *) - (* exact for certain fonts. They thus must be treated as unreliable *) - (* with an error margin of at least one pixel! *) - (* *) - (* Indeed, the only way to get the exact pixel ascender and descender *) - (* is to render _all_ glyphs. As this would be a definite *) - (* performance hit, it is up to client applications to perform such *) - (* computations. *) - (* *) - FT_Size_Metrics = record - x_ppem, (* horizontal pixels per EM *) - y_ppem: FT_UShort; (* vertical pixels per EM *) - x_scale, (* scaling values used to convert font *) - y_scale: FT_Fixed; (* units to 26.6 fractional pixels *) - - ascender, (* ascender in 26.6 frac. pixels *) - descender: FT_Pos; (* descender in 26.6 frac. pixels *) - height: FT_Pos; (* text height in 26.6 frac. pixels *) - max_advance: FT_Pos; (* max horizontal advance, in 26.6 pixels *) - end; - - (*************************************************************************) - (* *) - (* *) - (* FT_Size *) - (* *) - (* *) - (* A handle to a given size object. Such an object models the data *) - (* that depends on the current _resolution_ and _character size_ in a *) - (* given @FT_Face. *) - (* *) - (* *) - (* Each face object owns one or more sizes. There is however a *) - (* single _active_ size for the face at any time that will be used by *) - (* functions like @FT_Load_Glyph, @FT_Get_Kerning, etc. *) - (* *) - (* You can use the @FT_Activate_Size API to change the current *) - (* active size of any given face. *) - (* *) - (* *) - (* The @FT_SizeRec structure details the publicly accessible fields *) - (* of a given face object. *) - (* *) - FT_Size = ^FT_SizeRec; - - (*************************************************************************) - (* *) - (* *) - (* FT_SizeRec *) - (* *) - (* *) - (* FreeType root size class structure. A size object models the *) - (* resolution and pointsize dependent data of a given face. *) - (* *) - (* *) - (* face :: Handle to the parent face object. *) - (* *) - (* generic :: A typeless pointer, which is unused by the FreeType *) - (* library or any of its drivers. It can be used by *) - (* client applications to link their own data to each size *) - (* object. *) - (* *) - (* metrics :: Metrics for this size object. This field is read-only. *) - (* *) - FT_SizeRec = record - face : FT_Face; - generic : FT_Generic; - metrics : FT_Size_Metrics; - //internal : FT_Size_Internal; - end; - - - (*************************************************************************) - (* *) - (* *) - (* FT_FaceRec *) - (* *) - (* *) - (* FreeType root face class structure. A face object models the *) - (* resolution and point-size independent data found in a font file. *) - (* *) - (* *) - (* num_faces :: In the case where the face is located in a *) - (* collection (i.e., a file which embeds *) - (* several faces), this is the total number of *) - (* faces found in the resource. 1 by default. *) - (* Accessing non-existent face indices causes *) - (* an error. *) - (* *) - (* face_index :: The index of the face in its font file. *) - (* Usually, this is 0 for all normal font *) - (* formats. It can be > 0 in the case of *) - (* collections (which embed several fonts in a *) - (* single resource/file). *) - (* *) - (* face_flags :: A set of bit flags that give important *) - (* information about the face; see the *) - (* @FT_FACE_FLAG_XXX constants for details. *) - (* *) - (* style_flags :: A set of bit flags indicating the style of *) - (* the face (i.e., italic, bold, underline, *) - (* etc). See the @FT_STYLE_FLAG_XXX *) - (* constants. *) - (* *) - (* num_glyphs :: The total number of glyphs in the face. *) - (* *) - (* family_name :: The face's family name. This is an ASCII *) - (* string, usually in English, which describes *) - (* the typeface's family (like `Times New *) - (* Roman', `Bodoni', `Garamond', etc). This *) - (* is a least common denominator used to list *) - (* fonts. Some formats (TrueType & OpenType) *) - (* provide localized and Unicode versions of *) - (* this string. Applications should use the *) - (* format specific interface to access them. *) - (* *) - (* style_name :: The face's style name. This is an ASCII *) - (* string, usually in English, which describes *) - (* the typeface's style (like `Italic', *) - (* `Bold', `Condensed', etc). Not all font *) - (* formats provide a style name, so this field *) - (* is optional, and can be set to NULL. As *) - (* for `family_name', some formats provide *) - (* localized/Unicode versions of this string. *) - (* Applications should use the format specific *) - (* interface to access them. *) - (* *) - (* num_fixed_sizes :: The number of fixed sizes available in this *) - (* face. This should be set to 0 for scalable *) - (* fonts, unless its face includes a set of *) - (* glyphs (called a `strike') for the *) - (* specified sizes. *) - (* *) - (* available_sizes :: An array of sizes specifying the available *) - (* bitmap/graymap sizes that are contained in *) - (* in the font face. Should be set to NULL if *) - (* the field `num_fixed_sizes' is set to 0. *) - (* *) - (* num_charmaps :: The total number of character maps in the *) - (* face. *) - (* *) - (* charmaps :: A table of pointers to the face's charmaps. *) - (* Used to scan the list of available charmaps *) - (* -- this table might change after a call to *) - (* @FT_Attach_File or @FT_Attach_Stream (e.g. *) - (* if used to hook an additional encoding or *) - (* CMap to the face object). *) - (* *) - (* generic :: A field reserved for client uses. See the *) - (* @FT_Generic type description. *) - (* *) - (* bbox :: The font bounding box. Coordinates are *) - (* expressed in font units (see units_per_EM). *) - (* The box is large enough to contain any *) - (* glyph from the font. Thus, bbox.yMax can *) - (* be seen as the `maximal ascender', *) - (* bbox.yMin as the `minimal descender', and *) - (* the maximal glyph width is given by *) - (* `bbox.xMax-bbox.xMin' (not to be confused *) - (* with the maximal _advance_width_). Only *) - (* relevant for scalable formats. *) - (* *) - (* units_per_EM :: The number of font units per EM square for *) - (* this face. This is typically 2048 for *) - (* TrueType fonts, 1000 for Type1 fonts, and *) - (* should be set to the (unrealistic) value 1 *) - (* for fixed-sizes fonts. Only relevant for *) - (* scalable formats. *) - (* *) - (* ascender :: The face's ascender is the vertical *) - (* distance from the baseline to the topmost *) - (* point of any glyph in the face. This *) - (* field's value is positive, expressed in *) - (* font units. Some font designs use a value *) - (* different from `bbox.yMax'. Only relevant *) - (* for scalable formats. *) - (* *) - (* descender :: The face's descender is the vertical *) - (* distance from the baseline to the *) - (* bottommost point of any glyph in the face. *) - (* This field's value is *negative* for values *) - (* below the baseline. It is expressed in *) - (* font units. Some font designs use a value *) - (* different from `bbox.yMin'. Only relevant *) - (* for scalable formats. *) - (* *) - (* height :: The face's height is the vertical distance *) - (* from one baseline to the next when writing *) - (* several lines of text. Its value is always *) - (* positive, expressed in font units. The *) - (* value can be computed as *) - (* `ascender+descender+line_gap' where the *) - (* value of `line_gap' is also called *) - (* `external leading'. Only relevant for *) - (* scalable formats. *) - (* *) - (* max_advance_width :: The maximal advance width, in font units, *) - (* for all glyphs in this face. This can be *) - (* used to make word wrapping computations *) - (* faster. Only relevant for scalable *) - (* formats. *) - (* *) - (* max_advance_height :: The maximal advance height, in font units, *) - (* for all glyphs in this face. This is only *) - (* relevant for vertical layouts, and should *) - (* be set to the `height' for fonts that do *) - (* not provide vertical metrics. Only *) - (* relevant for scalable formats. *) - (* *) - (* underline_position :: The position, in font units, of the *) - (* underline line for this face. It's the *) - (* center of the underlining stem. Only *) - (* relevant for scalable formats. *) - (* *) - (* underline_thickness :: The thickness, in font units, of the *) - (* underline for this face. Only relevant for *) - (* scalable formats. *) - (* *) - (* glyph :: The face's associated glyph slot(s). This *) - (* object is created automatically with a new *) - (* face object. However, certain kinds of *) - (* applications (mainly tools like converters) *) - (* can need more than one slot to ease their *) - (* task. *) - (* *) - (* size :: The current active size for this face. *) - (* *) - (* charmap :: The current active charmap for this face. *) - (* *) - FT_FaceRec = record - num_faces : FT_Long; - face_index : FT_Long; - - face_flags : FT_Long; - style_flags : FT_Long; - - num_glyphs : FT_Long; - - family_name : PFT_String; - style_name : PFT_String; - - num_fixed_sizes : FT_Int; - available_sizes : PAFT_Bitmap_Size; // is array - - num_charmaps : FT_Int; - charmaps : PAFT_CharMap; // is array - - generic : FT_Generic; - - (*# the following are only relevant to scalable outlines *) - bbox : FT_BBox; - - units_per_EM : FT_UShort; - ascender : FT_Short; - descender : FT_Short; - height : FT_Short; - - max_advance_width : FT_Short; - max_advance_height : FT_Short; - - underline_position : FT_Short; - underline_thickness : FT_Short; - - glyph : FT_GlyphSlot; - size : FT_Size; - charmap : FT_CharMap; - end; - - - (*************************************************************************) - (* *) - (* *) - (* FT_CharMapRec *) - (* *) - (* *) - (* The base charmap structure. *) - (* *) - (* *) - (* face :: A handle to the parent face object. *) - (* *) - (* encoding :: An @FT_Encoding tag identifying the charmap. Use *) - (* this with @FT_Select_Charmap. *) - (* *) - (* platform_id :: An ID number describing the platform for the *) - (* following encoding ID. This comes directly from *) - (* the TrueType specification and should be emulated *) - (* for other formats. *) - (* *) - (* encoding_id :: A platform specific encoding number. This also *) - (* comes from the TrueType specification and should be *) - (* emulated similarly. *) - (* *) - FT_CharMapRec = record - face : FT_Face; - encoding : FT_Encoding; - platform_id : FT_UShort; - encoding_id : FT_UShort; - end; - - -{$I ftconfig.inc} -{$I fttypes.inc} -{$I ftimage.inc} -{$I ftglyph.inc} -{$I ftstroke.inc} -{$I ftoutln.inc} - - -{ GLOBAL PROCEDURES } - - (*************************************************************************) - (* *) - (* @macro: *) - (* FT_HAS_KERNING( face ) *) - (* *) - (* @description: *) - (* A macro that returns true whenever a face object contains kerning *) - (* data that can be accessed with @FT_Get_Kerning. *) - (* *) - function FT_HAS_KERNING(face : FT_Face ) : cbool; - - - (*************************************************************************) - (* *) - (* @macro: *) - (* FT_IS_SCALABLE( face ) *) - (* *) - (* @description: *) - (* A macro that returns true whenever a face object contains a *) - (* scalable font face (true for TrueType, Type 1, CID, and *) - (* OpenType/CFF font formats. *) - (* *) - function FT_IS_SCALABLE(face : FT_Face ) : cbool; - - - (*************************************************************************) - (* *) - (* *) - (* FT_Init_FreeType *) - (* *) - (* *) - (* Initializes a new FreeType library object. The set of modules *) - (* that are registered by this function is determined at build time. *) - (* *) - (* *) - (* alibrary :: A handle to a new library object. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Init_FreeType(out alibrary : FT_Library ) : FT_Error; - cdecl; external ft_lib name 'FT_Init_FreeType'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Done_FreeType *) - (* *) - (* *) - (* Destroys a given FreeType library object and all of its childs, *) - (* including resources, drivers, faces, sizes, etc. *) - (* *) - (* *) - (* library :: A handle to the target library object. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Done_FreeType(alibrary : FT_Library ) : FT_Error; - cdecl; external ft_lib name 'FT_Done_FreeType'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Attach_File *) - (* *) - (* *) - (* `Attaches' a given font file to an existing face. This is usually *) - (* to read additional information for a single face object. For *) - (* example, it is used to read the AFM files that come with Type 1 *) - (* fonts in order to add kerning data and other metrics. *) - (* *) - (* *) - (* face :: The target face object. *) - (* *) - (* *) - (* filepathname :: An 8-bit pathname naming the `metrics' file. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* If your font file is in memory, or if you want to provide your *) - (* own input stream object, use @FT_Attach_Stream. *) - (* *) - (* The meaning of the `attach' action (i.e., what really happens when *) - (* the new file is read) is not fixed by FreeType itself. It really *) - (* depends on the font format (and thus the font driver). *) - (* *) - (* Client applications are expected to know what they are doing *) - (* when invoking this function. Most drivers simply do not implement *) - (* file attachments. *) - (* *) - function FT_Attach_File(face : FT_Face; filepathname : PChar ) : FT_Error; - cdecl; external ft_lib name 'FT_Attach_File'; - - (*************************************************************************) - (* *) - (* *) - (* FT_New_Memory_Face *) - (* *) - (* *) - (* Creates a new face object from a given resource and typeface index *) - (* using a font file already loaded into memory. *) - (* *) - (* *) - (* library :: A handle to the library resource. *) - (* *) - (* *) - (* file_base :: A pointer to the beginning of the font data. *) - (* *) - (* file_size :: The size of the memory chunk used by the font data. *) - (* *) - (* face_index :: The index of the face within the resource. The *) - (* first face has index 0. *) - (* *) - (* *) - (* aface :: A handle to a new face object. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* The font data bytes are used _directly_ by the @FT_Face object. *) - (* This means that they are not copied, and that the client is *) - (* responsible for releasing/destroying them _after_ the *) - (* corresponding call to @FT_Done_Face . *) - (* *) - (* Unlike FreeType 1.x, this function automatically creates a glyph *) - (* slot for the face object which can be accessed directly through *) - (* `face->glyph'. *) - (* *) - (* @FT_New_Memory_Face can be used to determine and/or check the font *) - (* format of a given font resource. If the `face_index' field is *) - (* negative, the function will _not_ return any face handle in *) - (* `aface'; the return value is 0 if the font format is recognized, *) - (* or non-zero otherwise. *) - (* *) - function FT_New_Memory_Face( - library_ : FT_Library; - file_base : PFT_Byte; - file_size , - face_index : FT_Long; - out aface : FT_Face ) : FT_Error; - cdecl; external ft_lib name 'FT_New_Memory_Face'; - - (*************************************************************************) - (* *) - (* *) - (* FT_New_Face *) - (* *) - (* *) - (* Creates a new face object from a given resource and typeface index *) - (* using a pathname to the font file. *) - (* *) - (* *) - (* library :: A handle to the library resource. *) - (* *) - (* *) - (* pathname :: A path to the font file. *) - (* *) - (* face_index :: The index of the face within the resource. The *) - (* first face has index 0. *) - (* *) - (* *) - (* aface :: A handle to a new face object. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* Unlike FreeType 1.x, this function automatically creates a glyph *) - (* slot for the face object which can be accessed directly through *) - (* `face->glyph'. *) - (* *) - (* @FT_New_Face can be used to determine and/or check the font format *) - (* of a given font resource. If the `face_index' field is negative, *) - (* the function will _not_ return any face handle in `aface'; the *) - (* return value is 0 if the font format is recognized, or non-zero *) - (* otherwise. *) - (* *) - (* Each new face object created with this function also owns a *) - (* default @FT_Size object, accessible as `face->size'. *) - (* *) - function FT_New_Face( - library_ : FT_Library; - filepathname : PChar; - face_index : FT_Long; - out aface : FT_Face ) : FT_Error; - cdecl; external ft_lib name 'FT_New_Face'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Done_Face *) - (* *) - (* *) - (* Discards a given face object, as well as all of its child slots *) - (* and sizes. *) - (* *) - (* *) - (* face :: A handle to a target face object. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Done_Face(face : FT_Face ) : FT_Error; - cdecl; external ft_lib name 'FT_Done_Face'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Select_Charmap *) - (* *) - (* *) - (* Selects a given charmap by its encoding tag (as listed in *) - (* `freetype.h'). *) - (* *) - (* *) - (* face :: A handle to the source face object. *) - (* *) - (* *) - (* encoding :: A handle to the selected charmap. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* This function will return an error if no charmap in the face *) - (* corresponds to the encoding queried here. *) - (* *) - function FT_Select_Charmap(face : FT_Face; encoding : FT_Encoding ) : FT_Error; - cdecl; external ft_lib name 'FT_Select_Charmap'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Get_Char_Index *) - (* *) - (* *) - (* Returns the glyph index of a given character code. This function *) - (* uses a charmap object to do the translation. *) - (* *) - (* *) - (* face :: A handle to the source face object. *) - (* *) - (* charcode :: The character code. *) - (* *) - (* *) - (* The glyph index. 0 means `undefined character code'. *) - (* *) - (* *) - (* FreeType computes its own glyph indices which are not necessarily *) - (* the same as used in the font in case the font is based on glyph *) - (* indices. Reason for this behaviour is to assure that index 0 is *) - (* never used, representing the missing glyph. *) - (* *) - function FT_Get_Char_Index(face : FT_Face; charcode : FT_ULong ) : FT_UInt; - cdecl; external ft_lib name 'FT_Get_Char_Index'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Load_Glyph *) - (* *) - (* *) - (* A function used to load a single glyph within a given glyph slot, *) - (* for a given size. *) - (* *) - (* *) - (* face :: A handle to the target face object where the glyph *) - (* will be loaded. *) - (* *) - (* *) - (* glyph_index :: The index of the glyph in the font file. For *) - (* CID-keyed fonts (either in PS or in CFF format) *) - (* this argument specifies the CID value. *) - (* *) - (* load_flags :: A flag indicating what to load for this glyph. The *) - (* @FT_LOAD_XXX constants can be used to control the *) - (* glyph loading process (e.g., whether the outline *) - (* should be scaled, whether to load bitmaps or not, *) - (* whether to hint the outline, etc). *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* If the glyph image is not a bitmap, and if the bit flag *) - (* FT_LOAD_IGNORE_TRANSFORM is unset, the glyph image will be *) - (* transformed with the information passed to a previous call to *) - (* @FT_Set_Transform. *) - (* *) - (* Note that this also transforms the `face.glyph.advance' field, but *) - (* *not* the values in `face.glyph.metrics'. *) - (* *) - function FT_Load_Glyph( - face : FT_Face; - glyph_index : FT_UInt ; - load_flags : FT_Int32 ) : FT_Error; - cdecl; external ft_lib name 'FT_Load_Glyph'; - - - (*************************************************************************) - (* *) - (* *) - (* FT_Render_Glyph *) - (* *) - (* *) - (* Converts a given glyph image to a bitmap. It does so by *) - (* inspecting the glyph image format, find the relevant renderer, and *) - (* invoke it. *) - (* *) - (* *) - (* slot :: A handle to the glyph slot containing the image to *) - (* convert. *) - (* *) - (* *) - (* render_mode :: This is the render mode used to render the glyph *) - (* image into a bitmap. See FT_Render_Mode for a list *) - (* of possible values. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Render_Glyph(slot : FT_GlyphSlot; render_mode : FT_Render_Mode ) : FT_Error; - cdecl; external ft_lib name 'FT_Render_Glyph'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Kerning_Mode *) - (* *) - (* *) - (* An enumeration used to specify which kerning values to return in *) - (* @FT_Get_Kerning. *) - (* *) - (* *) - (* FT_KERNING_DEFAULT :: Return scaled and grid-fitted kerning *) - (* distances (value is 0). *) - (* *) - (* FT_KERNING_UNFITTED :: Return scaled but un-grid-fitted kerning *) - (* distances. *) - (* *) - (* FT_KERNING_UNSCALED :: Return the kerning vector in original font *) - (* units. *) - (* *) -const - FT_KERNING_DEFAULT = 0; - FT_KERNING_UNFITTED = 1; - FT_KERNING_UNSCALED = 2; - - - (*************************************************************************) - (* *) - (* *) - (* FT_Get_Kerning *) - (* *) - (* *) - (* Returns the kerning vector between two glyphs of a same face. *) - (* *) - (* *) - (* face :: A handle to a source face object. *) - (* *) - (* left_glyph :: The index of the left glyph in the kern pair. *) - (* *) - (* right_glyph :: The index of the right glyph in the kern pair. *) - (* *) - (* kern_mode :: See @FT_Kerning_Mode for more information. *) - (* Determines the scale/dimension of the returned *) - (* kerning vector. *) - (* *) - (* *) - (* akerning :: The kerning vector. This is in font units for *) - (* scalable formats, and in pixels for fixed-sizes *) - (* formats. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* Only horizontal layouts (left-to-right & right-to-left) are *) - (* supported by this method. Other layouts, or more sophisticated *) - (* kernings, are out of the scope of this API function -- they can be *) - (* implemented through format-specific interfaces. *) - (* *) - function FT_Get_Kerning( - face : FT_Face; - left_glyph , - right_glyph , - kern_mode : FT_UInt; - out akerning : FT_Vector ) : FT_Error; - cdecl; external ft_lib name 'FT_Get_Kerning'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Set_Char_Size *) - (* *) - (* *) - (* Sets the character dimensions of a given face object. The *) - (* `char_width' and `char_height' values are used for the width and *) - (* height, respectively, expressed in 26.6 fractional points. *) - (* *) - (* If the horizontal or vertical resolution values are zero, a *) - (* default value of 72dpi is used. Similarly, if one of the *) - (* character dimensions is zero, its value is set equal to the other. *) - (* *) - (* *) - (* face :: A handle to a target face object. *) - (* *) - (* *) - (* char_width :: The character width, in 26.6 fractional points. *) - (* *) - (* char_height :: The character height, in 26.6 fractional *) - (* points. *) - (* *) - (* horz_resolution :: The horizontal resolution. *) - (* *) - (* vert_resolution :: The vertical resolution. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* When dealing with fixed-size faces (i.e., non-scalable formats), *) - (* @FT_Set_Pixel_Sizes provides a more convenient interface. *) - (* *) - function FT_Set_Char_Size( - face : FT_Face; - char_width , - char_height : FT_F26dot6; - horz_res , - vert_res : FT_UInt) : FT_Error; - cdecl; external ft_lib name 'FT_Set_Char_Size'; - - (*************************************************************************) - (* *) - (* *) - (* FT_Set_Pixel_Sizes *) - (* *) - (* *) - (* Sets the character dimensions of a given face object. The width *) - (* and height are expressed in integer pixels. *) - (* *) - (* If one of the character dimensions is zero, its value is set equal *) - (* to the other. *) - (* *) - (* *) - (* face :: A handle to the target face object. *) - (* *) - (* *) - (* pixel_width :: The character width, in integer pixels. *) - (* *) - (* pixel_height :: The character height, in integer pixels. *) - (* *) - (* *) - (* FreeType error code. 0 means success. *) - (* *) - (* *) - (* The values of `pixel_width' and `pixel_height' correspond to the *) - (* pixel values of the _typographic_ character size, which are NOT *) - (* necessarily the same as the dimensions of the glyph `bitmap *) - (* cells'. *) - (* *) - (* The `character size' is really the size of an abstract square *) - (* called the `EM', used to design the font. However, depending *) - (* on the font design, glyphs will be smaller or greater than the *) - (* EM. *) - (* *) - (* This means that setting the pixel size to, say, 8x8 doesn't *) - (* guarantee in any way that you will get glyph bitmaps that all fit *) - (* within an 8x8 cell (sometimes even far from it). *) - (* *) - (* For bitmap fonts, `pixel_height' usually is a reliable value for *) - (* the height of the bitmap cell. Drivers for bitmap font formats *) - (* which contain a single bitmap strike only (BDF, PCF, FNT) ignore *) - (* `pixel_width'. *) - (* *) - function FT_Set_Pixel_Sizes( - face : FT_Face; - pixel_width , - pixel_height : FT_UInt ) : FT_Error; - cdecl; external ft_lib name 'FT_Set_Pixel_Sizes'; - -const - FT_ANGLE_PI = 180 shl 16; - FT_ANGLE_2PI = FT_ANGLE_PI * 2; - FT_ANGLE_PI2 = FT_ANGLE_PI div 2; - FT_ANGLE_PI4 = FT_ANGLE_PI div 4; - - -implementation - - -{ FT_CURVE_TAG } -function FT_CURVE_TAG(flag: byte): byte; -begin - result := flag and 3; -end; - -{ FT_HAS_KERNING } -function FT_HAS_KERNING(face : FT_Face ) : cbool; -begin - result := cbool(face.face_flags and FT_FACE_FLAG_KERNING ); -end; - -{ FT_IS_SCALABLE } -function FT_IS_SCALABLE(face : FT_Face ) : cbool; -begin - result := cbool(face.face_flags and FT_FACE_FLAG_SCALABLE ); -end; - -end. - diff --git a/src/lib/libpng/png.pas b/src/lib/libpng/png.pas deleted file mode 100644 index 0092dde3..00000000 --- a/src/lib/libpng/png.pas +++ /dev/null @@ -1,974 +0,0 @@ -(* - * libpng pascal headers - * Version: 1.2.12 - *) - -{$IFDEF FPC} - {$ifndef NO_SMART_LINK} - {$smartlink on} - {$endif} -{$ENDIF} - -unit png; - -interface - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKRECORDS C} -{$ENDIF} - -uses - ctypes, - {$IFDEF MSWINDOWS} - Windows, - {$ENDIF} - {$IFDEF UNIX} - baseunix, - {$ENDIF} - zlib; - -const -{$IFDEF MSWINDOWS} - // use libpng12-0 (Version 1.2.18), delivered wih SDL_Image - LibPng = 'libpng12-0'; // 'libpng13'; - // matching lib version for libpng13.dll, needed for initialization - PNG_LIBPNG_VER_STRING='1.2.12'; - // define the compiler that was used to built the DLL (necessary for jmp_buf) - // SDL_Image was compiled with GCC - //{$define MSVC_DLL} // MS Visual C++ - {$DEFINE GCC_DLL} // GCC -{$ELSE} - LibPng = 'png'; - // matching lib version for libpng, needed for initialization - PNG_LIBPNG_VER_STRING='1.2.12'; - {$IFDEF DARWIN} - {$linklib libpng} - {$ENDIF} -{$ENDIF} - - -{$IFDEF MSWINDOWS} -const - // JB_LEN (#elements in jmp_buf) depends on the compiler used to compile the DLL - // MSVC++: 16 (x86/AMD64), GCC: 52 - {$IF Defined(MSVC_DLL)} - JB_LEN = 16; - {$ELSEIF Defined(GCC_DLL)} - JB_LEN = 52; - {$ELSE} - JB_LEN = 0; - {$IFEND} -{$ENDIF} - -type - {$IFNDEF FPC} - // defines for Delphi - size_t = culong; - {$ENDIF} - - {$ifdef MSWINDOWS} - {$if JB_LEN > 0} - jmp_buf = array[0..JB_LEN-1] of cint; - // the png_struct cannot be accessed if the size of jmp_buf is unknown - {$define UsePngStruct} - {$ifend} - // Do NOT use time_t on windows! It might be 32 or 64bit, depending on the compiler and system. - // MSVS-2005 starts using 64bit for time_t on x86 by default, but GCC uses just 32bit. - //time_t = clong; - {$endif} - - z_stream = TZStream; - - png_uint_32 = cuint32; - png_int_32 = cint32; - png_uint_16 = cuint16; - png_int_16 = cint16; - png_byte = cuint8; - ppng_uint_32 = ^png_uint_32; - ppng_int_32 = ^png_int_32; - ppng_uint_16 = ^png_uint_16; - ppng_int_16 = ^png_int_16; - ppng_byte = ^png_byte; - pppng_uint_32 = ^ppng_uint_32; - pppng_int_32 = ^ppng_int_32; - pppng_uint_16 = ^ppng_uint_16; - pppng_int_16 = ^ppng_int_16; - pppng_byte = ^ppng_byte; - png_size_t = size_t; - png_fixed_point = png_int_32; - ppng_fixed_point = ^png_fixed_point; - pppng_fixed_point = ^ppng_fixed_point; - png_voidp = pointer; - png_bytep = Ppng_byte; - ppng_bytep = ^png_bytep; - png_uint_32p = Ppng_uint_32; - png_int_32p = Ppng_int_32; - png_uint_16p = Ppng_uint_16; - ppng_uint_16p = ^png_uint_16p; - png_int_16p = Ppng_int_16; - png_const_charp = {const} Pchar; - png_charp = Pchar; - ppng_charp = ^png_charp; - png_fixed_point_p = Ppng_fixed_point; - png_FILE_p = Pointer; - png_doublep = PCdouble; - png_bytepp = PPpng_byte; - png_uint_32pp = PPpng_uint_32; - png_int_32pp = PPpng_int_32; - png_uint_16pp = PPpng_uint_16; - png_int_16pp = PPpng_int_16; - png_const_charpp = {const} PPchar; - png_charpp = PPchar; - ppng_charpp = ^png_charpp; - png_fixed_point_pp = PPpng_fixed_point; - PPCdouble = ^PCdouble; - png_doublepp = PPCdouble; - PPPChar = ^PPChar; - png_charppp = PPPChar; - PCharf = PChar; - PPCharf = ^PCharf; - png_zcharp = PCharf; - png_zcharpp = PPCharf; - png_zstreamp = Pzstream; - -const - (* Maximum positive integer used in PNG is (2^31)-1 *) - PNG_UINT_31_MAX = (png_uint_32($7fffffff)); - PNG_UINT_32_MAX = (png_uint_32(-1)); - PNG_SIZE_MAX = (png_size_t(-1)); - {$if defined(PNG_1_0_X) or defined (PNG_1_2_X)} - (* PNG_MAX_UINT is deprecated; use PNG_UINT_31_MAX instead. *) - PNG_MAX_UINT = PNG_UINT_31_MAX; - {$ifend} - - (* These describe the color_type field in png_info. *) - (* color type masks *) - PNG_COLOR_MASK_PALETTE = 1; - PNG_COLOR_MASK_COLOR = 2; - PNG_COLOR_MASK_ALPHA = 4; - - (* color types. Note that not all combinations are legal *) - PNG_COLOR_TYPE_GRAY = 0; - PNG_COLOR_TYPE_PALETTE = (PNG_COLOR_MASK_COLOR or PNG_COLOR_MASK_PALETTE); - PNG_COLOR_TYPE_RGB = (PNG_COLOR_MASK_COLOR); - PNG_COLOR_TYPE_RGB_ALPHA = (PNG_COLOR_MASK_COLOR or PNG_COLOR_MASK_ALPHA); - PNG_COLOR_TYPE_GRAY_ALPHA = (PNG_COLOR_MASK_ALPHA); - (* aliases *) - PNG_COLOR_TYPE_RGBA = PNG_COLOR_TYPE_RGB_ALPHA; - PNG_COLOR_TYPE_GA = PNG_COLOR_TYPE_GRAY_ALPHA; - - (* This is for compression type. PNG 1.0-1.2 only define the single type. *) - PNG_COMPRESSION_TYPE_BASE = 0; (* Deflate method 8, 32K window *) - PNG_COMPRESSION_TYPE_DEFAULT = PNG_COMPRESSION_TYPE_BASE; - - (* This is for filter type. PNG 1.0-1.2 only define the single type. *) - PNG_FILTER_TYPE_BASE = 0; (* Single row per-byte filtering *) - PNG_INTRAPIXEL_DIFFERENCING = 64; (* Used only in MNG datastreams *) - PNG_FILTER_TYPE_DEFAULT = PNG_FILTER_TYPE_BASE; - - (* These are for the interlacing type. These values should NOT be changed. *) - PNG_INTERLACE_NONE = 0; (* Non-interlaced image *) - PNG_INTERLACE_ADAM7 = 1; (* Adam7 interlacing *) - PNG_INTERLACE_LAST = 2; (* Not a valid value *) - - (* These are for the oFFs chunk. These values should NOT be changed. *) - PNG_OFFSET_PIXEL = 0; (* Offset in pixels *) - PNG_OFFSET_MICROMETER = 1; (* Offset in micrometers (1/10^6 meter) *) - PNG_OFFSET_LAST = 2; (* Not a valid value *) - - (* These are for the pCAL chunk. These values should NOT be changed. *) - PNG_EQUATION_LINEAR = 0; (* Linear transformation *) - PNG_EQUATION_BASE_E = 1; (* Exponential base e transform *) - PNG_EQUATION_ARBITRARY = 2; (* Arbitrary base exponential transform *) - PNG_EQUATION_HYPERBOLIC = 3; (* Hyperbolic sine transformation *) - PNG_EQUATION_LAST = 4; (* Not a valid value *) - - (* These are for the sCAL chunk. These values should NOT be changed. *) - PNG_SCALE_UNKNOWN = 0; (* unknown unit (image scale) *) - PNG_SCALE_METER = 1; (* meters per pixel *) - PNG_SCALE_RADIAN = 2; (* radians per pixel *) - PNG_SCALE_LAST = 3; (* Not a valid value *) - - (* These are for the pHYs chunk. These values should NOT be changed. *) - PNG_RESOLUTION_UNKNOWN = 0; (* pixels/unknown unit (aspect ratio) *) - PNG_RESOLUTION_METER = 1; (* pixels/meter *) - PNG_RESOLUTION_LAST = 2; (* Not a valid value *) - - (* These are for the sRGB chunk. These values should NOT be changed. *) - PNG_sRGB_INTENT_PERCEPTUAL = 0; - PNG_sRGB_INTENT_RELATIVE = 1; - PNG_sRGB_INTENT_SATURATION = 2; - PNG_sRGB_INTENT_ABSOLUTE = 3; - PNG_sRGB_INTENT_LAST = 4; (* Not a valid value *) - - (* This is for text chunks *) - PNG_KEYWORD_MAX_LENGTH = 79; - - (* Maximum number of entries in PLTE/sPLT/tRNS arrays *) - PNG_MAX_PALETTE_LENGTH = 256; - - (* These determine if an ancillary chunk's data has been successfully read - * from the PNG header, or if the application has filled in the corresponding - * data in the info_struct to be written into the output file. The values - * of the PNG_INFO_ defines should NOT be changed. - *) - PNG_INFO_gAMA = $0001; - PNG_INFO_sBIT = $0002; - PNG_INFO_cHRM = $0004; - PNG_INFO_PLTE = $0008; - PNG_INFO_tRNS = $0010; - PNG_INFO_bKGD = $0020; - PNG_INFO_hIST = $0040; - PNG_INFO_pHYs = $0080; - PNG_INFO_oFFs = $0100; - PNG_INFO_tIME = $0200; - PNG_INFO_pCAL = $0400; - PNG_INFO_sRGB = $0800; (* GR-P, 0.96a *) - PNG_INFO_iCCP = $1000; (* ESR, 1.0.6 *) - PNG_INFO_sPLT = $2000; (* ESR, 1.0.6 *) - PNG_INFO_sCAL = $4000; (* ESR, 1.0.6 *) - PNG_INFO_IDAT = $8000; (* ESR, 1.0.6 *) - - -(* -var - png_libpng_ver : array[0..11] of char; external LibPng name 'png_libpng_ver'; - png_pass_start : array[0..6] of cint; external LibPng name 'png_pass_start'; - png_pass_inc : array[0..6] of cint; external LibPng name 'png_pass_inc'; - png_pass_ystart : array[0..6] of cint; external LibPng name 'png_pass_ystart'; - png_pass_yinc : array[0..6] of cint; external LibPng name 'png_pass_yinc'; - png_pass_mask : array[0..6] of cint; external LibPng name 'png_pass_mask'; - png_pass_dsp_mask : array[0..6] of cint; external LibPng name 'png_pass_dsp_mask'; -*) - -type - (* Three color definitions. The order of the red, green, and blue, (and the - * exact size) is not important, although the size of the fields need to - * be png_byte or png_uint_16 (as defined below). - *) - png_color = record - red : png_byte; - green : png_byte; - blue : png_byte; - end; - ppng_color = ^png_color; - pppng_color = ^ppng_color; - png_color_struct = png_color; - png_colorp = Ppng_color; - ppng_colorp = ^png_colorp; - png_colorpp = PPpng_color; - - png_color_16 = record - index : png_byte; (* used for palette files *) - red : png_uint_16; (* for use in red green blue files *) - green : png_uint_16; - blue : png_uint_16; - gray : png_uint_16; (* for use in grayscale files *) - end; - ppng_color_16 = ^png_color_16 ; - pppng_color_16 = ^ppng_color_16 ; - png_color_16_struct = png_color_16; - png_color_16p = Ppng_color_16; - ppng_color_16p = ^png_color_16p; - png_color_16pp = PPpng_color_16; - - png_color_8 = record - red : png_byte; (* for use in red green blue files *) - green : png_byte; - blue : png_byte; - gray : png_byte; (* for use in grayscale files *) - alpha : png_byte; (* for alpha channel files *) - end; - ppng_color_8 = ^png_color_8; - pppng_color_8 = ^ppng_color_8; - png_color_8_struct = png_color_8; - png_color_8p = Ppng_color_8; - ppng_color_8p = ^png_color_8p; - png_color_8pp = PPpng_color_8; - - (* - * The following two structures are used for the in-core representation - * of sPLT chunks. - *) - png_sPLT_entry = record - red : png_uint_16; - green : png_uint_16; - blue : png_uint_16; - alpha : png_uint_16; - frequency : png_uint_16; - end; - ppng_sPLT_entry = ^png_sPLT_entry; - pppng_sPLT_entry = ^ppng_sPLT_entry; - png_sPLT_entry_struct = png_sPLT_entry; - png_sPLT_entryp = Ppng_sPLT_entry; - png_sPLT_entrypp = PPpng_sPLT_entry; - - (* When the depth of the sPLT palette is 8 bits, the color and alpha samples - * occupy the LSB of their respective members, and the MSB of each member - * is zero-filled. The frequency member always occupies the full 16 bits. - *) - - png_sPLT_t = record - name : png_charp; (* palette name *) - depth : png_byte; (* depth of palette samples *) - entries : png_sPLT_entryp; (* palette entries *) - nentries : png_int_32; (* number of palette entries *) - end; - ppng_sPLT_t = ^png_sPLT_t; - pppng_sPLT_t = ^ppng_sPLT_t; - png_sPLT_struct = png_sPLT_t; - png_sPLT_tp = Ppng_sPLT_t; - png_sPLT_tpp = PPpng_sPLT_t; - - (* png_text holds the contents of a text/ztxt/itxt chunk in a PNG file, - * and whether that contents is compressed or not. The "key" field - * points to a regular zero-terminated C string. The "text", "lang", and - * "lang_key" fields can be regular C strings, empty strings, or NULL pointers. - * However, the * structure returned by png_get_text() will always contain - * regular zero-terminated C strings (possibly empty), never NULL pointers, - * so they can be safely used in printf() and other string-handling functions. - *) - png_text = record - compression : cint; (* compression value: - -1: tEXt, none - 0: zTXt, deflate - 1: iTXt, none - 2: iTXt, deflate *) - key : png_charp; (* keyword, 1-79 character description of "text" *) - text : png_charp; (* comment, may be an empty string (ie "") - or a NULL pointer *) - text_length : png_size_t; (* length of the text string *) - end; - ppng_text = ^png_text; - pppng_text = ^ppng_text; - png_text_struct = png_text; - png_textp = Ppng_text; - ppng_textp = ^png_textp; - png_textpp = PPpng_text; - - (* png_time is a way to hold the time in an machine independent way. - * Two conversions are provided, both from time_t and struct tm. There - * is no portable way to convert to either of these structures, as far - * as I know. If you know of a portable way, send it to me. As a side - * note - PNG has always been Year 2000 compliant! - *) - png_time = record - year : png_uint_16; (* full year, as in, 1995 *) - month : png_byte; (* month of year, 1 - 12 *) - day : png_byte; (* day of month, 1 - 31 *) - hour : png_byte; (* hour of day, 0 - 23 *) - minute : png_byte; (* minute of hour, 0 - 59 *) - second : png_byte; (* second of minute, 0 - 60 (for leap seconds) *) - end; - ppng_time = ^png_time; - pppng_time = ^ppng_time; - png_time_struct = png_time; - png_timep = Ppng_time; - PPNG_TIMEP = ^PNG_TIMEP; - png_timepp = PPpng_time; - -const - PNG_CHUNK_NAME_LENGTH = 5; -type - (* png_unknown_chunk is a structure to hold queued chunks for which there is - * no specific support. The idea is that we can use this to queue - * up private chunks for output even though the library doesn't actually - * know about their semantics. - *) - png_unknown_chunk = record - name : array[0..PNG_CHUNK_NAME_LENGTH-1] of png_byte; - data : Ppng_byte; - size : png_size_t; - - (* libpng-using applications should NOT directly modify this byte. *) - location : png_byte; (* mode of operation at read time *) - end; - ppng_unknown_chunk = ^png_unknown_chunk; - pppng_unknown_chunk = ^ppng_unknown_chunk; - png_unknown_chunk_t = png_unknown_chunk; - png_unknown_chunkp = Ppng_unknown_chunk; - png_unknown_chunkpp = PPpng_unknown_chunk; - - (* png_info is a structure that holds the information in a PNG file so - * that the application can find out the characteristics of the image. - * If you are reading the file, this structure will tell you what is - * in the PNG file. If you are writing the file, fill in the information - * you want to put into the PNG file, then call png_write_info(). - * The names chosen should be very close to the PNG specification, so - * consult that document for information about the meaning of each field. - * - * With libpng < 0.95, it was only possible to directly set and read the - * the values in the png_info_struct, which meant that the contents and - * order of the values had to remain fixed. With libpng 0.95 and later, - * however, there are now functions that abstract the contents of - * png_info_struct from the application, so this makes it easier to use - * libpng with dynamic libraries, and even makes it possible to use - * libraries that don't have all of the libpng ancillary chunk-handing - * functionality. - * - * In any case, the order of the parameters in png_info_struct should NOT - * be changed for as long as possible to keep compatibility with applications - * that use the old direct-access method with png_info_struct. - * - * The following members may have allocated storage attached that should be - * cleaned up before the structure is discarded: palette, trans, text, - * pcal_purpose, pcal_units, pcal_params, hist, iccp_name, iccp_profile, - * splt_palettes, scal_unit, row_pointers, and unknowns. By default, these - * are automatically freed when the info structure is deallocated, if they were - * allocated internally by libpng. This behavior can be changed by means - * of the png_data_freer() function. - * - * More allocation details: all the chunk-reading functions that - * change these members go through the corresponding png_set_* - * functions. A function to clear these members is available: see - * png_free_data(). The png_set_* functions do not depend on being - * able to point info structure members to any of the storage they are - * passed (they make their own copies), EXCEPT that the png_set_text - * functions use the same storage passed to them in the text_ptr or - * itxt_ptr structure argument, and the png_set_rows and png_set_unknowns - * functions do not make their own copies. - *) - png_info = record - width : png_uint_32; (* width of image in pixels (from IHDR) *) - height : png_uint_32; (* height of image in pixels (from IHDR) *) - valid : png_uint_32; (* valid chunk data (see PNG_INFO_ below) *) - rowbytes : png_uint_32; (* bytes needed to hold an untransformed row *) - palette : png_colorp; (* array of color values (valid & PNG_INFO_PLTE) *) - num_palette : png_uint_16; (* number of color entries in "palette" (PLTE) *) - num_trans : png_uint_16; (* number of transparent palette color (tRNS) *) - bit_depth : png_byte; (* 1, 2, 4, 8, or 16 bits/channel (from IHDR) *) - color_type : png_byte; (* see PNG_COLOR_TYPE_ below (from IHDR) *) - (* The following three should have been named *_method not *_type *) - compression_type : png_byte; (* must be PNG_COMPRESSION_TYPE_BASE (IHDR) *) - filter_type : png_byte; (* must be PNG_FILTER_TYPE_BASE (from IHDR) *) - interlace_type : png_byte; (* One of PNG_INTERLACE_NONE, PNG_INTERLACE_ADAM7 *) - - (* The following is informational only on read, and not used on writes. *) - channels : png_byte; (* number of data channels per pixel (1, 2, 3, 4) *) - pixel_depth : png_byte; (* number of bits per pixel *) - spare_byte : png_byte; (* to align the data, and for future use *) - signature : array[0..7] of png_byte; (* magic bytes read by libpng from start of file *) - - (* The rest of the data is optional. If you are reading, check the - * valid field to see if the information in these are valid. If you - * are writing, set the valid field to those chunks you want written, - * and initialize the appropriate fields below. - *) - - gamma : cfloat; - srgb_intent : png_byte; - num_text : cint; - max_text : cint; - text : png_textp; - mod_time : png_time; - sig_bit : png_color_8; - trans : png_bytep; - trans_values : png_color_16; - background : png_color_16; - x_offset : png_int_32; - y_offset : png_int_32; - offset_unit_type : png_byte; - x_pixels_per_unit : png_uint_32; - y_pixels_per_unit : png_uint_32; - phys_unit_type : png_byte; - hist : png_uint_16p; - x_white : cfloat; - y_white : cfloat; - x_red : cfloat; - y_red : cfloat; - x_green : cfloat; - y_green : cfloat; - x_blue : cfloat; - y_blue : cfloat; - pcal_purpose : png_charp; - pcal_X0 : png_int_32; - pcal_X1 : png_int_32; - pcal_units : png_charp; - pcal_params : png_charpp; - pcal_type : png_byte; - pcal_nparams : png_byte; - free_me : png_uint_32; - unknown_chunks : png_unknown_chunkp; - unknown_chunks_num : png_size_t; - iccp_name : png_charp; - iccp_profile : png_charp; - iccp_proflen : png_uint_32; - iccp_compression : png_byte; - splt_palettes : png_sPLT_tp; - splt_palettes_num : png_uint_32; - scal_unit : png_byte; - scal_pixel_width : cdouble; - scal_pixel_height : cdouble; - scal_s_width : png_charp; - scal_s_height : png_charp; - row_pointers : png_bytepp; - int_gamma : png_fixed_point; - int_x_white : png_fixed_point; - int_y_white : png_fixed_point; - int_x_red : png_fixed_point; - int_y_red : png_fixed_point; - int_x_green : png_fixed_point; - int_y_green : png_fixed_point; - int_x_blue : png_fixed_point; - int_y_blue : png_fixed_point; - end; - ppng_info = ^png_info; - pppng_info = ^ppng_info; - png_info_struct = png_info; - png_infop = Ppng_info; - png_infopp = PPpng_info; - - (* This is used for the transformation routines, as some of them - * change these values for the row. It also should enable using - * the routines for other purposes. - *) - png_row_info = record - width : png_uint_32; (* width of row *) - rowbytes : png_uint_32; (* number of bytes in row *) - color_type : png_byte; (* color type of row *) - bit_depth : png_byte; (* bit depth of row *) - channels : png_byte; (* number of channels (1, 2, 3, or 4) *) - pixel_depth : png_byte; (* bits per pixel (depth * channels) *) - end; - ppng_row_info = ^png_row_info; - pppng_row_info = ^ppng_row_info; - png_row_info_struct = png_row_info; - png_row_infop = Ppng_row_info; - png_row_infopp = PPpng_row_info; - png_structp = ^png_struct; - - - (* These are the function types for the I/O functions and for the functions - * that allow the user to override the default I/O functions with his or her - * own. The png_error_ptr type should match that of user-supplied warning - * and error functions, while the png_rw_ptr type should match that of the - * user read/write data functions. - *) - png_error_ptr = procedure(Arg1 : png_structp; Arg2 : png_const_charp); cdecl; - png_rw_ptr = procedure(Arg1 : png_structp; Arg2 : png_bytep; Arg3 : png_size_t); cdecl; - png_flush_ptr = procedure (Arg1 : png_structp); cdecl; - png_read_status_ptr = procedure (Arg1 : png_structp; Arg2 : png_uint_32; Arg3: cint); cdecl; - png_write_status_ptr = procedure (Arg1 : png_structp; Arg2:png_uint_32;Arg3 : cint); cdecl; - png_progressive_info_ptr = procedure (Arg1 : png_structp; Arg2 : png_infop); cdecl; - png_progressive_end_ptr = procedure (Arg1 : png_structp; Arg2 : png_infop); cdecl; - png_progressive_row_ptr = procedure (Arg1 : png_structp; Arg2 : png_bytep; Arg3 : png_uint_32; Arg4 : cint); cdecl; - png_user_transform_ptr = procedure (Arg1 : png_structp; Arg2 : png_row_infop; Arg3 : png_bytep); cdecl; - png_user_chunk_ptr = function (Arg1 : png_structp; Arg2 : png_unknown_chunkp): cint; cdecl; - png_unknown_chunk_ptr = procedure (Arg1 : png_structp); cdecl; - png_malloc_ptr = function (Arg1 : png_structp; Arg2 : png_size_t) : png_voidp; cdecl; - png_free_ptr = procedure (Arg1 : png_structp; Arg2 : png_voidp); cdecl; - - png_struct_def = record - {$ifdef UsePngStruct} - jmpbuf : jmp_buf; (* used in png_error *) - error_fn : png_error_ptr; (* function for printing errors and aborting *) - warning_fn : png_error_ptr; (* function for printing warnings *) - error_ptr : png_voidp; (* user supplied struct for error functions *) - write_data_fn : png_rw_ptr; (* function for writing output data *) - read_data_fn : png_rw_ptr; (* function for reading input data *) - io_ptr : png_voidp; (* ptr to application struct for I/O functions *) - - read_user_transform_fn : png_user_transform_ptr; (* user read transform *) - - write_user_transform_fn : png_user_transform_ptr; (* user write transform *) - - (* These were added in libpng-1.0.2 *) - user_transform_ptr : png_voidp; (* user supplied struct for user transform *) - user_transform_depth : png_byte; (* bit depth of user transformed pixels *) - user_transform_channels : png_byte; (* channels in user transformed pixels *) - - mode : png_uint_32; (* tells us where we are in the PNG file *) - flags : png_uint_32; (* flags indicating various things to libpng *) - transformations : png_uint_32; (* which transformations to perform *) - - zstream : z_stream; (* pointer to decompression structure (below) *) - zbuf : png_bytep; (* buffer for zlib *) - zbuf_size : png_size_t; (* size of zbuf *) - zlib_level : cint; (* holds zlib compression level *) - zlib_method : cint; (* holds zlib compression method *) - zlib_window_bits : cint; (* holds zlib compression window bits *) - zlib_mem_level : cint; (* holds zlib compression memory level *) - zlib_strategy : cint; (* holds zlib compression strategy *) - - width : png_uint_32; (* width of image in pixels *) - height : png_uint_32; (* height of image in pixels *) - num_rows : png_uint_32; (* number of rows in current pass *) - usr_width : png_uint_32; (* width of row at start of write *) - rowbytes : png_uint_32; (* size of row in bytes *) - irowbytes : png_uint_32; (* size of current interlaced row in bytes *) - iwidth : png_uint_32; (* width of current interlaced row in pixels *) - row_number : png_uint_32; (* current row in interlace pass *) - prev_row : png_bytep; (* buffer to save previous (unfiltered) row *) - row_buf : png_bytep; (* buffer to save current (unfiltered) row *) - sub_row : png_bytep; (* buffer to save "sub" row when filtering *) - up_row : png_bytep; (* buffer to save "up" row when filtering *) - avg_row : png_bytep; (* buffer to save "avg" row when filtering *) - paeth_row : png_bytep; (* buffer to save "Paeth" row when filtering *) - row_info : png_row_info; (* used for transformation routines *) - - idat_size : png_uint_32; (* current IDAT size for read *) - crc : png_uint_32; (* current chunk CRC value *) - palette : png_colorp; (* palette from the input file *) - num_palette : png_uint_16; (* number of color entries in palette *) - num_trans : png_uint_16; (* number of transparency values *) - chunk_name : array[0..4] of png_byte; (* null-terminated name of current chunk *) - compression : png_byte; (* file compression type (always 0) *) - filter : png_byte; (* file filter type (always 0) *) - interlaced : png_byte; (* PNG_INTERLACE_NONE, PNG_INTERLACE_ADAM7 *) - pass : png_byte; (* current interlace pass (0 - 6) *) - do_filter : png_byte; (* row filter flags (see PNG_FILTER_ below ) *) - color_type : png_byte; (* color type of file *) - bit_depth : png_byte; (* bit depth of file *) - usr_bit_depth : png_byte; (* bit depth of users row *) - pixel_depth : png_byte; (* number of bits per pixel *) - channels : png_byte; (* number of channels in file *) - usr_channels : png_byte; (* channels at start of write *) - sig_bytes : png_byte; (* magic bytes read/written from start of file *) - - filler : png_uint_16; - - background_gamma_type : png_byte; - background_gamma : cfloat; - background : png_color_16; - background_1 : png_color_16; - output_flush_fn : png_flush_ptr; - flush_dist : png_uint_32; - flush_rows : png_uint_32; - gamma_shift : cint; - gamma : cfloat; - screen_gamma : cfloat; - gamma_table : png_bytep; - gamma_from_1 : png_bytep; - gamma_to_1 : png_bytep; - gamma_16_table : png_uint_16pp; - gamma_16_from_1 : png_uint_16pp; - gamma_16_to_1 : png_uint_16pp; - sig_bit : png_color_8; - shift : png_color_8; - trans : png_bytep; - trans_values : png_color_16; - read_row_fn : png_read_status_ptr; - write_row_fn : png_write_status_ptr; - info_fn : png_progressive_info_ptr; - row_fn : png_progressive_row_ptr; - end_fn : png_progressive_end_ptr; - save_buffer_ptr : png_bytep; - save_buffer : png_bytep; - current_buffer_ptr : png_bytep; - current_buffer : png_bytep; - push_length : png_uint_32; - skip_length : png_uint_32; - save_buffer_size : png_size_t; - save_buffer_max : png_size_t; - buffer_size : png_size_t; - current_buffer_size : png_size_t; - process_mode : cint; - cur_palette : cint; - current_text_size : png_size_t; - current_text_left : png_size_t; - current_text : png_charp; - current_text_ptr : png_charp; - palette_lookup : png_bytep; - dither_index : png_bytep; - hist : png_uint_16p; - heuristic_method : png_byte; - num_prev_filters : png_byte; - prev_filters : png_bytep; - filter_weights : png_uint_16p; - inv_filter_weights : png_uint_16p; - filter_costs : png_uint_16p; - inv_filter_costs : png_uint_16p; - time_buffer : png_charp; - free_me : png_uint_32; - user_chunk_ptr : png_voidp; - read_user_chunk_fn : png_user_chunk_ptr; - num_chunk_list : cint; - chunk_list : png_bytep; - rgb_to_gray_status : png_byte; - rgb_to_gray_red_coeff : png_uint_16; - rgb_to_gray_green_coeff : png_uint_16; - rgb_to_gray_blue_coeff : png_uint_16; - empty_plte_permitted : png_byte; - int_gamma : png_fixed_point; - {$endif UsePngStruct} - end; - ppng_struct_def = ^png_struct_def; - pppng_struct_def = ^ppng_struct_def; - png_struct = png_struct_def; - ppng_struct = ^png_struct; - pppng_struct = ^ppng_struct; - - version_1_0_8 = png_structp; - png_structpp = PPpng_struct; - -function png_access_version_number:png_uint_32; cdecl; external LibPng; - -procedure png_set_sig_bytes(png_ptr:png_structp; num_bytes:cint); cdecl; external LibPng; -function png_sig_cmp(sig:png_bytep; start:png_size_t; num_to_check:png_size_t):cint; cdecl; external LibPng; -function png_check_sig(sig:png_bytep; num:cint):cint; cdecl; external LibPng; - -(* Allocate and initialize png_ptr struct for reading, and any other memory. *) -function png_create_read_struct(user_png_ver:png_const_charp; error_ptr:png_voidp; error_fn:png_error_ptr; warn_fn:png_error_ptr):png_structp; cdecl; external LibPng; - -(* Allocate and initialize png_ptr struct for writing, and any other memory *) -function png_create_write_struct(user_png_ver:png_const_charp; error_ptr:png_voidp; error_fn:png_error_ptr; warn_fn:png_error_ptr):png_structp; cdecl; external LibPng; - -function png_get_compression_buffer_size(png_ptr:png_structp):png_uint_32; cdecl; external LibPng; -procedure png_set_compression_buffer_size(png_ptr:png_structp; size:png_uint_32); cdecl; external LibPng; -function png_reset_zstream(png_ptr:png_structp):cint; cdecl; external LibPng; - -procedure png_write_chunk(png_ptr:png_structp; chunk_name:png_bytep; data:png_bytep; length:png_size_t); cdecl; external LibPng; -procedure png_write_chunk_start(png_ptr:png_structp; chunk_name:png_bytep; length:png_uint_32); cdecl; external LibPng; -procedure png_write_chunk_data(png_ptr:png_structp; data:png_bytep; length:png_size_t); cdecl; external LibPng; -procedure png_write_chunk_end(png_ptr:png_structp); cdecl; external LibPng; - -(* Allocate and initialize the info structure *) -function png_create_info_struct(png_ptr:png_structp):png_infop; cdecl; external LibPng; - -(* Initialize the info structure (old interface - DEPRECATED) *) -procedure png_info_init(info_ptr:png_infop); cdecl; external LibPng; - -(* Writes all the PNG information before the image. *) -procedure png_write_info_before_PLTE(png_ptr:png_structp; info_ptr:png_infop); cdecl; external LibPng; -procedure png_write_info(png_ptr:png_structp; info_ptr:png_infop); cdecl; external LibPng; - -(* read the information before the actual image data. *) -procedure png_read_info(png_ptr:png_structp; info_ptr:png_infop); cdecl; external LibPng; - -function png_convert_to_rfc1123(png_ptr:png_structp; ptime:png_timep):png_charp; cdecl; external LibPng; -procedure png_convert_from_struct_tm(ptime:png_timep; ttime:Pointer); cdecl; external LibPng; -{$IFDEF UNIX} -procedure png_convert_from_time_t(ptime:png_timep; ttime:time_t); cdecl; external LibPng; -{$ENDIF} -procedure png_set_expand(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_gray_1_2_4_to_8(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_palette_to_rgb(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_tRNS_to_alpha(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_bgr(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_gray_to_rgb(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_rgb_to_gray(png_ptr:png_structp; error_action:cint; red:cdouble; green:cdouble); cdecl; external LibPng; -procedure png_set_rgb_to_gray_fixed(png_ptr:png_structp; error_action:cint; red:png_fixed_point; green:png_fixed_point); cdecl; external LibPng; -function png_get_rgb_to_gray_status(png_ptr:png_structp):png_byte; cdecl; external LibPng; -procedure png_build_grayscale_palette(bit_depth:cint; palette:png_colorp); cdecl; external LibPng; -procedure png_set_strip_alpha(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_swap_alpha(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_invert_alpha(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_filler(png_ptr:png_structp; filler:png_uint_32; flags:cint); cdecl; external LibPng; -procedure png_set_swap(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_packing(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_packswap(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_shift(png_ptr:png_structp; true_bits:png_color_8p); cdecl; external LibPng; -function png_set_interlace_handling(png_ptr:png_structp):cint; cdecl; external LibPng; -procedure png_set_invert_mono(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_background(png_ptr:png_structp; background_color:png_color_16p; background_gamma_code:cint; need_expand:cint; background_gamma:cdouble); cdecl; external LibPng; -procedure png_set_strip_16(png_ptr:png_structp); cdecl; external LibPng; -procedure png_set_dither(png_ptr:png_structp; palette:png_colorp; num_palette:cint; maximum_colors:cint; histogram:png_uint_16p; - full_dither:cint); cdecl; external LibPng; -procedure png_set_gamma(png_ptr:png_structp; screen_gamma:cdouble; default_file_gamma:cdouble); cdecl; external LibPng; -procedure png_permit_empty_plte(png_ptr:png_structp; empty_plte_permitted:cint); cdecl; external LibPng; -procedure png_set_flush(png_ptr:png_structp; nrows:cint); cdecl; external LibPng; -procedure png_write_flush(png_ptr:png_structp); cdecl; external LibPng; -procedure png_start_read_image(png_ptr:png_structp); cdecl; external LibPng; -procedure png_read_update_info(png_ptr:png_structp; info_ptr:png_infop); cdecl; external LibPng; - -(* read one or more rows of image data. *) -procedure png_read_rows(png_ptr:png_structp; row:png_bytepp; display_row:png_bytepp; num_rows:png_uint_32); cdecl; external LibPng; - -(* read a row of data. *) -procedure png_read_row(png_ptr:png_structp; row:png_bytep; display_row:png_bytep); cdecl; external LibPng; - -(* read the whole image into memory at once. *) -procedure png_read_image(png_ptr:png_structp; image:png_bytepp); cdecl; external LibPng; - -(* write a row of image data *) -procedure png_write_row(png_ptr:png_structp; row:png_bytep); cdecl; external LibPng; - -(* write a few rows of image data *) -procedure png_write_rows(png_ptr:png_structp; row:png_bytepp; num_rows:png_uint_32); cdecl; external LibPng; - -(* write the image data *) -procedure png_write_image(png_ptr:png_structp; image:png_bytepp); cdecl; external LibPng; - -(* writes the end of the PNG file. *) -procedure png_write_end(png_ptr:png_structp; info_ptr:png_infop); cdecl; external LibPng; - -(* read the end of the PNG file. *) -procedure png_read_end(png_ptr:png_structp; info_ptr:png_infop); cdecl; external LibPng; - -(* free any memory associated with the png_info_struct *) -procedure png_destroy_info_struct(png_ptr:png_structp; info_ptr_ptr:png_infopp); cdecl; external LibPng; - -(* free any memory associated with the png_struct and the png_info_structs *) -procedure png_destroy_read_struct(png_ptr_ptr:png_structpp; info_ptr_ptr:png_infopp; end_info_ptr_ptr:png_infopp); cdecl; external LibPng; - -(* free all memory used by the read (old method - NOT DLL EXPORTED) *) -procedure png_read_destroy(png_ptr:png_structp; info_ptr:png_infop; end_info_ptr:png_infop); cdecl; external LibPng; - -(* free any memory associated with the png_struct and the png_info_structs *) -procedure png_destroy_write_struct(png_ptr_ptr:png_structpp; info_ptr_ptr:png_infopp); cdecl; external LibPng; - -procedure png_write_destroy_info(info_ptr:png_infop); cdecl; external LibPng; -procedure png_write_destroy(png_ptr:png_structp); cdecl; external LibPng; - -procedure png_set_crc_action(png_ptr:png_structp; crit_action:cint; ancil_action:cint); cdecl; external LibPng; - -procedure png_set_filter(png_ptr:png_structp; method:cint; filters:cint); cdecl; external LibPng; -procedure png_set_filter_heuristics(png_ptr:png_structp; heuristic_method:cint; num_weights:cint; filter_weights:png_doublep; filter_costs:png_doublep); cdecl; external LibPng; - -procedure png_set_compression_level(png_ptr:png_structp; level:cint); cdecl; external LibPng; -procedure png_set_compression_mem_level(png_ptr:png_structp; mem_level:cint); cdecl; external LibPng; -procedure png_set_compression_strategy(png_ptr:png_structp; strategy:cint); cdecl; external LibPng; -procedure png_set_compression_window_bits(png_ptr:png_structp; window_bits:cint); cdecl; external LibPng; -procedure png_set_compression_method(png_ptr:png_structp; method:cint); cdecl; external LibPng; - -procedure png_init_io(png_ptr:png_structp; fp:png_FILE_p); cdecl; external LibPng; - -(* Replace the (error and abort), and warning functions with user - * supplied functions. If no messages are to be printed you must still - * write and use replacement functions. The replacement error_fn should - * still do a longjmp to the last setjmp location if you are using this - * method of error handling. If error_fn or warning_fn is NULL, the - * default function will be used. - *) -procedure png_set_error_fn(png_ptr:png_structp; error_ptr:png_voidp; error_fn:png_error_ptr; warning_fn:png_error_ptr); cdecl; external LibPng; - -(* Return the user pointer associated with the error functions *) -function png_get_error_ptr(png_ptr:png_structp):png_voidp; cdecl; external LibPng; - -(* Replace the default data output functions with a user supplied one(s). - * If buffered output is not used, then output_flush_fn can be set to NULL. - * If PNG_WRITE_FLUSH_SUPPORTED is not defined at libpng compile time - * output_flush_fn will be ignored (and thus can be NULL). - *) -procedure png_set_write_fn(png_ptr:png_structp; io_ptr:png_voidp; write_data_fn:png_rw_ptr; output_flush_fn:png_flush_ptr); cdecl; external LibPng; - -(* Replace the default data input function with a user supplied one. *) -procedure png_set_read_fn(png_ptr:png_structp; io_ptr:png_voidp; read_data_fn:png_rw_ptr); cdecl; external LibPng; - -(* Return the user pointer associated with the I/O functions *) -function png_get_io_ptr(png_ptr:png_structp):png_voidp; cdecl; external LibPng; - -procedure png_set_read_status_fn(png_ptr:png_structp; read_row_fn:png_read_status_ptr); cdecl; external LibPng; -procedure png_set_write_status_fn(png_ptr:png_structp; write_row_fn:png_write_status_ptr); cdecl; external LibPng; -procedure png_set_read_user_transform_fn(png_ptr:png_structp; read_user_transform_fn:png_user_transform_ptr); cdecl; external LibPng; -procedure png_set_write_user_transform_fn(png_ptr:png_structp; write_user_transform_fn:png_user_transform_ptr); cdecl; external LibPng; -procedure png_set_user_transform_info(png_ptr:png_structp; user_transform_ptr:png_voidp; user_transform_depth:cint; user_transform_channels:cint); cdecl; external LibPng; -function png_get_user_transform_ptr(png_ptr:png_structp):png_voidp; cdecl; external LibPng; -procedure png_set_read_user_chunk_fn(png_ptr:png_structp; user_chunk_ptr:png_voidp; read_user_chunk_fn:png_user_chunk_ptr); cdecl; external LibPng; -function png_get_user_chunk_ptr(png_ptr:png_structp):png_voidp; cdecl; external LibPng; -procedure png_set_progressive_read_fn(png_ptr:png_structp; progressive_ptr:png_voidp; info_fn:png_progressive_info_ptr; row_fn:png_progressive_row_ptr; end_fn:png_progressive_end_ptr); cdecl; external LibPng; -function png_get_progressive_ptr(png_ptr:png_structp):png_voidp; cdecl; external LibPng; -procedure png_process_data(png_ptr:png_structp; info_ptr:png_infop; buffer:png_bytep; buffer_size:png_size_t); cdecl; external LibPng; -procedure png_progressive_combine_row(png_ptr:png_structp; old_row:png_bytep; new_row:png_bytep); cdecl; external LibPng; -function png_malloc(png_ptr:png_structp; size:png_uint_32):png_voidp; cdecl; external LibPng; -procedure png_free(png_ptr:png_structp; ptr:png_voidp); cdecl; external LibPng; -procedure png_free_data(png_ptr:png_structp; info_ptr:png_infop; free_me:png_uint_32; num:cint); cdecl; external LibPng; -procedure png_data_freer(png_ptr:png_structp; info_ptr:png_infop; freer:cint; mask:png_uint_32); cdecl; external LibPng; -function png_memcpy_check(png_ptr:png_structp; s1:png_voidp; s2:png_voidp; size:png_uint_32):png_voidp; cdecl; external LibPng; -function png_memset_check(png_ptr:png_structp; s1:png_voidp; value:cint; size:png_uint_32):png_voidp; cdecl; external LibPng; -procedure png_error(png_ptr:png_structp; error:png_const_charp); cdecl; external LibPng; -procedure png_chunk_error(png_ptr:png_structp; error:png_const_charp); cdecl; external LibPng; -procedure png_warning(png_ptr:png_structp; message:png_const_charp); cdecl; external LibPng; -procedure png_chunk_warning(png_ptr:png_structp; message:png_const_charp); cdecl; external LibPng; -function png_get_valid(png_ptr:png_structp; info_ptr:png_infop; flag:png_uint_32):png_uint_32; cdecl; external LibPng; -function png_get_rowbytes(png_ptr:png_structp; info_ptr:png_infop):png_uint_32; cdecl; external LibPng; -function png_get_rows(png_ptr:png_structp; info_ptr:png_infop):png_bytepp; cdecl; external LibPng; -procedure png_set_rows(png_ptr:png_structp; info_ptr:png_infop; row_pointers:png_bytepp); cdecl; external LibPng; -function png_get_channels(png_ptr:png_structp; info_ptr:png_infop):png_byte; cdecl; external LibPng; -function png_get_image_width(png_ptr:png_structp; info_ptr:png_infop):png_uint_32; cdecl; external LibPng; -function png_get_image_height(png_ptr:png_structp; info_ptr:png_infop):png_uint_32; cdecl; external LibPng; -function png_get_bit_depth(png_ptr:png_structp; info_ptr:png_infop):png_byte; cdecl; external LibPng; -function png_get_color_type(png_ptr:png_structp; info_ptr:png_infop):png_byte; cdecl; external LibPng; -function png_get_filter_type(png_ptr:png_structp; info_ptr:png_infop):png_byte; cdecl; external LibPng; -function png_get_interlace_type(png_ptr:png_structp; info_ptr:png_infop):png_byte; cdecl; external LibPng; -function png_get_compression_type(png_ptr:png_structp; info_ptr:png_infop):png_byte; cdecl; external LibPng; -function png_get_pixels_per_meter(png_ptr:png_structp; info_ptr:png_infop):png_uint_32; cdecl; external LibPng; -function png_get_x_pixels_per_meter(png_ptr:png_structp; info_ptr:png_infop):png_uint_32; cdecl; external LibPng; -function png_get_y_pixels_per_meter(png_ptr:png_structp; info_ptr:png_infop):png_uint_32; cdecl; external LibPng; -function png_get_pixel_aspect_ratio(png_ptr:png_structp; info_ptr:png_infop):cfloat; cdecl; external LibPng; -function png_get_x_offset_pixels(png_ptr:png_structp; info_ptr:png_infop):png_int_32; cdecl; external LibPng; -function png_get_y_offset_pixels(png_ptr:png_structp; info_ptr:png_infop):png_int_32; cdecl; external LibPng; -function png_get_x_offset_microns(png_ptr:png_structp; info_ptr:png_infop):png_int_32; cdecl; external LibPng; -function png_get_y_offset_microns(png_ptr:png_structp; info_ptr:png_infop):png_int_32; cdecl; external LibPng; -function png_get_signature(png_ptr:png_structp; info_ptr:png_infop):png_bytep; cdecl; external LibPng; - -function png_get_bKGD(png_ptr:png_structp; info_ptr:png_infop; background:Ppng_color_16p):png_uint_32; cdecl; external LibPng; -procedure png_set_bKGD(png_ptr:png_structp; info_ptr:png_infop; background:png_color_16p); cdecl; external LibPng; -function png_get_cHRM(png_ptr:png_structp; info_ptr:png_infop; white_x:PCdouble; white_y:PCdouble; red_x:PCdouble; - red_y:PCdouble; green_x:PCdouble; green_y:PCdouble; blue_x:PCdouble; blue_y:PCdouble):png_uint_32; cdecl; external LibPng; -function png_get_cHRM_fixed(png_ptr:png_structp; info_ptr:png_infop; int_white_x:Ppng_fixed_point; int_white_y:Ppng_fixed_point; int_red_x:Ppng_fixed_point; - int_red_y:Ppng_fixed_point; int_green_x:Ppng_fixed_point; int_green_y:Ppng_fixed_point; int_blue_x:Ppng_fixed_point; int_blue_y:Ppng_fixed_point):png_uint_32; cdecl; external LibPng; -procedure png_set_cHRM(png_ptr:png_structp; info_ptr:png_infop; white_x:cdouble; white_y:cdouble; red_x:cdouble; - red_y:cdouble; green_x:cdouble; green_y:cdouble; blue_x:cdouble; blue_y:cdouble); cdecl; external LibPng; -procedure png_set_cHRM_fixed(png_ptr:png_structp; info_ptr:png_infop; int_white_x:png_fixed_point; int_white_y:png_fixed_point; int_red_x:png_fixed_point; - int_red_y:png_fixed_point; int_green_x:png_fixed_point; int_green_y:png_fixed_point; int_blue_x:png_fixed_point; int_blue_y:png_fixed_point); cdecl; external LibPng; -function png_get_gAMA(png_ptr:png_structp; info_ptr:png_infop; file_gamma:PCdouble):png_uint_32; cdecl; external LibPng; -function png_get_gAMA_fixed(png_ptr:png_structp; info_ptr:png_infop; int_file_gamma:Ppng_fixed_point):png_uint_32; cdecl; external LibPng; -procedure png_set_gAMA(png_ptr:png_structp; info_ptr:png_infop; file_gamma:cdouble); cdecl; external LibPng; -procedure png_set_gAMA_fixed(png_ptr:png_structp; info_ptr:png_infop; int_file_gamma:png_fixed_point); cdecl; external LibPng; -function png_get_hIST(png_ptr:png_structp; info_ptr:png_infop; hist:Ppng_uint_16p):png_uint_32; cdecl; external LibPng; -procedure png_set_hIST(png_ptr:png_structp; info_ptr:png_infop; hist:png_uint_16p); cdecl; external LibPng; -function png_get_IHDR(png_ptr:png_structp; info_ptr:png_infop; width:Ppng_uint_32; height:Ppng_uint_32; bit_depth:PCint; - color_type:PCint; interlace_type:PCint; compression_type:PCint; filter_type:PCint):png_uint_32; cdecl; external LibPng; -procedure png_set_IHDR(png_ptr:png_structp; info_ptr:png_infop; width:png_uint_32; height:png_uint_32; bit_depth:cint; - color_type:cint; interlace_type:cint; compression_type:cint; filter_type:cint); cdecl; external LibPng; -function png_get_oFFs(png_ptr:png_structp; info_ptr:png_infop; offset_x:Ppng_int_32; offset_y:Ppng_int_32; unit_type:PCint):png_uint_32; cdecl; external LibPng; -procedure png_set_oFFs(png_ptr:png_structp; info_ptr:png_infop; offset_x:png_int_32; offset_y:png_int_32; unit_type:cint); cdecl; external LibPng; -function png_get_pCAL(png_ptr:png_structp; info_ptr:png_infop; purpose:Ppng_charp; X0:Ppng_int_32; X1:Ppng_int_32; - atype:PCint; nparams:PCint; units:Ppng_charp; params:Ppng_charpp):png_uint_32; cdecl; external LibPng; -procedure png_set_pCAL(png_ptr:png_structp; info_ptr:png_infop; purpose:png_charp; X0:png_int_32; X1:png_int_32; - atype:cint; nparams:cint; units:png_charp; params:png_charpp); cdecl; external LibPng; -function png_get_pHYs(png_ptr:png_structp; info_ptr:png_infop; res_x:Ppng_uint_32; res_y:Ppng_uint_32; unit_type:PCint):png_uint_32; cdecl; external LibPng; -procedure png_set_pHYs(png_ptr:png_structp; info_ptr:png_infop; res_x:png_uint_32; res_y:png_uint_32; unit_type:cint); cdecl; external LibPng; -function png_get_PLTE(png_ptr:png_structp; info_ptr:png_infop; palette:Ppng_colorp; num_palette:PCint):png_uint_32; cdecl; external LibPng; -procedure png_set_PLTE(png_ptr:png_structp; info_ptr:png_infop; palette:png_colorp; num_palette:cint); cdecl; external LibPng; -function png_get_sBIT(png_ptr:png_structp; info_ptr:png_infop; sig_bit:Ppng_color_8p):png_uint_32; cdecl; external LibPng; -procedure png_set_sBIT(png_ptr:png_structp; info_ptr:png_infop; sig_bit:png_color_8p); cdecl; external LibPng; -function png_get_sRGB(png_ptr:png_structp; info_ptr:png_infop; intent:PCint):png_uint_32; cdecl; external LibPng; -procedure png_set_sRGB(png_ptr:png_structp; info_ptr:png_infop; intent:cint); cdecl; external LibPng; -procedure png_set_sRGB_gAMA_and_cHRM(png_ptr:png_structp; info_ptr:png_infop; intent:cint); cdecl; external LibPng; -function png_get_iCCP(png_ptr:png_structp; info_ptr:png_infop; name:png_charpp; compression_type:PCint; profile:png_charpp; - proflen:Ppng_uint_32):png_uint_32; cdecl; external LibPng; -procedure png_set_iCCP(png_ptr:png_structp; info_ptr:png_infop; name:png_charp; compression_type:cint; profile:png_charp; - proflen:png_uint_32); cdecl; external LibPng; -function png_get_sPLT(png_ptr:png_structp; info_ptr:png_infop; entries:png_sPLT_tpp):png_uint_32; cdecl; external LibPng; -procedure png_set_sPLT(png_ptr:png_structp; info_ptr:png_infop; entries:png_sPLT_tp; nentries:cint); cdecl; external LibPng; - -(* png_get_text also returns the number of text chunks in *num_text *) -function png_get_text(png_ptr:png_structp; info_ptr:png_infop; text_ptr:Ppng_textp; num_text:PCint):png_uint_32; cdecl; external LibPng; - -(* - * Note while png_set_text() will accept a structure whose text, - * language, and translated keywords are NULL pointers, the structure - * returned by png_get_text will always contain regular - * zero-terminated C strings. They might be empty strings but - * they will never be NULL pointers. - *) -procedure png_set_text(png_ptr:png_structp; info_ptr:png_infop; text_ptr:png_textp; num_text:cint); cdecl; external LibPng; - -function png_get_tIME(png_ptr:png_structp; info_ptr:png_infop; mod_time:Ppng_timep):png_uint_32; cdecl; external LibPng; -procedure png_set_tIME(png_ptr:png_structp; info_ptr:png_infop; mod_time:png_timep); cdecl; external LibPng; -function png_get_tRNS(png_ptr:png_structp; info_ptr:png_infop; trans:Ppng_bytep; num_trans:PCint; trans_values:Ppng_color_16p):png_uint_32; cdecl; external LibPng; -procedure png_set_tRNS(png_ptr:png_structp; info_ptr:png_infop; trans:png_bytep; num_trans:cint; trans_values:png_color_16p); cdecl; external LibPng; -function png_get_sCAL(png_ptr:png_structp; info_ptr:png_infop; aunit:PCint; width:PCdouble; height:PCdouble):png_uint_32; cdecl; external LibPng; -procedure png_set_sCAL(png_ptr:png_structp; info_ptr:png_infop; aunit:cint; width:cdouble; height:cdouble); cdecl; external LibPng; -procedure png_set_sCAL_s(png_ptr:png_structp; info_ptr:png_infop; aunit:cint; swidth:png_charp; sheight:png_charp); cdecl; external LibPng; - -procedure png_set_keep_unknown_chunks(png_ptr:png_structp; keep:cint; chunk_list:png_bytep; num_chunks:cint); cdecl; external LibPng; -procedure png_set_unknown_chunks(png_ptr:png_structp; info_ptr:png_infop; unknowns:png_unknown_chunkp; num_unknowns:cint); cdecl; external LibPng; -procedure png_set_unknown_chunk_location(png_ptr:png_structp; info_ptr:png_infop; chunk:cint; location:cint); cdecl; external LibPng; -function png_get_unknown_chunks(png_ptr:png_structp; info_ptr:png_infop; entries:png_unknown_chunkpp):png_uint_32; cdecl; external LibPng; - -procedure png_set_invalid(png_ptr:png_structp; info_ptr:png_infop; mask:cint); cdecl; external LibPng; - -procedure png_read_png(png_ptr:png_structp; info_ptr:png_infop; transforms:cint; params:png_voidp); cdecl; external LibPng; -procedure png_write_png(png_ptr:png_structp; info_ptr:png_infop; transforms:cint; params:png_voidp); cdecl; external LibPng; - -function png_get_header_ver(png_ptr:png_structp):png_charp; cdecl; external LibPng; -function png_get_header_version(png_ptr:png_structp):png_charp; cdecl; external LibPng; -function png_get_libpng_ver(png_ptr:png_structp):png_charp; cdecl; external LibPng; - -implementation - -end. diff --git a/src/lib/midi/MidiFile.pas b/src/lib/midi/MidiFile.pas deleted file mode 100644 index acf44c04..00000000 --- a/src/lib/midi/MidiFile.pas +++ /dev/null @@ -1,968 +0,0 @@ -{ - Load a midifile and get access to tracks and events - I did build this component to convert midifiles to wave files - or play the files on a software synthesizer which I'm currenly - building. - - version 1.0 first release - - version 1.1 - added some function - function KeyToStr(key : integer) : string; - function MyTimeToStr(val : integer) : string; - Bpm can be set to change speed - - version 1.2 - added some functions - function GetTrackLength:integer; - function Ready: boolean; - - version 1.3 - update by Chulwoong, - He knows how to use the MM timer, the timing is much better now, thank you - - for comments/bugs - F.Bouwmans - fbouwmans@spiditel.nl - - if you think this component is nice and you use it, sent me a short email. - I've seen that other of my components have been downloaded a lot, but I've - got no clue wether they are actually used. - Don't worry because you are free to use these components - - Timing has improved, however because the messages are handled by the normal - windows message loop (of the main window) it is still influenced by actions - done on the window (minimize/maximize ..). - Use of a second thread with higher priority which only handles the - timer message should increase performance. If somebody knows such a component - which is freeware please let me know. - - interface description: - - procedure ReadFile: - actually read the file which is set in Filename - - function GetTrack(index: integer) : TMidiTrack; - - property Filename - set/read filename of midifile - - property NumberOfTracks - read number of tracks in current file - - property TicksPerQuarter: integer - ticks per quarter, tells how to interpret the time value in midi events - - property FileFormat: TFileFormat - tells the format of the current midifile - - property Bpm:integer - tells Beats per minut - - property OnMidiEvent:TOnMidiEvent - called while playing for each midi event - - procedure StartPlaying; - start playing the current loaded midifile from the beginning - - procedure StopPlaying; - stop playing the current midifile - - procedure PlayToTime(time : integer); - if playing yourself then events from last time to this time are produced - - - function KeyToStr(key : integer) : string; - give note string on key value: e.g. C4 - - function MyTimeToStr(val : integer) : string; - give time string from msec time - - function GetTrackLength:integer; - gives the track lenght in msec (assuming the bpm at the start oof the file) - - function Ready: boolean; - now you can check wether the playback is finished - -} - -unit MidiFile; - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -uses - Windows, - Messages, - Classes, - {$IFDEF FPC} - WinAllocation, - {$ENDIF} - SysUtils, - UPath; - -type - TChunkType = (illegal, header, track); - TFileFormat = (single, multi_synch, multi_asynch); - PByte = ^byte; - - TMidiEvent = record - event: byte; - data1: byte; - data2: byte; - str: string; - dticks: integer; - time: integer; - mtime: integer; - len: integer; - end; - PMidiEvent = ^TMidiEvent; - - TOnMidiEvent = procedure(event: PMidiEvent) of object; - TEvent = procedure of object; - - TMidiTrack = class(TObject) - protected - events: TList; - name: string; - instrument: string; - currentTime: integer; - currentPos: integer; - ready: boolean; - trackLenght: integer; - procedure checkReady; - public - OnMidiEvent: TOnMidiEvent; - OnTrackReady: TEvent; - constructor Create; - destructor Destroy; override; - - procedure Rewind(pos: integer); - procedure PlayUntil(pos: integer); - procedure GoUntil(pos: integer); - - procedure putEvent(event: PMidiEvent); - function getEvent(index: integer): PMidiEvent; - function getName: string; - function getInstrument: string; - function getEventCount: integer; - function getCurrentTime: integer; - function getTrackLength: integer; - function isReady:boolean; - end; - - TMidiFile = class(TComponent) - private - { Private declarations } - procedure MidiTimer(sender : TObject); - procedure WndProc(var Msg : TMessage); - protected - { Protected declarations } - midiFile: TBinaryFileStream; - chunkType: TChunkType; - chunkLength: integer; - chunkData: PByte; - chunkIndex: PByte; - chunkEnd: PByte; - FPriority: DWORD; - - // midi file attributes - FFileFormat: TFileFormat; - numberTracks: integer; - deltaTicks: integer; - FBpm: integer; - FBeatsPerMeasure: integer; - FusPerTick: double; - FFilename: IPath; - - Tracks: TList; - currentTrack: TMidiTrack; - FOnMidiEvent: TOnMidiEvent; - FOnUpdateEvent: TNotifyEvent; - - // playing attributes - playing: boolean; - PlayStartTime: integer; - currentTime: integer; // Current playtime in msec - currentPos: Double; // Current Position in ticks - - procedure OnTrackReady; - procedure SetFilename(val: IPath); - procedure ReadChunkHeader; - procedure ReadChunkContent; - procedure ReadChunk; - procedure ProcessHeaderChunk; - procedure ProcessTrackChunk; - function ReadVarLength: integer; - function ReadString(l: integer): string; - procedure SetOnMidiEvent(handler: TOnMidiEvent); - procedure SetBpm(val: integer); - public - { Public declarations } - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - procedure ReadFile; - function GetTrack(index: integer): TMidiTrack; - - procedure StartPlaying; - procedure StopPlaying; - procedure ContinuePlaying; - - procedure PlayToTime(time: integer); - procedure GoToTime(time: integer); - function GetCurrentTime: integer; - function GetFusPerTick : Double; - function GetTrackLength:integer; - function Ready: boolean; - published - { Published declarations } - property Filename: IPath read FFilename write SetFilename; - property NumberOfTracks: integer read numberTracks; - property TicksPerQuarter: integer read deltaTicks; - property FileFormat: TFileFormat read FFileFormat; - property Bpm: integer read FBpm write SetBpm; - property OnMidiEvent: TOnMidiEvent read FOnMidiEvent write SetOnMidiEvent; - property OnUpdateEvent: TNotifyEvent read FOnUpdateEvent write FOnUpdateEvent; - end; - -function KeyToStr(key: integer): string; -function MyTimeToStr(val: integer): string; -procedure Register; - -implementation - -uses mmsystem; - -type -{$IFDEF FPC} - TTimerProc = TTIMECALLBACK; - TTimeCaps = TIMECAPS; -{$ELSE} - TTimerProc = TFNTimeCallBack; -{$ENDIF} - -const TIMER_RESOLUTION=10; -const WM_MULTIMEDIA_TIMER=WM_USER+127; - -var MIDIFileHandle : HWND; - TimerProc : TTimerProc; - MIDITimerID : Integer; - TimerPeriod : Integer; - -procedure TimerCallBackProc(uTimerID,uMsg: Cardinal; dwUser,dwParam1,dwParam2:DWORD);stdcall; -begin - PostMessage(HWND(dwUser),WM_MULTIMEDIA_TIMER,0,0); -end; - -procedure SetMIDITimer; - var TimeCaps : TTimeCaps; -begin - timeGetDevCaps(@TimeCaps,SizeOf(TimeCaps)); - if TIMER_RESOLUTION < TimeCaps.wPeriodMin then - TimerPeriod:=TimeCaps.wPeriodMin - else if TIMER_RESOLUTION > TimeCaps.wPeriodMax then - TimerPeriod:=TimeCaps.wPeriodMax - else - TimerPeriod:=TIMER_RESOLUTION; - - timeBeginPeriod(TimerPeriod); - MIDITimerID:=timeSetEvent(TimerPeriod,TimerPeriod,TimerProc, - DWORD(MIDIFileHandle),TIME_PERIODIC); - if MIDITimerID=0 then - timeEndPeriod(TimerPeriod); -end; - -procedure KillMIDITimer; -begin - timeKillEvent(MIDITimerID); - timeEndPeriod(TimerPeriod); -end; - -constructor TMidiTrack.Create; -begin - inherited Create; - events := TList.Create; - currentTime := 0; - currentPos := 0; -end; - -destructor TMidiTrack.Destroy; -var - i: integer; -begin - for i := 0 to events.count - 1 do - Dispose(PMidiEvent(events.items[i])); - events.Free; - inherited Destroy; -end; - -procedure TMidiTRack.putEvent(event: PMidiEvent); -var - command: integer; - i: integer; - pevent: PMidiEvent; -begin - if (event.event = $FF) then - begin - if (event.data1 = 3) then - name := event.str; - if (event.data1 = 4) then - instrument := event.str; - end; - currentTime := currentTime + event.dticks; - event.time := currentTime; // for the moment just add dticks - event.len := 0; - events.add(TObject(event)); - command := event.event and $F0; - - if ((command = $80) // note off - or ((command = $90) and (event.data2 = 0))) //note on with speed 0 - then - begin - // this is a note off, try to find the accompanion note on - command := event.event or $90; - i := events.count - 2; - while i >= 0 do - begin - pevent := PMidiEvent(events[i]); - if (pevent.event = command) and - (pevent.data1 = event.data1) - then - begin - pevent.len := currentTIme - pevent.time; - i := 0; - event.len := -1; - end; - dec(i); - end; - end; -end; - -function TMidiTrack.getName: string; -begin - result := name; -end; - -function TMidiTrack.getInstrument: string; -begin - result := instrument; -end; - -function TMiditrack.getEventCount: integer; -begin - result := events.count; -end; - -function TMiditrack.getEvent(index: integer): PMidiEvent; -begin - if ((index < events.count) and (index >= 0)) then - result := events[index] - else - result := nil; -end; - -function TMiditrack.getCurrentTime: integer; -begin - result := currentTime; -end; - -procedure TMiditrack.Rewind(pos: integer); -begin - if currentPos = events.count then - dec(currentPos); - while ((currentPos > 0) and - (PMidiEvent(events[currentPos]).time > pos)) - do - begin - dec(currentPos); - end; - checkReady; -end; - -procedure TMiditrack.PlayUntil(pos: integer); -begin - if assigned(OnMidiEvent) then - begin - while ((currentPos < events.count) and - (PMidiEvent(events[currentPos]).time < pos)) do - begin - OnMidiEvent(PMidiEvent(events[currentPos])); - inc(currentPos); - end; - end; - checkReady; -end; - -procedure TMidiTrack.GoUntil(pos: integer); -begin - while ((currentPos < events.count) and - (PMidiEvent(events[currentPos]).time < pos)) do - begin - inc(currentPos); - end; - checkReady; -end; - -procedure TMidiTrack.checkReady; -begin - if currentPos >= events.count then - begin - ready := true; - if assigned(OnTrackReady) then - OnTrackReady; - end - else - ready := false; -end; - -function TMidiTrack.getTrackLength: integer; -begin - result := PMidiEvent(events[events.count-1]).time -end; - -function TMidiTrack.isReady: boolean; -begin - result := ready; -end; - -constructor TMidifile.Create(AOwner: TComponent); -begin - inherited Create(AOWner); - MIDIFileHandle:=AllocateHWnd(WndProc); - chunkData := nil; - chunkType := illegal; - Tracks := TList.Create; - TimerProc:=@TimerCallBackProc; - FPriority:=GetPriorityClass(MIDIFileHandle); -end; - -destructor TMidifile.Destroy; -var - i: integer; -begin - if not (chunkData = nil) then FreeMem(chunkData); - for i := 0 to Tracks.Count - 1 do - TMidiTrack(Tracks.Items[i]).Free; - Tracks.Free; - SetPriorityClass(MIDIFileHandle,FPriority); - - if MIDITimerID<>0 then KillMIDITimer; - - DeallocateHWnd(MIDIFileHandle); - - inherited Destroy; -end; - -function TMidiFile.GetTrack(index: integer): TMidiTrack; -begin - result := Tracks.Items[index]; -end; - -procedure TMidifile.SetFilename(val: IPath); -begin - FFilename := val; -// ReadFile; -end; - -procedure TMidifile.SetOnMidiEvent(handler: TOnMidiEvent); -var - i: integer; -begin -// if not (FOnMidiEvent = handler) then -// begin - FOnMidiEvent := handler; - for i := 0 to tracks.count - 1 do - TMidiTrack(tracks.items[i]).OnMidiEvent := handler; -// end; -end; - -{$WARNINGS OFF} -procedure TMidifile.MidiTimer(Sender: TObject); -begin - if playing then - begin - PlayToTime(GetTickCount - PlayStartTime); - if assigned(FOnUpdateEvent) then FOnUpdateEvent(self); - end; -end; -{$WARNINGS ON} - -procedure TMidifile.StartPlaying; -var - i: integer; -begin - for i := 0 to tracks.count - 1 do - TMidiTrack(tracks[i]).Rewind(0); - playStartTime := getTickCount; - playing := true; - - SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS); - - SetMIDITimer; - currentPos := 0.0; - currentTime := 0; -end; - -{$WARNINGS OFF} -procedure TMidifile.ContinuePlaying; -begin - PlayStartTime := GetTickCount - currentTime; - playing := true; - - SetPriorityClass(MIDIFileHandle,REALTIME_PRIORITY_CLASS); - - SetMIDITimer; -end; -{$WARNINGS ON} - -procedure TMidifile.StopPlaying; -begin - playing := false; - KillMIDITimer; - SetPriorityClass(MIDIFileHandle,FPriority); -end; - -function TMidiFile.GetCurrentTime: integer; -begin - Result := currentTime; -end; - -procedure TMidifile.PlayToTime(time: integer); -var - i: integer; - track: TMidiTrack; - pos: integer; - deltaTime: integer; -begin - // calculate the pos in the file. - // pos is actually tick - // Current FusPerTick is uses to determine the actual pos - - deltaTime := time - currentTime; - currentPos := currentPos + (deltaTime * 1000) / FusPerTick; - pos := round(currentPos); - - for i := 0 to tracks.count - 1 do - begin - TMidiTrack(tracks.items[i]).PlayUntil(pos); - end; - currentTime := time; -end; - -procedure TMidifile.GoToTime(time: integer); -var - i: integer; - track: TMidiTrack; - pos: integer; -begin - // this function should be changed because FusPerTick might not be constant - pos := round((time * 1000) / FusPerTick); - for i := 0 to tracks.count - 1 do - begin - TMidiTrack(tracks.items[i]).Rewind(0); - TMidiTrack(tracks.items[i]).GoUntil(pos); - end; -end; - -procedure TMidifile.SetBpm(val: integer); -var - us_per_quarter: integer; -begin - if not (val = FBpm) then - begin - us_per_quarter := 60000000 div val; - - FBpm := 60000000 div us_per_quarter; - FusPerTick := us_per_quarter / deltaTicks; - end; -end; - -procedure TMidifile.ReadChunkHeader; -var - theByte: array[0..7] of byte; -begin - midiFile.Read(theByte[0], 8); - if (theByte[0] = $4D) and (theByte[1] = $54) then - begin - if (theByte[2] = $68) and (theByte[3] = $64) then - chunkType := header - else if (theByte[2] = $72) and (theByte[3] = $6B) then - chunkType := track - else - chunkType := illegal; - end - else - begin - chunkType := illegal; - end; - chunkLength := theByte[7] + theByte[6] * $100 + theByte[5] * $10000 + theByte[4] * $1000000; -end; - -procedure TMidifile.ReadChunkContent; -begin - if not (chunkData = nil) then - FreeMem(chunkData); - GetMem(chunkData, chunkLength + 10); - midiFile.Read(chunkData^, chunkLength); - chunkIndex := chunkData; - chunkEnd := PByte(integer(chunkIndex) + integer(chunkLength) - 1); -end; - -procedure TMidifile.ReadChunk; -begin - ReadChunkHeader; - ReadChunkContent; - case chunkType of - header: - ProcessHeaderChunk; - track: - ProcessTrackCHunk; - end; -end; - -procedure TMidifile.ProcessHeaderChunk; -begin - chunkIndex := chunkData; - inc(chunkIndex); - if chunkType = header then - begin - case chunkIndex^ of - 0: FfileFormat := single; - 1: FfileFormat := multi_synch; - 2: FfileFormat := multi_asynch; - end; - inc(chunkIndex); - numberTracks := chunkIndex^ * $100; - inc(chunkIndex); - numberTracks := numberTracks + chunkIndex^; - inc(chunkIndex); - deltaTicks := chunkIndex^ * $100; - inc(chunkIndex); - deltaTicks := deltaTicks + chunkIndex^; - end; -end; - -procedure TMidifile.ProcessTrackChunk; -var - dTime: integer; - event: integer; - len: integer; - str: string; - midiEvent: PMidiEvent; - i: integer; - us_per_quarter: integer; -begin - chunkIndex := chunkData; -// inc(chunkIndex); - event := 0; - if chunkType = track then - begin - currentTrack := TMidiTrack.Create; - currentTrack.OnMidiEvent := FOnMidiEvent; - Tracks.add(currentTrack); - while integer(chunkIndex) < integer(chunkEnd) do - begin - // each event starts with var length delta time - dTime := ReadVarLength; - if chunkIndex^ >= $80 then - begin - event := chunkIndex^; - inc(chunkIndex); - end; - // else it is a running status event (just the same event as before) - - if event = $FF then - begin -{ case chunkIndex^ of - $00: // sequence number, not implemented jet - begin - inc(chunkIndex); // $02 - inc(chunkIndex); - end; - $01 .. $0f: // text events FF ty len text - begin - New(midiEvent); - midiEvent.event := $FF; - midiEvent.data1 := chunkIndex^; // type is stored in data1 - midiEvent.dticks := dtime; - - inc(chunkIndex); - len := ReadVarLength; - midiEvent.str := ReadString(len); - - currentTrack.putEvent(midiEvent); - end; - $20: // Midi channel prefix FF 20 01 cc - begin - inc(chunkIndex); // $01 - inc(chunkIndex); // channel - inc(chunkIndex); - end; - $2F: // End of track FF 2F 00 - begin - inc(chunkIndex); // $00 - inc(chunkIndex); - end; - $51: // Set Tempo FF 51 03 tttttt - begin - inc(chunkIndex); // $03 - inc(chunkIndex); // tt - inc(chunkIndex); // tt - inc(chunkIndex); // tt - inc(chunkIndex); - end; - $54: // SMPTE offset FF 54 05 hr mn se fr ff - begin - inc(chunkIndex); // $05 - inc(chunkIndex); // hr - inc(chunkIndex); // mn - inc(chunkIndex); // se - inc(chunkIndex); // fr - inc(chunkIndex); // ff - inc(chunkIndex); - end; - $58: // Time signature FF 58 04 nn dd cc bb - begin - inc(chunkIndex); // $04 - inc(chunkIndex); // nn - inc(chunkIndex); // dd - inc(chunkIndex); // cc - inc(chunkIndex); // bb - inc(chunkIndex); - end; - $59: // Key signature FF 59 02 df mi - begin - inc(chunkIndex); // $02 - inc(chunkIndex); // df - inc(chunkIndex); // mi - inc(chunkIndex); - end; - $7F: // Sequence specific Meta-event - begin - inc(chunkIndex); - len := ReadVarLength; - str := ReadString(len); - end; - else // unknown meta event - } - begin - New(midiEvent); - midiEvent.event := $FF; - midiEvent.data1 := chunkIndex^; // type is stored in data1 - midiEvent.dticks := dtime; - - inc(chunkIndex); - len := ReadVarLength; - midiEvent.str := ReadString(len); - currentTrack.putEvent(midiEvent); - - case midiEvent.data1 of - $51: - begin - us_per_quarter := - (integer(byte(midiEvent.str[1])) shl 16 + - integer(byte(midiEvent.str[2])) shl 8 + - integer(byte(midiEvent.str[3]))); - FBpm := 60000000 div us_per_quarter; - FusPerTick := us_per_quarter / deltaTicks; - end; - end; - end; -// end; - end - else - begin - // these are all midi events - New(midiEvent); - midiEvent.event := event; - midiEvent.dticks := dtime; -// inc(chunkIndex); - case event of - $80..$8F, // note off - $90..$9F, // note on - $A0..$AF, // key aftertouch - $B0..$BF, // control change - $E0..$EF: // pitch wheel change - begin - midiEvent.data1 := chunkIndex^; inc(chunkIndex); - midiEvent.data2 := chunkIndex^; inc(chunkIndex); - end; - $C0..$CF, // program change - $D0..$DF: // channel aftertouch - begin - midiEvent.data1 := chunkIndex^; inc(chunkIndex); - end; - else - // error - end; - currentTrack.putEvent(midiEvent); - end; - end; - end; -end; - - -function TMidifile.ReadVarLength: integer; -var - i: integer; - b: byte; -begin - b := 128; - i := 0; - while b > 127 do - begin - i := i shl 7; - b := chunkIndex^; - i := i + b and $7F; - inc(chunkIndex); - end; - result := i; -end; - -function TMidifile.ReadString(l: integer): string; -var - s: PChar; - i: integer; -begin - GetMem(s, l + 1); ; - s[l] := chr(0); - for i := 0 to l - 1 do - begin - s[i] := Chr(chunkIndex^); - inc(chunkIndex); - end; - result := string(s); -end; - -procedure TMidifile.ReadFile; -var - i: integer; -begin - for i := 0 to Tracks.Count - 1 do - TMidiTrack(Tracks.Items[i]).Free; - Tracks.Clear; - chunkType := illegal; - - midiFile := TBinaryFileStream.Create(FFilename, fmOpenRead); - while (midiFile.Position < midiFile.Size) do - ReadChunk; - FreeAndNil(midiFile); - numberTracks := Tracks.Count; -end; - -function KeyToStr(key: integer): string; -var - n: integer; - str: string; -begin - n := key mod 12; - case n of - 0: str := 'C'; - 1: str := 'C#'; - 2: str := 'D'; - 3: str := 'D#'; - 4: str := 'E'; - 5: str := 'F'; - 6: str := 'F#'; - 7: str := 'G'; - 8: str := 'G#'; - 9: str := 'A'; - 10: str := 'A#'; - 11: str := 'B'; - end; - Result := str + IntToStr(key div 12); -end; - -function IntToLenStr(val: integer; len: integer): string; -var - str: string; -begin - str := IntToStr(val); - while Length(str) < len do - str := '0' + str; - Result := str; -end; - -function MyTimeToStr(val: integer): string; - var - hour: integer; - min: integer; - sec: integer; - msec: integer; -begin - msec := val mod 1000; - sec := val div 1000; - min := sec div 60; - sec := sec mod 60; - hour := min div 60; - min := min mod 60; - Result := IntToStr(hour) + ':' + IntToLenStr(min, 2) + ':' + IntToLenStr(sec, 2) + '.' + IntToLenStr(msec, 3); -end; - -function TMidiFIle.GetFusPerTick : Double; -begin - Result := FusPerTick; -end; - -function TMidiFIle.GetTrackLength:integer; -var i,length : integer; - time : extended; -begin - length := 0; - for i := 0 to Tracks.Count - 1 do - if TMidiTrack(Tracks.Items[i]).getTrackLength > length then - length := TMidiTrack(Tracks.Items[i]).getTrackLength; - time := length * FusPerTick; - time := time / 1000.0; - result := round(time); -end; - -function TMidiFIle.Ready: boolean; -var i : integer; -begin - result := true; - for i := 0 to Tracks.Count - 1 do - if not TMidiTrack(Tracks.Items[i]).isready then - result := false; -end; - -procedure TMidiFile.OnTrackReady; -begin - if ready then - if assigned(FOnUpdateEvent) then FOnUpdateEvent(self); -end; - -procedure TMidiFile.WndProc(var Msg : TMessage); -begin - with MSG do - begin - case Msg of - WM_MULTIMEDIA_TIMER: - begin - //try - MidiTimer(self); - //except - // Note: HandleException() is called by default if exception is not handled - // Application.HandleException(Self); - //end; - end; - else - begin - Result := DefWindowProc(MIDIFileHandle, Msg, wParam, lParam); - end; - end; - end; -end; - -procedure Register; -begin - RegisterComponents('Synth', [TMidiFile]); -end; - -end. - diff --git a/src/lib/midi/MidiScope.pas b/src/lib/midi/MidiScope.pas deleted file mode 100644 index afc20b0f..00000000 --- a/src/lib/midi/MidiScope.pas +++ /dev/null @@ -1,198 +0,0 @@ -{ - Shows a large black area where midi note/controller events are shown - just to monitor midi activity (for the MidiPlayer) - - version 1.0 first release - - for comments/bugs - F.Bouwmans - fbouwmans@spiditel.nl - - if you think this component is nice and you use it, sent me a short email. - I've seen that other of my components have been downloaded a lot, but I've - got no clue wether they are actually used. - Don't worry because you are free to use these components -} - -unit MidiScope; - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs; - -type - TMidiScope = class(TGraphicControl) - private - { Private declarations } - protected - { Protected declarations } - notes : array[0..15,0..127] of integer; - controllers : array[0..15,0..17] of integer; - aftertouch : array[0..15,0..127] of integer; - - selectedChannel : integer; - - procedure PaintSlide(ch,pos,val: integer); - - procedure NoteOn(channel, note, speed : integer); - procedure Controller(channel,number,value : integer); - procedure AfterTch(channel, note, value : integer); - - public - { Public declarations } - constructor Create(AOwner: TComponent); override; - procedure MidiEvent(event,data1,data2 : integer); - procedure Paint; override; - published - { Published declarations } - end; - - -procedure Register; - -const - BarHeight = 16; - BarHeightInc = BarHeight+2; - BarWidth = 3; - BarWidthInc = BarWidth+1; - HeightDiv = 128 div BarHeight; - -implementation - -uses Midicons; - -procedure Register; -begin - RegisterComponents('Synth', [TMidiScope]); -end; - -constructor TMidiScope.Create(AOwner: TComponent); -var - i,j : integer; -begin - inherited Create(AOwner); - Height := BarHeightinc * 16 + 4; - Width := 147*BarWidthInc + 4 + 20; // for channel number - for i := 0 to 15 do - begin - for j := 0 to 127 do - begin - notes[i,j] := 0; - aftertouch[i,j] := 0; - end; - end; - for i := 0 to 17 do - begin - for j := 0 to 15 do - controllers[i,j] := 0; - end; -end; - -procedure TMidiScope.PaintSlide(ch,pos,val: integer); -var x,y:integer; -begin - Canvas.Brush.Color := clBlack; - Canvas.Pen.color := clBlack; - x := pos * BarWidthInc + 2; - y := 2 + ch * BarHeightInc; - Canvas.Rectangle(x, y, x+BarWidthInc, y+BarHeightInc); - Canvas.Brush.Color := clGreen; - Canvas.Pen.Color := clGreen; - Canvas.Rectangle(x, y + (BarHeight - (val div HeightDiv )), x + BarWidth, y + BarHeight) -end; - -procedure TMidiScope.Paint; -var i,j : integer; -x : integer; -begin - Canvas.Brush.color := clBlack; - Canvas.Rectangle(0,0,Width,Height); - Canvas.Pen.Color := clGreen; - x := 128*BarWidthInc+2; - Canvas.MoveTo(x,0); - Canvas.LineTo(x,Height); - x := 148*BarWIdthInc+2; - canvas.Font.Color := clGreen; - for i := 0 to 15 do - Canvas.TextOut(x,((i+1)*BarHeightInc) - Canvas.font.size-3,IntToStr(i+1)); - canvas.Pen.color := clBlack; - begin - for j := 0 to 127 do - begin - PaintSlide(i,j,notes[i,j]); - end; - for j := 0 to 17 do - begin - PaintSlide(i,j+129,controllers[i,j]); - end; - end; -end; -procedure TMidiScope.NoteOn(channel, note, speed : integer); -begin - notes[channel,note] := speed; - PaintSlide(channel,note,notes[channel,note]); -end; -procedure TMidiScope.AfterTch(channel, note, value : integer); -begin - aftertouch[channel,note] := value; -end; - -procedure TMidiScope.Controller(channel,number,value : integer); -var i : integer; -begin - if number < 18 then - begin - controllers[channel,number] := value; - PaintSlide(channel,number+129,value); - end - else if number >= $7B then - begin - // all notes of for channel - for i := 0 to 127 do - begin - if notes[channel,i] > 0 then - begin - notes[channel,i] := 0; - PaintSlide(channel,i,0); - end; - end; - end; -end; - -procedure TMidiScope.MidiEvent(event,data1,data2 : integer); -begin - case (event AND $F0) of - MIDI_NOTEON : - begin - NoteOn((event AND $F),data1,data2); - end; - MIDI_NOTEOFF: - begin - NoteOn((event AND $F),data1,0); - end; - MIDI_CONTROLCHANGE : - begin - Controller((event AND $F),data1,data2); - end; - MIDI_CHANAFTERTOUCH: - begin - Controller((Event AND $F),16,Data1); - end; - MIDI_PITCHBEND: - begin - begin - Controller((Event AND $F),17,data2); - end; - end; - MIDI_KEYAFTERTOUCH: - begin - end; - end; -end; -end. diff --git a/src/lib/midi/Midicons.pas b/src/lib/midi/Midicons.pas deleted file mode 100644 index 72259beb..00000000 --- a/src/lib/midi/Midicons.pas +++ /dev/null @@ -1,47 +0,0 @@ -{ $Header: /MidiComp/MIDICONS.PAS 2 10/06/97 7:33 Davec $ } - -{ Written by David Churcher , - released to the public domain. } - - -{ MIDI Constants } -unit Midicons; - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -uses Messages; - -const - MIDI_ALLNOTESOFF = $7B; - MIDI_NOTEON = $90; - MIDI_NOTEOFF = $80; - MIDI_KEYAFTERTOUCH = $a0; - MIDI_CONTROLCHANGE = $b0; - MIDI_PROGRAMCHANGE = $c0; - MIDI_CHANAFTERTOUCH = $d0; - MIDI_PITCHBEND = $e0; - MIDI_SYSTEMMESSAGE = $f0; - MIDI_BEGINSYSEX = $f0; - MIDI_MTCQUARTERFRAME = $f1; - MIDI_SONGPOSPTR = $f2; - MIDI_SONGSELECT = $f3; - MIDI_ENDSYSEX = $F7; - MIDI_TIMINGCLOCK = $F8; - MIDI_START = $FA; - MIDI_CONTINUE = $FB; - MIDI_STOP = $FC; - MIDI_ACTIVESENSING = $FE; - MIDI_SYSTEMRESET = $FF; - - MIM_OVERFLOW = WM_USER; { Input buffer overflow } - MOM_PLAYBACK_DONE = WM_USER+1; { Timed playback complete } - - -implementation - -end. diff --git a/src/lib/midi/Midiin.pas b/src/lib/midi/Midiin.pas deleted file mode 100644 index 66e4f76d..00000000 --- a/src/lib/midi/Midiin.pas +++ /dev/null @@ -1,727 +0,0 @@ -{ $Header: /MidiComp/Midiin.pas 2 10/06/97 7:33 Davec $ } - -{ Written by David Churcher , - released to the public domain. } - -unit MidiIn; - -{ - Properties: - DeviceID: Windows numeric device ID for the MIDI input device. - Between 0 and NumDevs-1. - Read-only while device is open, exception when changed while open - - MIDIHandle: The input handle to the MIDI device. - 0 when device is not open - Read-only, runtime-only - - MessageCount: Number of input messages waiting in input buffer - - Capacity: Number of messages input buffer can hold - Defaults to 1024 - Limited to (64K/event size) - Read-only when device is open (exception when changed while open) - - SysexBufferSize: Size in bytes of each sysex buffer - Defaults to 10K - Minimum 0K (no buffers), Maximum 64K-1 - - SysexBufferCount: Number of sysex buffers - Defaults to 16 - Minimum 0 (no buffers), Maximum (avail mem/SysexBufferSize) - Check where these buffers are allocated? - - SysexOnly: True to ignore all non-sysex input events. May be changed while - device is open. Handy for patch editors where you have lots of short MIDI - events on the wire which you are always going to ignore anyway. - - DriverVersion: Version number of MIDI device driver. High-order byte is - major version, low-order byte is minor version. - - ProductName: Name of product (e.g. 'MPU 401 In') - - MID and PID: Manufacturer ID and Product ID, see - "Manufacturer and Product IDs" in MMSYSTEM.HLP for list of possible values. - - Methods: - GetMidiEvent: Read Midi event at the head of the FIFO input buffer. - Returns a TMyMidiEvent object containing MIDI message data, timestamp, - and sysex data if applicable. - This method automatically removes the event from the input buffer. - It makes a copy of the received sysex buffer and puts the buffer back - on the input device. - The TMyMidiEvent object must be freed by calling MyMidiEvent.Free. - - Open: Opens device. Note no input will appear until you call the Start - method. - - Close: Closes device. Any pending system exclusive output will be cancelled. - - Start: Starts receiving MIDI input. - - Stop: Stops receiving MIDI input. - - Events: - OnMidiInput: Called when MIDI input data arrives. Use the GetMidiEvent to - get the MIDI input data. - - OnOverflow: Called if the MIDI input buffer overflows. The caller must - clear the buffer before any more MIDI input can be received. - - Notes: - Buffering: Uses a circular buffer, separate pointers for next location - to fill and next location to empty because a MIDI input interrupt may - be adding data to the buffer while the buffer is being read. Buffer - pointers wrap around from end to start of buffer automatically. If - buffer overflows then the OnBufferOverflow event is triggered and no - further input will be received until the buffer is emptied by calls - to GetMidiEvent. - - Sysex buffers: There are (SysexBufferCount) buffers on the input device. - When sysex events arrive these buffers are removed from the input device and - added to the circular buffer by the interrupt handler in the DLL. When the sysex events - are removed from the circular buffer by the GetMidiEvent method the buffers are - put back on the input. If all the buffers are used up there will be no - more sysex input until at least one sysex event is removed from the input buffer. - In other words if you're expecting lots of sysex input you need to set the - SysexBufferCount property high enough so that you won't run out of - input buffers before you get a chance to read them with GetMidiEvent. - - If the synth sends a block of sysex that's longer than SysexBufferSize it - will be received as separate events. - TODO: Component derived from this one that handles >64K sysex blocks cleanly - and can stream them to disk. - - Midi Time Code (MTC) and Active Sensing: The DLL is currently hardcoded - to filter these short events out, so that we don't spend all our time - processing them. - TODO: implement a filter property to select the events that will be filtered - out. -} - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -uses - Classes, - SysUtils, - Messages, - Windows, - MMSystem, - {$IFDEF FPC} - WinAllocation, - {$ENDIF} - MidiDefs, - MidiType, - MidiCons, - Circbuf, - Delphmcb; - -type - MidiInputState = (misOpen, misClosed, misCreating, misDestroying); - EMidiInputError = class(Exception); - - {-------------------------------------------------------------------} - TMidiInput = class(TComponent) - private - Handle: THandle; { Window handle used for callback notification } - FDeviceID: Word; { MIDI device ID } - FMIDIHandle: HMIDIIn; { Handle to input device } - FState: MidiInputState; { Current device state } - - FError: Word; - FSysexOnly: Boolean; - - { Stuff from MIDIINCAPS } - FDriverVersion: MMVERSION; - FProductName: string; - FMID: Word; { Manufacturer ID } - FPID: Word; { Product ID } - - { Queue } - FCapacity: Word; { Buffer capacity } - PBuffer: PCircularBuffer; { Low-level MIDI input buffer created by Open method } - FNumdevs: Word; { Number of input devices on system } - - { Events } - FOnMIDIInput: TNotifyEvent; { MIDI Input arrived } - FOnOverflow: TNotifyEvent; { Input buffer overflow } - { TODO: Some sort of error handling event for MIM_ERROR } - - { Sysex } - FSysexBufferSize: Word; - FSysexBufferCount: Word; - MidiHdrs: Tlist; - - PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL } - - protected - procedure Prepareheaders; - procedure UnprepareHeaders; - procedure AddBuffers; - procedure SetDeviceID(DeviceID: Word); - procedure SetProductName(NewProductName: string); - function GetEventCount: Word; - procedure SetSysexBufferSize(BufferSize: Word); - procedure SetSysexBufferCount(BufferCount: Word); - procedure SetSysexOnly(bSysexOnly: Boolean); - function MidiInErrorString(WError: Word): string; - - public - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - property MIDIHandle: HMIDIIn read FMIDIHandle; - - property DriverVersion: MMVERSION read FDriverVersion; - property MID: Word read FMID; { Manufacturer ID } - property PID: Word read FPID; { Product ID } - - property Numdevs: Word read FNumdevs; - - property MessageCount: Word read GetEventCount; - { TODO: property to select which incoming messages get filtered out } - - procedure Open; - procedure Close; - procedure Start; - procedure Stop; - { Get first message in input queue } - function GetMidiEvent: TMyMidiEvent; - procedure MidiInput(var Message: TMessage); - - { Some functions to decode and classify incoming messages would be good } - - published - - { TODO: Property editor with dropdown list of product names } - property ProductName: string read FProductName write SetProductName; - - property DeviceID: Word read FDeviceID write SetDeviceID default 0; - property Capacity: Word read FCapacity write FCapacity default 1024; - property Error: Word read FError; - property SysexBufferSize: Word - read FSysexBufferSize - write SetSysexBufferSize - default 10000; - property SysexBufferCount: Word - read FSysexBufferCount - write SetSysexBufferCount - default 16; - property SysexOnly: Boolean - read FSysexOnly - write SetSysexOnly - default False; - - { Events } - property OnMidiInput: TNotifyEvent read FOnMidiInput write FOnMidiInput; - property OnOverflow: TNotifyEvent read FOnOverflow write FOnOverflow; - - end; - -procedure Register; - -{====================================================================} -implementation - -uses Controls, - Graphics; - -(* Not used in Delphi 3 -{ This is the callback procedure in the external DLL. - It's used when midiInOpen is called by the Open method. - There are special requirements and restrictions for this callback - procedure (see midiInOpen in MMSYSTEM.HLP) so it's impractical to - make it an object method } -{$IFDEF WIN32} -function midiHandler( - hMidiIn: HMidiIn; - wMsg: UINT; - dwInstance: DWORD; - dwParam1: DWORD; - dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL'; -{$ELSE} -procedure midiHandler( - hMidiIn: HMidiIn; - wMsg: Word; - dwInstance: DWORD; - dwParam1: DWORD; - dwParam2: DWORD); far; external 'DELPHMID'; -{$ENDIF} -*) -{-------------------------------------------------------------------} - -constructor TMidiInput.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FState := misCreating; - - FSysexOnly := False; - FNumDevs := midiInGetNumDevs; - MidiHdrs := nil; - - { Set defaults } - if (FNumDevs > 0) then - SetDeviceID(0); - FCapacity := 1024; - FSysexBufferSize := 4096; - FSysexBufferCount := 16; - - { Create the window for callback notification } - if not (csDesigning in ComponentState) then - begin - Handle := AllocateHwnd(MidiInput); - end; - - FState := misClosed; - -end; - -{-------------------------------------------------------------------} -{ Close the device if it's open } - -destructor TMidiInput.Destroy; -begin - if (FMidiHandle <> 0) then - begin - Close; - FMidiHandle := 0; - end; - - if (PCtlInfo <> nil) then - GlobalSharedLockedFree(PCtlinfo^.hMem, PCtlInfo); - - DeallocateHwnd(Handle); - inherited Destroy; -end; - -{-------------------------------------------------------------------} -{ Convert the numeric return code from an MMSYSTEM function to a string - using midiInGetErrorText. TODO: These errors aren't very helpful - (e.g. "an invalid parameter was passed to a system function") so - sort out some proper error strings. } - -function TMidiInput.MidiInErrorString(WError: Word): string; -var - errorDesc: PChar; -begin - errorDesc := nil; - try - errorDesc := StrAlloc(MAXERRORLENGTH); - if midiInGetErrorText(WError, errorDesc, MAXERRORLENGTH) = 0 then - result := StrPas(errorDesc) - else - result := 'Specified error number is out of range'; - finally - if errorDesc <> nil then StrDispose(errorDesc); - end; -end; - -{-------------------------------------------------------------------} -{ Set the sysex buffer size, fail if device is already open } - -procedure TMidiInput.SetSysexBufferSize(BufferSize: Word); -begin - if FState = misOpen then - raise EMidiInputError.Create('Change to SysexBufferSize while device was open') - else - { TODO: Validate the sysex buffer size. Is this necessary for WIN32? } - FSysexBufferSize := BufferSize; -end; - -{-------------------------------------------------------------------} -{ Set the sysex buffer count, fail if device is already open } - -procedure TMidiInput.SetSysexBuffercount(Buffercount: Word); -begin - if FState = misOpen then - raise EMidiInputError.Create('Change to SysexBuffercount while device was open') - else - { TODO: Validate the sysex buffer count } - FSysexBuffercount := Buffercount; -end; - -{-------------------------------------------------------------------} -{ Set the Sysex Only flag to eliminate unwanted short MIDI input messages } - -procedure TMidiInput.SetSysexOnly(bSysexOnly: Boolean); -begin - FSysexOnly := bSysexOnly; - { Update the interrupt handler's copy of this property } - if PCtlInfo <> nil then - PCtlInfo^.SysexOnly := bSysexOnly; -end; - -{-------------------------------------------------------------------} -{ Set the Device ID to select a new MIDI input device - Note: If no MIDI devices are installed, throws an 'Invalid Device ID' exception } - -procedure TMidiInput.SetDeviceID(DeviceID: Word); -var - MidiInCaps: TMidiInCaps; -begin - if FState = misOpen then - raise EMidiInputError.Create('Change to DeviceID while device was open') - else - if (DeviceID >= midiInGetNumDevs) then - raise EMidiInputError.Create('Invalid device ID') - else - begin - FDeviceID := DeviceID; - - { Set the name and other MIDIINCAPS properties to match the ID } - FError := - midiInGetDevCaps(DeviceID, @MidiInCaps, sizeof(TMidiInCaps)); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - - FProductName := StrPas(MidiInCaps.szPname); - FDriverVersion := MidiInCaps.vDriverVersion; - FMID := MidiInCaps.wMID; - FPID := MidiInCaps.wPID; - - end; -end; - -{-------------------------------------------------------------------} -{ Set the product name and put the matching input device number in FDeviceID. - This is handy if you want to save a configured input/output device - by device name instead of device number, because device numbers may - change if users add or remove MIDI devices. - Exception if input device with matching name not found, - or if input device is open } - -procedure TMidiInput.SetProductName(NewProductName: string); -var - MidiInCaps: TMidiInCaps; - testDeviceID: Word; - testProductName: string; -begin - if FState = misOpen then - raise EMidiInputError.Create('Change to ProductName while device was open') - else - { Don't set the name if the component is reading properties because - the saved Productname will be from the machine the application was compiled - on, which may not be the same for the corresponding DeviceID on the user's - machine. The FProductname property will still be set by SetDeviceID } - if not (csLoading in ComponentState) then - begin - begin - for testDeviceID := 0 to (midiInGetNumDevs - 1) do - begin - FError := - midiInGetDevCaps(testDeviceID, @MidiInCaps, sizeof(TMidiInCaps)); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - testProductName := StrPas(MidiInCaps.szPname); - if testProductName = NewProductName then - begin - FProductName := NewProductName; - Break; - end; - end; - if FProductName <> NewProductName then - raise EMidiInputError.Create('MIDI Input Device ' + - NewProductName + ' not installed ') - else - SetDeviceID(testDeviceID); - end; - end; -end; - - -{-------------------------------------------------------------------} -{ Get the sysex buffers ready } - -procedure TMidiInput.PrepareHeaders; -var - ctr: Word; - MyMidiHdr: TMyMidiHdr; -begin - if (FSysexBufferCount > 0) and (FSysexBufferSize > 0) - and (FMidiHandle <> 0) then - begin - Midihdrs := TList.Create; - for ctr := 1 to FSysexBufferCount do - begin - { Initialize the header and allocate buffer memory } - MyMidiHdr := TMyMidiHdr.Create(FSysexBufferSize); - - { Store the address of the MyMidiHdr object in the contained MIDIHDR - structure so we can get back to the object when a pointer to the - MIDIHDR is received. - E.g. see TMidiOutput.Output method } - MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr); - - { Get MMSYSTEM's blessing for this header } - FError := midiInPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer, - sizeof(TMIDIHDR)); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - - { Save it in our list } - MidiHdrs.Add(MyMidiHdr); - end; - end; - -end; - -{-------------------------------------------------------------------} -{ Clean up from PrepareHeaders } - -procedure TMidiInput.UnprepareHeaders; -var - ctr: Word; -begin - if (MidiHdrs <> nil) then { will be Nil if 0 sysex buffers } - begin - for ctr := 0 to MidiHdrs.Count - 1 do - begin - FError := midiInUnprepareHeader(FMidiHandle, - TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer, - sizeof(TMIDIHDR)); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - TMyMidiHdr(MidiHdrs.Items[ctr]).Free; - end; - MidiHdrs.Free; - MidiHdrs := nil; - end; -end; - -{-------------------------------------------------------------------} -{ Add sysex buffers, if required, to input device } - -procedure TMidiInput.AddBuffers; -var - ctr: Word; -begin - if MidiHdrs <> nil then { will be Nil if 0 sysex buffers } - begin - if MidiHdrs.Count > 0 then - begin - for ctr := 0 to MidiHdrs.Count - 1 do - begin - FError := midiInAddBuffer(FMidiHandle, - TMyMidiHdr(MidiHdrs.Items[ctr]).hdrPointer, - sizeof(TMIDIHDR)); - if FError <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - end; - end; - end; -end; - -{-------------------------------------------------------------------} - -procedure TMidiInput.Open; -var - hMem: THandle; -begin - try - { Create the buffer for the MIDI input messages } - if (PBuffer = nil) then - PBuffer := CircBufAlloc(FCapacity); - - { Create the control info for the DLL } - if (PCtlInfo = nil) then - begin - PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem); - PctlInfo^.hMem := hMem; - end; - PctlInfo^.pBuffer := PBuffer; - Pctlinfo^.hWindow := Handle; { Control's window handle } - PCtlInfo^.SysexOnly := FSysexOnly; - FError := midiInOpen(@FMidiHandle, FDeviceId, - DWORD(@midiHandler), - DWORD(PCtlInfo), - CALLBACK_FUNCTION); - - if (FError <> MMSYSERR_NOERROR) then - { TODO: use CreateFmtHelp to add MIDI device name/ID to message } - raise EMidiInputError.Create(MidiInErrorString(FError)); - - { Get sysex buffers ready } - PrepareHeaders; - - { Add them to the input } - AddBuffers; - - FState := misOpen; - - except - if PBuffer <> nil then - begin - CircBufFree(PBuffer); - PBuffer := nil; - end; - - if PCtlInfo <> nil then - begin - GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo); - PCtlInfo := nil; - end; - - end; - -end; - -{-------------------------------------------------------------------} - -function TMidiInput.GetMidiEvent: TMyMidiEvent; -var - thisItem: TMidiBufferItem; -begin - if (FState = misOpen) and - CircBufReadEvent(PBuffer, @thisItem) then - begin - Result := TMyMidiEvent.Create; - with thisItem do - begin - Result.Time := Timestamp; - if (Sysex = nil) then - begin - { Short message } - Result.MidiMessage := LoByte(LoWord(Data)); - Result.Data1 := HiByte(LoWord(Data)); - Result.Data2 := LoByte(HiWord(Data)); - Result.Sysex := nil; - Result.SysexLength := 0; - end - else - { Long Sysex message } - begin - Result.MidiMessage := MIDI_BEGINSYSEX; - Result.Data1 := 0; - Result.Data2 := 0; - Result.SysexLength := Sysex^.dwBytesRecorded; - if Sysex^.dwBytesRecorded <> 0 then - begin - { Put a copy of the sysex buffer in the object } - GetMem(Result.Sysex, Sysex^.dwBytesRecorded); - StrMove(Result.Sysex, Sysex^.lpData, Sysex^.dwBytesRecorded); - end; - - { Put the header back on the input buffer } - FError := midiInPrepareHeader(FMidiHandle, Sysex, - sizeof(TMIDIHDR)); - if Ferror = 0 then - FError := midiInAddBuffer(FMidiHandle, - Sysex, sizeof(TMIDIHDR)); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - end; - end; - CircbufRemoveEvent(PBuffer); - end - else - { Device isn't open, return a nil event } - Result := nil; -end; - -{-------------------------------------------------------------------} - -function TMidiInput.GetEventCount: Word; -begin - if FState = misOpen then - Result := PBuffer^.EventCount - else - Result := 0; -end; - -{-------------------------------------------------------------------} - -procedure TMidiInput.Close; -begin - if FState = misOpen then - begin - FState := misClosed; - - { MidiInReset cancels any pending output. - Note that midiInReset causes an MIM_LONGDATA callback for each sysex - buffer on the input, so the callback function and Midi input buffer - should still be viable at this stage. - All the resulting MIM_LONGDATA callbacks will be completed by the time - MidiInReset returns, though. } - FError := MidiInReset(FMidiHandle); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - - { Remove sysex buffers from input device and free them } - UnPrepareHeaders; - - { Close the device (finally!) } - FError := MidiInClose(FMidiHandle); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - - FMidiHandle := 0; - - if (PBuffer <> nil) then - begin - CircBufFree(PBuffer); - PBuffer := nil; - end; - end; -end; - -{-------------------------------------------------------------------} - -procedure TMidiInput.Start; -begin - if FState = misOpen then - begin - FError := MidiInStart(FMidiHandle); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - end; -end; - -{-------------------------------------------------------------------} - -procedure TMidiInput.Stop; -begin - if FState = misOpen then - begin - FError := MidiInStop(FMidiHandle); - if Ferror <> MMSYSERR_NOERROR then - raise EMidiInputError.Create(MidiInErrorString(FError)); - end; -end; - -{-------------------------------------------------------------------} - -procedure TMidiInput.MidiInput(var Message: TMessage); -{ Triggered by incoming message from DLL. - Note DLL has already put the message in the queue } -begin - case Message.Msg of - mim_data: - { Trigger the user's MIDI input event, if they've specified one and - we're not in the process of closing the device. The check for - GetEventCount > 0 prevents unnecessary event calls where the user has - already cleared all the events from the input buffer using a GetMidiEvent - loop in the OnMidiInput event handler } - if Assigned(FOnMIDIInput) and (FState = misOpen) - and (GetEventCount > 0) then - FOnMIDIInput(Self); - - mim_Overflow: { input circular buffer overflow } - if Assigned(FOnOverflow) and (FState = misOpen) then - FOnOverflow(Self); - end; -end; - -{-------------------------------------------------------------------} - -procedure Register; -begin - RegisterComponents('Synth', [TMIDIInput]); -end; - -end. - diff --git a/src/lib/midi/Midiout.pas b/src/lib/midi/Midiout.pas deleted file mode 100644 index 98e6e3fb..00000000 --- a/src/lib/midi/Midiout.pas +++ /dev/null @@ -1,619 +0,0 @@ -{ $Header: /MidiComp/MidiOut.pas 2 10/06/97 7:33 Davec $ } - -{ Written by David Churcher , - released to the public domain. } - -{ Thanks very much to Fred Kohler for the Technology code. } - -unit MidiOut; - -{ - MIDI Output component. - - Properties: - DeviceID: Windows numeric device ID for the MIDI output device. - Between 0 and (midioutGetNumDevs-1), or MIDI_MAPPER (-1). - Special value MIDI_MAPPER specifies output to the Windows MIDI mapper - Read-only while device is open, exception if changed while open - - MIDIHandle: The output handle to the MIDI device. - 0 when device is not open - Read-only, runtime-only - - ProductName: Name of the output device product that corresponds to the - DeviceID property (e.g. 'MPU 401 out'). - You can write to this while the device is closed to select a particular - output device by name (the DeviceID property will change to match). - Exception if this property is changed while the device is open. - - Numdevs: Number of MIDI output devices installed on the system. This - is the value returned by midiOutGetNumDevs. It's included for - completeness. - - Technology: Type of technology used by the MIDI device. You can set this - property to one of the values listed for OutportTech (below) and the component - will find an appropriate MIDI device. For example: - MidiOutput.Technology := opt_FMSynth; - will set MidiInput.DeviceID to the MIDI device ID of the FM synth, if one - is installed. If no such device is available an exception is raised, - see MidiOutput.SetTechnology. - - See the MIDIOUTCAPS entry in MMSYSTEM.HLP for descriptions of the - following properties: - DriverVersion - Voices - Notes - ChannelMask - Support - - Error: The error code for the last MMSYSTEM error. See the MMSYSERR_ - entries in MMSYSTEM.INT for possible values. - - Methods: - Open: Open MIDI device specified by DeviceID property for output - - Close: Close device - - PutMidiEvent(Event:TMyMidiEvent): Output a note or sysex message to the - device. This method takes a TMyMidiEvent object and transmits it. - Notes: - 1. If the object contains a sysex event the OnMidiOutput event will - be triggered when the sysex transmission is complete. - 2. You can queue up multiple blocks of system exclusive data for - transmission by chucking them at this method; they will be - transmitted as quickly as the device can manage. - 3. This method will not free the TMyMidiEvent object, the caller - must do that. Any sysex data in the TMyMidiEvent is copied before - transmission so you can free the TMyMidiEvent immediately after - calling PutMidiEvent, even if output has not yet finished. - - PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte): Output a short - MIDI message. Handy when you can't be bothered to build a TMyMidiEvent. - If the message you're sending doesn't use Data1 or Data2, set them to 0. - - PutLong(TheSysex: Pointer; msgLength: Word): Output sysex data. - SysexPointer: Pointer to sysex data to send - msgLength: Length of sysex data. - This is handy when you don't have a TMyMidiEvent. - - SetVolume(Left: Word, Right: Word): Set the volume of the - left and right channels on the output device (only on internal devices?). - 0xFFFF is maximum volume. If the device doesn't support separate - left/right volume control, the value of the Left parameter will be used. - Check the Support property to see whether the device supports volume - control. See also other notes on volume control under midiOutSetVolume() - in MMSYSTEM.HLP. - - Events: - OnMidiOutput: Procedure called when output of a system exclusive block - is completed. - - Notes: - I haven't implemented any methods for midiOutCachePatches and - midiOutCacheDrumpatches, mainly 'cause I don't have any way of testing - them. Does anyone really use these? -} - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -uses - SysUtils, - Windows, - Messages, - Classes, - MMSystem, - {$IFDEF FPC} - WinAllocation, - {$ENDIF} - Circbuf, - MidiType, - MidiDefs, - Delphmcb; - -{$IFDEF FPC} -type TmidioutCaps = MIDIOUTCAPS; -{$ENDIF} - -type - midioutputState = (mosOpen, mosClosed); - EmidioutputError = class(Exception); - - { These are the equivalent of constants prefixed with mod_ - as defined in MMSystem. See SetTechnology } - OutPortTech = ( - opt_None, { none } - opt_MidiPort, { output port } - opt_Synth, { generic internal synth } - opt_SQSynth, { square wave internal synth } - opt_FMSynth, { FM internal synth } - opt_Mapper); { MIDI mapper } - TechNameMap = array[OutPortTech] of string[18]; - - -const - TechName: TechNameMap = ( - 'None', 'MIDI Port', 'Generic Synth', 'Square Wave Synth', - 'FM Synth', 'MIDI Mapper'); - -{-------------------------------------------------------------------} -type - TMidiOutput = class(TComponent) - protected - Handle: THandle; { Window handle used for callback notification } - FDeviceID: Cardinal; { MIDI device ID } - FMIDIHandle: Hmidiout; { Handle to output device } - FState: midioutputState; { Current device state } - PCtlInfo: PMidiCtlInfo; { Pointer to control info for DLL } - - PBuffer: PCircularBuffer; { Output queue for PutTimedEvent, set by Open } - - FError: Word; { Last MMSYSTEM error } - - { Stuff from midioutCAPS } - FDriverVersion: MMVERSION; { Driver version from midioutGetDevCaps } - FProductName: string; { product name } - FTechnology: OutPortTech; { Type of MIDI output device } - FVoices: Word; { Number of voices (internal synth) } - FNotes: Word; { Number of notes (internal synth) } - FChannelMask: Word; { Bit set for each MIDI channels that the - device responds to (internal synth) } - FSupport: DWORD; { Technology supported (volume control, - patch caching etc. } - FNumdevs: Word; { Number of MIDI output devices on system } - - - FOnMIDIOutput: TNotifyEvent; { Sysex output finished } - - procedure MidiOutput(var Message: TMessage); - procedure SetDeviceID(DeviceID: Cardinal); - procedure SetProductName(NewProductName: string); - procedure SetTechnology(NewTechnology: OutPortTech); - function midioutErrorString(WError: Word): string; - - public - { Properties } - property MIDIHandle: Hmidiout read FMIDIHandle; - property DriverVersion: MMVERSION { Driver version from midioutGetDevCaps } - read FDriverVersion; - property Technology: OutPortTech { Type of MIDI output device } - read FTechnology - write SetTechnology - default opt_Synth; - property Voices: Word { Number of voices (internal synth) } - read FVoices; - property Notes: Word { Number of notes (internal synth) } - read FNotes; - property ChannelMask: Word { Bit set for each MIDI channels that the } - read FChannelMask; { device responds to (internal synth) } - property Support: DWORD { Technology supported (volume control, } - read FSupport; { patch caching etc. } - property Error: Word read FError; - property Numdevs: Word read FNumdevs; - - { Methods } - function Open: Boolean; virtual; - function Close: Boolean; virtual; - procedure PutMidiEvent(theEvent: TMyMidiEvent); virtual; - procedure PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); virtual; - procedure PutLong(TheSysex: Pointer; msgLength: Word); virtual; - procedure SetVolume(Left: Word; Right: Word); - constructor Create(AOwner: TComponent); override; - destructor Destroy; override; - - { Some functions to decode and classify incoming messages would be nice } - - published - { TODO: Property editor with dropdown list of product names } - property ProductName: string read FProductName write SetProductName; - - property DeviceID: Cardinal read FDeviceID write SetDeviceID default 0; - { TODO: midiOutGetVolume? Or two properties for Left and Right volume? - Is it worth it?? - midiOutMessage?? Does anyone use this? } - - { Events } - property Onmidioutput: TNotifyEvent - read FOnmidioutput - write FOnmidioutput; - end; - -procedure Register; - -{-------------------------------------------------------------------} -implementation - -(* Not used in Delphi 3 - -{ This is the callback procedure in the external DLL. - It's used when midioutOpen is called by the Open method. - There are special requirements and restrictions for this callback - procedure (see midioutOpen in MMSYSTEM.HLP) so it's impractical to - make it an object method } -{$IFDEF WIN32} -function midiHandler( - hMidiIn: HMidiIn; - wMsg: UINT; - dwInstance: DWORD; - dwParam1: DWORD; - dwParam2: DWORD): Boolean; stdcall; external 'DELMID32.DLL'; -{$ELSE} -function midiHandler( - hMidiIn: HMidiIn; - wMsg: Word; - dwInstance: DWORD; - dwParam1: DWORD; - dwParam2: DWORD): Boolean; far; external 'DELPHMID.DLL'; -{$ENDIF} -*) - -{-------------------------------------------------------------------} - -constructor Tmidioutput.Create(AOwner: TComponent); -begin - inherited Create(AOwner); - FState := mosClosed; - FNumdevs := midiOutGetNumDevs; - - { Create the window for callback notification } - if not (csDesigning in ComponentState) then - begin - Handle := AllocateHwnd(MidiOutput); - end; - -end; - -{-------------------------------------------------------------------} - -destructor Tmidioutput.Destroy; -begin - if FState = mosOpen then - Close; - if (PCtlInfo <> nil) then - GlobalSharedLockedFree(PCtlinfo^.hMem, PCtlInfo); - DeallocateHwnd(Handle); - inherited Destroy; -end; - -{-------------------------------------------------------------------} -{ Convert the numeric return code from an MMSYSTEM function to a string - using midioutGetErrorText. TODO: These errors aren't very helpful - (e.g. "an invalid parameter was passed to a system function") so - some proper error strings would be nice. } - - -function Tmidioutput.midioutErrorString(WError: Word): string; -var - errorDesc: PChar; -begin - errorDesc := nil; - try - errorDesc := StrAlloc(MAXERRORLENGTH); - if midioutGetErrorText(WError, errorDesc, MAXERRORLENGTH) = 0 then - result := StrPas(errorDesc) - else - result := 'Specified error number is out of range'; - finally - if errorDesc <> nil then StrDispose(errorDesc); - end; -end; - -{-------------------------------------------------------------------} -{ Set the output device ID and change the other properties to match } - -procedure Tmidioutput.SetDeviceID(DeviceID: Cardinal); -var - midioutCaps: TmidioutCaps; -begin - if FState = mosOpen then - raise EmidioutputError.Create('Change to DeviceID while device was open') - else - if (DeviceID >= midioutGetNumDevs) and (DeviceID <> MIDI_MAPPER) then - raise EmidioutputError.Create('Invalid device ID') - else - begin - FDeviceID := DeviceID; - - { Set the name and other midioutCAPS properties to match the ID } - FError := - midioutGetDevCaps(DeviceID, @midioutCaps, sizeof(TmidioutCaps)); - if Ferror > 0 then - raise EmidioutputError.Create(midioutErrorString(FError)); - - with midiOutCaps do - begin - FProductName := StrPas(szPname); - FDriverVersion := vDriverVersion; - FTechnology := OutPortTech(wTechnology); - FVoices := wVoices; - FNotes := wNotes; - FChannelMask := wChannelMask; - FSupport := dwSupport; - end; - - end; -end; - -{-------------------------------------------------------------------} -{ Set the product name property and put the matching output device number - in FDeviceID. - This is handy if you want to save a configured output/output device - by device name instead of device number, because device numbers may - change if users install or remove MIDI devices. - Exception if output device with matching name not found, - or if output device is open } - -procedure Tmidioutput.SetProductName(NewProductName: string); -var - midioutCaps: TmidioutCaps; - testDeviceID: Integer; - testProductName: string; -begin - if FState = mosOpen then - raise EmidioutputError.Create('Change to ProductName while device was open') - else - { Don't set the name if the component is reading properties because - the saved Productname will be from the machine the application was compiled - on, which may not be the same for the corresponding DeviceID on the user's - machine. The FProductname property will still be set by SetDeviceID } - if not (csLoading in ComponentState) then - begin - { Loop uses -1 to test for MIDI_MAPPER as well } - for testDeviceID := -1 to (midioutGetNumDevs - 1) do - begin - FError := - midioutGetDevCaps(testDeviceID, @midioutCaps, sizeof(TmidioutCaps)); - if Ferror > 0 then - raise EmidioutputError.Create(midioutErrorString(FError)); - testProductName := StrPas(midioutCaps.szPname); - if testProductName = NewProductName then - begin - FProductName := NewProductName; - Break; - end; - end; - if FProductName <> NewProductName then - raise EmidioutputError.Create('MIDI output Device ' + - NewProductName + ' not installed') - else - SetDeviceID(testDeviceID); - end; -end; - -{-------------------------------------------------------------------} -{ Set the output technology property and put the matching output device - number in FDeviceID. - This is handy, for example, if you want to be able to switch between a - sound card and a MIDI port } - -procedure TMidiOutput.SetTechnology(NewTechnology: OutPortTech); -var - midiOutCaps: TMidiOutCaps; - testDeviceID: Integer; - testTechnology: OutPortTech; -begin - if FState = mosOpen then - raise EMidiOutputError.Create( - 'Change to Product Technology while device was open') - else - begin - { Loop uses -1 to test for MIDI_MAPPER as well } - for testDeviceID := -1 to (midiOutGetNumDevs - 1) do - begin - FError := - midiOutGetDevCaps(testDeviceID, - @midiOutCaps, sizeof(TMidiOutCaps)); - if Ferror > 0 then - raise EMidiOutputError.Create(MidiOutErrorString(FError)); - testTechnology := OutPortTech(midiOutCaps.wTechnology); - if testTechnology = NewTechnology then - begin - FTechnology := NewTechnology; - Break; - end; - end; - if FTechnology <> NewTechnology then - raise EMidiOutputError.Create('MIDI output technology ' + - TechName[NewTechnology] + ' not installed') - else - SetDeviceID(testDeviceID); - end; -end; - -{-------------------------------------------------------------------} - -function Tmidioutput.Open: Boolean; -var - hMem: THandle; -begin - Result := False; - try - { Create the control info for the DLL } - if (PCtlInfo = nil) then - begin - PCtlInfo := GlobalSharedLockedAlloc(Sizeof(TMidiCtlInfo), hMem); - PctlInfo^.hMem := hMem; - end; - - Pctlinfo^.hWindow := Handle; { Control's window handle } - - FError := midioutOpen(@FMidiHandle, FDeviceId, - DWORD(@midiHandler), - DWORD(PCtlInfo), - CALLBACK_FUNCTION); -{ FError := midioutOpen(@FMidiHandle, FDeviceId, - Handle, - DWORD(PCtlInfo), - CALLBACK_WINDOW); } - if (FError <> 0) then - { TODO: use CreateFmtHelp to add MIDI device name/ID to message } - raise EmidioutputError.Create(midioutErrorString(FError)) - else - begin - Result := True; - FState := mosOpen; - end; - - except - if PCtlInfo <> nil then - begin - GlobalSharedLockedFree(PCtlInfo^.hMem, PCtlInfo); - PCtlInfo := nil; - end; - end; - -end; - -{-------------------------------------------------------------------} - -procedure TMidiOutput.PutShort(MidiMessage: Byte; Data1: Byte; Data2: Byte); -var - thisMsg: DWORD; -begin - thisMsg := DWORD(MidiMessage) or - (DWORD(Data1) shl 8) or - (DWORD(Data2) shl 16); - - FError := midiOutShortMsg(FMidiHandle, thisMsg); - if Ferror > 0 then - raise EmidioutputError.Create(midioutErrorString(FError)); -end; - -{-------------------------------------------------------------------} - -procedure TMidiOutput.PutLong(TheSysex: Pointer; msgLength: Word); -{ Notes: This works asynchronously; you send your sysex output by -calling this function, which returns immediately. When the MIDI device -driver has finished sending the data the MidiOutPut function in this -component is called, which will in turn call the OnMidiOutput method -if the component user has defined one. } -{ TODO: Combine common functions with PutTimedLong into subroutine } - -var - MyMidiHdr: TMyMidiHdr; -begin - { Initialize the header and allocate buffer memory } - MyMidiHdr := TMyMidiHdr.Create(msgLength); - - { Copy the data over to the MidiHdr buffer - We can't just use the caller's PChar because the buffer memory - has to be global, shareable, and locked. } - StrMove(MyMidiHdr.SysexPointer, TheSysex, msgLength); - - { Store the MyMidiHdr address in the header so we can find it again quickly - (see the MidiOutput proc) } - MyMidiHdr.hdrPointer^.dwUser := DWORD(MyMidiHdr); - - { Get MMSYSTEM's blessing for this header } - FError := midiOutPrepareHeader(FMidiHandle, MyMidiHdr.hdrPointer, - sizeof(TMIDIHDR)); - if Ferror > 0 then - raise EMidiOutputError.Create(MidiOutErrorString(FError)); - - { Send it } - FError := midiOutLongMsg(FMidiHandle, MyMidiHdr.hdrPointer, - sizeof(TMIDIHDR)); - if Ferror > 0 then - raise EMidiOutputError.Create(MidiOutErrorString(FError)); - -end; - -{-------------------------------------------------------------------} - -procedure Tmidioutput.PutMidiEvent(theEvent: TMyMidiEvent); -begin - if FState <> mosOpen then - raise EMidiOutputError.Create('MIDI Output device not open'); - - with theEvent do - begin - if Sysex = nil then - begin - PutShort(MidiMessage, Data1, Data2) - end - else - PutLong(Sysex, SysexLength); - end; -end; - -{-------------------------------------------------------------------} - -function Tmidioutput.Close: Boolean; -begin - Result := False; - if FState = mosOpen then - begin - - { Note this sends a lot of fast control change messages which some synths can't handle. - TODO: Make this optional. } -{ FError := midioutReset(FMidiHandle); - if Ferror <> 0 then - raise EMidiOutputError.Create(MidiOutErrorString(FError)); } - - FError := midioutClose(FMidiHandle); - if Ferror <> 0 then - raise EMidiOutputError.Create(MidiOutErrorString(FError)) - else - Result := True; - end; - - FMidiHandle := 0; - FState := mosClosed; - -end; - -{-------------------------------------------------------------------} - -procedure TMidiOutput.SetVolume(Left: Word; Right: Word); -var - dwVolume: DWORD; -begin - dwVolume := (DWORD(Left) shl 16) or Right; - FError := midiOutSetVolume(DeviceID, dwVolume); - if Ferror <> 0 then - raise EMidiOutputError.Create(MidiOutErrorString(FError)); -end; - -{-------------------------------------------------------------------} - -procedure Tmidioutput.midioutput(var Message: TMessage); -{ Triggered when sysex output from PutLong is complete } -var - MyMidiHdr: TMyMidiHdr; - thisHdr: PMidiHdr; -begin - if Message.Msg = Mom_Done then - begin - { Find the MIDIHDR we used for the output. Message.lParam is its address } - thisHdr := PMidiHdr(Message.lParam); - - { Remove it from the output device } - midiOutUnprepareHeader(FMidiHandle, thisHdr, sizeof(TMIDIHDR)); - - { Get the address of the MyMidiHdr object containing this MIDIHDR structure. - We stored this address in the PutLong procedure } - MyMidiHdr := TMyMidiHdr(thisHdr^.dwUser); - - { Header and copy of sysex data no longer required since output is complete } - MyMidiHdr.Free; - - { Call the user's event handler if any } - if Assigned(FOnmidioutput) then - FOnmidioutput(Self); - end; - { TODO: Case for MOM_PLAYBACK_DONE } -end; - -{-------------------------------------------------------------------} - -procedure Register; -begin - RegisterComponents('Synth', [Tmidioutput]); -end; - -end. - diff --git a/src/lib/midi/demo/MidiTest.pas b/src/lib/midi/demo/MidiTest.pas deleted file mode 100644 index 793db730..00000000 --- a/src/lib/midi/demo/MidiTest.pas +++ /dev/null @@ -1,249 +0,0 @@ -// Test application for TMidiFile - -unit MidiTest; - -interface - -uses - Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, - StdCtrls, MidiFile, ExtCtrls, MidiOut, MidiType, MidiScope, Grids; -type - TMidiPlayer = class(TForm) - OpenDialog1: TOpenDialog; - Button1: TButton; - Button3: TButton; - Button4: TButton; - MidiOutput1: TMidiOutput; - cmbInput: TComboBox; - MidiFile1: TMidiFile; - MidiScope1: TMidiScope; - Label3: TLabel; - edtBpm: TEdit; - Memo2: TMemo; - edtTime: TEdit; - Button2: TButton; - TrackGrid: TStringGrid; - TracksGrid: TStringGrid; - edtLength: TEdit; - procedure Button1Click(Sender: TObject); - procedure MidiFile1MidiEvent(event: PMidiEvent); - procedure Button3Click(Sender: TObject); - procedure Button4Click(Sender: TObject); - procedure FormCreate(Sender: TObject); - procedure cmbInputChange(Sender: TObject); - procedure MidiFile1UpdateEvent(Sender: TObject); - procedure Button2Click(Sender: TObject); - procedure edtBpmKeyPress(Sender: TObject; var Key: Char); - procedure TracksGridSelectCell(Sender: TObject; Col, Row: Integer; - var CanSelect: Boolean); - procedure FormShow(Sender: TObject); - private - { Private declarations } - MidiOpened : boolean; - procedure SentAllNotesOff; - - procedure MidiOpen; - procedure MidiClose; - - public - { Public declarations } - end; - -var - MidiPlayer: TMidiPlayer; - -implementation - -{$R *.DFM} - -procedure TMidiPlayer.Button1Click(Sender: TObject); -var - i,j: integer; - track : TMidiTrack; - event : PMidiEvent; -begin - if opendialog1.execute then - begin - midifile1.filename := opendialog1.filename; - midifile1.readfile; -// label1.caption := IntToStr(midifile1.NumberOfTracks); - edtBpm.text := IntToStr(midifile1.Bpm); -// TracksGrid.cells.clear; - for i := 0 to midifile1.NumberOfTracks-1 do - begin - track := midifile1.getTrack(i); - TracksGrid.cells[0,i] := 'Tr: '+ track.getName + ' '+ track.getInstrument ; - end; - edtLength.Text := MyTimeToStr(MidiFile1.GetTrackLength); - end; -end; - -procedure TMidiPlayer.MidiFile1MidiEvent(event: PMidiEvent); -var mEvent : TMyMidiEvent; -begin - mEvent := TMyMidiEvent.Create; - if not (event.event = $FF) then - begin - mEvent.MidiMessage := event.event; - mEvent.data1 := event.data1; - mEvent.data2 := event.data2; - midioutput1.PutMidiEvent(mEvent); - end - else - begin - if (event.data1 >= 1) and (event.data1 < 15) then - begin - memo2.Lines.add(IntToStr(event.data1) + ' '+ event.str); - end - end; - midiScope1.MidiEvent(event.event,event.data1,event.data2); - mEvent.Destroy; -end; - -procedure TMidiPlayer.SentAllNotesOff; -var mEvent : TMyMidiEvent; -channel : integer; -begin - mEvent := TMyMidiEvent.Create; - for channel:= 0 to 15 do - begin - mEvent.MidiMessage := $B0 + channel; - mEvent.data1 := $78; - mEvent.data2 := 0; - if MidiOpened then - midioutput1.PutMidiEvent(mEvent); - midiScope1.MidiEvent(mEvent.MidiMessage,mEvent.data1,mEvent.data2); - end; - mEvent.Destroy; -end; - -procedure TMidiPlayer.Button3Click(Sender: TObject); -begin - midifile1.StartPlaying; -end; - -procedure TMidiPlayer.Button4Click(Sender: TObject); -begin - midifile1.StopPlaying; - SentAllNotesOff; -end; - -procedure TMidiPlayer.MidiOpen; -begin - if not (cmbInput.Text = '') then - begin - MidiOutput1.ProductName := cmbInput.Text; - MidiOutput1.OPEN; - MidiOpened := true; - end; -end; - -procedure TMidiPlayer.MidiClose; -begin - if MidiOpened then - begin - MidiOutput1.Close; - MidiOpened := false; - end; -end; - - -procedure TMidiPlayer.FormCreate(Sender: TObject); -var thisDevice : integer; -begin - for thisDevice := 0 to MidiOutput1.NumDevs - 1 do - begin - MidiOutput1.DeviceID := thisDevice; - cmbInput.Items.Add(MidiOutput1.ProductName); - end; - cmbInput.ItemIndex := 0; - MidiOpened := false; - MidiOpen; -end; - -procedure TMidiPlayer.cmbInputChange(Sender: TObject); -begin - MidiClose; - MidiOPen; -end; - -procedure TMidiPlayer.MidiFile1UpdateEvent(Sender: TObject); -begin - edtTime.Text := MyTimeToStr(MidiFile1.GetCurrentTime); - edtTime.update; - if MidiFile1.ready then - begin - midifile1.StopPlaying; - SentAllNotesOff; - end; -end; - -procedure TMidiPlayer.Button2Click(Sender: TObject); -begin - MidiFile1.ContinuePlaying; -end; - -procedure TMidiPlayer.edtBpmKeyPress(Sender: TObject; var Key: Char); -begin - if Key = char(13) then - begin - MidiFile1.Bpm := StrToInt(edtBpm.Text); - edtBpm.text := IntToStr(midifile1.Bpm); - abort; - end; - -end; - -procedure TMidiPlayer.TracksGridSelectCell(Sender: TObject; Col, - Row: Integer; var CanSelect: Boolean); -var - MidiTrack : TMidiTrack; - i : integer; - j : integer; - event : PMidiEvent; -begin - CanSelect := false; - if Row < MidiFile1.NumberOfTracks then - begin - CanSelect := true; - MidiTrack := MidiFile1.GetTrack(Row); - TrackGrid.RowCount := 2; - TrackGrid.RowCount := MidiTrack.getEventCount; - j := 1; - for i := 0 to MidiTrack.GetEventCount-1 do - begin - event := MidiTrack.getEvent(i); - if not (event.len = -1) then - begin // do not print when - TrackGrid.cells[0,j] := IntToStr(i); - TrackGrid.cells[1,j] := MyTimeToStr(event.time); - TrackGrid.cells[2,j] := IntToHex(event.event,2); - if not (event.event = $FF) then - begin - TrackGrid.cells[3,j] := IntToStr(event.len); - TrackGrid.cells[4,j] := KeyToStr(event.data1); - TrackGrid.cells[5,j] := IntToStr(event.data2); - end - else - begin - TrackGrid.cells[3,j] := IntToStr(event.data1); - TrackGrid.cells[4,j] := ''; - TrackGrid.cells[5,j] := event.str; - end; - inc(j); - end; - end; - TrackGrid.RowCount := j; - end; -end; - -procedure TMidiPlayer.FormShow(Sender: TObject); -begin - TrackGrid.ColWidths[0] := 30; - TrackGrid.ColWidths[2] := 30; - TrackGrid.ColWidths[3] := 30; - TrackGrid.ColWidths[4] := 30; - TrackGrid.ColWidths[5] := 100; -end; - -end. diff --git a/src/lib/other/DirWatch.pas b/src/lib/other/DirWatch.pas deleted file mode 100644 index 1e00ec5d..00000000 --- a/src/lib/other/DirWatch.pas +++ /dev/null @@ -1,345 +0,0 @@ -unit DirWatch; - -// ----------------------------------------------------------------------------- -// Component Name: TDirectoryWatch . -// Module: DirWatch . -// Description: Implements watching for file changes in a designated . -// directory (or directories). . -// Version: 1.4 . -// Date: 10-MAR-2003 . -// Target: Win32, Delphi 3 - Delphi 7 . -// Author: Angus Johnson, angusj-AT-myrealbox-DOT-com . -// A portion of code has been copied from the Drag & Drop . -// Component Suite which I co-authored with Anders Melander. . -// Copyright: © 2003 Angus Johnson . -// . -// Usage: 1. Add a TDirectoryWatch component to your form. . -// 2. Set its Directory property . -// 3. If you wish to watch its subdirectories too then set . -// the WatchSubDir property to true . -// 4. Assign the OnChange event . -// 5. Set Active to true . -// ----------------------------------------------------------------------------- - -interface - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -uses - Windows, - Messages, - Classes, - {$IFDEF FPC} - WinAllocation, - {$ENDIF} - SysUtils; - -type - TNotifyFilters = set of (nfFilename, nfDirname, nfAttrib, - nfSize, nfLastWrite, nfSecurity); - - TWatchThread = class; //forward declaration - - TDirectoryWatch = class(TComponent) - private - fWindowHandle: THandle; - fWatchThread: TWatchThread; - fWatchSubDirs: boolean; - fDirectory: string; - fActive: boolean; - fNotifyFilters: TNotifyFilters; //see FindFirstChangeNotification in winAPI - fOnChangeEvent: TNotifyEvent; - procedure SetActive(aActive: boolean); - procedure SetDirectory(aDir: string); - procedure SetWatchSubDirs(aWatchSubDirs: boolean); - procedure SetNotifyFilters(aNotifyFilters: TNotifyFilters); - procedure WndProc(var aMsg: TMessage); - public - constructor Create(aOwner: TComponent); override; - destructor Destroy; override; - published - property Directory: string read fDirectory write SetDirectory; - property NotifyFilters: TNotifyFilters - read fNotifyFilters write SetNotifyFilters; - property WatchSubDirs: boolean read fWatchSubDirs write SetWatchSubDirs; - property Active: boolean read fActive write SetActive; - property OnChange: TNotifyEvent read fOnChangeEvent write fOnChangeEvent; - end; - - TWatchThread = class(TThread) - private - fOwnerHdl: Thandle; - fChangeNotify : THandle; //Signals whenever Windows detects a change in . - //the watched directory . - fBreakEvent: THandle; //Signals when either the Directory property . - //changes or when the thread terminates . - fDirectory: string; - fWatchSubDirs: longbool; - fNotifyFilters: dword; - fFinished: boolean; - protected - procedure SetDirectory(const Value: string); - procedure ProcessFilenameChanges; - procedure Execute; override; - public - constructor Create( OwnerHdl: THandle; - const InitialDir: string; WatchSubDirs: boolean; NotifyFilters: dword); - destructor Destroy; override; - procedure Terminate; - property Directory: string write SetDirectory; - end; - -procedure Register; - -implementation - -const - NOTIFYCHANGE_MESSAGE = WM_USER + 1; - -resourcestring - sInvalidDir = 'Invalid Directory: '; - -//---------------------------------------------------------------------------- -// Miscellaneous functions ... -//---------------------------------------------------------------------------- - -procedure Register; -begin - RegisterComponents('Samples', [TDirectoryWatch]); -end; -//---------------------------------------------------------------------------- - -function DirectoryExists(const Name: string): Boolean; -var - Code: Integer; -begin - Code := GetFileAttributes(PChar(Name)); - Result := (Code <> -1) and (FILE_ATTRIBUTE_DIRECTORY and Code <> 0); -end; - -//---------------------------------------------------------------------------- -// TDirectoryWatch methods ... -//---------------------------------------------------------------------------- - -constructor TDirectoryWatch.Create(aOwner: TComponent); -begin - inherited Create(aOwner); - //default Notify values - notify if either a file name or a directory name - //changes or if a file is modified ... - fNotifyFilters := [nfFilename, nfDirname, nfLastWrite]; - fDirectory := 'C:\'; - //this non-visual control needs to handle messages, so ... - if not (csDesigning in ComponentState) then - fWindowHandle := AllocateHWnd(WndProc); -end; -//---------------------------------------------------------------------------- - -destructor TDirectoryWatch.Destroy; -begin - Active := false; - if not (csDesigning in ComponentState) then - DeallocateHWnd(fWindowHandle); - inherited Destroy; -end; -//---------------------------------------------------------------------------- - -procedure TDirectoryWatch.WndProc(var aMsg: TMessage); -begin - with aMsg do - if Msg = NOTIFYCHANGE_MESSAGE then - begin - if assigned(OnChange) then OnChange(self); - end else - Result := DefWindowProc(FWindowHandle, Msg, wParam, lParam); -end; -//------------------------------------------------------------------------------ - -procedure TDirectoryWatch.SetNotifyFilters(aNotifyFilters: TNotifyFilters); -begin - if aNotifyFilters = fNotifyFilters then exit; - fNotifyFilters := aNotifyFilters; - if assigned(fWatchThread) then - begin - Active := false; - Active := true; - end; -end; -//------------------------------------------------------------------------------ - -procedure TDirectoryWatch.SetWatchSubDirs(aWatchSubDirs: boolean); -begin - if aWatchSubDirs = fWatchSubDirs then exit; - fWatchSubDirs := aWatchSubDirs; - if assigned(fWatchThread) then - begin - Active := false; - Active := true; - end; -end; -//------------------------------------------------------------------------------ - -procedure TDirectoryWatch.SetDirectory(aDir: string); -begin - if aDir = '' then - begin - Active := false; - fDirectory := ''; - exit; - end; - if (aDir[length(aDir)] <> '\') then aDir := aDir + '\'; - if aDir = fDirectory then exit; - if not (csDesigning in ComponentState) and not DirectoryExists(aDir) then - raise Exception.Create( sInvalidDir + aDir); - fDirectory := aDir; - if assigned(fWatchThread) then - fWatchThread.Directory := fDirectory; -end; -//------------------------------------------------------------------------------ - -procedure TDirectoryWatch.SetActive(aActive: boolean); -var - nf: dword; -begin - if aActive = fActive then exit; - fActive := aActive; - if csDesigning in ComponentState then exit; - if fActive then - begin - if not DirectoryExists(fDirectory) then - begin - fActive := false; - raise Exception.Create(sInvalidDir + fDirectory); - end; - nf := 0; - if nfFilename in fNotifyFilters then - nf := nf or FILE_NOTIFY_CHANGE_FILE_NAME; - if nfDirname in fNotifyFilters then - nf := nf or FILE_NOTIFY_CHANGE_DIR_NAME; - if nfAttrib in fNotifyFilters then - nf := nf or FILE_NOTIFY_CHANGE_ATTRIBUTES; - if nfSize in fNotifyFilters then - nf := nf or FILE_NOTIFY_CHANGE_SIZE; - if nfLastWrite in fNotifyFilters then - nf := nf or FILE_NOTIFY_CHANGE_LAST_WRITE; - if nfSecurity in fNotifyFilters then - nf := nf or FILE_NOTIFY_CHANGE_SECURITY; - fWatchThread := TWatchThread.Create( - fWindowHandle, fDirectory, fWatchSubDirs, nf); - end else - begin - fWatchThread.Terminate; - fWatchThread := nil; - end; -end; - -//---------------------------------------------------------------------------- -// TWatchThread methods ... -//---------------------------------------------------------------------------- - -constructor TWatchThread.Create(OwnerHdl: THandle; - const InitialDir: string; WatchSubDirs: boolean; NotifyFilters: dword); -begin - inherited Create(True); - fOwnerHdl := OwnerHdl; - if WatchSubDirs then - cardinal(fWatchSubDirs) := 1 //workaround a Win9x OS issue - else - fWatchSubDirs := false; - FreeOnTerminate := true; - Priority := tpLowest; - fDirectory := InitialDir; - fNotifyFilters := NotifyFilters; - fBreakEvent := windows.CreateEvent(nil, False, False, nil); - Resume; -end; -//------------------------------------------------------------------------------ - -destructor TWatchThread.Destroy; -begin - CloseHandle(fBreakEvent); - inherited Destroy; -end; -//------------------------------------------------------------------------------ - -procedure TWatchThread.SetDirectory(const Value: string); -begin - if (Value = FDirectory) then exit; - FDirectory := Value; - SetEvent(fBreakEvent); -end; -//------------------------------------------------------------------------------ - -procedure TWatchThread.Terminate; -begin - inherited Terminate; - SetEvent(fBreakEvent); - while not fFinished do sleep(10); //avoids a reported resource leak - //if called while closing the application. -end; -//------------------------------------------------------------------------------ - -procedure TWatchThread.Execute; -begin - //OUTER LOOP - manages Directory property reassignments - while (not Terminated) do - begin - fChangeNotify := FindFirstChangeNotification(pchar(fDirectory), - fWatchSubDirs, fNotifyFilters); - if (fChangeNotify = INVALID_HANDLE_VALUE) then - //Can't monitor the specified directory so we'll just wait for - //a new Directory assignment or the thread terminating ... - WaitForSingleObject(fBreakEvent, INFINITE) - else - try - //Now do the INNER loop... - ProcessFilenameChanges; - finally - FindCloseChangeNotification(fChangeNotify); - end; - end; - fFinished := true; -end; -//------------------------------------------------------------------------------ - -procedure TWatchThread.ProcessFilenameChanges; -var - WaitResult : DWORD; - HandleArray : array[0..1] of THandle; -const - TEN_MSECS = 10; - HUNDRED_MSECS = 100; -begin - HandleArray[0] := fBreakEvent; - HandleArray[1] := fChangeNotify; - //INNER LOOP - exits only when fBreakEvent signaled - while (not Terminated) do - begin - //waits for either fChangeNotify or fBreakEvent ... - WaitResult := WaitForMultipleObjects(2, @HandleArray, False, INFINITE); - if (WaitResult = WAIT_OBJECT_0 + 1) then //fChangeNotify - begin - repeat //ie: if a number of files are changing in a block - //just post the one notification message ... - FindNextChangeNotification(fChangeNotify); - until Terminated or - (WaitForSingleObject(fChangeNotify, TEN_MSECS) <> WAIT_OBJECT_0); - if Terminated then break; - //OK, now notify the main thread (before restarting inner loop)... - PostMessage(fOwnerHdl, NOTIFYCHANGE_MESSAGE, 0, 0); - end else //fBreakEvent ... - begin - //If the Directory property is undergoing multiple rapid reassignments - //wait 'til this stops before restarting monitoring of a new directory ... - while (not Terminated) and - (WaitForSingleObject(fBreakEvent, HUNDRED_MSECS) = WAIT_OBJECT_0) do; - break; //EXIT LOOP HERE - end; - end; -end; -//------------------------------------------------------------------------------ -//------------------------------------------------------------------------------ - -end. \ No newline at end of file diff --git a/src/lib/other/WinAllocation.pas b/src/lib/other/WinAllocation.pas deleted file mode 100644 index ba1b0919..00000000 --- a/src/lib/other/WinAllocation.pas +++ /dev/null @@ -1,101 +0,0 @@ -unit WinAllocation; - -// FPC misses AllocateHWnd and DeallocateHWnd which is used by several -// libraries such as Midi... or DirWatch. -// Since FPC 2.2.2 there are dummies in Classes that just raise RunTime exceptions. -// To avoid those exceptions, include this unit AFTER Classes. -// Maybe the dummies will be replaced by functional routines in the future.WinAllocation -// -// THESE FUNCTIONS ARE ONLY FOR COMPATIBILITY WITH SOME EXTERNAL WIN32 LIBS. -// DO NOT USE THEM IN USDX CODE. -// - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -uses - Classes, - Windows; - -function AllocateHWnd(Method: TWndMethod): HWND; -procedure DeallocateHWnd(hWnd: HWND); - -implementation - -function AllocateHWndCallback(hWnd: HWND; uMsg: UINT; wParam: WPARAM; lParam: LPARAM): LRESULT; stdcall; -var - Msg: TMessage; - MethodPtr: ^TWndMethod; -begin - FillChar(Msg, SizeOf(Msg), 0); - Msg.msg := uMsg; - Msg.wParam := wParam; - Msg.lParam := lParam; - - MethodPtr := Pointer(GetWindowLongPtr(hwnd, GWL_USERDATA)); - if Assigned(MethodPtr) then - MethodPtr^(Msg); - - Result := DefWindowProc(hwnd, uMsg, wParam, lParam); -end; - -function AllocateHWnd(Method: TWndMethod): HWND; -var - ClassExists: Boolean; - WndClass, OldClass: TWndClass; - MethodPtr: ^TMethod; -begin - Result := 0; - - // setup class-info - FillChar(WndClass, SizeOf(TWndClass), 0); - WndClass.hInstance := HInstance; - // Important: do not enable AllocateHWndCallback before the msg-handler method is assigned, - // otherwise race-conditions might occur - WndClass.lpfnWndProc := @DefWindowProc; - WndClass.lpszClassName:= 'USDXUtilWindowClass'; - - // check if class is already registered - ClassExists := GetClassInfo(HInstance, WndClass.lpszClassName, OldClass); - // create window-class shared by all windows created by AllocateHWnd() - if (not ClassExists) or (@OldClass.lpfnWndProc <> @DefWindowProc) then - begin - if ClassExists then - UnregisterClass(WndClass.lpszClassName, HInstance); - if (RegisterClass(WndClass) = 0) then - Exit; - end; - // create window - Result := CreateWindowEx(WS_EX_TOOLWINDOW, WndClass.lpszClassName, '', - DWORD(WS_POPUP), 0, 0, 0, 0, 0, 0, HInstance, nil); - if (Result = 0) then - Exit; - // assign individual callback procedure to the window - if Assigned(Method) then - begin - // TMethod contains two pointers but we can pass just one as USERDATA - GetMem(MethodPtr, SizeOf(TMethod)); - MethodPtr^ := TMethod(Method); - SetWindowLongPtr(Result, GWL_USERDATA, LONG_PTR(MethodPtr)); - end; - // now enable AllocateHWndCallback for this window - SetWindowLongPtr(Result, GWL_WNDPROC, LONG_PTR(@AllocateHWndCallback)); -end; - -procedure DeallocateHWnd(hWnd: HWND); -var - MethodPtr: ^TMethod; -begin - if (hWnd <> 0) then - begin - MethodPtr := Pointer(GetWindowLongPtr(hWnd, GWL_USERDATA)); - DestroyWindow(hWnd); - if Assigned(MethodPtr) then - FreeMem(MethodPtr); - end; -end; - -end. diff --git a/src/lib/pcre/pcre.pas b/src/lib/pcre/pcre.pas deleted file mode 100644 index 50e3371a..00000000 --- a/src/lib/pcre/pcre.pas +++ /dev/null @@ -1,852 +0,0 @@ -{**************************************************************************************************} -{ } -{ Project JEDI Code Library (JCL) } -{ } -{ The contents of this file are 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/ } -{ } -{ 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. } -{ } -{ The Original Code is JclPRCE.pas. } -{ } -{ The Initial Developer of the Original Code is Peter Thornqvist. } -{ Portions created by Peter Thornqvist are Copyright (C) of Peter Thornqvist. All rights reserved. } -{ Portions created by University of Cambridge are } -{ Copyright (C) 1997-2001 by University of Cambridge. } -{ } -{ Contributor(s): } -{ Robert Rossmair (rrossmair) } -{ Mario R. Carro } -{ Florent Ouchet (outchy) } -{ } -{ The latest release of PCRE is always available from } -{ ftp://ftp.csx.cam.ac.uk/pub/software/programming/pcre/pcre-xxx.tar.gz } -{ } -{**************************************************************************************************} -{ } -{ Header conversion of pcre.h } -{ } -{ } -{**************************************************************************************************} -{ } -{ Last modified: $Date:: $ } -{ Revision: $Rev:: $ } -{ Author: $Author:: $ } -{ } -{**************************************************************************************************} - -unit pcre; - -interface - -(************************************************* -* Perl-Compatible Regular Expressions * -*************************************************) - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -{$WEAKPACKAGEUNIT ON} - -(*$HPPEMIT '#include "pcre.h"'*) - -const - MAX_PATTERN_LENGTH = $10003; - {$EXTERNALSYM MAX_PATTERN_LENGTH} - MAX_QUANTIFY_REPEAT = $10000; - {$EXTERNALSYM MAX_QUANTIFY_REPEAT} - MAX_CAPTURE_COUNT = $FFFF; - {$EXTERNALSYM MAX_CAPTURE_COUNT} - MAX_NESTING_DEPTH = 200; - {$EXTERNALSYM MAX_NESTING_DEPTH} - -const - (* Options *) - PCRE_CASELESS = $00000001; - {$EXTERNALSYM PCRE_CASELESS} - PCRE_MULTILINE = $00000002; - {$EXTERNALSYM PCRE_MULTILINE} - PCRE_DOTALL = $00000004; - {$EXTERNALSYM PCRE_DOTALL} - PCRE_EXTENDED = $00000008; - {$EXTERNALSYM PCRE_EXTENDED} - PCRE_ANCHORED = $00000010; - {$EXTERNALSYM PCRE_ANCHORED} - PCRE_DOLLAR_ENDONLY = $00000020; - {$EXTERNALSYM PCRE_DOLLAR_ENDONLY} - PCRE_EXTRA = $00000040; - {$EXTERNALSYM PCRE_EXTRA} - PCRE_NOTBOL = $00000080; - {$EXTERNALSYM PCRE_NOTBOL} - PCRE_NOTEOL = $00000100; - {$EXTERNALSYM PCRE_NOTEOL} - PCRE_UNGREEDY = $00000200; - {$EXTERNALSYM PCRE_UNGREEDY} - PCRE_NOTEMPTY = $00000400; - {$EXTERNALSYM PCRE_NOTEMPTY} - PCRE_UTF8 = $00000800; - {$EXTERNALSYM PCRE_UTF8} - PCRE_NO_AUTO_CAPTURE = $00001000; - {$EXTERNALSYM PCRE_NO_AUTO_CAPTURE} - PCRE_NO_UTF8_CHECK = $00002000; - {$EXTERNALSYM PCRE_NO_UTF8_CHECK} - PCRE_AUTO_CALLOUT = $00004000; - {$EXTERNALSYM PCRE_AUTO_CALLOUT} - PCRE_PARTIAL_SOFT = $00008000; - {$EXTERNALSYM PCRE_PARTIAL_SOFT} - PCRE_PARTIAL = PCRE_PARTIAL_SOFT; // Backwards compatible synonym - {$EXTERNALSYM PCRE_PARTIAL} - PCRE_DFA_SHORTEST = $00010000; - {$EXTERNALSYM PCRE_DFA_SHORTEST} - PCRE_DFA_RESTART = $00020000; - {$EXTERNALSYM PCRE_DFA_RESTART} - PCRE_FIRSTLINE = $00040000; - {$EXTERNALSYM PCRE_FIRSTLINE} - PCRE_DUPNAMES = $00080000; - {$EXTERNALSYM PCRE_DUPNAMES} - PCRE_NEWLINE_CR = $00100000; - {$EXTERNALSYM PCRE_NEWLINE_CR} - PCRE_NEWLINE_LF = $00200000; - {$EXTERNALSYM PCRE_NEWLINE_LF} - PCRE_NEWLINE_CRLF = $00300000; - {$EXTERNALSYM PCRE_NEWLINE_CRLF} - PCRE_NEWLINE_ANY = $00400000; - {$EXTERNALSYM PCRE_NEWLINE_ANY} - PCRE_NEWLINE_ANYCRLF = $00500000; - {$EXTERNALSYM PCRE_NEWLINE_ANYCRLF} - PCRE_BSR_ANYCRLF = $00800000; - {$EXTERNALSYM PCRE_BSR_ANYCRLF} - PCRE_BSR_UNICODE = $01000000; - {$EXTERNALSYM PCRE_BSR_UNICODE} - PCRE_JAVASCRIPT_COMPAT = $02000000; - {$EXTERNALSYM PCRE_JAVASCRIPT_COMPAT} - PCRE_NO_START_OPTIMIZE = $04000000; - {$EXTERNALSYM PCRE_NO_START_OPTIMIZE} - PCRE_NO_START_OPTIMISE = $04000000; - {$EXTERNALSYM PCRE_NO_START_OPTIMISE} - PCRE_PARTIAL_HARD = $08000000; - {$EXTERNALSYM PCRE_PARTIAL_HARD} - PCRE_NOTEMPTY_ATSTART = $10000000; - {$EXTERNALSYM PCRE_NOTEMPTY_ATSTART} - - (* Exec-time and get-time error codes *) - - PCRE_ERROR_NOMATCH = -1; - {$EXTERNALSYM PCRE_ERROR_NOMATCH} - PCRE_ERROR_NULL = -2; - {$EXTERNALSYM PCRE_ERROR_NULL} - PCRE_ERROR_BADOPTION = -3; - {$EXTERNALSYM PCRE_ERROR_BADOPTION} - PCRE_ERROR_BADMAGIC = -4; - {$EXTERNALSYM PCRE_ERROR_BADMAGIC} - PCRE_ERROR_UNKNOWN_NODE = -5; - {$EXTERNALSYM PCRE_ERROR_UNKNOWN_NODE} - PCRE_ERROR_NOMEMORY = -6; - {$EXTERNALSYM PCRE_ERROR_NOMEMORY} - PCRE_ERROR_NOSUBSTRING = -7; - {$EXTERNALSYM PCRE_ERROR_NOSUBSTRING} - PCRE_ERROR_MATCHLIMIT = -8; - {$EXTERNALSYM PCRE_ERROR_MATCHLIMIT} - PCRE_ERROR_CALLOUT = -9; (* Never used by PCRE itself *) - {$EXTERNALSYM PCRE_ERROR_CALLOUT} - PCRE_ERROR_BADUTF8 = -10; - {$EXTERNALSYM PCRE_ERROR_BADUTF8} - PCRE_ERROR_BADUTF8_OFFSET = -11; - {$EXTERNALSYM PCRE_ERROR_BADUTF8_OFFSET} - PCRE_ERROR_PARTIAL = -12; - {$EXTERNALSYM PCRE_ERROR_PARTIAL} - PCRE_ERROR_BADPARTIAL = -13; - {$EXTERNALSYM PCRE_ERROR_BADPARTIAL} - PCRE_ERROR_INTERNAL = -14; - {$EXTERNALSYM PCRE_ERROR_INTERNAL} - PCRE_ERROR_BADCOUNT = -15; - {$EXTERNALSYM PCRE_ERROR_BADCOUNT} - PCRE_ERROR_DFA_UITEM = -16; - {$EXTERNALSYM PCRE_ERROR_DFA_UITEM} - PCRE_ERROR_DFA_UCOND = -17; - {$EXTERNALSYM PCRE_ERROR_DFA_UCOND} - PCRE_ERROR_DFA_UMLIMIT = -18; - {$EXTERNALSYM PCRE_ERROR_DFA_UMLIMIT} - PCRE_ERROR_DFA_WSSIZE = -19; - {$EXTERNALSYM PCRE_ERROR_DFA_WSSIZE} - PCRE_ERROR_DFA_RECURSE = -20; - {$EXTERNALSYM PCRE_ERROR_DFA_RECURSE} - PCRE_ERROR_RECURSIONLIMIT = -21; - {$EXTERNALSYM PCRE_ERROR_RECURSIONLIMIT} - PCRE_ERROR_NULLWSLIMIT = -22; (* No longer actually used *) - {$EXTERNALSYM PCRE_ERROR_NULLWSLIMIT} - PCRE_ERROR_BADNEWLINE = -23; - {$EXTERNALSYM PCRE_ERROR_BADNEWLINE} - - (* Request types for pcre_fullinfo() *) - - PCRE_INFO_OPTIONS = 0; - {$EXTERNALSYM PCRE_INFO_OPTIONS} - PCRE_INFO_SIZE = 1; - {$EXTERNALSYM PCRE_INFO_SIZE} - PCRE_INFO_CAPTURECOUNT = 2; - {$EXTERNALSYM PCRE_INFO_CAPTURECOUNT} - PCRE_INFO_BACKREFMAX = 3; - {$EXTERNALSYM PCRE_INFO_BACKREFMAX} - PCRE_INFO_FIRSTCHAR = 4; - {$EXTERNALSYM PCRE_INFO_FIRSTCHAR} - PCRE_INFO_FIRSTTABLE = 5; - {$EXTERNALSYM PCRE_INFO_FIRSTTABLE} - PCRE_INFO_LASTLITERAL = 6; - {$EXTERNALSYM PCRE_INFO_LASTLITERAL} - PCRE_INFO_NAMEENTRYSIZE = 7; - {$EXTERNALSYM PCRE_INFO_NAMEENTRYSIZE} - PCRE_INFO_NAMECOUNT = 8; - {$EXTERNALSYM PCRE_INFO_NAMECOUNT} - PCRE_INFO_NAMETABLE = 9; - {$EXTERNALSYM PCRE_INFO_NAMETABLE} - PCRE_INFO_STUDYSIZE = 10; - {$EXTERNALSYM PCRE_INFO_STUDYSIZE} - PCRE_INFO_DEFAULT_TABLES = 11; - {$EXTERNALSYM PCRE_INFO_DEFAULT_TABLES} - PCRE_INFO_OKPARTIAL = 12; - {$EXTERNALSYM PCRE_INFO_OKPARTIAL} - PCRE_INFO_JCHANGED = 13; - {$EXTERNALSYM PCRE_INFO_JCHANGED} - PCRE_INFO_HASCRORLF = 14; - {$EXTERNALSYM PCRE_INFO_HASCRORLF} - PCRE_INFO_MINLENGTH = 15; - {$EXTERNALSYM PCRE_INFO_MINLENGTH} - - (* Request types for pcre_config() *) - PCRE_CONFIG_UTF8 = 0; - {$EXTERNALSYM PCRE_CONFIG_UTF8} - PCRE_CONFIG_NEWLINE = 1; - {$EXTERNALSYM PCRE_CONFIG_NEWLINE} - PCRE_CONFIG_LINK_SIZE = 2; - {$EXTERNALSYM PCRE_CONFIG_LINK_SIZE} - PCRE_CONFIG_POSIX_MALLOC_THRESHOLD = 3; - {$EXTERNALSYM PCRE_CONFIG_POSIX_MALLOC_THRESHOLD} - PCRE_CONFIG_MATCH_LIMIT = 4; - {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT} - PCRE_CONFIG_STACKRECURSE = 5; - {$EXTERNALSYM PCRE_CONFIG_STACKRECURSE} - PCRE_CONFIG_UNICODE_PROPERTIES = 6; - {$EXTERNALSYM PCRE_CONFIG_UNICODE_PROPERTIES} - PCRE_CONFIG_MATCH_LIMIT_RECURSION = 7; - {$EXTERNALSYM PCRE_CONFIG_MATCH_LIMIT_RECURSION} - PCRE_CONFIG_BSR = 8; - {$EXTERNALSYM PCRE_CONFIG_BSR} - - (* Bit flags for the pcre_extra structure *) - - PCRE_EXTRA_STUDY_DATA = $0001; - {$EXTERNALSYM PCRE_EXTRA_STUDY_DATA} - PCRE_EXTRA_MATCH_LIMIT = $0002; - {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT} - PCRE_EXTRA_CALLOUT_DATA = $0004; - {$EXTERNALSYM PCRE_EXTRA_CALLOUT_DATA} - PCRE_EXTRA_TABLES = $0008; - {$EXTERNALSYM PCRE_EXTRA_TABLES} - PCRE_EXTRA_MATCH_LIMIT_RECURSION = $0010; - {$EXTERNALSYM PCRE_EXTRA_MATCH_LIMIT_RECURSION} - -type - {$IFNDEF FPC} - {$IFDEF CPU64} - SizeInt = Int64; - {$ELSE ~CPU64} - SizeInt = Integer; - {$ENDIF ~CPU64} - PPAnsiChar = ^PAnsiChar; - {$ENDIF ~FPC} - PPPAnsiChar = ^PPAnsiChar; - - real_pcre = packed record - {magic_number: Longword; - size: Integer; - tables: PAnsiChar; - options: Longword; - top_bracket: Word; - top_backref: word; - first_char: PAnsiChar; - req_char: PAnsiChar; - code: array [0..0] of AnsiChar;} - end; - TPCRE = real_pcre; - PPCRE = ^TPCRE; - - real_pcre_extra = packed record - {options: PAnsiChar; - start_bits: array [0..31] of AnsiChar;} - flags: Cardinal; (* Bits for which fields are set *) - study_data: Pointer; (* Opaque data from pcre_study() *) - match_limit: Cardinal; (* Maximum number of calls to match() *) - callout_data: Pointer; (* Data passed back in callouts *) - tables: PAnsiChar; (* Pointer to character tables *) - match_limit_recursion: Cardinal; (* Max recursive calls to match() *) - end; - TPCREExtra = real_pcre_extra; - PPCREExtra = ^TPCREExtra; - - pcre_callout_block = packed record - version: Integer; (* Identifies version of block *) - (* ------------------------ Version 0 ------------------------------- *) - callout_number: Integer; (* Number compiled into pattern *) - offset_vector: PInteger; (* The offset vector *) - subject: PAnsiChar; (* The subject being matched *) - subject_length: Integer; (* The length of the subject *) - start_match: Integer; (* Offset to start of this match attempt *) - current_position: Integer; (* Where we currently are in the subject *) - capture_top: Integer; (* Max current capture *) - capture_last: Integer; (* Most recently closed capture *) - callout_data: Pointer; (* Data passed in with the call *) - (* ------------------- Added for Version 1 -------------------------- *) - pattern_position: Integer; (* Offset to next item in the pattern *) - next_item_length: Integer; (* Length of next item in the pattern *) - (* ------------------------------------------------------------------ *) - end; - - pcre_malloc_callback = function(Size: SizeInt): Pointer; cdecl; - {$EXTERNALSYM pcre_malloc_callback} - pcre_free_callback = procedure(P: Pointer); cdecl; - {$EXTERNALSYM pcre_free_callback} - pcre_stack_malloc_callback = function(Size: SizeInt): Pointer; cdecl; - {$EXTERNALSYM pcre_stack_malloc_callback} - pcre_stack_free_callback = procedure(P: Pointer); cdecl; - {$EXTERNALSYM pcre_stack_free_callback} - pcre_callout_callback = function(var callout_block: pcre_callout_block): Integer; cdecl; - {$EXTERNALSYM pcre_callout_callback} - -var - // renamed from "pcre_X" to "pcre_X_func" to allow functions with name "pcre_X" to be - // declared in implementation when static linked - pcre_malloc_func: ^pcre_malloc_callback = nil; - {$EXTERNALSYM pcre_malloc_func} - pcre_free_func: ^pcre_free_callback = nil; - {$EXTERNALSYM pcre_free_func} - pcre_stack_malloc_func: ^pcre_stack_malloc_callback = nil; - {$EXTERNALSYM pcre_stack_malloc_func} - pcre_stack_free_func: ^pcre_stack_free_callback = nil; - {$EXTERNALSYM pcre_stack_free_func} - pcre_callout_func: ^pcre_callout_callback = nil; - {$EXTERNALSYM pcre_callout_func} - -procedure SetPCREMallocCallback(const Value: pcre_malloc_callback); -{$EXTERNALSYM SetPCREMallocCallback} -function GetPCREMallocCallback: pcre_malloc_callback; -{$EXTERNALSYM GetPCREMallocCallback} -function CallPCREMalloc(Size: SizeInt): Pointer; -{$EXTERNALSYM CallPCREMalloc} - -procedure SetPCREFreeCallback(const Value: pcre_free_callback); -{$EXTERNALSYM SetPCREFreeCallback} -function GetPCREFreeCallback: pcre_free_callback; -{$EXTERNALSYM GetPCREFreeCallback} -procedure CallPCREFree(P: Pointer); -{$EXTERNALSYM CallPCREFree} - -procedure SetPCREStackMallocCallback(const Value: pcre_stack_malloc_callback); -{$EXTERNALSYM SetPCREStackMallocCallback} -function GetPCREStackMallocCallback: pcre_stack_malloc_callback; -{$EXTERNALSYM GetPCREStackMallocCallback} -function CallPCREStackMalloc(Size: SizeInt): Pointer; -{$EXTERNALSYM CallPCREStackMalloc} - -procedure SetPCREStackFreeCallback(const Value: pcre_stack_free_callback); -{$EXTERNALSYM SetPCREStackFreeCallback} -function GetPCREStackFreeCallback: pcre_stack_free_callback; -{$EXTERNALSYM GetPCREStackFreeCallback} -procedure CallPCREStackFree(P: Pointer); -{$EXTERNALSYM CallPCREStackFree} - -procedure SetPCRECalloutCallback(const Value: pcre_callout_callback); -{$EXTERNALSYM SetPCRECalloutCallback} -function GetPCRECalloutCallback: pcre_callout_callback; -{$EXTERNALSYM GetPCRECalloutCallback} -function CallPCRECallout(var callout_block: pcre_callout_block): Integer; -{$EXTERNALSYM CallPCRECallout} - -type - TPCRELibNotLoadedHandler = procedure; cdecl; - -var - // Value to initialize function pointers below with, in case LoadPCRE fails - // or UnloadPCRE is called. Typically the handler will raise an exception. - LibNotLoadedHandler: TPCRELibNotLoadedHandler = nil; - -(* Functions *) - -// dynamic dll import -type - pcre_compile_func = function(const pattern: PAnsiChar; options: Integer; - const errptr: PPAnsiChar; erroffset: PInteger; const tableptr: PAnsiChar): PPCRE; - cdecl; - {$EXTERNALSYM pcre_compile_func} - pcre_compile2_func = function(const pattern: PAnsiChar; options: Integer; - const errorcodeptr: PInteger; const errorptr: PPAnsiChar; erroroffset: PInteger; - const tables: PAnsiChar): PPCRE; cdecl; - {$EXTERNALSYM pcre_compile2_func} - pcre_config_func = function(what: Integer; where: Pointer): Integer; - cdecl; - {$EXTERNALSYM pcre_config_func} - pcre_copy_named_substring_func = function(const code: PPCRE; const subject: PAnsiChar; - ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar; - buffer: PAnsiChar; size: Integer): Integer; cdecl; - {$EXTERNALSYM pcre_copy_named_substring_func} - pcre_copy_substring_func = function(const subject: PAnsiChar; ovector: PInteger; - stringcount, stringnumber: Integer; buffer: PAnsiChar; buffersize: Integer): Integer; - cdecl; - {$EXTERNALSYM pcre_copy_substring_func} - pcre_dfa_exec_func = function(const argument_re: PPCRE; const extra_data: PPCREExtra; - const subject: PAnsiChar; length: Integer; start_offset: Integer; - options: Integer; offsets: PInteger; offsetcount: Integer; workspace: PInteger; - wscount: Integer): Integer; cdecl; - {$EXTERNALSYM pcre_dfa_exec_func} - pcre_exec_func = function(const code: PPCRE; const extra: PPCREExtra; const subject: PAnsiChar; - length, startoffset, options: Integer; ovector: PInteger; ovecsize: Integer): Integer; - cdecl; - {$EXTERNALSYM pcre_exec_func} - pcre_free_substring_func = procedure(stringptr: PAnsiChar); - cdecl; - {$EXTERNALSYM pcre_free_substring_func} - pcre_free_substring_list_func = procedure(stringptr: PPAnsiChar); - cdecl; - {$EXTERNALSYM pcre_free_substring_list_func} - pcre_fullinfo_func = function(const code: PPCRE; const extra: PPCREExtra; - what: Integer; where: Pointer): Integer; - cdecl; - {$EXTERNALSYM pcre_fullinfo_func} - pcre_get_named_substring_func = function(const code: PPCRE; const subject: PAnsiChar; - ovector: PInteger; stringcount: Integer; const stringname: PAnsiChar; - const stringptr: PPAnsiChar): Integer; cdecl; - {$EXTERNALSYM pcre_get_named_substring_func} - pcre_get_stringnumber_func = function(const code: PPCRE; - const stringname: PAnsiChar): Integer; cdecl; - {$EXTERNALSYM pcre_get_stringnumber_func} - pcre_get_stringtable_entries_func = function(const code: PPCRE; const stringname: PAnsiChar; - firstptr: PPAnsiChar; lastptr: PPAnsiChar): Integer; - cdecl; - {$EXTERNALSYM pcre_get_stringtable_entries_func} - pcre_get_substring_func = function(const subject: PAnsiChar; ovector: PInteger; - stringcount, stringnumber: Integer; const stringptr: PPAnsiChar): Integer; - cdecl; - {$EXTERNALSYM pcre_get_substring_func} - pcre_get_substring_list_func = function(const subject: PAnsiChar; ovector: PInteger; - stringcount: Integer; listptr: PPPAnsiChar): Integer; - cdecl; - {$EXTERNALSYM pcre_get_substring_list_func} - pcre_info_func = function(const code: PPCRE; optptr, firstcharptr: PInteger): Integer; - cdecl; - {$EXTERNALSYM pcre_info_func} - pcre_maketables_func = function: PAnsiChar; cdecl; - {$EXTERNALSYM pcre_maketables_func} - pcre_refcount_func = function(argument_re: PPCRE; adjust: Integer): Integer; - cdecl; - {$EXTERNALSYM pcre_refcount_func} - pcre_study_func = function(const code: PPCRE; options: Integer; const errptr: PPAnsiChar): PPCREExtra; - cdecl; - {$EXTERNALSYM pcre_study_func} - pcre_version_func = function: PAnsiChar; cdecl; - {$EXTERNALSYM pcre_version_func} - -var - pcre_compile: pcre_compile_func = nil; - {$EXTERNALSYM pcre_compile} - pcre_compile2: pcre_compile2_func = nil; - {$EXTERNALSYM pcre_compile2} - pcre_config: pcre_config_func = nil; - {$EXTERNALSYM pcre_config} - pcre_copy_named_substring: pcre_copy_named_substring_func = nil; - {$EXTERNALSYM pcre_copy_named_substring} - pcre_copy_substring: pcre_copy_substring_func = nil; - {$EXTERNALSYM pcre_copy_substring} - pcre_dfa_exec: pcre_dfa_exec_func = nil; - {$EXTERNALSYM pcre_dfa_exec} - pcre_exec: pcre_exec_func = nil; - {$EXTERNALSYM pcre_exec} - pcre_free_substring: pcre_free_substring_func = nil; - {$EXTERNALSYM pcre_free_substring} - pcre_free_substring_list: pcre_free_substring_list_func = nil; - {$EXTERNALSYM pcre_free_substring_list} - pcre_fullinfo: pcre_fullinfo_func = nil; - {$EXTERNALSYM pcre_fullinfo} - pcre_get_named_substring: pcre_get_named_substring_func = nil; - {$EXTERNALSYM pcre_get_named_substring} - pcre_get_stringnumber: pcre_get_stringnumber_func = nil; - {$EXTERNALSYM pcre_get_stringnumber} - pcre_get_stringtable_entries: pcre_get_stringtable_entries_func = nil; - {$EXTERNALSYM pcre_get_stringtable_entries} - pcre_get_substring: pcre_get_substring_func = nil; - {$EXTERNALSYM pcre_get_substring} - pcre_get_substring_list: pcre_get_substring_list_func = nil; - {$EXTERNALSYM pcre_get_substring_list} - pcre_info: pcre_info_func = nil; - {$EXTERNALSYM pcre_info} - pcre_maketables: pcre_maketables_func = nil; - {$EXTERNALSYM pcre_maketables} - pcre_refcount: pcre_refcount_func = nil; - {$EXTERNALSYM pcre_refcount} - pcre_study: pcre_study_func = nil; - {$EXTERNALSYM pcre_study} - pcre_version: pcre_version_func = nil; - {$EXTERNALSYM pcre_version} - -function IsPCRELoaded: Boolean; -function LoadPCRE: Boolean; -procedure UnloadPCRE; - -implementation - -uses - SysUtils, - {$IFDEF MSWINDOWS} - Windows; - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - {$IFDEF HAS_UNIT_TYPES} - Types, - {$ENDIF HAS_UNIT_TYPES} - {$IFDEF HAS_UNIT_LIBC} - Libc; - {$ELSE ~HAS_UNIT_LIBC} - dl; - {$ENDIF ~HAS_UNIT_LIBC} - {$ENDIF UNIX} - -type - {$IFDEF MSWINDOWS} - TModuleHandle = HINST; - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - TModuleHandle = Pointer; - {$ENDIF LINUX} - {$IFDEF DARWIN} - TModuleHandle = Pointer; - {$ENDIF DARWIN} - -const - {$IFDEF MSWINDOWS} - libpcremodulename = 'pcre3.dll'; - {$ENDIF MSWINDOWS} - {$IFDEF LINUX} - libpcremodulename = 'libpcre.so.0'; - {$ENDIF LINUX} - {$IFDEF DARWIN} - libpcremodulename = 'libpcre.dylib'; - {$ENDIF DARWIN} - PCRECompileExportName = 'pcre_compile'; - PCRECompile2ExportName = 'pcre_compile2'; - PCREConfigExportName = 'pcre_config'; - PCRECopyNamedSubstringExportName = 'pcre_copy_named_substring'; - PCRECopySubStringExportName = 'pcre_copy_substring'; - PCREDfaExecExportName = 'pcre_dfa_exec'; - PCREExecExportName = 'pcre_exec'; - PCREFreeSubStringExportName = 'pcre_free_substring'; - PCREFreeSubStringListExportName = 'pcre_free_substring_list'; - PCREFullInfoExportName = 'pcre_fullinfo'; - PCREGetNamedSubstringExportName = 'pcre_get_named_substring'; - PCREGetStringNumberExportName = 'pcre_get_stringnumber'; - PCREGetStringTableEntriesExportName = 'pcre_get_stringtable_entries'; - PCREGetSubStringExportName = 'pcre_get_substring'; - PCREGetSubStringListExportName = 'pcre_get_substring_list'; - PCREInfoExportName = 'pcre_info'; - PCREMakeTablesExportName = 'pcre_maketables'; - PCRERefCountExportName = 'pcre_refcount'; - PCREStudyExportName = 'pcre_study'; - PCREVersionExportName = 'pcre_version'; - PCREMallocExportName = 'pcre_malloc'; - PCREFreeExportName = 'pcre_free'; - PCREStackMallocExportName = 'pcre_stack_malloc'; - PCREStackFreeExportName = 'pcre_stack_free'; - PCRECalloutExportName = 'pcre_callout'; - INVALID_MODULEHANDLE_VALUE = TModuleHandle(0); - -var - PCRELib: TModuleHandle = INVALID_MODULEHANDLE_VALUE; - -procedure SetPCREMallocCallback(const Value: pcre_malloc_callback); -begin - if not Assigned(pcre_malloc_func) then - LoadPCRE; - - if Assigned(pcre_malloc_func) then - pcre_malloc_func^ := Value - else if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; -end; - -function GetPCREMallocCallback: pcre_malloc_callback; -begin - if not Assigned(pcre_malloc_func) then - LoadPCRE; - - if not Assigned(pcre_malloc_func) then - begin - Result := nil; - if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; - end - else - Result := pcre_malloc_func^; -end; - -function CallPCREMalloc(Size: SizeInt): Pointer; -begin - Result := pcre_malloc_func^(Size); -end; - -procedure SetPCREFreeCallback(const Value: pcre_free_callback); -begin - if not Assigned(pcre_free_func) then - LoadPCRE; - - if Assigned(pcre_free_func) then - pcre_free_func^ := Value - else if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; -end; - -function GetPCREFreeCallback: pcre_free_callback; -begin - if not Assigned(pcre_free_func) then - LoadPCRE; - - if not Assigned(pcre_free_func) then - begin - Result := nil; - if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; - end - else - Result := pcre_free_func^ -end; - -procedure CallPCREFree(P: Pointer); -begin - pcre_free_func^(P); -end; - -procedure SetPCREStackMallocCallback(const Value: pcre_stack_malloc_callback); -begin - if not Assigned(pcre_stack_malloc_func) then - LoadPCRE; - - if Assigned(pcre_stack_malloc_func) then - pcre_stack_malloc_func^ := Value - else if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; -end; - -function GetPCREStackMallocCallback: pcre_stack_malloc_callback; -begin - if not Assigned(pcre_stack_malloc_func) then - LoadPCRE; - - if not Assigned(pcre_stack_malloc_func) then - begin - Result := nil; - if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; - end - else - Result := pcre_stack_malloc_func^; -end; - -function CallPCREStackMalloc(Size: SizeInt): Pointer; -begin - Result := pcre_stack_malloc_func^(Size); -end; - -procedure SetPCREStackFreeCallback(const Value: pcre_stack_free_callback); -begin - if not Assigned(pcre_stack_free_func) then - LoadPCRE; - - if Assigned(pcre_stack_free_func) then - pcre_stack_free_func^ := Value - else if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; -end; - -function GetPCREStackFreeCallback: pcre_stack_free_callback; -begin - if not Assigned(pcre_stack_free_func) then - LoadPCRE; - - if not Assigned(pcre_stack_free_func) then - begin - Result := nil; - if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; - end - else - Result := pcre_stack_free_func^; -end; - -procedure CallPCREStackFree(P: Pointer); -begin - pcre_stack_free_func^(P); -end; - -procedure SetPCRECalloutCallback(const Value: pcre_callout_callback); -begin - if not Assigned(pcre_callout_func) then - LoadPCRE; - - if Assigned(pcre_callout_func) then - pcre_callout_func^ := Value - else if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; -end; - -function GetPCRECalloutCallback: pcre_callout_callback; -begin - if not Assigned(pcre_callout_func) then - LoadPCRE; - - if not Assigned(pcre_callout_func) then - begin - Result := nil; - if Assigned(LibNotLoadedHandler) then - LibNotLoadedHandler; - end - else - Result := pcre_callout_func^; -end; - -function CallPCRECallout(var callout_block: pcre_callout_block): Integer; -begin - Result := pcre_callout_func^(callout_block); -end; - -procedure InitPCREFuncPtrs(const Value: Pointer); -begin - @pcre_compile := Value; - @pcre_compile2 := Value; - @pcre_config := Value; - @pcre_copy_named_substring := Value; - @pcre_copy_substring := Value; - @pcre_dfa_exec := Value; - @pcre_exec := Value; - @pcre_free_substring := Value; - @pcre_free_substring_list := Value; - @pcre_fullinfo := Value; - @pcre_get_named_substring := Value; - @pcre_get_stringnumber := Value; - @pcre_get_stringtable_entries := Value; - @pcre_get_substring := Value; - @pcre_get_substring_list := Value; - @pcre_info := Value; - @pcre_maketables := Value; - @pcre_refcount := Value; - @pcre_study := Value; - @pcre_version := Value; - pcre_malloc_func := nil; - pcre_free_func := nil; - pcre_stack_malloc_func := nil; - pcre_stack_free_func := nil; - pcre_callout_func := nil; -end; - -function IsPCRELoaded: Boolean; -begin - Result := PCRELib <> INVALID_MODULEHANDLE_VALUE; -end; - -function LoadPCRE: Boolean; - function GetSymbol(SymbolName: PAnsiChar): Pointer; - begin - {$IFDEF MSWINDOWS} - Result := GetProcAddress(PCRELib, SymbolName); - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - Result := dlsym(PCRELib, SymbolName); - {$ENDIF UNIX} - end; - -begin - Result := PCRELib <> INVALID_MODULEHANDLE_VALUE; - if Result then - Exit; - - if PCRELib = INVALID_MODULEHANDLE_VALUE then - {$IFDEF MSWINDOWS} - PCRELib := SafeLoadLibrary(libpcremodulename); - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - PCRELib := dlopen(PAnsiChar(libpcremodulename), RTLD_NOW); - {$ENDIF UNIX} - Result := PCRELib <> INVALID_MODULEHANDLE_VALUE; - if Result then - begin - @pcre_compile := GetSymbol(PCRECompileExportName); - @pcre_compile2 := GetSymbol(PCRECompile2ExportName); - @pcre_config := GetSymbol(PCREConfigExportName); - @pcre_copy_named_substring := GetSymbol(PCRECopyNamedSubstringExportName); - @pcre_copy_substring := GetSymbol(PCRECopySubStringExportName); - @pcre_dfa_exec := GetSymbol(PCREDfaExecExportName); - @pcre_exec := GetSymbol(PCREExecExportName); - @pcre_free_substring := GetSymbol(PCREFreeSubStringExportName); - @pcre_free_substring_list := GetSymbol(PCREFreeSubStringListExportName); - @pcre_fullinfo := GetSymbol(PCREFullInfoExportName); - @pcre_get_named_substring := GetSymbol(PCREGetNamedSubstringExportName); - @pcre_get_stringnumber := GetSymbol(PCREGetStringNumberExportName); - @pcre_get_stringtable_entries := GetSymbol(PCREGetStringTableEntriesExportName); - @pcre_get_substring := GetSymbol(PCREGetSubStringExportName); - @pcre_get_substring_list := GetSymbol(PCREGetSubStringListExportName); - @pcre_info := GetSymbol(PCREInfoExportName); - @pcre_maketables := GetSymbol(PCREMakeTablesExportName); - @pcre_refcount := GetSymbol(PCRERefCountExportName); - @pcre_study := GetSymbol(PCREStudyExportName); - @pcre_version := GetSymbol(PCREVersionExportName); - pcre_malloc_func := GetSymbol(PCREMallocExportName); - pcre_free_func := GetSymbol(PCREFreeExportName); - pcre_stack_malloc_func := GetSymbol(PCREStackMallocExportName); - pcre_stack_free_func := GetSymbol(PCREStackFreeExportName); - pcre_callout_func := GetSymbol(PCRECalloutExportName); - end - else - InitPCREFuncPtrs(@LibNotLoadedHandler); -end; - -procedure UnloadPCRE; -begin - if PCRELib <> INVALID_MODULEHANDLE_VALUE then - {$IFDEF MSWINDOWS} - FreeLibrary(PCRELib); - {$ENDIF MSWINDOWS} - {$IFDEF UNIX} - dlclose(Pointer(PCRELib)); - {$ENDIF UNIX} - PCRELib := INVALID_MODULEHANDLE_VALUE; - InitPCREFuncPtrs(@LibNotLoadedHandler); -end; - -(* -function pcre_compile; external libpcremodulename name PCRECompileExportName; -function pcre_compile2; external libpcremodulename name PCRECompile2ExportName; -function pcre_config; external libpcremodulename name PCREConfigExportName; -function pcre_copy_named_substring; external libpcremodulename name PCRECopyNamedSubStringExportName; -function pcre_copy_substring; external libpcremodulename name PCRECopySubStringExportName; -function pcre_dfa_exec; external libpcremodulename name PCREDfaExecExportName; -function pcre_exec; external libpcremodulename name PCREExecExportName; -procedure pcre_free_substring; external libpcremodulename name PCREFreeSubStringExportName; -procedure pcre_free_substring_list; external libpcremodulename name PCREFreeSubStringListExportName; -function pcre_fullinfo; external libpcremodulename name PCREFullInfoExportName; -function pcre_get_named_substring; external libpcremodulename name PCREGetNamedSubStringExportName; -function pcre_get_stringnumber; external libpcremodulename name PCREGetStringNumberExportName; -function pcre_get_stringtable_entries; external libpcremodulename name PCREGetStringTableEntriesExportName; -function pcre_get_substring; external libpcremodulename name PCREGetSubStringExportName; -function pcre_get_substring_list; external libpcremodulename name PCREGetSubStringListExportName; -function pcre_info; external libpcremodulename name PCREInfoExportName; -function pcre_maketables; external libpcremodulename name PCREMakeTablesExportName; -function pcre_refcount; external libpcremodulename name PCRERefCountExportName; -function pcre_study; external libpcremodulename name PCREStudyExportName; -function pcre_version; external libpcremodulename name PCREVersionExportName; -*) - -end. diff --git a/src/lib/portaudio/portaudio.pas b/src/lib/portaudio/portaudio.pas deleted file mode 100644 index ea7d06b7..00000000 --- a/src/lib/portaudio/portaudio.pas +++ /dev/null @@ -1,1160 +0,0 @@ -{* - * $Id: portaudio.h,v 1.7 2007/08/16 20:45:34 richardash1981 Exp $ - * PortAudio Portable Real-Time Audio Library - * PortAudio API Header File - * Latest version available at: http://www.portaudio.com/ - * - * Copyright (c) 1999-2002 Ross Bencina and Phil Burk - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - *} - -{* - * The text above constitutes the entire PortAudio license; however, - * the PortAudio community also makes the following non-binding requests: - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. It is also - * requested that these non-binding requests be included along with the - * license above. - *} - -{** @file - @brief The PortAudio API. -*} - -unit portaudio; - -{$IFDEF FPC} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) - {$MODE DELPHI } -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -interface - -uses - ctypes; - -const -{$IF Defined(MSWINDOWS)} - LibName = 'portaudio_x86.dll'; -{$ELSEIF Defined(DARWIN)} - // this is for portaudio version 19 - LibName = 'libportaudio.2.dylib'; - {$LINKLIB libportaudio.2} -{$ELSEIF Defined(UNIX)} - LibName = 'libportaudio.so'; -{$IFEND} - -{** Retrieve the release number of the currently running PortAudio build, - eg 1900. -*} -function Pa_GetVersion(): cint; cdecl; external LibName; - - -{** Retrieve a textual description of the current PortAudio build, - eg "PortAudio V19-devel 13 October 2002". -*} -function Pa_GetVersionText(): PChar; cdecl; external LibName; - - -{** Error codes returned by PortAudio functions. - Note that with the exception of paNoError, all PaErrorCodes are negative. -*} - -type TPaError = cint; -type TPaErrorCode = {enum}cint; const -{enum_begin PaErrorCode} - paNoError = 0; - - paNotInitialized = -10000; - paUnanticipatedHostError = (paNotInitialized+ 1); - paInvalidChannelCount = (paNotInitialized+ 2); - paInvalidSampleRate = (paNotInitialized+ 3); - paInvalidDevice = (paNotInitialized+ 4); - paInvalidFlag = (paNotInitialized+ 5); - paSampleFormatNotSupported = (paNotInitialized+ 6); - paBadIODeviceCombination = (paNotInitialized+ 7); - paInsufficientMemory = (paNotInitialized+ 8); - paBufferTooBig = (paNotInitialized+ 9); - paBufferTooSmall = (paNotInitialized+10); - paNullCallback = (paNotInitialized+11); - paBadStreamPtr = (paNotInitialized+12); - paTimedOut = (paNotInitialized+13); - paInternalError = (paNotInitialized+14); - paDeviceUnavailable = (paNotInitialized+15); - paIncompatibleHostApiSpecificStreamInfo = (paNotInitialized+16); - paStreamIsStopped = (paNotInitialized+17); - paStreamIsNotStopped = (paNotInitialized+18); - paInputOverflowed = (paNotInitialized+19); - paOutputUnderflowed = (paNotInitialized+20); - paHostApiNotFound = (paNotInitialized+21); // The notes below are from the - paInvalidHostApi = (paNotInitialized+22); // original file portaudio.h - paCanNotReadFromACallbackStream = (paNotInitialized+23); {**< @todo review error code name *} - paCanNotWriteToACallbackStream = (paNotInitialized+24); {**< @todo review error code name *} - paCanNotReadFromAnOutputOnlyStream = (paNotInitialized+25); {**< @todo review error code name *} - paCanNotWriteToAnInputOnlyStream = (paNotInitialized+26); {**< @todo review error code name *} - paIncompatibleStreamHostApi = (paNotInitialized+27); - paBadBufferPtr = (paNotInitialized+28); -{enum_end PaErrorCode} - - -{** Translate the supplied PortAudio error code into a human readable - message. -*} -function Pa_GetErrorText( errorCode: TPaError ): PChar; cdecl; external LibName; - - -{** Library initialization function - call this before using PortAudio. - This function initialises internal data structures and prepares underlying - host APIs for use. With the exception of Pa_GetVersion(), Pa_GetVersionText(), - and Pa_GetErrorText(), this function MUST be called before using any other - PortAudio API functions. - - If Pa_Initialize() is called multiple times, each successful - call must be matched with a corresponding call to Pa_Terminate(). - Pairs of calls to Pa_Initialize()/Pa_Terminate() may overlap, and are not - required to be fully nested. - - Note that if Pa_Initialize() returns an error code, Pa_Terminate() should - NOT be called. - - @return paNoError if successful, otherwise an error code indicating the cause - of failure. - - @see Pa_Terminate -*} -function Pa_Initialize(): TPaError; cdecl; external LibName; - - -{** Library termination function - call this when finished using PortAudio. - This function deallocates all resources allocated by PortAudio since it was - initializied by a call to Pa_Initialize(). In cases where Pa_Initialise() has - been called multiple times, each call must be matched with a corresponding call - to Pa_Terminate(). The final matching call to Pa_Terminate() will automatically - close any PortAudio streams that are still open. - - Pa_Terminate() MUST be called before exiting a program which uses PortAudio. - Failure to do so may result in serious resource leaks, such as audio devices - not being available until the next reboot. - - @return paNoError if successful, otherwise an error code indicating the cause - of failure. - - @see Pa_Initialize -*} -function Pa_Terminate(): TPaError; cdecl; external LibName; - - - -{** The type used to refer to audio devices. Values of this type usually - range from 0 to (Pa_GetDeviceCount()-1), and may also take on the PaNoDevice - and paUseHostApiSpecificDeviceSpecification values. - - @see Pa_GetDeviceCount, paNoDevice, paUseHostApiSpecificDeviceSpecification -*} -type TPaDeviceIndex = cint; - - -{** A special PaDeviceIndex value indicating that no device is available, - or should be used. - - @see PaDeviceIndex -*} -const paNoDevice = TPaDeviceIndex(-1); - - -{** A special PaDeviceIndex value indicating that the device(s) to be used - are specified in the host api specific stream info structure. - - @see PaDeviceIndex -*} -const paUseHostApiSpecificDeviceSpecification = TPaDeviceIndex(-2); - - -{* Host API enumeration mechanism *} - -{** The type used to enumerate to host APIs at runtime. Values of this type - range from 0 to (Pa_GetHostApiCount()-1). - - @see Pa_GetHostApiCount -*} -type TPaHostApiIndex = cint; - -{** Retrieve the number of available host APIs. Even if a host API is - available it may have no devices available. - - @return A non-negative value indicating the number of available host APIs - or, a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. - - @see PaHostApiIndex -*} -function Pa_GetHostApiCount(): TPaHostApiIndex; cdecl; external LibName; - - -{** Retrieve the index of the default host API. The default host API will be - the lowest common denominator host API on the current platform and is - unlikely to provide the best performance. - - @return A non-negative value ranging from 0 to (Pa_GetHostApiCount()-1) - indicating the default host API index or, a PaErrorCode (which are always - negative) if PortAudio is not initialized or an error is encountered. -*} -function Pa_GetDefaultHostApi(): TPaHostApiIndex; cdecl; external LibName; - - -{** Unchanging unique identifiers for each supported host API. This type - is used in the PaHostApiInfo structure. The values are guaranteed to be - unique and to never change, thus allowing code to be written that - conditionally uses host API specific extensions. - - New type ids will be allocated when support for a host API reaches - "public alpha" status, prior to that developers should use the - paInDevelopment type id. - - @see PaHostApiInfo -*} -type TPaHostApiTypeId = {enum}cint; const -{enum_begin PaHostApiTypeId} - paInDevelopment=0; {* use while developing support for a new host API *} - paDirectSound=1; - paMME=2; - paASIO=3; - paSoundManager=4; - paCoreAudio=5; - paOSS=7; - paALSA=8; - paAL=9; - paBeOS=10; - paWDMKS=11; - paJACK=12; - paWASAPI=13; - paAudioScienceHPI=14; -{enum_end PaHostApiTypeId} - -{** A structure containing information about a particular host API. *} - -type - PPaHostApiInfo = ^TPaHostApiInfo; - TPaHostApiInfo = record - {** this is struct version 1 *} - structVersion: cint; - {** The well known unique identifier of this host API @see PaHostApiTypeId *} - _type: TPaHostApiTypeId; - {** A textual description of the host API for display on user interfaces. *} - name: PChar; - - {** The number of devices belonging to this host API. This field may be - used in conjunction with Pa_HostApiDeviceIndexToDeviceIndex() to enumerate - all devices for this host API. - @see Pa_HostApiDeviceIndexToDeviceIndex - *} - deviceCount: cint; - - {** The default input device for this host API. The value will be a - device index ranging from 0 to (Pa_GetDeviceCount()-1), or paNoDevice - if no default input device is available. - *} - defaultInputDevice: TPaDeviceIndex; - - {** The default output device for this host API. The value will be a - device index ranging from 0 to (Pa_GetDeviceCount()-1), or paNoDevice - if no default output device is available. - *} - defaultOutputDevice: TPaDeviceIndex; - end; - - -{** Retrieve a pointer to a structure containing information about a specific - host Api. - - @param hostApi A valid host API index ranging from 0 to (Pa_GetHostApiCount()-1) - - @return A pointer to an immutable PaHostApiInfo structure describing - a specific host API. If the hostApi parameter is out of range or an error - is encountered, the function returns NULL. - - The returned structure is owned by the PortAudio implementation and must not - be manipulated or freed. The pointer is only guaranteed to be valid between - calls to Pa_Initialize() and Pa_Terminate(). -*} -function Pa_GetHostApiInfo( hostApi: TPaHostApiIndex ): PPaHostApiInfo; cdecl; external LibName; - - -{** Convert a static host API unique identifier, into a runtime - host API index. - - @param type A unique host API identifier belonging to the PaHostApiTypeId - enumeration. - - @return A valid PaHostApiIndex ranging from 0 to (Pa_GetHostApiCount()-1) or, - a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. - - The paHostApiNotFound error code indicates that the host API specified by the - type parameter is not available. - - @see PaHostApiTypeId -*} -function Pa_HostApiTypeIdToHostApiIndex( _type: TPaHostApiTypeId ): TPaHostApiIndex; cdecl; external LibName; - - -{** Convert a host-API-specific device index to standard PortAudio device index. - This function may be used in conjunction with the deviceCount field of - PaHostApiInfo to enumerate all devices for the specified host API. - - @param hostApi A valid host API index ranging from 0 to (Pa_GetHostApiCount()-1) - - @param hostApiDeviceIndex A valid per-host device index in the range - 0 to (Pa_GetHostApiInfo(hostApi)->deviceCount-1) - - @return A non-negative PaDeviceIndex ranging from 0 to (Pa_GetDeviceCount()-1) - or, a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. - - A paInvalidHostApi error code indicates that the host API index specified by - the hostApi parameter is out of range. - - A paInvalidDevice error code indicates that the hostApiDeviceIndex parameter - is out of range. - - @see PaHostApiInfo -*} -function Pa_HostApiDeviceIndexToDeviceIndex( hostApi: TPaHostApiIndex; - hostApiDeviceIndex: cint ): TPaDeviceIndex; cdecl; external LibName; - - - -{** Structure used to return information about a host error condition. -*} -type - PPaHostErrorInfo = ^TPaHostErrorInfo; - TPaHostErrorInfo = record - hostApiType: TPaHostApiTypeId; {**< the host API which returned the error code *} - errorCode: clong; {**< the error code returned *} - errorText: PChar; {**< a textual description of the error if available, otherwise a zero-length string *} - end; - - -{** Return information about the last host error encountered. The error - information returned by Pa_GetLastHostErrorInfo() will never be modified - asyncronously by errors occurring in other PortAudio owned threads - (such as the thread that manages the stream callback.) - - This function is provided as a last resort, primarily to enhance debugging - by providing clients with access to all available error information. - - @return A pointer to an immutable structure constaining information about - the host error. The values in this structure will only be valid if a - PortAudio function has previously returned the paUnanticipatedHostError - error code. -*} -function Pa_GetLastHostErrorInfo(): PPaHostErrorInfo; cdecl; external LibName; - - - -{* Device enumeration and capabilities *} - -{** Retrieve the number of available devices. The number of available devices - may be zero. - - @return A non-negative value indicating the number of available devices or, - a PaErrorCode (which are always negative) if PortAudio is not initialized - or an error is encountered. -*} -function Pa_GetDeviceCount(): TPaDeviceIndex; cdecl; external LibName; - - -{** Retrieve the index of the default input device. The result can be - used in the inputDevice parameter to Pa_OpenStream(). - - @return The default input device index for the default host API, or paNoDevice - if no default input device is available or an error was encountered. -*} -function Pa_GetDefaultInputDevice(): TPaDeviceIndex; cdecl; external LibName; - - -{** Retrieve the index of the default output device. The result can be - used in the outputDevice parameter to Pa_OpenStream(). - - @return The default output device index for the defualt host API, or paNoDevice - if no default output device is available or an error was encountered. - - @note - On the PC, the user can specify a default device by - setting an environment variable. For example, to use device #1. -
- set PA_RECOMMENDED_OUTPUT_DEVICE=1
-
- The user should first determine the available device ids by using - the supplied application "pa_devs". -*} -function Pa_GetDefaultOutputDevice(): TPaDeviceIndex; cdecl; external LibName; - - -{** The type used to represent monotonic time in seconds that can be used - for syncronisation. The type is used for the outTime argument to the - PaStreamCallback and as the result of Pa_GetStreamTime(). - - @see PaStreamCallback, Pa_GetStreamTime -*} -type TPaTime = cdouble; - - -{** A type used to specify one or more sample formats. Each value indicates - a possible format for sound data passed to and from the stream callback, - Pa_ReadStream and Pa_WriteStream. - - The standard formats paFloat32, paInt16, paInt32, paInt24, paInt8 - and aUInt8 are usually implemented by all implementations. - - The floating point representation (paFloat32) uses +1.0 and -1.0 as the - maximum and minimum respectively. - - paUInt8 is an unsigned 8 bit format where 128 is considered "ground" - - The paNonInterleaved flag indicates that a multichannel buffer is passed - as a set of non-interleaved pointers. - - @see Pa_OpenStream, Pa_OpenDefaultStream, PaDeviceInfo - @see paFloat32, paInt16, paInt32, paInt24, paInt8 - @see paUInt8, paCustomFormat, paNonInterleaved -*} -type TPaSampleFormat = culong; -const - paFloat32 = TPaSampleFormat($00000001); {**< @see PaSampleFormat *} - paInt32 = TPaSampleFormat($00000002); {**< @see PaSampleFormat *} - paInt24 = TPaSampleFormat($00000004); {**< Packed 24 bit format. @see PaSampleFormat *} - paInt16 = TPaSampleFormat($00000008); {**< @see PaSampleFormat *} - paInt8 = TPaSampleFormat($00000010); {**< @see PaSampleFormat *} - paUInt8 = TPaSampleFormat($00000020); {**< @see PaSampleFormat *} - paCustomFormat = TPaSampleFormat($00010000); {**< @see PaSampleFormat *} - paNonInterleaved = TPaSampleFormat($80000000); - -{** A structure providing information and capabilities of PortAudio devices. - Devices may support input, output or both input and output. -*} -type - PPaDeviceInfo = ^TPaDeviceInfo; - TPaDeviceInfo = record - structVersion: cint; {* this is struct version 2 *} - name: PChar; - hostApi: TPaHostApiIndex; {* note this is a host API index, not a type id*} - - maxInputChannels: cint; - maxOutputChannels: cint; - - {* Default latency values for interactive performance. *} - defaultLowInputLatency: TPaTime; - defaultLowOutputLatency: TPaTime; - {* Default latency values for robust non-interactive applications (eg. playing sound files). *} - defaultHighInputLatency: TPaTime; - defaultHighOutputLatency: TPaTime; - - defaultSampleRate: cdouble; - end; - - -{** Retrieve a pointer to a PaDeviceInfo structure containing information - about the specified device. - @return A pointer to an immutable PaDeviceInfo structure. If the device - parameter is out of range the function returns NULL. - - @param device A valid device index in the range 0 to (Pa_GetDeviceCount()-1) - - @note PortAudio manages the memory referenced by the returned pointer, - the client must not manipulate or free the memory. The pointer is only - guaranteed to be valid between calls to Pa_Initialize() and Pa_Terminate(). - - @see PaDeviceInfo, PaDeviceIndex -*} -function Pa_GetDeviceInfo( device: TPaDeviceIndex ): PPaDeviceInfo; cdecl; external LibName; - - -{** Parameters for one direction (input or output) of a stream. -*} -type - PPaStreamParameters = ^TPaStreamParameters; - TPaStreamParameters = record - {** A valid device index in the range 0 to (Pa_GetDeviceCount()-1) - specifying the device to be used or the special constant - paUseHostApiSpecificDeviceSpecification which indicates that the actual - device(s) to use are specified in hostApiSpecificStreamInfo. - This field must not be set to paNoDevice. - *} - device: TPaDeviceIndex; - - {** The number of channels of sound to be delivered to the - stream callback or accessed by Pa_ReadStream() or Pa_WriteStream(). - It can range from 1 to the value of maxInputChannels in the - PaDeviceInfo record for the device specified by the device parameter. - *} - channelCount: cint; - - {** The sample format of the buffer provided to the stream callback, - a_ReadStream() or Pa_WriteStream(). It may be any of the formats described - by the PaSampleFormat enumeration. - *} - sampleFormat: TPaSampleFormat; - - {** The desired latency in seconds. Where practical, implementations should - configure their latency based on these parameters, otherwise they may - choose the closest viable latency instead. Unless the suggested latency - is greater than the absolute upper limit for the device implementations - should round the suggestedLatency up to the next practial value - ie to - provide an equal or higher latency than suggestedLatency wherever possibe. - Actual latency values for an open stream may be retrieved using the - inputLatency and outputLatency fields of the PaStreamInfo structure - returned by Pa_GetStreamInfo(). - @see default*Latency in PaDeviceInfo, *Latency in PaStreamInfo - *} - suggestedLatency: TPaTime; - - {** An optional pointer to a host api specific data structure - containing additional information for device setup and/or stream processing. - hostApiSpecificStreamInfo is never required for correct operation, - if not used it should be set to NULL. - *} - hostApiSpecificStreamInfo: Pointer; - end; - - -{** Return code for Pa_IsFormatSupported indicating success. *} -const paFormatIsSupported = (0); - -{** Determine whether it would be possible to open a stream with the specified - parameters. - - @param inputParameters A structure that describes the input parameters used to - open a stream. The suggestedLatency field is ignored. See PaStreamParameters - for a description of these parameters. inputParameters must be NULL for - output-only streams. - - @param outputParameters A structure that describes the output parameters used - to open a stream. The suggestedLatency field is ignored. See PaStreamParameters - for a description of these parameters. outputParameters must be NULL for - input-only streams. - - @param sampleRate The required sampleRate. For full-duplex streams it is the - sample rate for both input and output - - @return Returns 0 if the format is supported, and an error code indicating why - the format is not supported otherwise. The constant paFormatIsSupported is - provided to compare with the return value for success. - - @see paFormatIsSupported, PaStreamParameters -*} -function Pa_IsFormatSupported( inputParameters: PPaStreamParameters; - outputParameters: PPaStreamParameters; - sampleRate: cdouble ): TPaError; cdecl; external LibName; - - - -{* Streaming types and functions *} - - -{** - A single PaStream can provide multiple channels of real-time - streaming audio input and output to a client application. A stream - provides access to audio hardware represented by one or more - PaDevices. Depending on the underlying Host API, it may be possible - to open multiple streams using the same device, however this behavior - is implementation defined. Portable applications should assume that - a PaDevice may be simultaneously used by at most one PaStream. - - Pointers to PaStream objects are passed between PortAudio functions that - operate on streams. - - @see Pa_OpenStream, Pa_OpenDefaultStream, Pa_OpenDefaultStream, Pa_CloseStream, - Pa_StartStream, Pa_StopStream, Pa_AbortStream, Pa_IsStreamActive, - Pa_GetStreamTime, Pa_GetStreamCpuLoad - -*} -type - PPaStream = Pointer; - -{** Can be passed as the framesPerBuffer parameter to Pa_OpenStream() - or Pa_OpenDefaultStream() to indicate that the stream callback will - accept buffers of any size. -*} -const paFramesPerBufferUnspecified = (0); - - -{** Flags used to control the behavior of a stream. They are passed as - parameters to Pa_OpenStream or Pa_OpenDefaultStream. Multiple flags may be - ORed together. - - @see Pa_OpenStream, Pa_OpenDefaultStream - @see paNoFlag, paClipOff, paDitherOff, paNeverDropInput, - paPrimeOutputBuffersUsingStreamCallback, paPlatformSpecificFlags -*} -type TPaStreamFlags = culong; - -{** @see PaStreamFlags *} -const paNoFlag = TPaStreamFlags(0); - -{** Disable default clipping of out of range samples. - @see PaStreamFlags -*} -const paClipOff = TPaStreamFlags($00000001); - -{** Disable default dithering. - @see PaStreamFlags -*} -const paDitherOff = TPaStreamFlags($00000002); - -{** Flag requests that where possible a full duplex stream will not discard - overflowed input samples without calling the stream callback. This flag is - only valid for full duplex callback streams and only when used in combination - with the paFramesPerBufferUnspecified (0) framesPerBuffer parameter. Using - this flag incorrectly results in a paInvalidFlag error being returned from - Pa_OpenStream and Pa_OpenDefaultStream. - - @see PaStreamFlags, paFramesPerBufferUnspecified -*} -const paNeverDropInput = TPaStreamFlags($00000004); - -{** Call the stream callback to fill initial output buffers, rather than the - default behavior of priming the buffers with zeros (silence). This flag has - no effect for input-only and blocking read/write streams. - - @see PaStreamFlags -*} -const paPrimeOutputBuffersUsingStreamCallback = TPaStreamFlags($00000008); - -{** A mask specifying the platform specific bits. - @see PaStreamFlags -*} -const paPlatformSpecificFlags = TPaStreamFlags($FFFF0000); - -{** - Timing information for the buffers passed to the stream callback. -*} -type - PPaStreamCallbackTimeInfo = ^TPaStreamCallbackTimeInfo; - TPaStreamCallbackTimeInfo = record - inputBufferAdcTime: TPaTime; - currentTime: TPaTime; - outputBufferDacTime: TPaTime; - end; - - -{** - Flag bit constants for the statusFlags to PaStreamCallback. - - @see paInputUnderflow, paInputOverflow, paOutputUnderflow, paOutputOverflow, - paPrimingOutput -*} -type TPaStreamCallbackFlags = culong; - -{** In a stream opened with paFramesPerBufferUnspecified, indicates that - input data is all silence (zeros) because no real data is available. In a - stream opened without paFramesPerBufferUnspecified, it indicates that one or - more zero samples have been inserted into the input buffer to compensate - for an input underflow. - @see PaStreamCallbackFlags -*} -const paInputUnderflow = TPaStreamCallbackFlags($00000001); - -{** In a stream opened with paFramesPerBufferUnspecified, indicates that data - prior to the first sample of the input buffer was discarded due to an - overflow, possibly because the stream callback is using too much CPU time. - Otherwise indicates that data prior to one or more samples in the - input buffer was discarded. - @see PaStreamCallbackFlags -*} -const paInputOverflow = TPaStreamCallbackFlags($00000002); - -{** Indicates that output data (or a gap) was inserted, possibly because the - stream callback is using too much CPU time. - @see PaStreamCallbackFlags -*} -const paOutputUnderflow = TPaStreamCallbackFlags($00000004); - -{** Indicates that output data will be discarded because no room is available. - @see PaStreamCallbackFlags -*} -const paOutputOverflow = TPaStreamCallbackFlags($00000008); - -{** Some of all of the output data will be used to prime the stream, input - data may be zero. - @see PaStreamCallbackFlags -*} -const paPrimingOutput = TPaStreamCallbackFlags($00000010); - -{** - Allowable return values for the PaStreamCallback. - @see PaStreamCallback -*} -type TPaStreamCallbackResult = {enum}cint; const -{enum_begin PaStreamCallbackResult} - paContinue=0; - paComplete=1; - paAbort=2; -{enum_end PaStreamCallbackResult} - -{** - Functions of type PaStreamCallback are implemented by PortAudio clients. - They consume, process or generate audio in response to requests from an - active PortAudio stream. - - @param input and @param output are arrays of interleaved samples, - the format, packing and number of channels used by the buffers are - determined by parameters to Pa_OpenStream(). - - @param frameCount The number of sample frames to be processed by - the stream callback. - - @param timeInfo The time in seconds when the first sample of the input - buffer was received at the audio input, the time in seconds when the first - sample of the output buffer will begin being played at the audio output, and - the time in seconds when the stream callback was called. - See also Pa_GetStreamTime() - - @param statusFlags Flags indicating whether input and/or output buffers - have been inserted or will be dropped to overcome underflow or overflow - conditions. - - @param userData The value of a user supplied pointer passed to - Pa_OpenStream() intended for storing synthesis data etc. - - @return - The stream callback should return one of the values in the - PaStreamCallbackResult enumeration. To ensure that the callback continues - to be called, it should return paContinue (0). Either paComplete or paAbort - can be returned to finish stream processing, after either of these values is - returned the callback will not be called again. If paAbort is returned the - stream will finish as soon as possible. If paComplete is returned, the stream - will continue until all buffers generated by the callback have been played. - This may be useful in applications such as soundfile players where a specific - duration of output is required. However, it is not necessary to utilise this - mechanism as Pa_StopStream(), Pa_AbortStream() or Pa_CloseStream() can also - be used to stop the stream. The callback must always fill the entire output - buffer irrespective of its return value. - - @see Pa_OpenStream, Pa_OpenDefaultStream - - @note With the exception of Pa_GetStreamCpuLoad() it is not permissable to call - PortAudio API functions from within the stream callback. -*} -type - PPaStreamCallback = ^TPaStreamCallback; - TPaStreamCallback = function( - input: Pointer; output: Pointer; - frameCount: culong; - timeInfo: PPaStreamCallbackTimeInfo; - statusFlags: TPaStreamCallbackFlags; - userData: Pointer ): cint; cdecl; - - -{** Opens a stream for either input, output or both. - - @param stream The address of a PaStream pointer which will receive - a pointer to the newly opened stream. - - @param inputParameters A structure that describes the input parameters used by - the opened stream. See PaStreamParameters for a description of these parameters. - inputParameters must be NULL for output-only streams. - - @param outputParameters A structure that describes the output parameters used by - the opened stream. See PaStreamParameters for a description of these parameters. - outputParameters must be NULL for input-only streams. - - @param sampleRate The desired sampleRate. For full-duplex streams it is the - sample rate for both input and output - - @param framesPerBuffer The number of frames passed to the stream callback - function, or the preferred block granularity for a blocking read/write stream. - The special value paFramesPerBufferUnspecified (0) may be used to request that - the stream callback will recieve an optimal (and possibly varying) number of - frames based on host requirements and the requested latency settings. - Note: With some host APIs, the use of non-zero framesPerBuffer for a callback - stream may introduce an additional layer of buffering which could introduce - additional latency. PortAudio guarantees that the additional latency - will be kept to the theoretical minimum however, it is strongly recommended - that a non-zero framesPerBuffer value only be used when your algorithm - requires a fixed number of frames per stream callback. - - @param streamFlags Flags which modify the behaviour of the streaming process. - This parameter may contain a combination of flags ORed together. Some flags may - only be relevant to certain buffer formats. - - @param streamCallback A pointer to a client supplied function that is responsible - for processing and filling input and output buffers. If this parameter is NULL - the stream will be opened in 'blocking read/write' mode. In blocking mode, - the client can receive sample data using Pa_ReadStream and write sample data - using Pa_WriteStream, the number of samples that may be read or written - without blocking is returned by Pa_GetStreamReadAvailable and - Pa_GetStreamWriteAvailable respectively. - - @param userData A client supplied pointer which is passed to the stream callback - function. It could for example, contain a pointer to instance data necessary - for processing the audio buffers. This parameter is ignored if streamCallback - is NULL. - - @return - Upon success Pa_OpenStream() returns paNoError and places a pointer to a - valid PaStream in the stream argument. The stream is inactive (stopped). - If a call to Pa_OpenStream() fails, a non-zero error code is returned (see - PaError for possible error codes) and the value of stream is invalid. - - @see PaStreamParameters, PaStreamCallback, Pa_ReadStream, Pa_WriteStream, - Pa_GetStreamReadAvailable, Pa_GetStreamWriteAvailable -*} -function Pa_OpenStream( var stream: PPaStream; - inputParameters: PPaStreamParameters; - outputParameters: PPaStreamParameters; - sampleRate: cdouble; - framesPerBuffer: culong; - streamFlags: TPaStreamFlags; - streamCallback: PPaStreamCallback; - userData: Pointer ): TPaError; cdecl; external LibName; - - -{** A simplified version of Pa_OpenStream() that opens the default input - and/or output devices. - - @param stream The address of a PaStream pointer which will receive - a pointer to the newly opened stream. - - @param numInputChannels The number of channels of sound that will be supplied - to the stream callback or returned by Pa_ReadStream. It can range from 1 to - the value of maxInputChannels in the PaDeviceInfo record for the default input - device. If 0 the stream is opened as an output-only stream. - - @param numOutputChannels The number of channels of sound to be delivered to the - stream callback or passed to Pa_WriteStream. It can range from 1 to the value - of maxOutputChannels in the PaDeviceInfo record for the default output dvice. - If 0 the stream is opened as an output-only stream. - - @param sampleFormat The sample format of both the input and output buffers - provided to the callback or passed to and from Pa_ReadStream and Pa_WriteStream. - sampleFormat may be any of the formats described by the PaSampleFormat - enumeration. - - @param sampleRate Same as Pa_OpenStream parameter of the same name. - @param framesPerBuffer Same as Pa_OpenStream parameter of the same name. - @param streamCallback Same as Pa_OpenStream parameter of the same name. - @param userData Same as Pa_OpenStream parameter of the same name. - - @return As for Pa_OpenStream - - @see Pa_OpenStream, PaStreamCallback -*} -function Pa_OpenDefaultStream( var stream: PPaStream; - numInputChannels: cint; - numOutputChannels: cint; - sampleFormat: TPaSampleFormat; - sampleRate: cdouble; - framesPerBuffer: culong; - streamCallback: PPaStreamCallback; - userData: Pointer ): TPaError; cdecl; external LibName; - - -{** Closes an audio stream. If the audio stream is active it - discards any pending buffers as if Pa_AbortStream() had been called. -*} -function Pa_CloseStream( stream: PPaStream ): TPaError; cdecl; external LibName; - - -{** Functions of type PaStreamFinishedCallback are implemented by PortAudio - clients. They can be registered with a stream using the Pa_SetStreamFinishedCallback - function. Once registered they are called when the stream becomes inactive - (ie once a call to Pa_StopStream() will not block). - A stream will become inactive after the stream callback returns non-zero, - or when Pa_StopStream or Pa_AbortStream is called. For a stream providing audio - output, if the stream callback returns paComplete, or Pa_StopStream is called, - the stream finished callback will not be called until all generated sample data - has been played. - - @param userData The userData parameter supplied to Pa_OpenStream() - - @see Pa_SetStreamFinishedCallback -*} -type - PPaStreamFinishedCallback = ^TPaStreamFinishedCallback; - TPaStreamFinishedCallback = procedure( userData: Pointer ); cdecl; - - -{** Register a stream finished callback function which will be called when the - stream becomes inactive. See the description of PaStreamFinishedCallback for - further details about when the callback will be called. - - @param stream a pointer to a PaStream that is in the stopped state - if the - stream is not stopped, the stream's finished callback will remain unchanged - and an error code will be returned. - - @param streamFinishedCallback a pointer to a function with the same signature - as PaStreamFinishedCallback, that will be called when the stream becomes - inactive. Passing NULL for this parameter will un-register a previously - registered stream finished callback function. - - @return on success returns paNoError, otherwise an error code indicating the cause - of the error. - - @see PaStreamFinishedCallback -*} -function Pa_SetStreamFinishedCallback( stream: PPaStream; - streamFinishedCallback: PPaStreamFinishedCallback ): TPaError; cdecl; external LibName; - - -{** Commences audio processing. -*} -function Pa_StartStream( stream: PPaStream ): TPaError; cdecl; external LibName; - - -{** Terminates audio processing. It waits until all pending - audio buffers have been played before it returns. -*} -function Pa_StopStream( stream: PPaStream ): TPaError; cdecl; external LibName; - - -{** Terminates audio processing immediately without waiting for pending - buffers to complete. -*} -function Pa_AbortStream( stream: PPaStream ): TPaError; cdecl; external LibName; - - -{** Determine whether the stream is stopped. - A stream is considered to be stopped prior to a successful call to - Pa_StartStream and after a successful call to Pa_StopStream or Pa_AbortStream. - If a stream callback returns a value other than paContinue the stream is NOT - considered to be stopped. - - @return Returns one (1) when the stream is stopped, zero (0) when - the stream is running or, a PaErrorCode (which are always negative) if - PortAudio is not initialized or an error is encountered. - - @see Pa_StopStream, Pa_AbortStream, Pa_IsStreamActive -*} -function Pa_IsStreamStopped( stream: PPaStream ): TPaError; cdecl; external LibName; - - -{** Determine whether the stream is active. - A stream is active after a successful call to Pa_StartStream(), until it - becomes inactive either as a result of a call to Pa_StopStream() or - Pa_AbortStream(), or as a result of a return value other than paContinue from - the stream callback. In the latter case, the stream is considered inactive - after the last buffer has finished playing. - - @return Returns one (1) when the stream is active (ie playing or recording - audio), zero (0) when not playing or, a PaErrorCode (which are always negative) - if PortAudio is not initialized or an error is encountered. - - @see Pa_StopStream, Pa_AbortStream, Pa_IsStreamStopped -*} -function Pa_IsStreamActive( stream: PPaStream ): TPaError; cdecl; external LibName; - - - -{** A structure containing unchanging information about an open stream. - @see Pa_GetStreamInfo -*} -type - PPaStreamInfo = ^TPaStreamInfo; - TPaStreamInfo = record - {** this is struct version 1 *} - structVersion: cint; - - {** The input latency of the stream in seconds. This value provides the most - accurate estimate of input latency available to the implementation. It may - differ significantly from the suggestedLatency value passed to Pa_OpenStream(). - The value of this field will be zero (0.) for output-only streams. - @see PaTime - *} - inputLatency: TPaTime; - - {** The output latency of the stream in seconds. This value provides the most - accurate estimate of output latency available to the implementation. It may - differ significantly from the suggestedLatency value passed to Pa_OpenStream(). - The value of this field will be zero (0.) for input-only streams. - @see PaTime - *} - outputLatency: TPaTime; - - {** The sample rate of the stream in Hertz (samples per second). In cases - where the hardware sample rate is inaccurate and PortAudio is aware of it, - the value of this field may be different from the sampleRate parameter - passed to Pa_OpenStream(). If information about the actual hardware sample - rate is not available, this field will have the same value as the sampleRate - parameter passed to Pa_OpenStream(). - *} - sampleRate: cdouble; - end; - - -{** Retrieve a pointer to a PaStreamInfo structure containing information - about the specified stream. - @return A pointer to an immutable PaStreamInfo structure. If the stream - parameter invalid, or an error is encountered, the function returns NULL. - - @param stream A pointer to an open stream previously created with Pa_OpenStream. - - @note PortAudio manages the memory referenced by the returned pointer, - the client must not manipulate or free the memory. The pointer is only - guaranteed to be valid until the specified stream is closed. - - @see PaStreamInfo -*} -function Pa_GetStreamInfo( stream: PPaStream ): PPaStreamInfo; cdecl; external LibName; - - -{** Determine the current time for the stream according to the same clock used - to generate buffer timestamps. This time may be used for syncronising other - events to the audio stream, for example synchronizing audio to MIDI. - - @return The stream's current time in seconds, or 0 if an error occurred. - - @see PaTime, PaStreamCallback -*} -function Pa_GetStreamTime( stream: PPaStream ): TPaTime; cdecl; external LibName; - - -{** Retrieve CPU usage information for the specified stream. - The "CPU Load" is a fraction of total CPU time consumed by a callback stream's - audio processing routines including, but not limited to the client supplied - stream callback. This function does not work with blocking read/write streams. - - This function may be called from the stream callback function or the - application. - - @return - A floating point value, typically between 0.0 and 1.0, where 1.0 indicates - that the stream callback is consuming the maximum number of CPU cycles possible - to maintain real-time operation. A value of 0.5 would imply that PortAudio and - the stream callback was consuming roughly 50% of the available CPU time. The - return value may exceed 1.0. A value of 0.0 will always be returned for a - blocking read/write stream, or if an error occurrs. -*} -function Pa_GetStreamCpuLoad( stream: PPaStream ): cdouble; cdecl; external LibName; - - -{** Read samples from an input stream. The function doesn't return until - the entire buffer has been filled - this may involve waiting for the operating - system to supply the data. - - @param stream A pointer to an open stream previously created with Pa_OpenStream. - - @param buffer A pointer to a buffer of sample frames. The buffer contains - samples in the format specified by the inputParameters->sampleFormat field - used to open the stream, and the number of channels specified by - inputParameters->numChannels. If non-interleaved samples were requested, - buffer is a pointer to the first element of an array of non-interleaved - buffer pointers, one for each channel. - - @param frames The number of frames to be read into buffer. This parameter - is not constrained to a specific range, however high performance applications - will want to match this parameter to the framesPerBuffer parameter used - when opening the stream. - - @return On success PaNoError will be returned, or PaInputOverflowed if input - data was discarded by PortAudio after the previous call and before this call. -*} -function Pa_ReadStream( stream: PPaStream; - buffer: Pointer; - frames: culong ): TPaError; cdecl; external LibName; - - -{** Write samples to an output stream. This function doesn't return until the - entire buffer has been consumed - this may involve waiting for the operating - system to consume the data. - - @param stream A pointer to an open stream previously created with Pa_OpenStream. - - @param buffer A pointer to a buffer of sample frames. The buffer contains - samples in the format specified by the outputParameters->sampleFormat field - used to open the stream, and the number of channels specified by - outputParameters->numChannels. If non-interleaved samples were requested, - buffer is a pointer to the first element of an array of non-interleaved - buffer pointers, one for each channel. - - @param frames The number of frames to be written from buffer. This parameter - is not constrained to a specific range, however high performance applications - will want to match this parameter to the framesPerBuffer parameter used - when opening the stream. - - @return On success PaNoError will be returned, or paOutputUnderflowed if - additional output data was inserted after the previous call and before this - call. -*} -function Pa_WriteStream( stream: PPaStream; - buffer: Pointer; - frames: culong ): TPaError; cdecl; external LibName; - - -{** Retrieve the number of frames that can be read from the stream without - waiting. - - @return Returns a non-negative value representing the maximum number of frames - that can be read from the stream without blocking or busy waiting or, a - PaErrorCode (which are always negative) if PortAudio is not initialized or an - error is encountered. -*} -function Pa_GetStreamReadAvailable( stream: PPaStream ): cslong; cdecl; external LibName; - - -{** Retrieve the number of frames that can be written to the stream without - waiting. - - @return Returns a non-negative value representing the maximum number of frames - that can be written to the stream without blocking or busy waiting or, a - PaErrorCode (which are always negative) if PortAudio is not initialized or an - error is encountered. -*} -function Pa_GetStreamWriteAvailable( stream: PPaStream ): cslong; cdecl; external LibName; - - -{** Retrieve the host type handling an open stream. - - @return Returns a non-negative value representing the host API type - handling an open stream or, a PaErrorCode (which are always negative) - if PortAudio is not initialized or an error is encountered. -*} -function Pa_GetStreamHostApiType( stream: PPaStream ): TPaHostApiTypeId; cdecl; external LibName; - - -{* Miscellaneous utilities *} - - -{** Retrieve the size of a given sample format in bytes. - - @return The size in bytes of a single sample in the specified format, - or paSampleFormatNotSupported if the format is not supported. -*} -function Pa_GetSampleSize( format: TPaSampleFormat ): TPaError; cdecl; external LibName; - - -{** Put the caller to sleep for at least 'msec' milliseconds. This function is - provided only as a convenience for authors of portable code (such as the tests - and examples in the PortAudio distribution.) - - The function may sleep longer than requested so don't rely on this for accurate - musical timing. -*} -procedure Pa_Sleep( msec: clong ); cdecl; external LibName; - -implementation - -end. diff --git a/src/lib/portmixer/portmixer.pas b/src/lib/portmixer/portmixer.pas deleted file mode 100644 index b84e0cd6..00000000 --- a/src/lib/portmixer/portmixer.pas +++ /dev/null @@ -1,149 +0,0 @@ -{* - * PortMixer - * PortMixer API Header File - * - * Copyright (c) 2002, 2006 - * - * Written by Dominic Mazzoni - * and Leland Lucius - * - * PortMixer is intended to work side-by-side with PortAudio, - * the Portable Real-Time Audio Library by Ross Bencina and - * Phil Burk. - * - * Permission is hereby granted, free of charge, to any person obtaining - * a copy of this software and associated documentation files - * (the "Software"), to deal in the Software without restriction, - * including without limitation the rights to use, copy, modify, merge, - * publish, distribute, sublicense, and/or sell copies of the Software, - * and to permit persons to whom the Software is furnished to do so, - * subject to the following conditions: - * - * The above copyright notice and this permission notice shall be - * included in all copies or substantial portions of the Software. - * - * Any person wishing to distribute modifications to the Software is - * requested to send the modifications to the original developer so that - * they can be incorporated into the canonical version. - * - * THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - * EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF - * MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. - * IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR - * ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF - * CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION - * WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. - * - *} -unit portmixer; - -{$IFDEF FPC} - {$PACKRECORDS C} (* GCC/Visual C/C++ compatible record packing *) - {$MODE DELPHI } -{$ENDIF} - -interface - -uses - ctypes, - portaudio; - -const -{$IF Defined(MSWINDOWS)} - LibName = 'portmixer.dll'; -{$ELSEIF Defined(DARWIN)} -// LibName = 'libportmixer.dylib'; -// {$LINKLIB libportaudio} -{$ELSEIF Defined(UNIX)} - LibName = 'libportmixer.so'; -{$IFEND} - -type - PPxMixer = Pointer; - TPxVolume = cfloat; {* 0.0 (min) --> 1.0 (max) *} - TPxBalance = cfloat; {* -1.0 (left) --> 1.0 (right) *} - -{* - Px_OpenMixer() returns a mixer which will work with the given PortAudio - audio device. Pass 0 as the index for the first (default) mixer. -*} - -function Px_OpenMixer( pa_stream: Pointer; i: cint ): PPxMixer; cdecl; external LibName; - -{* - Px_CloseMixer() closes a mixer opened using Px_OpenMixer and frees any - memory associated with it. -*} - -procedure Px_CloseMixer( mixer: PPxMixer ); cdecl; external LibName; - -{* - Px_GetNumMixers returns the number of mixers which could be - used with the given PortAudio device. On most systems, there - will be only one mixer for each device; however there may be - multiple mixers for each device, or possibly multiple mixers - which are independent of any particular PortAudio device. -*} - -function Px_GetNumMixers( mixer: PPxMixer ): cint; cdecl; external LibName; -function Px_GetMixerName( mixer: PPxMixer; i: cint ): PChar; cdecl; external LibName; - -{* - Master (output) volume -*} - -function Px_GetMasterVolume( mixer: PPxMixer ): TPxVolume; cdecl; external LibName; -procedure Px_SetMasterVolume( mixer: PPxMixer; volume: TPxVolume ); cdecl; external LibName; - -{* - Main output volume -*} - -function Px_GetPCMOutputVolume( mixer: PPxMixer ): TPxVolume; cdecl; external LibName; -procedure Px_SetPCMOutputVolume( mixer: PPxMixer; volume: TPxVolume ); cdecl; external LibName; -function Px_SupportsPCMOutputVolume( mixer: PPxMixer ): cint; cdecl; external LibName; - -{* - All output volumes -*} - -function Px_GetNumOutputVolumes( mixer: PPxMixer ): cint; cdecl; external LibName; -function Px_GetOutputVolumeName( mixer: PPxMixer; i: cint ): PChar; cdecl; external LibName; -function Px_GetOutputVolume( mixer: PPxMixer; i: cint ): TPxVolume; cdecl; external LibName; -procedure Px_SetOutputVolume( mixer: PPxMixer; i: cint; volume: TPxVolume ); cdecl; external LibName; - -{* - Input source -*} - -function Px_GetNumInputSources( mixer: PPxMixer ): cint; cdecl; external LibName; -function Px_GetInputSourceName( mixer: PPxMixer; i: cint): PChar; cdecl; external LibName; -function Px_GetCurrentInputSource( mixer: PPxMixer ): cint; cdecl; external LibName; {* may return -1 == none *} -procedure Px_SetCurrentInputSource( mixer: PPxMixer; i: cint ); cdecl; external LibName; - -{* - Input volume -*} - -function Px_GetInputVolume( mixer: PPxMixer ): TPxVolume; cdecl; external LibName; -procedure Px_SetInputVolume( mixer: PPxMixer; volume: TPxVolume ); cdecl; external LibName; - -{* - Balance -*} - -function Px_SupportsOutputBalance( mixer: PPxMixer ): cint; cdecl; external LibName; -function Px_GetOutputBalance( mixer: PPxMixer ): TPxBalance; cdecl; external LibName; -procedure Px_SetOutputBalance( mixer: PPxMixer; balance: TPxBalance ); cdecl; external LibName; - -{* - Playthrough -*} - -function Px_SupportsPlaythrough( mixer: PPxMixer ): cint; cdecl; external LibName; -function Px_GetPlaythrough( mixer: PPxMixer ): TPxVolume; cdecl; external LibName; -procedure Px_SetPlaythrough( mixer: PPxMixer; volume: TPxVolume ); cdecl; external LibName; - -implementation - -end. diff --git a/src/lib/projectM/projectM.pas b/src/lib/projectM/projectM.pas deleted file mode 100644 index 533cb19b..00000000 --- a/src/lib/projectM/projectM.pas +++ /dev/null @@ -1,232 +0,0 @@ -unit projectM; - -{$IFDEF FPC} - {$MODE DELPHI} - {$H+} (* use long strings *) - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* C/C++-compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - -interface - -uses - SysUtils, - ctypes, - gl, - UConfig; - -type - // 16bit non-interleaved data - TPCM16 = array[0..1, 0..511] of Smallint; - PPCM16 = ^TPCM16; - // 8bit non-interleaved data (512 samples) - TPCM8_512 = array[0..1, 0..511] of byte; - PPCM8_512 = ^TPCM8_512; - // 8bit non-interleaved data (1024 samples) - TPCM8_1024 = array[0..1, 0..1023] of byte; - PPCM8_1024 = ^TPCM8_512; - -{ Event types } -type - TProjectMEvent = cint; -const - PROJECTM_KEYUP = 0; - PROJECTM_KEYDOWN = 1; - PROJECTM_VIDEORESIZE = 2; - PROJECTM_VIDEOQUIT = 3; - PROJECTM_NONE = 4; - -{ Keycodes } -type - TProjectMKeycode = cint; -const - PROJECTM_K_RETURN = 0; - PROJECTM_K_RIGHT = 1; - PROJECTM_K_LEFT = 2; - PROJECTM_K_UP = 3; - PROJECTM_K_DOWN = 4; - PROJECTM_K_PAGEUP = 5; - PROJECTM_K_PAGEDOWN = 6; - PROJECTM_K_INSERT = 7; - PROJECTM_K_DELETE = 8; - PROJECTM_K_ESCAPE = 9; - PROJECTM_K_LSHIFT = 10; - PROJECTM_K_RSHIFT = 11; - PROJECTM_K_CAPSLOCK = 12; - PROJECTM_K_LCTRL = 13; - PROJECTM_K_HOME = 14; - PROJECTM_K_END = 15; - PROJECTM_K_BACKSPACE = 16; - - PROJECTM_K_F1 = 17; - PROJECTM_K_F2 = (PROJECTM_K_F1 + 1); - PROJECTM_K_F3 = (PROJECTM_K_F1 + 2); - PROJECTM_K_F4 = (PROJECTM_K_F1 + 3); - PROJECTM_K_F5 = (PROJECTM_K_F1 + 4); - PROJECTM_K_F6 = (PROJECTM_K_F1 + 5); - PROJECTM_K_F7 = (PROJECTM_K_F1 + 6); - PROJECTM_K_F8 = (PROJECTM_K_F1 + 7); - PROJECTM_K_F9 = (PROJECTM_K_F1 + 8); - PROJECTM_K_F10 = (PROJECTM_K_F1 + 9); - PROJECTM_K_F11 = (PROJECTM_K_F1 + 10); - PROJECTM_K_F12 = (PROJECTM_K_F1 + 11); - - PROJECTM_K_0 = 48; - PROJECTM_K_1 = (PROJECTM_K_0 + 1); - PROJECTM_K_2 = (PROJECTM_K_0 + 2); - PROJECTM_K_3 = (PROJECTM_K_0 + 3); - PROJECTM_K_4 = (PROJECTM_K_0 + 4); - PROJECTM_K_5 = (PROJECTM_K_0 + 5); - PROJECTM_K_6 = (PROJECTM_K_0 + 6); - PROJECTM_K_7 = (PROJECTM_K_0 + 7); - PROJECTM_K_8 = (PROJECTM_K_0 + 8); - PROJECTM_K_9 = (PROJECTM_K_0 + 9); - - { Upper case } - PROJECTM_K_A_UPPERCASE = 65; - PROJECTM_K_B_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 1); - PROJECTM_K_C_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 2); - PROJECTM_K_D_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 3); - PROJECTM_K_E_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 4); - PROJECTM_K_F_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 5); - PROJECTM_K_G_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 6); - PROJECTM_K_H_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 7); - PROJECTM_K_I_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 8); - PROJECTM_K_J_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 9); - PROJECTM_K_K_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 10); - PROJECTM_K_L_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 11); - PROJECTM_K_M_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 12); - PROJECTM_K_N_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 13); - PROJECTM_K_O_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 14); - PROJECTM_K_P_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 15); - PROJECTM_K_Q_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 16); - PROJECTM_K_R_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 17); - PROJECTM_K_S_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 18); - PROJECTM_K_T_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 19); - PROJECTM_K_U_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 20); - PROJECTM_K_V_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 21); - PROJECTM_K_W_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 22); - PROJECTM_K_X_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 23); - PROJECTM_K_Y_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 24); - PROJECTM_K_Z_UPPERCASE = (PROJECTM_K_A_UPPERCASE + 25); - - { Lower case } - PROJECTM_K_a_LOWERCASE = 97; - PROJECTM_K_b_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 1); - PROJECTM_K_c_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 2); - PROJECTM_K_d_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 3); - PROJECTM_K_e_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 4); - PROJECTM_K_f_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 5); - PROJECTM_K_g_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 6); - PROJECTM_K_h_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 7); - PROJECTM_K_i_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 8); - PROJECTM_K_j_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 9); - PROJECTM_K_k_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 10); - PROJECTM_K_l_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 11); - PROJECTM_K_m_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 12); - PROJECTM_K_n_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 13); - PROJECTM_K_o_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 14); - PROJECTM_K_p_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 15); - PROJECTM_K_q_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 16); - PROJECTM_K_r_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 17); - PROJECTM_K_s_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 18); - PROJECTM_K_t_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 19); - PROJECTM_K_u_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 20); - PROJECTM_K_v_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 21); - PROJECTM_K_w_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 22); - PROJECTM_K_x_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 23); - PROJECTM_K_y_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 24); - PROJECTM_K_z_LOWERCASE = (PROJECTM_K_a_LOWERCASE + 25); - - PROJECTM_K_NONE = (PROJECTM_K_z_LOWERCASE + 1); - -{ Modifiers } -type - TProjectMModifier = cint; -const - PROJECTM_KMOD_LSHIFT = 0; - PROJECTM_KMOD_RSHIFT = 1; - PROJECTM_KMOD_CAPS = 2; - PROJECTM_KMOD_LCTRL = 3; - PROJECTM_KMOD_RCTRL = 4; - -type - PSettings = ^TSettings; - TSettings = record - meshX: cint; - meshY: cint; - fps: cint; - textureSize: cint; - windowWidth: cint; - windowHeight: cint; - presetURL: PChar; - titleFontURL: PChar; - menuFontURL: PChar; - smoothPresetDuration: cint; - presetDuration: cint; - beatSensitivity: cfloat; - aspectCorrection: byte; - easterEgg: cfloat; - shuffleEnabled: byte; - end; - -type - PProjectM = ^TProjectM; - TProjectM = class(TObject) - private - data: Pointer; - public - {$IF PROJECTM_VERSION < 1000000} // 0.9x - constructor Create(gx, gy: integer; fps: integer; - texsize: integer; width, height: integer; - const presetsDir, fontsDir: string; - const titleFont: string = 'Vera.ttf'; - const menuFont: string = 'Vera.ttf'); overload; - {$IFEND} - {$IF PROJECTM_VERSION >= 1000000} - constructor Create(const configFile: string); overload; - {$IFEND} - - procedure ResetGL(width, height: Integer); - procedure SetTitle(const title: string); - procedure RenderFrame(); - - procedure AddPCMfloat(pcmData: PSingle; samples: integer); - procedure AddPCM16(pcmData: PPCM16); - procedure AddPCM16Data(pcmData: PSmallint; samples: Smallint); - procedure AddPCM8_512(pcmData: PPCM8_512); - {$IF PROJECTM_VERSION >= 1000000} - procedure AddPCM8_1024(pcmData: PPCM8_1024); - {$IFEND} - - procedure RandomPreset(); - procedure PreviousPreset(); - procedure NextPreset(); - procedure ToggleShowPresetNames(); - - {$IF PROJECTM_VERSION >= 1000000} - function InitRenderToTexture(): GLuint; - {$IFEND} - - procedure KeyHandler(event: TProjectMEvent; - keycode: TProjectMKeycode; - modifier: TProjectMModifier); - - {$IF PROJECTM_VERSION > 1000000} // > 1.01 - procedure Settings(var settings: TSettings); - {$IFEND} - - destructor Destroy(); override; - end; - -implementation - -{$IF PROJECTM_VERSION >= 1000000} - {$I projectM-1_0.inc} -{$ELSE} - {$I projectM-0_9.inc} -{$IFEND} - -end. diff --git a/src/lib/samplerate/samplerate.pas b/src/lib/samplerate/samplerate.pas deleted file mode 100644 index 784b87da..00000000 --- a/src/lib/samplerate/samplerate.pas +++ /dev/null @@ -1,199 +0,0 @@ -{* -** Copyright (C) 2002-2004 Erik de Castro Lopo -** -** This program is free software; you can redistribute it and/or modify -** it under the terms of the GNU General Public License as published by -** the Free Software Foundation; either version 2 of the License, or -** (at your option) any later version. -** -** This program is distributed in the hope that it will be useful, -** but WITHOUT ANY WARRANTY; without even the implied warranty of -** MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -** GNU General Public License for more details. -** -** You should have received a copy of the GNU General Public License -** along with this program; if not, write to the Free Software -** Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA. -*} - -{* -** API documentation is available here: -** http://www.mega-nerd.com/SRC/api.html -*} - -unit samplerate; - -{$IFDEF FPC} - {$MODE DELPHI} - {$PACKENUM 4} (* use 4-byte enums *) - {$PACKRECORDS C} (* GCC/Visual C/C++ compatible record packing *) -{$ELSE} - {$MINENUMSIZE 4} (* use 4-byte enums *) -{$ENDIF} - - -interface - -uses - ctypes, - UConfig; - -const -{$IFDEF MSWINDOWS} - LibName = 'libsamplerate-0.dll'; -{$ENDIF} -{$IFDEF UNIX} - LibName = 'samplerate'; - {$IFDEF DARWIN} - {$LINKLIB libsamplerate} - {$ENDIF} -{$ENDIF} - -{ Opaque data type SRC_STATE. } -type - PSRC_STATE = ^SRC_STATE; - SRC_STATE = record - // opaque - end; - -{ SRC_DATA is used to pass data to src_simple() and src_process(). } -type - PSRC_DATA = ^SRC_DATA; - SRC_DATA = record - data_in, data_out: PCfloat; - input_frames, output_frames: clong; - input_frames_used, output_frames_gen: clong; - end_of_input: cint; - src_ratio: cdouble; - end; - -{ SRC_CB_DATA is used with callback based API. } -type - SRC_CB_DATA = record - frames: clong; - data_in: PCfloat; - end; - -{* -** User supplied callback function type for use with src_callback_new() -** and src_callback_read(). First parameter is the same pointer that was -** passed into src_callback_new(). Second parameter is pointer to a -** pointer. The user supplied callback function must modify *data to -** point to the start of the user supplied float array. The user supplied -** function must return the number of frames that **data points to. -*} -src_callback_t = function (cb_data: pointer; var data: PCfloat): clong; cdecl; - -{* -** Standard initialisation function : return an anonymous pointer to the -** internal state of the converter. Choose a converter from the enums below. -** Error returned in *error. -*} -function src_new(converter_type: cint; channels: cint; error: PCint): PSRC_STATE; cdecl; external LibName; - -{* -** Initilisation for callback based API : return an anonymous pointer to the -** internal state of the converter. Choose a converter from the enums below. -** The cb_data pointer can point to any data or be set to NULL. Whatever the -** value, when processing, user supplied function "func" gets called with -** cb_data as first parameter. -*} -function src_callback_new(func: src_callback_t; converter_type: cint; channels: cint; - error: Pinteger; cb_data: pointer): PSRC_STATE; cdecl; external LibName; - -{* -** Cleanup all internal allocations. -** Always returns NULL. -*} -function src_delete(state: PSRC_STATE): PSRC_STATE; cdecl; external LibName; - -{* -** Standard processing function. -** Returns non zero on error. -*} -function src_process(state: PSRC_STATE; data: PSRC_DATA): cint; cdecl; external LibName; - -{* -** Callback based processing function. Read up to frames worth of data from -** the converter int *data and return frames read or -1 on error. -*} -function src_callback_read(state: PSRC_STATE; src_ratio: cdouble; - frames: clong; data: PCfloat): clong; cdecl; external LibName; - -{* -** Simple interface for performing a single conversion from input buffer to -** output buffer at a fixed conversion ratio. -** Simple interface does not require initialisation as it can only operate on -** a single buffer worth of audio. -*} -function src_simple(data: PSRC_DATA; converter_type: cint; channels: cint): cint; cdecl; external LibName; - -{* -** This library contains a number of different sample rate converters, -** numbered 0 through N. -** -** Return a string giving either a name or a more full description of each -** sample rate converter or NULL if no sample rate converter exists for -** the given value. The converters are sequentially numbered from 0 to N. -*} -function src_get_name(converter_type: cint): {const} Pchar; cdecl; external LibName; -function src_get_description(converter_type: cint): {const} Pchar; cdecl; external LibName; -function src_get_version(): {const} Pchar; cdecl; external LibName; - -{* -** Set a new SRC ratio. This allows step responses -** in the conversion ratio. -** Returns non zero on error. -*} -function src_set_ratio(state: PSRC_STATE; new_ratio: cdouble): cint; cdecl; external LibName; - -{* -** Reset the internal SRC state. -** Does not modify the quality settings. -** Does not free any memory allocations. -** Returns non zero on error. -*} -function src_reset(state: PSRC_STATE): cint; cdecl; external LibName; - -{* -** Return TRUE if ratio is a valid conversion ratio, FALSE -** otherwise. -*} -function src_is_valid_ratio(ratio: cdouble): cint; cdecl; external LibName; - -{* -** Return an error number. -*} -function src_error(state: PSRC_STATE): cint; cdecl; external LibName; - -{* -** Convert the error number into a string. -*} -function src_strerror(error: cint): {const} Pchar; cdecl; external LibName; - -{* -** The following enums can be used to set the interpolator type -** using the function src_set_converter(). -*} -const - SRC_SINC_BEST_QUALITY = 0; - SRC_SINC_MEDIUM_QUALITY = 1; - SRC_SINC_FASTEST = 2; - SRC_ZERO_ORDER_HOLD = 3; - SRC_LINEAR = 4; - -{* -** Extra helper functions for converting from short to float and -** back again. -*} -procedure src_short_to_float_array(input: {const} PCshort; output: PCfloat; len: cint); cdecl; external LibName; -procedure src_float_to_short_array(input: {const} PCfloat; output: PCshort; len: cint); cdecl; external LibName; - -{$IF LIBSAMPLERATE_VERSION >= 1003} // 0.1.3 -procedure src_int_to_float_array(input: {const} PCint; output: PCfloat; len: cint); cdecl; external LibName; -procedure src_float_to_int_array(input: {const} PCfloat; output: PCint; len: cint); cdecl; external LibName; -{$IFEND} - -implementation - -end. diff --git a/src/lib/zlib/zlib.pas b/src/lib/zlib/zlib.pas deleted file mode 100644 index 8d09313f..00000000 --- a/src/lib/zlib/zlib.pas +++ /dev/null @@ -1,215 +0,0 @@ -(* - * zlib pascal headers - * This file is part of Free Pascal, released under the LGPL. - *) - -{$ifdef FPC} - {$ifndef NO_SMART_LINK} - {$smartlink on} - {$endif} -{$endif} -unit zlib; - -interface - -{$ifdef FPC} - {$mode objfpc} // Needed for array of const - {$H+} // use long strings - {$PACKRECORDS C} -{$endif} - -uses - ctypes; - -const - ZLIB_VERSION = '1.2.3'; - -{$ifdef MSWINDOWS} - libz = 'zlib1'; -{$else} - libz = 'z'; - {$IFDEF DARWIN} - {$linklib libz} - {$ENDIF} -{$endif} - -type - { Compatible with paszlib } - uInt = cuint; - uLong = culong; - uLongf = uLong; {FAR} - PuLongf = ^uLongf; - z_off_t = clong; - pbyte = ^byte; - bytef = byte; {FAR} - pbytef = ^byte; - voidpf = pointer; - - TAllocfunc = function (opaque: voidpf; items: uInt; size: uInt): voidpf; cdecl; - TFreeFunc = procedure (opaque: voidpf; address: voidpf); cdecl; - - TInternalState = record - end; - PInternalState = ^TInternalstate; - - TZStream = record - next_in: pbytef; - avail_in: uInt; - total_in: uLong; - next_out: pbytef; - avail_out: uInt; - total_out: uLong; - msg: pchar; - state: PInternalState; - zalloc: TAllocFunc; - zfree: TFreeFunc; - opaque: voidpf; - data_type: cint; - adler: uLong; - reserved: uLong; - end; - TZStreamRec = TZStream; - PZstream = ^TZStream; - gzFile = pointer; - - -const - Z_NO_FLUSH = 0; - Z_PARTIAL_FLUSH = 1; - Z_SYNC_FLUSH = 2; - Z_FULL_FLUSH = 3; - Z_FINISH = 4; - Z_BLOCK = 5; - - Z_OK = 0; - Z_STREAM_END = 1; - Z_NEED_DICT = 2; - Z_ERRNO = -(1); - Z_STREAM_ERROR = -(2); - Z_DATA_ERROR = -(3); - Z_MEM_ERROR = -(4); - Z_BUF_ERROR = -(5); - Z_VERSION_ERROR = -(6); - - Z_NO_COMPRESSION = 0; - Z_BEST_SPEED = 1; - Z_BEST_COMPRESSION = 9; - Z_DEFAULT_COMPRESSION = -(1); - - Z_FILTERED = 1; - Z_HUFFMAN_ONLY = 2; - Z_RLE = 3; - Z_FIXED = 4; - Z_DEFAULT_STRATEGY = 0; - - Z_BINARY = 0; - Z_TEXT = 1; - Z_ASCII = Z_TEXT; - Z_UNKNOWN = 2; - - Z_DEFLATED = 8; - - Z_NULL = 0; - -function zlibVersionpchar(): pchar; cdecl; external libz name 'zlibVersion'; -function zlibVersion(): string; - -function deflate(var strm: TZStream; flush: integer): integer; cdecl; external libz name 'deflate'; -function deflateEnd(var strm: TZStream): integer; cdecl; external libz name 'deflateEnd'; -function inflate(var strm: TZStream; flush: integer): integer; cdecl; external libz name 'inflate'; -function inflateEnd(var strm: TZStream): integer; cdecl; external libz name 'inflateEnd'; -function deflateSetDictionary(var strm: TZStream; dictionary: pbytef; dictLength: uInt): integer; cdecl; external libz name 'deflateSetDictionary'; -function deflateCopy(var dest, source: TZstream): integer; cdecl; external libz name 'deflateCopy'; -function deflateReset(var strm: TZStream): integer; cdecl; external libz name 'deflateReset'; -function deflateParams(var strm: TZStream; level: integer; strategy: integer): integer; cdecl; external libz name 'deflateParams'; -//... -function inflateSetDictionary(var strm: TZStream; dictionary: pbytef; dictLength: uInt): integer; cdecl; external libz name 'inflateSetDictionary'; -function inflateSync(var strm: TZStream): integer; cdecl; external libz name 'inflateSync'; -//... -function inflateReset(var strm: TZStream): integer; cdecl; external libz name 'inflateReset'; - -function compress(dest: pbytef; destLen: puLongf; source : pbytef; sourceLen: uLong): integer; cdecl; external libz name 'compress'; -function compress2(dest: pbytef; destLen: puLongf; source : pbytef; sourceLen: uLong; level: integer): integer; cdecl; external libz name 'compress2'; -function uncompress(dest: pbytef; destLen: puLongf; source : pbytef; sourceLen: uLong): integer; cdecl; external libz name 'uncompress'; - -function gzopen(path: pchar; mode: pchar): gzFile; cdecl; external libz name 'gzopen'; -function gzdopen(fd: integer; mode: pchar): gzFile; cdecl; external libz name 'gzdopen'; -function gzsetparams(thefile: gzFile; level: integer; strategy: integer): integer; cdecl; external libz name 'gzsetparams'; -function gzread(thefile: gzFile; buf: pointer; len: cardinal): integer; cdecl; external libz name 'gzread'; -function gzwrite(thefile: gzFile; buf: pointer; len: cardinal): integer; cdecl; external libz name 'gzwrite'; -function gzprintf(thefile: gzFile; format: pbytef; args: array of const): integer; cdecl; external libz name 'gzprintf'; -function gzputs(thefile: gzFile; s: pbytef): integer; cdecl; external libz name 'gzputs'; -function gzgets(thefile: gzFile; buf: pbytef; len: integer): pchar; cdecl; external libz name 'gzgets'; -function gzputc(thefile: gzFile; c: integer): integer; cdecl; external libz name 'gzputc'; -function gzgetc(thefile: gzFile): integer; cdecl; external libz name 'gzgetc'; -function gzflush(thefile: gzFile; flush: integer): integer; cdecl; external libz name 'gzflush'; -function gzseek(thefile: gzFile; offset: z_off_t; whence: integer): z_off_t; cdecl; external libz name 'gzseek'; -function gzrewind(thefile: gzFile): integer; cdecl; external libz name 'gzrewind'; -function gztell(thefile: gzFile): z_off_t; cdecl; external libz name 'gztell'; -function gzeof(thefile: gzFile): integer; cdecl; external libz name 'gzeof'; -function gzclose(thefile: gzFile): integer; cdecl; external libz name 'gzclose'; -function gzerror(thefile: gzFile; var errnum: integer): pchar; cdecl; external libz name 'gzerror'; - -function adler32(adler: uLong; buf: pbytef; len: uInt): uLong; cdecl; external libz name 'adler32'; -function crc32(crc: uLong; buf: pbytef; len: uInt): uLong; cdecl; external libz name 'crc32'; - -function deflateInit_(var strm: TZStream; level: integer; version: pchar; stream_size: integer): integer; cdecl; external libz name 'deflateInit_'; -function deflateInit(var strm: TZStream; level : integer) : integer; -function inflateInit_(var strm: TZStream; version: pchar; stream_size: integer): integer; cdecl; external libz name 'inflateInit_'; -function inflateInit(var strm:TZStream) : integer; -function deflateInit2_(var strm: TZStream; level: integer; method: integer; windowBits: integer; memLevel: integer; strategy: integer; version: pchar; stream_size: integer): integer; cdecl; external libz name 'deflateInit2_'; -function deflateInit2(var strm: TZStream; level, method, windowBits, memLevel, strategy: integer): integer; -function inflateInit2_(var strm: TZStream; windowBits: integer; version: pchar; stream_size: integer): integer; cdecl; external libz name 'inflateInit2_'; -function inflateInit2(var strm: TZStream; windowBits: integer): integer; - -function zErrorpchar(err: integer): pchar; cdecl; external libz name 'zError'; -function zError(err: integer): string; -function inflateSyncPoint(z: PZstream): integer; cdecl; external libz name 'inflateSyncPoint'; -function get_crc_table(): pointer; cdecl; external libz name 'get_crc_table'; - -function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; -procedure zlibFreeMem(AppData, Block: Pointer); cdecl; - -implementation - -function zlibversion(): string; -begin - zlibversion := string(zlibversionpchar); -end; - -function deflateInit(var strm: TZStream; level: integer) : integer; -begin - deflateInit := deflateInit_(strm, level, ZLIB_VERSION, sizeof(TZStream)); -end; - -function inflateInit(var strm: TZStream): integer; -begin - inflateInit := inflateInit_(strm, ZLIB_VERSION, sizeof(TZStream)); -end; - -function deflateInit2(var strm: TZStream; level, method, windowBits, memLevel, strategy: integer) : integer; -begin - deflateInit2 := deflateInit2_(strm, level, method, windowBits, memLevel, strategy, ZLIB_VERSION, sizeof(TZStream)); -end; - -function inflateInit2(var strm: TZStream; windowBits: integer): integer; -begin - inflateInit2 := inflateInit2_(strm, windowBits, ZLIB_VERSION, sizeof(TZStream)); -end; - -function zError(err: integer): string; -begin - zerror := string(zErrorpchar(err)); -end; - -function zlibAllocMem(AppData: Pointer; Items, Size: Integer): Pointer; cdecl; -begin - Result := GetMemory(Items * Size); -end; - -procedure zlibFreeMem(AppData, Block: Pointer); cdecl; -begin - FreeMem(Block); -end; - -end. diff --git a/src/macosx/PseudoThread.pas b/src/macosx/PseudoThread.pas deleted file mode 100644 index d74285f7..00000000 --- a/src/macosx/PseudoThread.pas +++ /dev/null @@ -1,75 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit PseudoThread; - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -interface - -type - -// Debugging threads with XCode doesn't seem to work. -// We use PseudoThread in Debug mode to get proper debugging. - -TPseudoThread = class(TObject) - private - protected - Terminated, - FreeOnTerminate: boolean; - procedure Execute; virtual; abstract; - procedure Resume; - procedure Suspend; - public - constructor Create(const suspended : boolean); -end; - -implementation - -{ TPseudoThread } - -constructor TPseudoThread.Create(const suspended: boolean); -begin - if not suspended then - begin - Execute; - end; -end; - -procedure TPseudoThread.Resume; -begin - Execute; -end; - -procedure TPseudoThread.Suspend; -begin -end; - -end. - diff --git a/src/media/UAudioConverter.pas b/src/media/UAudioConverter.pas deleted file mode 100644 index 657b80dd..00000000 --- a/src/media/UAudioConverter.pas +++ /dev/null @@ -1,483 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioConverter; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMusic, - ULog, - ctypes, - {$IFDEF UseSRCResample} - samplerate, - {$ENDIF} - {$IFDEF UseFFmpegResample} - avcodec, - {$ENDIF} - UMediaCore_SDL, - sdl, - SysUtils, - Math; - -type - {* - * Notes: - * - 44.1kHz to 48kHz conversion or vice versa is not supported - * by SDL 1.2 (will be introduced in 1.3). - * No conversion takes place in this cases. - * This is because SDL just converts differences in powers of 2. - * So the result might not be that accurate. - * This IS audible (voice to high/low) and it needs good synchronization - * with the video or the lyrics timer. - * - float<->int16 conversion is not supported (will be part of 1.3) and - * SDL (<1.3) is not capable of handling floats at all. - * -> Using FFmpeg or libsamplerate for resampling is preferred. - * Use SDL for channel and format conversion only. - *} - TAudioConverter_SDL = class(TAudioConverter) - private - cvt: TSDL_AudioCVT; - public - function Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; override; - destructor Destroy(); override; - - function Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; override; - function GetOutputBufferSize(InputSize: integer): integer; override; - function GetRatio(): double; override; - end; - - {$IFDEF UseFFmpegResample} - // Note: FFmpeg seems to be using "kaiser windowed sinc" for resampling, so - // the quality should be good. - TAudioConverter_FFmpeg = class(TAudioConverter) - private - // TODO: use SDL for multi-channel->stereo and format conversion - ResampleContext: PReSampleContext; - Ratio: double; - public - function Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; override; - destructor Destroy(); override; - - function Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; override; - function GetOutputBufferSize(InputSize: integer): integer; override; - function GetRatio(): double; override; - end; - {$ENDIF} - - {$IFDEF UseSRCResample} - TAudioConverter_SRC = class(TAudioConverter) - private - ConverterState: PSRC_STATE; - ConversionData: SRC_DATA; - FormatConverter: TAudioConverter; - public - function Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; override; - destructor Destroy(); override; - - function Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; override; - function GetOutputBufferSize(InputSize: integer): integer; override; - function GetRatio(): double; override; - end; - - // Note: SRC (=libsamplerate) provides several converters with different quality - // speed trade-offs. The SINC-types are slow but offer best quality. - // The SRC_SINC_* converters are too slow for realtime conversion, - // (SRC_SINC_FASTEST is approx. ten times slower than SRC_LINEAR) resulting - // in audible clicks and pops. - // SRC_LINEAR is very fast and should have a better quality than SRC_ZERO_ORDER_HOLD - // because it interpolates the samples. Normal "non-audiophile" users should not - // be able to hear a difference between the SINC_* ones and LINEAR. Especially - // if people sing along with the song. - // But FFmpeg might offer a better quality/speed ratio than SRC_LINEAR. - const - SRC_CONVERTER_TYPE = SRC_LINEAR; - {$ENDIF} - -implementation - -function TAudioConverter_SDL.Init(srcFormatInfo: TAudioFormatInfo; dstFormatInfo: TAudioFormatInfo): boolean; -var - srcFormat: UInt16; - dstFormat: UInt16; -begin - inherited Init(SrcFormatInfo, DstFormatInfo); - - Result := false; - - if (not ConvertAudioFormatToSDL(srcFormatInfo.Format, srcFormat) or - not ConvertAudioFormatToSDL(dstFormatInfo.Format, dstFormat)) then - begin - Log.LogError('Audio-format not supported by SDL', 'TSoftMixerPlaybackStream.InitFormatConversion'); - Exit; - end; - - if (SDL_BuildAudioCVT(@cvt, - srcFormat, srcFormatInfo.Channels, Round(srcFormatInfo.SampleRate), - dstFormat, dstFormatInfo.Channels, Round(dstFormatInfo.SampleRate)) = -1) then - begin - Log.LogError(SDL_GetError(), 'TSoftMixerPlaybackStream.InitFormatConversion'); - Exit; - end; - - Result := true; -end; - -destructor TAudioConverter_SDL.Destroy(); -begin - // nothing to be done here - inherited; -end; - -(* - * Returns the size of the output buffer. This might be bigger than the actual - * size of resampled audio data. - *) -function TAudioConverter_SDL.GetOutputBufferSize(InputSize: integer): integer; -begin - // Note: len_ratio must not be used here. Even if the len_ratio is 1.0, len_mult might be 2. - // Example: 44.1kHz/mono to 22.05kHz/stereo -> len_ratio=1, len_mult=2 - Result := InputSize * cvt.len_mult; -end; - -function TAudioConverter_SDL.GetRatio(): double; -begin - Result := cvt.len_ratio; -end; - -function TAudioConverter_SDL.Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; -begin - Result := -1; - - if (InputSize <= 0) then - begin - // avoid div-by-zero problems - if (InputSize = 0) then - Result := 0; - Exit; - end; - - // OutputBuffer is always bigger than or equal to InputBuffer - Move(InputBuffer[0], OutputBuffer[0], InputSize); - cvt.buf := PUint8(OutputBuffer); - cvt.len := InputSize; - if (SDL_ConvertAudio(@cvt) = -1) then - Exit; - - Result := cvt.len_cvt; -end; - - -{$IFDEF UseFFmpegResample} - -function TAudioConverter_FFmpeg.Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; -begin - inherited Init(SrcFormatInfo, DstFormatInfo); - - Result := false; - - // Note: ffmpeg does not support resampling for more than 2 input channels - - if (srcFormatInfo.Format <> asfS16) then - begin - Log.LogError('Unsupported format', 'TAudioConverter_FFmpeg.Init'); - Exit; - end; - - // TODO: use SDL here - if (srcFormatInfo.Format <> dstFormatInfo.Format) then - begin - Log.LogError('Incompatible formats', 'TAudioConverter_FFmpeg.Init'); - Exit; - end; - - ResampleContext := audio_resample_init( - dstFormatInfo.Channels, srcFormatInfo.Channels, - Round(dstFormatInfo.SampleRate), Round(srcFormatInfo.SampleRate)); - if (ResampleContext = nil) then - begin - Log.LogError('audio_resample_init() failed', 'TAudioConverter_FFmpeg.Init'); - Exit; - end; - - // calculate ratio - Ratio := (dstFormatInfo.Channels / srcFormatInfo.Channels) * - (dstFormatInfo.SampleRate / srcFormatInfo.SampleRate); - - Result := true; -end; - -destructor TAudioConverter_FFmpeg.Destroy(); -begin - if (ResampleContext <> nil) then - audio_resample_close(ResampleContext); - inherited; -end; - -function TAudioConverter_FFmpeg.Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; -var - InputSampleCount: integer; - OutputSampleCount: integer; -begin - Result := -1; - - if (InputSize <= 0) then - begin - // avoid div-by-zero in audio_resample() - if (InputSize = 0) then - Result := 0; - Exit; - end; - - InputSampleCount := InputSize div SrcFormatInfo.FrameSize; - OutputSampleCount := audio_resample( - ResampleContext, PSmallInt(OutputBuffer), PSmallInt(InputBuffer), - InputSampleCount); - if (OutputSampleCount = -1) then - begin - Log.LogError('audio_resample() failed', 'TAudioConverter_FFmpeg.Convert'); - Exit; - end; - Result := OutputSampleCount * DstFormatInfo.FrameSize; -end; - -function TAudioConverter_FFmpeg.GetOutputBufferSize(InputSize: integer): integer; -begin - Result := Ceil(InputSize * GetRatio()); -end; - -function TAudioConverter_FFmpeg.GetRatio(): double; -begin - Result := Ratio; -end; - -{$ENDIF} - - -{$IFDEF UseSRCResample} - -function TAudioConverter_SRC.Init(SrcFormatInfo: TAudioFormatInfo; DstFormatInfo: TAudioFormatInfo): boolean; -var - error: integer; - TempSrcFormatInfo: TAudioFormatInfo; - TempDstFormatInfo: TAudioFormatInfo; -begin - inherited Init(SrcFormatInfo, DstFormatInfo); - - Result := false; - - FormatConverter := nil; - - // SRC does not handle channel or format conversion - if ((SrcFormatInfo.Channels <> DstFormatInfo.Channels) or - not (SrcFormatInfo.Format in [asfS16, asfFloat])) then - begin - // SDL can not convert to float, so we have to convert to SInt16 first - TempSrcFormatInfo := TAudioFormatInfo.Create( - SrcFormatInfo.Channels, SrcFormatInfo.SampleRate, SrcFormatInfo.Format); - TempDstFormatInfo := TAudioFormatInfo.Create( - DstFormatInfo.Channels, SrcFormatInfo.SampleRate, asfS16); - - // init format/channel conversion - FormatConverter := TAudioConverter_SDL.Create(); - if (not FormatConverter.Init(TempSrcFormatInfo, TempDstFormatInfo)) then - begin - Log.LogError('Unsupported input format', 'TAudioConverter_SRC.Init'); - FormatConverter.Free; - // exit after the format-info is freed - end; - - // this info was copied so we do not need it anymore - TempSrcFormatInfo.Free; - TempDstFormatInfo.Free; - - // leave if the format is not supported - if (not assigned(FormatConverter)) then - Exit; - - // adjust our copy of the input audio-format for SRC conversion - Self.SrcFormatInfo.Channels := DstFormatInfo.Channels; - Self.SrcFormatInfo.Format := asfS16; - end; - - if ((DstFormatInfo.Format <> asfS16) and - (DstFormatInfo.Format <> asfFloat)) then - begin - Log.LogError('Unsupported output format', 'TAudioConverter_SRC.Init'); - Exit; - end; - - ConversionData.src_ratio := DstFormatInfo.SampleRate / SrcFormatInfo.SampleRate; - if (src_is_valid_ratio(ConversionData.src_ratio) = 0) then - begin - Log.LogError('Invalid samplerate ratio', 'TAudioConverter_SRC.Init'); - Exit; - end; - - ConverterState := src_new(SRC_CONVERTER_TYPE, DstFormatInfo.Channels, @error); - if (ConverterState = nil) then - begin - Log.LogError('src_new() failed: ' + src_strerror(error), 'TAudioConverter_SRC.Init'); - Exit; - end; - - Result := true; -end; - -destructor TAudioConverter_SRC.Destroy(); -begin - if (ConverterState <> nil) then - src_delete(ConverterState); - FormatConverter.Free; - inherited; -end; - -function TAudioConverter_SRC.Convert(InputBuffer: PByteArray; OutputBuffer: PByteArray; var InputSize: integer): integer; -var - FloatInputBuffer: PSingle; - FloatOutputBuffer: PSingle; - TempBuffer: PByteArray; - TempSize: integer; - NumSamples: integer; - OutputSize: integer; - error: integer; -begin - Result := -1; - - TempBuffer := nil; - - // format conversion with external converter (to correct number of channels and format) - if (assigned(FormatConverter)) then - begin - TempSize := FormatConverter.GetOutputBufferSize(InputSize); - GetMem(TempBuffer, TempSize); - InputSize := FormatConverter.Convert(InputBuffer, TempBuffer, InputSize); - InputBuffer := TempBuffer; - end; - - if (InputSize <= 0) then - begin - // avoid div-by-zero problems - if (InputSize = 0) then - Result := 0; - if (TempBuffer <> nil) then - FreeMem(TempBuffer); - Exit; - end; - - if (SrcFormatInfo.Format = asfFloat) then - begin - FloatInputBuffer := PSingle(InputBuffer); - end else begin - NumSamples := InputSize div AudioSampleSize[SrcFormatInfo.Format]; - GetMem(FloatInputBuffer, NumSamples * SizeOf(Single)); - src_short_to_float_array(PCshort(InputBuffer), PCfloat(FloatInputBuffer), NumSamples); - end; - - // calculate approx. output size - OutputSize := Ceil(InputSize * ConversionData.src_ratio); - - if (DstFormatInfo.Format = asfFloat) then - begin - FloatOutputBuffer := PSingle(OutputBuffer); - end else begin - NumSamples := OutputSize div AudioSampleSize[DstFormatInfo.Format]; - GetMem(FloatOutputBuffer, NumSamples * SizeOf(Single)); - end; - - with ConversionData do - begin - data_in := PCFloat(FloatInputBuffer); - input_frames := InputSize div SrcFormatInfo.FrameSize; - data_out := PCFloat(FloatOutputBuffer); - output_frames := OutputSize div DstFormatInfo.FrameSize; - // TODO: set this to 1 at end of file-playback - end_of_input := 0; - end; - - error := src_process(ConverterState, @ConversionData); - if (error <> 0) then - begin - Log.LogError(src_strerror(error), 'TAudioConverter_SRC.Convert'); - if (SrcFormatInfo.Format <> asfFloat) then - FreeMem(FloatInputBuffer); - if (DstFormatInfo.Format <> asfFloat) then - FreeMem(FloatOutputBuffer); - if (TempBuffer <> nil) then - FreeMem(TempBuffer); - Exit; - end; - - if (SrcFormatInfo.Format <> asfFloat) then - FreeMem(FloatInputBuffer); - - if (DstFormatInfo.Format <> asfFloat) then - begin - NumSamples := ConversionData.output_frames_gen * DstFormatInfo.Channels; - src_float_to_short_array(PCfloat(FloatOutputBuffer), PCshort(OutputBuffer), NumSamples); - FreeMem(FloatOutputBuffer); - end; - - // free format conversion buffer if used - if (TempBuffer <> nil) then - FreeMem(TempBuffer); - - if (assigned(FormatConverter)) then - InputSize := ConversionData.input_frames_used * FormatConverter.SrcFormatInfo.FrameSize - else - InputSize := ConversionData.input_frames_used * SrcFormatInfo.FrameSize; - - // set result to output size according to SRC - Result := ConversionData.output_frames_gen * DstFormatInfo.FrameSize; -end; - -function TAudioConverter_SRC.GetOutputBufferSize(InputSize: integer): integer; -begin - Result := Ceil(InputSize * GetRatio()); -end; - -function TAudioConverter_SRC.GetRatio(): double; -begin - // if we need additional channel/format conversion, use this ratio - if (assigned(FormatConverter)) then - Result := FormatConverter.GetRatio() - else - Result := 1.0; - - // now the SRC ratio (Note: the format might change from SInt16 to float) - Result := Result * - ConversionData.src_ratio * - (DstFormatInfo.FrameSize / SrcFormatInfo.FrameSize); -end; - -{$ENDIF} - -end. \ No newline at end of file diff --git a/src/media/UAudioCore_Bass.pas b/src/media/UAudioCore_Bass.pas deleted file mode 100644 index 197f9760..00000000 --- a/src/media/UAudioCore_Bass.pas +++ /dev/null @@ -1,160 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioCore_Bass; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - SysUtils, - UMusic, - bass; // (Note: DWORD is defined here) - -type - TAudioCore_Bass = class - public - constructor Create(); - class function GetInstance(): TAudioCore_Bass; - function CheckVersion(): boolean; - function ErrorGetString(): string; overload; - function ErrorGetString(errCode: integer): string; overload; - function ConvertAudioFormatToBASSFlags(Format: TAudioSampleFormat; out Flags: DWORD): boolean; - function ConvertBASSFlagsToAudioFormat(Flags: DWORD; out Format: TAudioSampleFormat): boolean; - end; - -implementation - -uses - UMain, - ULog; - -const - // TODO: 2.4.2 is not ABI compatible with older versions - // as (BASS_RECORDINFO.driver was removed) - //BASS_MIN_REQUIRED_VERSION = $02040201; - BASS_MIN_REQUIRED_VERSION = $02000000; - -var - Instance: TAudioCore_Bass; - -constructor TAudioCore_Bass.Create(); -begin - inherited; -end; - -class function TAudioCore_Bass.GetInstance(): TAudioCore_Bass; -begin - if (not Assigned(Instance)) then - Instance := TAudioCore_Bass.Create(); - Result := Instance; -end; - -function TAudioCore_Bass.CheckVersion(): boolean; -begin - Result := BASS_GetVersion() >= BASS_MIN_REQUIRED_VERSION; -end; - -function TAudioCore_Bass.ErrorGetString(): string; -begin - Result := ErrorGetString(BASS_ErrorGetCode()); -end; - -function TAudioCore_Bass.ErrorGetString(errCode: integer): string; -begin - case errCode of - BASS_OK: result := 'No error'; - BASS_ERROR_MEM: result := 'Insufficient memory'; - BASS_ERROR_FILEOPEN: result := 'File could not be opened'; - BASS_ERROR_DRIVER: result := 'Device driver not available'; - BASS_ERROR_BUFLOST: result := 'Buffer lost'; - BASS_ERROR_HANDLE: result := 'Invalid Handle'; - BASS_ERROR_FORMAT: result := 'Sample-Format not supported'; - BASS_ERROR_POSITION: result := 'Illegal position'; - BASS_ERROR_INIT: result := 'BASS_Init has not been successfully called'; - BASS_ERROR_START: result := 'Paused/stopped'; - BASS_ERROR_ALREADY: result := 'Already created/used'; - BASS_ERROR_NOCHAN: result := 'No free channels'; - BASS_ERROR_ILLTYPE: result := 'Type is invalid'; - BASS_ERROR_ILLPARAM: result := 'Illegal parameter'; - BASS_ERROR_NO3D: result := 'No 3D support'; - BASS_ERROR_NOEAX: result := 'No EAX support'; - BASS_ERROR_DEVICE: result := 'Invalid device number'; - BASS_ERROR_NOPLAY: result := 'Channel not playing'; - BASS_ERROR_FREQ: result := 'Freq out of range'; - BASS_ERROR_NOTFILE: result := 'Not a file stream'; - BASS_ERROR_NOHW: result := 'No hardware support'; - BASS_ERROR_EMPTY: result := 'Is empty'; - BASS_ERROR_NONET: result := 'Network unavailable'; - BASS_ERROR_CREATE: result := 'Creation error'; - BASS_ERROR_NOFX: result := 'DX8 effects unavailable'; - BASS_ERROR_NOTAVAIL: result := 'Not available'; - BASS_ERROR_DECODE: result := 'Is a decoding channel'; - BASS_ERROR_DX: result := 'Insufficient version of DirectX'; - BASS_ERROR_TIMEOUT: result := 'Timeout'; - BASS_ERROR_FILEFORM: result := 'File-Format not recognised/supported'; - BASS_ERROR_SPEAKER: result := 'Requested speaker(s) not support'; - BASS_ERROR_VERSION: result := 'Version error'; - BASS_ERROR_CODEC: result := 'Codec not available/supported'; - BASS_ERROR_ENDED: result := 'The channel/file has ended'; - BASS_ERROR_UNKNOWN: result := 'Unknown error'; - else result := 'Unknown error'; - end; -end; - -function TAudioCore_Bass.ConvertAudioFormatToBASSFlags(Format: TAudioSampleFormat; out Flags: DWORD): boolean; -begin - case Format of - asfS16: Flags := 0; - asfFloat: Flags := BASS_SAMPLE_FLOAT; - asfU8: Flags := BASS_SAMPLE_8BITS; - else begin - Result := false; - Exit; - end; - end; - - Result := true; -end; - -function TAudioCore_Bass.ConvertBASSFlagsToAudioFormat(Flags: DWORD; out Format: TAudioSampleFormat): boolean; -begin - if ((Flags and BASS_SAMPLE_FLOAT) <> 0) then - Format := asfFloat - else if ((Flags and BASS_SAMPLE_8BITS) <> 0) then - Format := asfU8 - else - Format := asfS16; - - Result := true; -end; - -end. diff --git a/src/media/UAudioCore_Portaudio.pas b/src/media/UAudioCore_Portaudio.pas deleted file mode 100644 index 25ceae3c..00000000 --- a/src/media/UAudioCore_Portaudio.pas +++ /dev/null @@ -1,281 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioCore_Portaudio; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I ../switches.inc} - -uses - Classes, - SysUtils, - portaudio; - -type - TAudioCore_Portaudio = class - public - constructor Create(); - class function GetInstance(): TAudioCore_Portaudio; - function GetPreferredApiIndex(): TPaHostApiIndex; - function TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: Double): boolean; - end; - -implementation - -uses - ULog; - -{* - * The default API used by Portaudio is the least common denominator - * and might lack efficiency. In addition it might not even work. - * We use an array named ApiPreferenceOrder with which we define the order of - * preferred APIs to use. The first API-type in the list is tried first. - * If it is not available the next one is tried and so on ... - * If none of the preferred APIs was found the default API (detected by - * portaudio) is used. - * - * Pascal does not permit zero-length static arrays, so you must use paDefaultApi - * as an array's only member if you do not have any preferences. - * You can also append paDefaultApi to a non-zero length preferences array but - * this is optional because the default API is always used as a fallback. - *} -const - paDefaultApi = -1; -const - ApiPreferenceOrder: -{$IF Defined(MSWINDOWS)} - // Note1: Portmixer has no mixer support for paASIO and paWASAPI at the moment - // Note2: Windows Default-API is MME, but DirectSound is faster - array[0..0] of TPaHostApiTypeId = ( paDirectSound ); -{$ELSEIF Defined(DARWIN)} - array[0..0] of TPaHostApiTypeId = ( paDefaultApi ); // paCoreAudio -{$ELSEIF Defined(UNIX)} - // Note: Portmixer has no mixer support for JACK at the moment - array[0..2] of TPaHostApiTypeId = ( paALSA, paJACK, paOSS ); -{$ELSE} - array[0..0] of TPaHostApiTypeId = ( paDefaultApi ); -{$IFEND} - - -{ TAudioInput_Portaudio } - -var - Instance: TAudioCore_Portaudio; - -constructor TAudioCore_Portaudio.Create(); -begin - inherited; -end; - -class function TAudioCore_Portaudio.GetInstance(): TAudioCore_Portaudio; -begin - if not assigned(Instance) then - Instance := TAudioCore_Portaudio.Create(); - Result := Instance; -end; - -function TAudioCore_Portaudio.GetPreferredApiIndex(): TPaHostApiIndex; -var - i: integer; - apiIndex: TPaHostApiIndex; - apiInfo: PPaHostApiInfo; -begin - result := -1; - - // select preferred sound-API - for i:= 0 to High(ApiPreferenceOrder) do - begin - if(ApiPreferenceOrder[i] <> paDefaultApi) then - begin - // check if API is available - apiIndex := Pa_HostApiTypeIdToHostApiIndex(ApiPreferenceOrder[i]); - if(apiIndex >= 0) then - begin - // we found an API but we must check if it works - // (on linux portaudio might detect OSS but does not provide - // any devices if ALSA is enabled) - apiInfo := Pa_GetHostApiInfo(apiIndex); - if (apiInfo^.deviceCount > 0) then - begin - Result := apiIndex; - break; - end; - end; - end; - end; - - // None of the preferred APIs is available -> use default - if(result < 0) then - begin - result := Pa_GetDefaultHostApi(); - end; -end; - -{* - * Portaudio test callback used by TestDevice(). - *} -function TestCallback(input: Pointer; output: Pointer; frameCount: Longword; - timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; -begin - // this callback is called only once - result := paAbort; -end; - -(* - * Tests if the callback works. Some devices can be opened without - * an error but the callback is never called. Calling Pa_StopStream() on such - * a stream freezes USDX then. Probably because the callback-thread is deadlocked - * due to some bug in portaudio. The blocking Pa_ReadStream() and Pa_WriteStream() - * block forever too and though can't be used for testing. - * - * To avoid freezing Pa_AbortStream (or Pa_CloseStream which calls Pa_AbortStream) - * can be used to force the stream to stop. But for some reason this stops debugging - * in gdb with a "no process found" message. - * - * Because freezing devices are non-working devices we test the devices here to - * be able to exclude them from the device-selection list. - * - * Portaudio does not provide any test to check this error case (probably because - * it should not even occur). So we have to open the device, start the stream and - * check if the callback is called (the stream is stopped if the callback is called - * for the first time, so we can poll until the stream is stopped). - * - * Another error that occurs is that some devices (even the default device) might - * work at the beginning but stop after a few calls (maybe 50) of the callback. - * For me this problem occurs with the default output-device. The "dmix" or "front" - * device must be selected instead. Another problem is that (due to a bug in - * portaudio or ALSA) the "front" device is not detected every time portaudio - * is started. Sometimes it needs two or more restarts. - * - * There is no reasonable way to test for these errors. For the first error-case - * we could test if the callback is called 50 times but this can take a second - * for each device and it can fail in the 51st or even 100th callback call then. - * - * The second error-case cannot be tested at all. How should we now that one - * device is missing if portaudio is not even able to detect it. - * We could start and terminate Portaudio for several times and see if the device - * count changes but this is ugly. - * - * Conclusion: We are not able to autodetect a working device with - * portaudio (at least not with the newest v19_20071207) at the moment. - * So we have to provide the possibility to manually select an output device - * in the UltraStar options if we want to use portaudio instead of SDL. - *) -function TAudioCore_Portaudio.TestDevice(inParams, outParams: PPaStreamParameters; var sampleRate: Double): boolean; -var - stream: PPaStream; - err: TPaError; - cbWorks: boolean; - cbPolls: integer; - i: integer; -const - altSampleRates: array[0..1] of Double = (44100, 48000); // alternative sample-rates -begin - Result := false; - - if (sampleRate <= 0) then - sampleRate := 44100; - - // check if device supports our input-format - err := Pa_IsFormatSupported(inParams, outParams, sampleRate); - if(err <> paNoError) then - begin - // we cannot fix the error -> exit - if (err <> paInvalidSampleRate) then - Exit; - - // try alternative sample-rates to the detected one - sampleRate := 0; - for i := 0 to High(altSampleRates) do - begin - // do not check the detected sample-rate twice - if (altSampleRates[i] = sampleRate) then - continue; - // check alternative - err := Pa_IsFormatSupported(inParams, outParams, altSampleRates[i]); - if (err = paNoError) then - begin - // sample-rate works - sampleRate := altSampleRates[i]; - break; - end; - end; - // no working sample-rate found - if (sampleRate = 0) then - Exit; - end; - - // FIXME: for some reason gdb stops after a call of Pa_AbortStream() - // which is implicitely called by Pa_CloseStream(). - // gdb's stops with the message: "ptrace: no process found". - // Probably because the callback-thread is killed what confuses gdb. - {$IF Defined(Debug) and Defined(Linux)} - cbWorks := true; - {$ELSE} - // open device for testing - err := Pa_OpenStream(stream, inParams, outParams, sampleRate, - paFramesPerBufferUnspecified, - paNoFlag, @TestCallback, nil); - if(err <> paNoError) then - begin - exit; - end; - - // start the callback - err := Pa_StartStream(stream); - if(err <> paNoError) then - begin - Pa_CloseStream(stream); - exit; - end; - - cbWorks := false; - // check if the callback was called (poll for max. 200ms) - for cbPolls := 1 to 20 do - begin - // if the test-callback was called it should be aborted now - if (Pa_IsStreamActive(stream) = 0) then - begin - cbWorks := true; - break; - end; - // not yet aborted, wait and try (poll) again - Pa_Sleep(10); - end; - - // finally abort the stream - Pa_CloseStream(stream); - {$IFEND} - - Result := cbWorks; -end; - -end. diff --git a/src/media/UAudioDecoder_Bass.pas b/src/media/UAudioDecoder_Bass.pas deleted file mode 100644 index d6d2425a..00000000 --- a/src/media/UAudioDecoder_Bass.pas +++ /dev/null @@ -1,278 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioDecoder_Bass; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -implementation - -uses - Classes, - SysUtils, - bass, - UMain, - UMusic, - UAudioCore_Bass, - ULog, - UPath; - -type - TBassDecodeStream = class(TAudioDecodeStream) - private - Handle: HSTREAM; - FormatInfo : TAudioFormatInfo; - Error: boolean; - public - constructor Create(Handle: HSTREAM); - destructor Destroy(); override; - - procedure Close(); override; - - function GetLength(): real; override; - function GetAudioFormatInfo(): TAudioFormatInfo; override; - function GetPosition: real; override; - procedure SetPosition(Time: real); override; - function GetLoop(): boolean; override; - procedure SetLoop(Enabled: boolean); override; - function IsEOF(): boolean; override; - function IsError(): boolean; override; - - function ReadData(Buffer: PByteArray; BufSize: integer): integer; override; - end; - -type - TAudioDecoder_Bass = class( TInterfacedObject, IAudioDecoder ) - public - function GetName: string; - - function InitializeDecoder(): boolean; - function FinalizeDecoder(): boolean; - function Open(const Filename: IPath): TAudioDecodeStream; - end; - -var - BassCore: TAudioCore_Bass; - - -{ TBassDecodeStream } - -constructor TBassDecodeStream.Create(Handle: HSTREAM); -var - ChannelInfo: BASS_CHANNELINFO; - Format: TAudioSampleFormat; -begin - inherited Create(); - Self.Handle := Handle; - - // setup format info - if (not BASS_ChannelGetInfo(Handle, ChannelInfo)) then - begin - raise Exception.Create('Failed to open decode-stream'); - end; - BassCore.ConvertBASSFlagsToAudioFormat(ChannelInfo.flags, Format); - FormatInfo := TAudioFormatInfo.Create(ChannelInfo.chans, ChannelInfo.freq, format); - - Error := false; -end; - -destructor TBassDecodeStream.Destroy(); -begin - Close(); - inherited; -end; - -procedure TBassDecodeStream.Close(); -begin - if (Handle <> 0) then - begin - BASS_StreamFree(Handle); - Handle := 0; - end; - PerformOnClose(); - FreeAndNil(FormatInfo); - Error := false; -end; - -function TBassDecodeStream.GetAudioFormatInfo(): TAudioFormatInfo; -begin - Result := FormatInfo; -end; - -function TBassDecodeStream.GetLength(): real; -var - bytes: QWORD; -begin - bytes := BASS_ChannelGetLength(Handle, BASS_POS_BYTE); - Result := BASS_ChannelBytes2Seconds(Handle, bytes); -end; - -function TBassDecodeStream.GetPosition: real; -var - bytes: QWORD; -begin - bytes := BASS_ChannelGetPosition(Handle, BASS_POS_BYTE); - Result := BASS_ChannelBytes2Seconds(Handle, bytes); -end; - -procedure TBassDecodeStream.SetPosition(Time: real); -var - bytes: QWORD; -begin - bytes := BASS_ChannelSeconds2Bytes(Handle, Time); - BASS_ChannelSetPosition(Handle, bytes, BASS_POS_BYTE); -end; - -function TBassDecodeStream.GetLoop(): boolean; -var - flags: DWORD; -begin - // retrieve channel flags - flags := BASS_ChannelFlags(Handle, 0, 0); - if (flags = DWORD(-1)) then - begin - Log.LogError('BASS_ChannelFlags: ' + BassCore.ErrorGetString(), 'TBassDecodeStream.GetLoop'); - Result := false; - Exit; - end; - Result := (flags and BASS_SAMPLE_LOOP) <> 0; -end; - -procedure TBassDecodeStream.SetLoop(Enabled: boolean); -var - flags: DWORD; -begin - // set/unset loop-flag - if (Enabled) then - flags := BASS_SAMPLE_LOOP - else - flags := 0; - - // set new flag-bits - if (BASS_ChannelFlags(Handle, flags, BASS_SAMPLE_LOOP) = DWORD(-1)) then - begin - Log.LogError('BASS_ChannelFlags: ' + BassCore.ErrorGetString(), 'TBassDecodeStream.SetLoop'); - Exit; - end; -end; - -function TBassDecodeStream.IsEOF(): boolean; -begin - Result := (BASS_ChannelIsActive(Handle) = BASS_ACTIVE_STOPPED); -end; - -function TBassDecodeStream.IsError(): boolean; -begin - Result := Error; -end; - -function TBassDecodeStream.ReadData(Buffer: PByteArray; BufSize: integer): integer; -begin - Result := BASS_ChannelGetData(Handle, Buffer, BufSize); - // check error state (do not handle EOF as error) - if ((Result = -1) and (BASS_ErrorGetCode() <> BASS_ERROR_ENDED)) then - Error := true - else - Error := false; -end; - - -{ TAudioDecoder_Bass } - -function TAudioDecoder_Bass.GetName: String; -begin - result := 'BASS_Decoder'; -end; - -function TAudioDecoder_Bass.InitializeDecoder(): boolean; -begin - Result := false; - BassCore := TAudioCore_Bass.GetInstance(); - if not BassCore.CheckVersion then - Exit; - Result := true; -end; - -function TAudioDecoder_Bass.FinalizeDecoder(): boolean; -begin - Result := true; -end; - -function TAudioDecoder_Bass.Open(const Filename: IPath): TAudioDecodeStream; -var - Stream: HSTREAM; - ChannelInfo: BASS_CHANNELINFO; - FileExt: string; -begin - Result := nil; - - // check if BASS was initialized - // in case the decoder is not used with BASS playback, init the NO_SOUND device - if ((integer(BASS_GetDevice) = -1) and (BASS_ErrorGetCode() = BASS_ERROR_INIT)) then - BASS_Init(0, 44100, 0, 0, nil); - - // TODO: use BASS_STREAM_PRESCAN for accurate seeking in VBR-files? - // disadvantage: seeking will slow down. - - {$IFDEF MSWINDOWS} - // Windows: Use UTF-16 version - Stream := BASS_StreamCreateFile(False, PWideChar(Filename.ToWide), 0, 0, BASS_STREAM_DECODE or BASS_UNICODE); - {$ELSE} - // Mac OS X: Use UTF8/ANSI version - Stream := BASS_StreamCreateFile(False, PAnsiChar(Filename.ToNative), 0, 0, BASS_STREAM_DECODE); - {$ENDIF} - if (Stream = 0) then - begin - //Log.LogError(BassCore.ErrorGetString(), 'TAudioDecoder_Bass.Open'); - Exit; - end; - - // check if BASS opened some erroneously recognized file-formats - if BASS_ChannelGetInfo(Stream, channelInfo) then - begin - fileExt := Filename.GetExtension.ToUTF8; - // BASS opens FLV-files (maybe others too) although it cannot handle them. - // Setting BASS_CONFIG_VERIFY to the max. value (100000) does not help. - if ((fileExt = '.flv') and (channelInfo.ctype = BASS_CTYPE_STREAM_MP1)) then - begin - BASS_StreamFree(Stream); - Exit; - end; - end; - - Result := TBassDecodeStream.Create(Stream); -end; - - -initialization - MediaManager.Add(TAudioDecoder_Bass.Create); - -end. diff --git a/src/media/UAudioDecoder_FFmpeg.pas b/src/media/UAudioDecoder_FFmpeg.pas deleted file mode 100644 index d079afdc..00000000 --- a/src/media/UAudioDecoder_FFmpeg.pas +++ /dev/null @@ -1,1141 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioDecoder_FFmpeg; - -(******************************************************************************* - * - * This unit is primarily based upon - - * http://www.dranger.com/ffmpeg/ffmpegtutorial_all.html - * - * and tutorial03.c - * - * http://www.inb.uni-luebeck.de/~boehme/using_libavcodec.html - * - *******************************************************************************) - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -// show FFmpeg specific debug output -{.$DEFINE DebugFFmpegDecode} - -// FFmpeg is very verbose and shows a bunch of errors. -// Those errors (they can be considered as warnings by us) can be ignored -// as they do not give any useful information. -// There is no solution to fix this except for turning them off. -{.$DEFINE EnableFFmpegErrorOutput} - -implementation - -uses - SDL, // SDL redefines some base types -> include before SysUtils to ignore them - Classes, - Math, - SysUtils, - avcodec, - avformat, - avutil, - avio, - mathematics, // used for av_rescale_q - rational, - UMusic, - UIni, - UMain, - UMediaCore_FFmpeg, - ULog, - UCommon, - UConfig, - UPath; - -const - MAX_AUDIOQ_SIZE = (5 * 16 * 1024); - -const - // TODO: The factor 3/2 might not be necessary as we do not need extra - // space for synchronizing as in the tutorial. - AUDIO_BUFFER_SIZE = (AVCODEC_MAX_AUDIO_FRAME_SIZE * 3) div 2; - -type - TFFmpegDecodeStream = class(TAudioDecodeStream) - private - StateLock: PSDL_Mutex; - - EOFState: boolean; // end-of-stream flag (locked by StateLock) - ErrorState: boolean; // error flag (locked by StateLock) - - QuitRequest: boolean; // (locked by StateLock) - ParserIdleCond: PSDL_Cond; - - // parser pause/resume data - ParserLocked: boolean; - ParserPauseRequestCount: integer; - ParserUnlockedCond: PSDL_Cond; - ParserResumeCond: PSDL_Cond; - - SeekRequest: boolean; // (locked by StateLock) - SeekFlags: integer; // (locked by StateLock) - SeekPos: double; // stream position to seek for (in secs) (locked by StateLock) - SeekFlush: boolean; // true if the buffers should be flushed after seeking (locked by StateLock) - SeekFinishedCond: PSDL_Cond; - - Loop: boolean; // (locked by StateLock) - - ParseThread: PSDL_Thread; - PacketQueue: TPacketQueue; - - FormatInfo: TAudioFormatInfo; - - // FFmpeg specific data - FormatCtx: PAVFormatContext; - CodecCtx: PAVCodecContext; - Codec: PAVCodec; - - AudioStreamIndex: integer; - AudioStream: PAVStream; - AudioStreamPos: double; // stream position in seconds (locked by DecoderLock) - - // decoder pause/resume data - DecoderLocked: boolean; - DecoderPauseRequestCount: integer; - DecoderUnlockedCond: PSDL_Cond; - DecoderResumeCond: PSDL_Cond; - - // state-vars for DecodeFrame (locked by DecoderLock) - AudioPaket: TAVPacket; - AudioPaketData: PByteArray; - AudioPaketSize: integer; - AudioPaketSilence: integer; // number of bytes of silence to return - - // state-vars for AudioCallback (locked by DecoderLock) - AudioBufferPos: integer; - AudioBufferSize: integer; - AudioBuffer: PByteArray; - - Filename: IPath; - - procedure SetPositionIntern(Time: real; Flush: boolean; Blocking: boolean); - procedure SetEOF(State: boolean); {$IFDEF HasInline}inline;{$ENDIF} - procedure SetError(State: boolean); {$IFDEF HasInline}inline;{$ENDIF} - function IsSeeking(): boolean; - function IsQuit(): boolean; - - procedure Reset(); - - procedure Parse(); - function ParseLoop(): boolean; - procedure PauseParser(); - procedure ResumeParser(); - - function DecodeFrame(Buffer: PByteArray; BufferSize: integer): integer; - procedure FlushCodecBuffers(); - procedure PauseDecoder(); - procedure ResumeDecoder(); - public - constructor Create(); - destructor Destroy(); override; - - function Open(const Filename: IPath): boolean; - procedure Close(); override; - - function GetLength(): real; override; - function GetAudioFormatInfo(): TAudioFormatInfo; override; - function GetPosition: real; override; - procedure SetPosition(Time: real); override; - function GetLoop(): boolean; override; - procedure SetLoop(Enabled: boolean); override; - function IsEOF(): boolean; override; - function IsError(): boolean; override; - - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; override; - end; - -type - TAudioDecoder_FFmpeg = class(TInterfacedObject, IAudioDecoder) - public - function GetName: string; - - function InitializeDecoder(): boolean; - function FinalizeDecoder(): boolean; - function Open(const Filename: IPath): TAudioDecodeStream; - end; - -var - FFmpegCore: TMediaCore_FFmpeg; - -function ParseThreadMain(Data: Pointer): integer; cdecl; forward; - - -{ TFFmpegDecodeStream } - -constructor TFFmpegDecodeStream.Create(); -begin - inherited Create(); - - StateLock := SDL_CreateMutex(); - ParserUnlockedCond := SDL_CreateCond(); - ParserResumeCond := SDL_CreateCond(); - ParserIdleCond := SDL_CreateCond(); - SeekFinishedCond := SDL_CreateCond(); - DecoderUnlockedCond := SDL_CreateCond(); - DecoderResumeCond := SDL_CreateCond(); - - // according to the documentation of avcodec_decode_audio(2), sample-data - // should be aligned on a 16 byte boundary. Otherwise internal calls - // (e.g. to SSE or Altivec operations) might fail or lack performance on some - // CPUs. Although GetMem() in Delphi and FPC seems to use a 16 byte or higher - // alignment for buffers of this size (alignment depends on the size of the - // requested buffer), we will set the alignment explicitly as the minimum - // alignment used by Delphi and FPC is on an 8 byte boundary. - // - // Note: AudioBuffer was previously defined as a field of type TAudioBuffer - // (array[0..AUDIO_BUFFER_SIZE-1] of byte) and hence statically allocated. - // Fields of records are aligned different to memory allocated with GetMem(), - // aligning depending on the type but will be at least 2 bytes. - // AudioBuffer was not aligned to a 16 byte boundary. The {$ALIGN x} directive - // was not applicable as Delphi in contrast to FPC provides at most 8 byte - // alignment ({$ALIGN 16} is not supported) by this directive. - AudioBuffer := GetAlignedMem(AUDIO_BUFFER_SIZE, 16); - - Reset(); -end; - -procedure TFFmpegDecodeStream.Reset(); -begin - ParseThread := nil; - - EOFState := false; - ErrorState := false; - Loop := false; - QuitRequest := false; - - AudioPaketData := nil; - AudioPaketSize := 0; - AudioPaketSilence := 0; - - AudioBufferPos := 0; - AudioBufferSize := 0; - - ParserLocked := false; - ParserPauseRequestCount := 0; - DecoderLocked := false; - DecoderPauseRequestCount := 0; - - FillChar(AudioPaket, SizeOf(TAVPacket), 0); -end; - -{* - * Frees the decode-stream data. - *} -destructor TFFmpegDecodeStream.Destroy(); -begin - Close(); - - SDL_DestroyMutex(StateLock); - SDL_DestroyCond(ParserUnlockedCond); - SDL_DestroyCond(ParserResumeCond); - SDL_DestroyCond(ParserIdleCond); - SDL_DestroyCond(SeekFinishedCond); - SDL_DestroyCond(DecoderUnlockedCond); - SDL_DestroyCond(DecoderResumeCond); - - FreeAlignedMem(AudioBuffer); - - inherited; -end; - -function TFFmpegDecodeStream.Open(const Filename: IPath): boolean; -var - SampleFormat: TAudioSampleFormat; - AVResult: integer; -begin - Result := false; - - Close(); - Reset(); - - if (not Filename.IsFile) then - begin - Log.LogError('Audio-file does not exist: "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); - Exit; - end; - - Self.Filename := Filename; - - // use custom 'ufile' protocol for UTF-8 support - if (av_open_input_file(FormatCtx, PAnsiChar('ufile:'+FileName.ToUTF8), nil, 0, nil) <> 0) then - begin - Log.LogError('av_open_input_file failed: "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); - Exit; - end; - - // generate PTS values if they do not exist - FormatCtx^.flags := FormatCtx^.flags or AVFMT_FLAG_GENPTS; - - // retrieve stream information - if (av_find_stream_info(FormatCtx) < 0) then - begin - Log.LogError('av_find_stream_info failed: "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); - Close(); - Exit; - end; - - // FIXME: hack used by ffplay. Maybe should not use url_feof() to test for the end - FormatCtx^.pb.eof_reached := 0; - - {$IFDEF DebugFFmpegDecode} - dump_format(FormatCtx, 0, PAnsiChar(Filename.ToNative), 0); - {$ENDIF} - - AudioStreamIndex := FFmpegCore.FindAudioStreamIndex(FormatCtx); - if (AudioStreamIndex < 0) then - begin - Log.LogError('FindAudioStreamIndex: No Audio-stream found "' + Filename.ToNative + '"', 'UAudio_FFmpeg'); - Close(); - Exit; - end; - - //Log.LogStatus('AudioStreamIndex is: '+ inttostr(ffmpegStreamID), 'UAudio_FFmpeg'); - - AudioStream := FormatCtx.streams[AudioStreamIndex]; - CodecCtx := AudioStream^.codec; - - // TODO: should we use this or not? Should we allow 5.1 channel audio? - (* - {$IF LIBAVCODEC_VERSION >= 51042000} - if (CodecCtx^.channels > 0) then - CodecCtx^.request_channels := Min(2, CodecCtx^.channels) - else - CodecCtx^.request_channels := 2; - {$IFEND} - *) - - Codec := avcodec_find_decoder(CodecCtx^.codec_id); - if (Codec = nil) then - begin - Log.LogError('Unsupported codec!', 'UAudio_FFmpeg'); - CodecCtx := nil; - Close(); - Exit; - end; - - // set debug options - CodecCtx^.debug_mv := 0; - CodecCtx^.debug := 0; - - // detect bug-workarounds automatically - CodecCtx^.workaround_bugs := FF_BUG_AUTODETECT; - // error resilience strategy (careful/compliant/agressive/very_aggressive) - //CodecCtx^.error_resilience := FF_ER_CAREFUL; //FF_ER_COMPLIANT; - // allow non spec compliant speedup tricks. - //CodecCtx^.flags2 := CodecCtx^.flags2 or CODEC_FLAG2_FAST; - - // Note: avcodec_open() and avcodec_close() are not thread-safe and will - // fail if called concurrently by different threads. - FFmpegCore.LockAVCodec(); - try - AVResult := avcodec_open(CodecCtx, Codec); - finally - FFmpegCore.UnlockAVCodec(); - end; - if (AVResult < 0) then - begin - Log.LogError('avcodec_open failed!', 'UAudio_FFmpeg'); - Close(); - Exit; - end; - - // now initialize the audio-format - - if (not FFmpegCore.ConvertFFmpegToAudioFormat(CodecCtx^.sample_fmt, SampleFormat)) then - begin - // try standard format - SampleFormat := asfS16; - end; - if CodecCtx^.channels > 255 then - Log.LogStatus('Error: CodecCtx^.channels > 255', 'TFFmpegDecodeStream.Open'); - FormatInfo := TAudioFormatInfo.Create( - byte(CodecCtx^.channels), - CodecCtx^.sample_rate, - SampleFormat - ); - - PacketQueue := TPacketQueue.Create(); - - // finally start the decode thread - ParseThread := SDL_CreateThread(@ParseThreadMain, Self); - - Result := true; -end; - -procedure TFFmpegDecodeStream.Close(); -var - ThreadResult: integer; -begin - // wake threads waiting for packet-queue data - // Note: normally, there are no waiting threads. If there were waiting - // ones, they would block the audio-callback thread. - if (assigned(PacketQueue)) then - PacketQueue.Abort(); - - // send quit request (to parse-thread etc) - SDL_mutexP(StateLock); - QuitRequest := true; - SDL_CondBroadcast(ParserIdleCond); - SDL_mutexV(StateLock); - - // abort parse-thread - if (ParseThread <> nil) then - begin - // and wait until it terminates - SDL_WaitThread(ParseThread, ThreadResult); - ParseThread := nil; - end; - - // Close the codec - if (CodecCtx <> nil) then - begin - // avcodec_close() is not thread-safe - FFmpegCore.LockAVCodec(); - try - avcodec_close(CodecCtx); - finally - FFmpegCore.UnlockAVCodec(); - end; - CodecCtx := nil; - end; - - // Close the video file - if (FormatCtx <> nil) then - begin - av_close_input_file(FormatCtx); - FormatCtx := nil; - end; - - PerformOnClose(); - - FreeAndNil(PacketQueue); - FreeAndNil(FormatInfo); -end; - -function TFFmpegDecodeStream.GetLength(): real; -begin - // do not forget to consider the start_time value here - // there is a type size mismatch warnign because start_time and duration are cint64. - // So, in principle there could be an overflow when doing the sum. - Result := (FormatCtx^.start_time + FormatCtx^.duration) / AV_TIME_BASE; -end; - -function TFFmpegDecodeStream.GetAudioFormatInfo(): TAudioFormatInfo; -begin - Result := FormatInfo; -end; - -function TFFmpegDecodeStream.IsEOF(): boolean; -begin - SDL_mutexP(StateLock); - Result := EOFState; - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.SetEOF(State: boolean); -begin - SDL_mutexP(StateLock); - EOFState := State; - SDL_mutexV(StateLock); -end; - -function TFFmpegDecodeStream.IsError(): boolean; -begin - SDL_mutexP(StateLock); - Result := ErrorState; - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.SetError(State: boolean); -begin - SDL_mutexP(StateLock); - ErrorState := State; - SDL_mutexV(StateLock); -end; - -function TFFmpegDecodeStream.IsSeeking(): boolean; -begin - SDL_mutexP(StateLock); - Result := SeekRequest; - SDL_mutexV(StateLock); -end; - -function TFFmpegDecodeStream.IsQuit(): boolean; -begin - SDL_mutexP(StateLock); - Result := QuitRequest; - SDL_mutexV(StateLock); -end; - -function TFFmpegDecodeStream.GetPosition(): real; -var - BufferSizeSec: double; -begin - PauseDecoder(); - - // ReadData() does not return all of the buffer retrieved by DecodeFrame(). - // Determine the size of the unused part of the decode-buffer. - BufferSizeSec := (AudioBufferSize - AudioBufferPos) / - FormatInfo.BytesPerSec; - - // subtract the size of unused buffer-data from the audio clock. - Result := AudioStreamPos - BufferSizeSec; - - ResumeDecoder(); -end; - -procedure TFFmpegDecodeStream.SetPosition(Time: real); -begin - SetPositionIntern(Time, true, true); -end; - -function TFFmpegDecodeStream.GetLoop(): boolean; -begin - SDL_mutexP(StateLock); - Result := Loop; - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.SetLoop(Enabled: boolean); -begin - SDL_mutexP(StateLock); - Loop := Enabled; - SDL_mutexV(StateLock); -end; - - -(******************************************** - * Parser section - ********************************************) - -procedure TFFmpegDecodeStream.PauseParser(); -begin - if (SDL_ThreadID() = ParseThread.threadid) then - Exit; - - SDL_mutexP(StateLock); - Inc(ParserPauseRequestCount); - while (ParserLocked) do - SDL_CondWait(ParserUnlockedCond, StateLock); - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.ResumeParser(); -begin - if (SDL_ThreadID() = ParseThread.threadid) then - Exit; - - SDL_mutexP(StateLock); - Dec(ParserPauseRequestCount); - SDL_CondSignal(ParserResumeCond); - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.SetPositionIntern(Time: real; Flush: boolean; Blocking: boolean); -begin - // - Pause the parser first to prevent it from putting obsolete packages - // into the queue after the queue was flushed and before seeking is done. - // Otherwise we will hear fragments of old data, if the stream was seeked - // in stopped mode and resumed afterwards (applies to non-blocking mode only). - // - Pause the decoder to avoid race-condition that might occur otherwise. - // - Last lock the state lock because we are manipulating some shared state-vars. - PauseParser(); - PauseDecoder(); - SDL_mutexP(StateLock); - - // configure seek parameters - SeekPos := Time; - SeekFlush := Flush; - SeekFlags := AVSEEK_FLAG_ANY; - SeekRequest := true; - - // Note: the BACKWARD-flag seeks to the first position <= the position - // searched for. Otherwise e.g. position 0 might not be seeked correct. - // For some reason ffmpeg sometimes doesn't use position 0 but the key-frame - // following. In streams with few key-frames (like many flv-files) the next - // key-frame after 0 might be 5secs ahead. - if (Time < AudioStreamPos) then - SeekFlags := SeekFlags or AVSEEK_FLAG_BACKWARD; - - EOFState := false; - ErrorState := false; - - // send a reuse signal in case the parser was stopped (e.g. because of an EOF) - SDL_CondSignal(ParserIdleCond); - - SDL_mutexV(StateLock); - ResumeDecoder(); - ResumeParser(); - - // in blocking mode, wait until seeking is done - if (Blocking) then - begin - SDL_mutexP(StateLock); - while (SeekRequest) do - SDL_CondWait(SeekFinishedCond, StateLock); - SDL_mutexV(StateLock); - end; -end; - -function ParseThreadMain(Data: Pointer): integer; cdecl; -var - Stream: TFFmpegDecodeStream; -begin - Stream := TFFmpegDecodeStream(Data); - if (Stream <> nil) then - Stream.Parse(); - Result := 0; -end; - -procedure TFFmpegDecodeStream.Parse(); -begin - // reuse thread as long as the stream is not terminated - while (ParseLoop()) do - begin - // wait for reuse or destruction of stream - SDL_mutexP(StateLock); - while (not (SeekRequest or QuitRequest)) do - SDL_CondWait(ParserIdleCond, StateLock); - SDL_mutexV(StateLock); - end; -end; - -(** - * Parser main loop. - * Will not return until parsing of the stream is finished. - * Reasons for the parser to return are: - * - the end-of-file is reached - * - an error occured - * - the stream was quited (received a quit-request) - * Returns true if the stream can be resumed or false if the stream has to - * be terminated. - *) -function TFFmpegDecodeStream.ParseLoop(): boolean; -var - Packet: TAVPacket; - SeekTarget: int64; - ByteIOCtx: PByteIOContext; - ErrorCode: integer; - StartSilence: double; // duration of silence at start of stream - StartSilencePtr: PDouble; // pointer for the EMPTY status packet - - // Note: pthreads wakes threads waiting on a mutex in the order of their - // priority and not in FIFO order. SDL does not provide any option to - // control priorities. This might (and already did) starve threads waiting - // on the mutex (e.g. SetPosition) making usdx look like it was froozen. - // Instead of simply locking the critical section we set a ParserLocked flag - // instead and give priority to the threads requesting the parser to pause. - procedure LockParser(); - begin - SDL_mutexP(StateLock); - while (ParserPauseRequestCount > 0) do - SDL_CondWait(ParserResumeCond, StateLock); - ParserLocked := true; - SDL_mutexV(StateLock); - end; - - procedure UnlockParser(); - begin - SDL_mutexP(StateLock); - ParserLocked := false; - SDL_CondBroadcast(ParserUnlockedCond); - SDL_mutexV(StateLock); - end; - -begin - Result := true; - - while (true) do - begin - LockParser(); - try - - if (IsQuit()) then - begin - Result := false; - Exit; - end; - - // handle seek-request (Note: no need to lock SeekRequest here) - if (SeekRequest) then - begin - // first try: seek on the audio stream - SeekTarget := Round(SeekPos / av_q2d(AudioStream^.time_base)); - StartSilence := 0; - if (SeekTarget < AudioStream^.start_time) then - StartSilence := (AudioStream^.start_time - SeekTarget) * av_q2d(AudioStream^.time_base); - ErrorCode := av_seek_frame(FormatCtx, AudioStreamIndex, SeekTarget, SeekFlags); - - if (ErrorCode < 0) then - begin - // second try: seek on the default stream (necessary for flv-videos and some ogg-files) - SeekTarget := Round(SeekPos * AV_TIME_BASE); - StartSilence := 0; - if (SeekTarget < FormatCtx^.start_time) then - StartSilence := (FormatCtx^.start_time - SeekTarget) / AV_TIME_BASE; - ErrorCode := av_seek_frame(FormatCtx, -1, SeekTarget, SeekFlags); - end; - - // pause decoder and lock state (keep the lock-order to avoid deadlocks). - // Note that the decoder does not block in the packet-queue in seeking state, - // so locking the decoder here does not cause a dead-lock. - PauseDecoder(); - SDL_mutexP(StateLock); - try - if (ErrorCode < 0) then - begin - // seeking failed - ErrorState := true; - Log.LogStatus('Seek Error in "'+FormatCtx^.filename+'"', 'UAudioDecoder_FFmpeg'); - end - else - begin - if (SeekFlush) then - begin - // flush queue (we will send a Flush-Packet when seeking is finished) - PacketQueue.Flush(); - - // flush the decode buffers - AudioBufferSize := 0; - AudioBufferPos := 0; - AudioPaketSize := 0; - AudioPaketSilence := 0; - FlushCodecBuffers(); - - // Set preliminary stream position. The position will be set to - // the correct value as soon as the first packet is decoded. - AudioStreamPos := SeekPos; - end - else - begin - // request avcodec buffer flush - PacketQueue.PutStatus(PKT_STATUS_FLAG_FLUSH, nil); - end; - - // fill the gap between position 0 and start_time with silence - // but not if we are in loop mode - if ((StartSilence > 0) and (not Loop)) then - begin - GetMem(StartSilencePtr, SizeOf(StartSilence)); - StartSilencePtr^ := StartSilence; - PacketQueue.PutStatus(PKT_STATUS_FLAG_EMPTY, StartSilencePtr); - end; - end; - - SeekRequest := false; - SDL_CondBroadcast(SeekFinishedCond); - finally - SDL_mutexV(StateLock); - ResumeDecoder(); - end; - end; - - if (PacketQueue.GetSize() > MAX_AUDIOQ_SIZE) then - begin - SDL_Delay(10); - Continue; - end; - - if (av_read_frame(FormatCtx, Packet) < 0) then - begin - // failed to read a frame, check reason - {$IF (LIBAVFORMAT_VERSION_MAJOR >= 52)} - ByteIOCtx := FormatCtx^.pb; - {$ELSE} - ByteIOCtx := @FormatCtx^.pb; - {$IFEND} - - // check for end-of-file (eof is not an error) - if (url_feof(ByteIOCtx) <> 0) then - begin - if (GetLoop()) then - begin - // rewind stream (but do not flush) - SetPositionIntern(0, false, false); - Continue; - end - else - begin - // signal end-of-file - PacketQueue.PutStatus(PKT_STATUS_FLAG_EOF, nil); - Exit; - end; - end; - - // check for errors - if (url_ferror(ByteIOCtx) <> 0) then - begin - // an error occured -> abort and wait for repositioning or termination - PacketQueue.PutStatus(PKT_STATUS_FLAG_ERROR, nil); - Exit; - end; - - // no error -> wait for user input - SDL_Delay(100); - Continue; - end; - - if (Packet.stream_index = AudioStreamIndex) then - PacketQueue.Put(@Packet) - else - av_free_packet(@Packet); - - finally - UnlockParser(); - end; - end; -end; - - -(******************************************** - * Decoder section - ********************************************) - -procedure TFFmpegDecodeStream.PauseDecoder(); -begin - SDL_mutexP(StateLock); - Inc(DecoderPauseRequestCount); - while (DecoderLocked) do - SDL_CondWait(DecoderUnlockedCond, StateLock); - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.ResumeDecoder(); -begin - SDL_mutexP(StateLock); - Dec(DecoderPauseRequestCount); - SDL_CondSignal(DecoderResumeCond); - SDL_mutexV(StateLock); -end; - -procedure TFFmpegDecodeStream.FlushCodecBuffers(); -begin - // if no flush operation is specified, avcodec_flush_buffers will not do anything. - if (@CodecCtx.codec.flush <> nil) then - begin - // flush buffers used by avcodec_decode_audio, etc. - avcodec_flush_buffers(CodecCtx); - end - else - begin - // we need a Workaround to avoid plopping noise with ogg-vorbis and - // mp3 (in older versions of FFmpeg). - // We will just reopen the codec. - FFmpegCore.LockAVCodec(); - try - avcodec_close(CodecCtx); - avcodec_open(CodecCtx, Codec); - finally - FFmpegCore.UnlockAVCodec(); - end; - end; -end; - -function TFFmpegDecodeStream.DecodeFrame(Buffer: PByteArray; BufferSize: integer): integer; -var - PaketDecodedSize: integer; // size of packet data used for decoding - DataSize: integer; // size of output data decoded by FFmpeg - BlockQueue: boolean; - SilenceDuration: double; - {$IFDEF DebugFFmpegDecode} - TmpPos: double; - {$ENDIF} -begin - Result := -1; - - if (EOF) then - Exit; - - while(true) do - begin - // for titles with start_time > 0 we have to generate silence - // until we reach the pts of the first data packet. - if (AudioPaketSilence > 0) then - begin - DataSize := Min(AudioPaketSilence, BufferSize); - FillChar(Buffer[0], DataSize, 0); - Dec(AudioPaketSilence, DataSize); - AudioStreamPos := AudioStreamPos + DataSize / FormatInfo.BytesPerSec; - Result := DataSize; - Exit; - end; - - // read packet data - while (AudioPaketSize > 0) do - begin - DataSize := BufferSize; - - {$IF LIBAVCODEC_VERSION >= 51030000} // 51.30.0 - PaketDecodedSize := avcodec_decode_audio2(CodecCtx, PSmallint(Buffer), - DataSize, AudioPaketData, AudioPaketSize); - {$ELSE} - PaketDecodedSize := avcodec_decode_audio(CodecCtx, PSmallint(Buffer), - DataSize, AudioPaketData, AudioPaketSize); - {$IFEND} - - if(PaketDecodedSize < 0) then - begin - // if error, skip frame - {$IFDEF DebugFFmpegDecode} - DebugWriteln('Skip audio frame'); - {$ENDIF} - AudioPaketSize := 0; - Break; - end; - - Inc(AudioPaketData, PaketDecodedSize); - Dec(AudioPaketSize, PaketDecodedSize); - - // check if avcodec_decode_audio returned data, otherwise fetch more frames - if (DataSize <= 0) then - Continue; - - // update stream position by the amount of fetched data - AudioStreamPos := AudioStreamPos + DataSize / FormatInfo.BytesPerSec; - - // we have data, return it and come back for more later - Result := DataSize; - Exit; - end; - - // free old packet data - if (AudioPaket.data <> nil) then - av_free_packet(@AudioPaket); - - // do not block queue on seeking (to avoid deadlocks on the DecoderLock) - if (IsSeeking()) then - BlockQueue := false - else - BlockQueue := true; - - // request a new packet and block if none available. - // If this fails, the queue was aborted. - if (PacketQueue.Get(AudioPaket, BlockQueue) <= 0) then - Exit; - - // handle Status-packet - if (PAnsiChar(AudioPaket.data) = STATUS_PACKET) then - begin - AudioPaket.data := nil; - AudioPaketData := nil; - AudioPaketSize := 0; - - case (AudioPaket.flags) of - PKT_STATUS_FLAG_FLUSH: - begin - // just used if SetPositionIntern was called without the flush flag. - FlushCodecBuffers; - end; - PKT_STATUS_FLAG_EOF: // end-of-file - begin - // ignore EOF while seeking - if (not IsSeeking()) then - SetEOF(true); - // buffer contains no data -> result = -1 - Exit; - end; - PKT_STATUS_FLAG_ERROR: - begin - SetError(true); - Log.LogStatus('I/O Error', 'TFFmpegDecodeStream.DecodeFrame'); - Exit; - end; - PKT_STATUS_FLAG_EMPTY: - begin - SilenceDuration := PDouble(PacketQueue.GetStatusInfo(AudioPaket))^; - AudioPaketSilence := Round(SilenceDuration * FormatInfo.SampleRate) * FormatInfo.FrameSize; - PacketQueue.FreeStatusInfo(AudioPaket); - end - else - begin - Log.LogStatus('Unknown status', 'TFFmpegDecodeStream.DecodeFrame'); - end; - end; - - Continue; - end; - - AudioPaketData := AudioPaket.data; - AudioPaketSize := AudioPaket.size; - - // if available, update the stream position to the presentation time of this package - if(AudioPaket.pts <> AV_NOPTS_VALUE) then - begin - {$IFDEF DebugFFmpegDecode} - TmpPos := AudioStreamPos; - {$ENDIF} - AudioStreamPos := av_q2d(AudioStream^.time_base) * AudioPaket.pts; - {$IFDEF DebugFFmpegDecode} - DebugWriteln('Timestamp: ' + floattostrf(AudioStreamPos, ffFixed, 15, 3) + ' ' + - '(Calc: ' + floattostrf(TmpPos, ffFixed, 15, 3) + '), ' + - 'Diff: ' + floattostrf(AudioStreamPos-TmpPos, ffFixed, 15, 3)); - {$ENDIF} - end; - end; -end; - -function TFFmpegDecodeStream.ReadData(Buffer: PByteArray; BufferSize: integer): integer; -var - CopyByteCount: integer; // number of bytes to copy - RemainByteCount: integer; // number of bytes left (remain) to read - BufferPos: integer; - - // prioritize pause requests - procedure LockDecoder(); - begin - SDL_mutexP(StateLock); - while (DecoderPauseRequestCount > 0) do - SDL_CondWait(DecoderResumeCond, StateLock); - DecoderLocked := true; - SDL_mutexV(StateLock); - end; - - procedure UnlockDecoder(); - begin - SDL_mutexP(StateLock); - DecoderLocked := false; - SDL_CondBroadcast(DecoderUnlockedCond); - SDL_mutexV(StateLock); - end; - -begin - Result := -1; - - // set number of bytes to copy to the output buffer - BufferPos := 0; - - LockDecoder(); - try - // leave if end-of-file is reached - if (EOF) then - Exit; - - // copy data to output buffer - while (BufferPos < BufferSize) do - begin - // check if we need more data - if (AudioBufferPos >= AudioBufferSize) then - begin - AudioBufferPos := 0; - - // we have already sent all our data; get more - AudioBufferSize := DecodeFrame(AudioBuffer, AUDIO_BUFFER_SIZE); - - // check for errors or EOF - if(AudioBufferSize < 0) then - begin - Result := BufferPos; - Exit; - end; - end; - - // calc number of new bytes in the decode-buffer - CopyByteCount := AudioBufferSize - AudioBufferPos; - // resize copy-count if more bytes available than needed (remaining bytes are used the next time) - RemainByteCount := BufferSize - BufferPos; - if (CopyByteCount > RemainByteCount) then - CopyByteCount := RemainByteCount; - - Move(AudioBuffer[AudioBufferPos], Buffer[BufferPos], CopyByteCount); - - Inc(BufferPos, CopyByteCount); - Inc(AudioBufferPos, CopyByteCount); - end; - finally - UnlockDecoder(); - end; - - Result := BufferSize; -end; - - -{ TAudioDecoder_FFmpeg } - -function TAudioDecoder_FFmpeg.GetName: String; -begin - Result := 'FFmpeg_Decoder'; -end; - -function TAudioDecoder_FFmpeg.InitializeDecoder: boolean; -begin - //Log.LogStatus('InitializeDecoder', 'UAudioDecoder_FFmpeg'); - FFmpegCore := TMediaCore_FFmpeg.GetInstance(); - av_register_all(); - - // Do not show uninformative error messages by default. - // FFmpeg prints all error-infos on the console by default what - // is very confusing as the playback of the files is correct. - // We consider these errors to be internal to FFMpeg. They can be fixed - // by the FFmpeg guys only and do not provide any useful information in - // respect to USDX. - {$IFNDEF EnableFFmpegErrorOutput} - {$IF LIBAVUTIL_VERSION_MAJOR >= 50} - av_log_set_level(AV_LOG_FATAL); - {$ELSE} - // FATAL and ERROR share one log-level, so we have to use QUIET - av_log_set_level(AV_LOG_QUIET); - {$IFEND} - {$ENDIF} - - Result := true; -end; - -function TAudioDecoder_FFmpeg.FinalizeDecoder(): boolean; -begin - Result := true; -end; - -function TAudioDecoder_FFmpeg.Open(const Filename: IPath): TAudioDecodeStream; -var - Stream: TFFmpegDecodeStream; -begin - Result := nil; - - Stream := TFFmpegDecodeStream.Create(); - if (not Stream.Open(Filename)) then - begin - Stream.Free; - Exit; - end; - - Result := Stream; -end; - - -initialization - MediaManager.Add(TAudioDecoder_FFmpeg.Create); - -end. diff --git a/src/media/UAudioInput_Bass.pas b/src/media/UAudioInput_Bass.pas deleted file mode 100644 index 9d4417f1..00000000 --- a/src/media/UAudioInput_Bass.pas +++ /dev/null @@ -1,510 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioInput_Bass; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - SysUtils, - URecord, - UMusic; - -implementation - -uses - UMain, - UIni, - ULog, - UAudioCore_Bass, - UCommon, // (Note: for MakeLong on non-windows platforms) - {$IFDEF MSWINDOWS} - Windows, // (Note: for MakeLong) - {$ENDIF} - bass; // (Note: DWORD is redefined here -> insert after Windows-unit) - -type - TAudioInput_Bass = class(TAudioInputBase) - private - function EnumDevices(): boolean; - public - function GetName: String; override; - function InitializeRecord: boolean; override; - function FinalizeRecord: boolean; override; - end; - - TBassInputDevice = class(TAudioInputDevice) - private - RecordStream: HSTREAM; - BassDeviceID: DWORD; // DeviceID used by BASS - SingleIn: boolean; - - function SetInputSource(SourceIndex: integer): boolean; - function GetInputSource(): integer; - public - function Open(): boolean; - function Close(): boolean; - function Start(): boolean; override; - function Stop(): boolean; override; - - function GetVolume(): single; override; - procedure SetVolume(Volume: single); override; - end; - -var - BassCore: TAudioCore_Bass; - - -{ Global } - -{* - * Bass input capture callback. - * Params: - * stream - BASS input stream - * buffer - buffer of captured samples - * len - size of buffer in bytes - * user - players associated with left/right channels - *} -function MicrophoneCallback(stream: HSTREAM; buffer: Pointer; - len: integer; inputDevice: Pointer): boolean; {$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} -begin - AudioInputProcessor.HandleMicrophoneData(buffer, len, inputDevice); - Result := true; -end; - - -{ TBassInputDevice } - -function TBassInputDevice.GetInputSource(): integer; -var - SourceCnt: integer; - i: integer; - flags: DWORD; -begin - // get input-source config (subtract virtual device to get BASS indices) - SourceCnt := Length(Source)-1; - - // find source - Result := -1; - for i := 0 to SourceCnt-1 do - begin - // get input settings - flags := BASS_RecordGetInput(i, PSingle(nil)^); - if (flags = DWORD(-1)) then - begin - Log.LogError('BASS_RecordGetInput: ' + BassCore.ErrorGetString(), 'TBassInputDevice.GetInputSource'); - Exit; - end; - - // check if current source is selected - if ((flags and BASS_INPUT_OFF) = 0) then - begin - // selected source found - Result := i; - Exit; - end; - end; -end; - -function TBassInputDevice.SetInputSource(SourceIndex: integer): boolean; -var - SourceCnt: integer; - i: integer; - flags: DWORD; -begin - Result := false; - - // check for invalid source index - if (SourceIndex < 0) then - Exit; - - // get input-source config (subtract virtual device to get BASS indices) - SourceCnt := Length(Source)-1; - - // turn on selected source (turns off the others for single-in devices) - if (not BASS_RecordSetInput(SourceIndex, BASS_INPUT_ON, -1)) then - begin - Log.LogError('BASS_RecordSetInput: ' + BassCore.ErrorGetString(), 'TBassInputDevice.Start'); - Exit; - end; - - // turn off all other sources (not needed for single-in devices) - if (not SingleIn) then - begin - for i := 0 to SourceCnt-1 do - begin - if (i = SourceIndex) then - continue; - // get input settings - flags := BASS_RecordGetInput(i, PSingle(nil)^); - if (flags = DWORD(-1)) then - begin - Log.LogError('BASS_RecordGetInput: ' + BassCore.ErrorGetString(), 'TBassInputDevice.GetInputSource'); - Exit; - end; - // deselect source if selected - if ((flags and BASS_INPUT_OFF) = 0) then - BASS_RecordSetInput(i, BASS_INPUT_OFF, -1); - end; - end; - - Result := true; -end; - -function TBassInputDevice.Open(): boolean; -var - FormatFlags: DWORD; - SourceIndex: integer; -const - latency = 20; // 20ms callback period (= latency) -begin - Result := false; - - if (not BASS_RecordInit(BassDeviceID)) then - begin - Log.LogError('BASS_RecordInit['+Name+']: ' + - BassCore.ErrorGetString(), 'TBassInputDevice.Open'); - Exit; - end; - - if (not BassCore.ConvertAudioFormatToBASSFlags(AudioFormat.Format, FormatFlags)) then - begin - Log.LogError('Unhandled sample-format', 'TBassInputDevice.Open'); - Exit; - end; - - // start capturing in paused state - RecordStream := BASS_RecordStart(Round(AudioFormat.SampleRate), AudioFormat.Channels, - MakeLong(FormatFlags or BASS_RECORD_PAUSE, latency), - @MicrophoneCallback, Self); - if (RecordStream = 0) then - begin - Log.LogError('BASS_RecordStart: ' + BassCore.ErrorGetString(), 'TBassInputDevice.Open'); - BASS_RecordFree; - Exit; - end; - - // save current source selection and select new source - SourceIndex := Ini.InputDeviceConfig[CfgIndex].Input-1; - if (SourceIndex = -1) then - begin - // nothing to do if default source is used - SourceRestore := -1; - end - else - begin - // store current source-index and select new source - SourceRestore := GetInputSource(); - SetInputSource(SourceIndex); - end; - - Result := true; -end; - -{* Start input-capturing on this device. *} -function TBassInputDevice.Start(): boolean; -begin - Result := false; - - // recording already started -> stop first - if (RecordStream <> 0) then - Stop(); - - // TODO: Do not open the device here (takes too much time). - if not Open() then - Exit; - - if (not BASS_ChannelPlay(RecordStream, true)) then - begin - Log.LogError('BASS_ChannelPlay: ' + BassCore.ErrorGetString(), 'TBassInputDevice.Start'); - Exit; - end; - - Result := true; -end; - -{* Stop input-capturing on this device. *} -function TBassInputDevice.Stop(): boolean; -begin - Result := false; - - if (RecordStream = 0) then - Exit; - if (not BASS_RecordSetDevice(BassDeviceID)) then - Exit; - - if (not BASS_ChannelStop(RecordStream)) then - begin - Log.LogError('BASS_ChannelStop: ' + BassCore.ErrorGetString(), 'TBassInputDevice.Stop'); - end; - - // TODO: Do not close the device here (takes too much time). - Result := Close(); -end; - -function TBassInputDevice.Close(): boolean; -begin - // restore source selection - if (SourceRestore >= 0) then - begin - SetInputSource(SourceRestore); - end; - - // free data - if (not BASS_RecordFree()) then - begin - Log.LogError('BASS_RecordFree: ' + BassCore.ErrorGetString(), 'TBassInputDevice.Close'); - Result := false; - end - else - begin - Result := true; - end; - - RecordStream := 0; -end; - -function TBassInputDevice.GetVolume(): single; -var - SourceIndex: integer; - lVolume: Single; -begin - Result := 0; - - SourceIndex := Ini.InputDeviceConfig[CfgIndex].Input-1; - if (SourceIndex = -1) then - begin - // if default source used find selected source - SourceIndex := GetInputSource(); - if (SourceIndex = -1) then - Exit; - end; - - if (BASS_RecordGetInput(SourceIndex, lVolume) = DWORD(-1)) then - begin - Log.LogError('BASS_RecordGetInput: ' + BassCore.ErrorGetString() , 'TBassInputDevice.GetVolume'); - Exit; - end; - Result := lVolume; -end; - -procedure TBassInputDevice.SetVolume(Volume: single); -var - SourceIndex: integer; -begin - SourceIndex := Ini.InputDeviceConfig[CfgIndex].Input-1; - if (SourceIndex = -1) then - begin - // if default source used find selected source - SourceIndex := GetInputSource(); - if (SourceIndex = -1) then - Exit; - end; - - // clip volume to valid range - if (Volume > 1.0) then - Volume := 1.0 - else if (Volume < 0) then - Volume := 0; - - if (not BASS_RecordSetInput(SourceIndex, 0, Volume)) then - begin - Log.LogError('BASS_RecordSetInput: ' + BassCore.ErrorGetString() , 'TBassInputDevice.SetVolume'); - end; -end; - - -{ TAudioInput_Bass } - -function TAudioInput_Bass.GetName: String; -begin - result := 'BASS_Input'; -end; - -function TAudioInput_Bass.EnumDevices(): boolean; -var - Descr: PChar; - SourceName: PChar; - Flags: integer; - BassDeviceID: integer; - BassDevice: TBassInputDevice; - DeviceIndex: integer; - DeviceInfo: BASS_DEVICEINFO; - SourceIndex: integer; - RecordInfo: BASS_RECORDINFO; - SelectedSourceIndex: integer; -begin - result := false; - - DeviceIndex := 0; - BassDeviceID := 0; - SetLength(AudioInputProcessor.DeviceList, 0); - - // checks for recording devices and puts them into an array - while true do - begin - if (not BASS_RecordGetDeviceInfo(BassDeviceID, DeviceInfo)) then - break; - - // try to initialize the device - if not BASS_RecordInit(BassDeviceID) then - begin - Log.LogStatus('Failed to initialize BASS Capture-Device['+inttostr(BassDeviceID)+']', - 'TAudioInput_Bass.InitializeRecord'); - end - else - begin - SetLength(AudioInputProcessor.DeviceList, DeviceIndex+1); - - // TODO: free object on termination - BassDevice := TBassInputDevice.Create(); - AudioInputProcessor.DeviceList[DeviceIndex] := BassDevice; - - Descr := DeviceInfo.name; - - BassDevice.BassDeviceID := BassDeviceID; - BassDevice.Name := UnifyDeviceName(Descr, DeviceIndex); - - // zero info-struct as some fields might not be set (e.g. freq is just set on Vista and MacOSX) - FillChar(RecordInfo, SizeOf(RecordInfo), 0); - // retrieve recording device info - BASS_RecordGetInfo(RecordInfo); - - // check if BASS has capture-freq. info - if (RecordInfo.freq > 0) then - begin - // use current input sample rate (available only on Windows Vista and OSX). - // Recording at this rate will give the best quality and performance, as no resampling is required. - // FIXME: does BASS use LSB/MSB or system integer values for 16bit? - BassDevice.AudioFormat := TAudioFormatInfo.Create(2, RecordInfo.freq, asfS16) - end - else - begin - // BASS does not provide an explizit input channel count (except BASS_RECORDINFO.formats) - // but it doesn't fail if we use stereo input on a mono device - // -> use stereo by default - BassDevice.AudioFormat := TAudioFormatInfo.Create(2, 44100, asfS16) - end; - - // get info if multiple input-sources can be selected at once - BassDevice.SingleIn := RecordInfo.singlein; - - // init list for capture buffers per channel - SetLength(BassDevice.CaptureChannel, BassDevice.AudioFormat.Channels); - - BassDevice.MicSource := -1; - BassDevice.SourceRestore := -1; - - // add a virtual default source (will not change mixer-settings) - SetLength(BassDevice.Source, 1); - BassDevice.Source[0].Name := DEFAULT_SOURCE_NAME; - - // add real input sources - SourceIndex := 1; - - // process each input - while true do - begin - SourceName := BASS_RecordGetInputName(SourceIndex-1); - - {$IFDEF DARWIN} - // Under MacOSX the SingStar Mics have an empty InputName. - // So, we have to add a hard coded Workaround for this problem - // FIXME: - Do we need this anymore? Doesn't the (new) default source already solve this problem? - // - Normally a nil return value of BASS_RecordGetInputName() means end-of-list, so maybe - // BASS is not able to detect any mic-sources (the default source will work then). - // - Does BASS_RecordGetInfo() return true or false? If it returns true in this case - // we could use this value to check if the device exists. - // Please check that, eddie. - // If it returns false, then the source is not detected and it does not make sense to add a second - // fake device here. - // What about BASS_RecordGetInput()? Does it return a value <> -1? - // - Does it even work at all with this fake source-index, now that input switching works? - // This info was not used before (sources were never switched), so it did not matter what source-index was used. - // But now BASS_RecordSetInput() will probably fail. - if ((SourceName = nil) and (SourceIndex = 1) and (Pos('USBMIC Serial#', Descr) > 0)) then - SourceName := 'Microphone' - {$ENDIF} - - if (SourceName = nil) then - break; - - SetLength(BassDevice.Source, Length(BassDevice.Source)+1); - BassDevice.Source[SourceIndex].Name := SourceName; - - // get input-source info - Flags := BASS_RecordGetInput(SourceIndex, PSingle(nil)^); - if (Flags <> -1) then - begin - // is the current source a mic-source? - if ((Flags and BASS_INPUT_TYPE_MIC) <> 0) then - BassDevice.MicSource := SourceIndex; - end; - - Inc(SourceIndex); - end; - - // FIXME: this call hangs in FPC (windows) every 2nd time USDX is called. - // Maybe because the sound-device was not released properly? - BASS_RecordFree; - - Inc(DeviceIndex); - end; - - Inc(BassDeviceID); - end; - - result := true; -end; - -function TAudioInput_Bass.InitializeRecord(): boolean; -begin - BassCore := TAudioCore_Bass.GetInstance(); - if not BassCore.CheckVersion then - begin - Result := false; - Exit; - end; - Result := EnumDevices(); -end; - -function TAudioInput_Bass.FinalizeRecord(): boolean; -begin - CaptureStop; - Result := inherited FinalizeRecord; -end; - - -initialization - MediaManager.Add(TAudioInput_Bass.Create); - -end. diff --git a/src/media/UAudioInput_Portaudio.pas b/src/media/UAudioInput_Portaudio.pas deleted file mode 100644 index 31d2882b..00000000 --- a/src/media/UAudioInput_Portaudio.pas +++ /dev/null @@ -1,495 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioInput_Portaudio; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I ../switches.inc} - -uses - Classes, - SysUtils, - UMusic; - -implementation - -uses - {$IFDEF UsePortmixer} - portmixer, - {$ENDIF} - portaudio, - UAudioCore_Portaudio, - URecord, - UIni, - ULog, - UMain; - -type - TAudioInput_Portaudio = class(TAudioInputBase) - private - AudioCore: TAudioCore_Portaudio; - function EnumDevices(): boolean; - public - function GetName: String; override; - function InitializeRecord: boolean; override; - function FinalizeRecord: boolean; override; - end; - - TPortaudioInputDevice = class(TAudioInputDevice) - private - RecordStream: PPaStream; - {$IFDEF UsePortmixer} - Mixer: PPxMixer; - {$ENDIF} - PaDeviceIndex: TPaDeviceIndex; - public - function Open(): boolean; - function Close(): boolean; - function Start(): boolean; override; - function Stop(): boolean; override; - - function GetVolume(): single; override; - procedure SetVolume(Volume: single); override; - end; - -function MicrophoneCallback(input: Pointer; output: Pointer; frameCount: Longword; - timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; forward; - -function MicrophoneTestCallback(input: Pointer; output: Pointer; frameCount: Longword; - timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; forward; - - -{ TPortaudioInputDevice } - -function TPortaudioInputDevice.Open(): boolean; -var - Error: TPaError; - inputParams: TPaStreamParameters; - deviceInfo: PPaDeviceInfo; -begin - Result := false; - - // get input latency info - deviceInfo := Pa_GetDeviceInfo(PaDeviceIndex); - - // set input stream parameters - with inputParams do - begin - device := PaDeviceIndex; - channelCount := AudioFormat.Channels; - sampleFormat := paInt16; - suggestedLatency := deviceInfo^.defaultLowInputLatency; - hostApiSpecificStreamInfo := nil; - end; - - //Log.LogStatus(deviceInfo^.name, 'Portaudio'); - //Log.LogStatus(floattostr(deviceInfo^.defaultLowInputLatency), 'Portaudio'); - - // open input stream - Error := Pa_OpenStream(RecordStream, @inputParams, nil, - AudioFormat.SampleRate, - paFramesPerBufferUnspecified, paNoFlag, - @MicrophoneCallback, Pointer(Self)); - if(Error <> paNoError) then - begin - Log.LogError('Error opening stream: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Open'); - Exit; - end; - - {$IFDEF UsePortmixer} - // open default mixer - Mixer := Px_OpenMixer(RecordStream, 0); - if (Mixer = nil) then - begin - Log.LogError('Error opening mixer: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Open'); - end - else - begin - // save current source selection and select new source - SourceIndex := Ini.InputDeviceConfig[CfgIndex].Input-1; - if (SourceIndex = -1) then - begin - // nothing to do if default source is used - SourceRestore := -1; - end - else - begin - // store current source-index and select new source - SourceRestore := Px_GetCurrentInputSource(Mixer); // -1 in error case - Px_SetCurrentInputSource(Mixer, SourceIndex); - end; - end; - {$ENDIF} - - Result := true; -end; - -function TPortaudioInputDevice.Start(): boolean; -var - Error: TPaError; -begin - Result := false; - - // recording already started -> stop first - if (RecordStream <> nil) then - Stop(); - - // TODO: Do not open the device here (takes too much time). - if (not Open()) then - Exit; - - // start capture - Error := Pa_StartStream(RecordStream); - if(Error <> paNoError) then - begin - Log.LogError('Error starting stream: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Start'); - Close(); - RecordStream := nil; - Exit; - end; - - Result := true; -end; - -function TPortaudioInputDevice.Stop(): boolean; -var - Error: TPaError; -begin - Result := false; - - if (RecordStream = nil) then - Exit; - - // Note: do NOT call Pa_StopStream here! - // It gets stuck on devices with non-working callback as Pa_StopStream - // waits until all buffers have been handled (which never occurs in that case). - Error := Pa_AbortStream(RecordStream); - if (Error <> paNoError) then - begin - Log.LogError('Pa_AbortStream: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Stop'); - end; - - Result := Close(); -end; - -function TPortaudioInputDevice.Close(): boolean; -var - Error: TPaError; -begin - {$IFDEF UsePortmixer} - if (Mixer <> nil) then - begin - // restore source selection - if (SourceRestore >= 0) then - begin - Px_SetCurrentInputSource(Mixer, SourceRestore); - end; - - // close mixer - Px_CloseMixer(Mixer); - Mixer := nil; - end; - {$ENDIF} - - Error := Pa_CloseStream(RecordStream); - if (Error <> paNoError) then - begin - Log.LogError('Pa_CloseStream: ' + Pa_GetErrorText(Error), 'TPortaudioInputDevice.Close'); - Result := false; - end - else - begin - Result := true; - end; - - RecordStream := nil; -end; - -function TPortaudioInputDevice.GetVolume(): single; -begin - Result := 0; - {$IFDEF UsePortmixer} - if (Mixer <> nil) then - Result := Px_GetInputVolume(Mixer); - {$ENDIF} -end; - -procedure TPortaudioInputDevice.SetVolume(Volume: single); -begin - {$IFDEF UsePortmixer} - if (Mixer <> nil) then - begin - // clip to valid range - if (Volume > 1.0) then - Volume := 1.0 - else if (Volume < 0) then - Volume := 0; - Px_SetInputVolume(Mixer, Volume); - end; - {$ENDIF} -end; - - -{ TAudioInput_Portaudio } - -function TAudioInput_Portaudio.GetName: String; -begin - result := 'Portaudio'; -end; - -function TAudioInput_Portaudio.EnumDevices(): boolean; -var - i: integer; - paApiIndex: TPaHostApiIndex; - paApiInfo: PPaHostApiInfo; - deviceName: string; - deviceIndex: TPaDeviceIndex; - deviceInfo: PPaDeviceInfo; - channelCnt: integer; - SC: integer; // soundcard - err: TPaError; - errMsg: string; - paDevice: TPortaudioInputDevice; - inputParams: TPaStreamParameters; - stream: PPaStream; - streamInfo: PPaStreamInfo; - sampleRate: double; - latency: TPaTime; - {$IFDEF UsePortmixer} - mixer: PPxMixer; - sourceCnt: integer; - sourceIndex: integer; - sourceName: string; - {$ENDIF} -begin - Result := false; - - // choose the best available Audio-API - paApiIndex := AudioCore.GetPreferredApiIndex(); - if(paApiIndex = -1) then - begin - Log.LogError('No working Audio-API found', 'TAudioInput_Portaudio.EnumDevices'); - Exit; - end; - - paApiInfo := Pa_GetHostApiInfo(paApiIndex); - - SC := 0; - - // init array-size to max. input-devices count - SetLength(AudioInputProcessor.DeviceList, paApiInfo^.deviceCount); - for i:= 0 to High(AudioInputProcessor.DeviceList) do - begin - // convert API-specific device-index to global index - deviceIndex := Pa_HostApiDeviceIndexToDeviceIndex(paApiIndex, i); - deviceInfo := Pa_GetDeviceInfo(deviceIndex); - - channelCnt := deviceInfo^.maxInputChannels; - - // current device is no input device -> skip - if (channelCnt <= 0) then - continue; - - // portaudio returns a channel-count of 128 for some devices - // (e.g. the "default"-device), so we have to detect those - // fantasy channel counts. - if (channelCnt > 8) then - channelCnt := 2; - - paDevice := TPortaudioInputDevice.Create(); - AudioInputProcessor.DeviceList[SC] := paDevice; - - // retrieve device-name - deviceName := deviceInfo^.name; - paDevice.Name := deviceName; - paDevice.PaDeviceIndex := deviceIndex; - - sampleRate := deviceInfo^.defaultSampleRate; - - // on vista and xp the defaultLowInputLatency may be set to 0 but it works. - // TODO: correct too low latencies (what is a too low latency, maybe < 10ms?) - latency := deviceInfo^.defaultLowInputLatency; - - // setup desired input parameters - // TODO: retry with input-latency set to 20ms (defaultLowInputLatency might - // not be set correctly in OSS) - with inputParams do - begin - device := deviceIndex; - channelCount := channelCnt; - sampleFormat := paInt16; - suggestedLatency := latency; - hostApiSpecificStreamInfo := nil; - end; - - // check souncard and adjust sample-rate - if (not AudioCore.TestDevice(@inputParams, nil, sampleRate)) then - begin - // ignore device if it does not work - Log.LogError('Device "'+paDevice.Name+'" does not work', - 'TAudioInput_Portaudio.EnumDevices'); - paDevice.Free(); - continue; - end; - - // open device for further info - err := Pa_OpenStream(stream, @inputParams, nil, sampleRate, - paFramesPerBufferUnspecified, paNoFlag, @MicrophoneTestCallback, nil); - if(err <> paNoError) then - begin - // unable to open device -> skip - errMsg := Pa_GetErrorText(err); - Log.LogError('Device error: "'+ deviceName +'" ('+ errMsg +')', - 'TAudioInput_Portaudio.EnumDevices'); - paDevice.Free(); - continue; - end; - - // adjust sample-rate (might be changed by portaudio) - streamInfo := Pa_GetStreamInfo(stream); - if (streamInfo <> nil) then - begin - if (sampleRate <> streamInfo^.sampleRate) then - begin - Log.LogStatus('Portaudio changed Samplerate from ' + FloatToStr(sampleRate) + - ' to ' + FloatToStr(streamInfo^.sampleRate), - 'TAudioInput_Portaudio.InitializeRecord'); - sampleRate := streamInfo^.sampleRate; - end; - end; - - // create audio-format info and resize capture-buffer array - paDevice.AudioFormat := TAudioFormatInfo.Create( - channelCnt, - sampleRate, - asfS16 - ); - SetLength(paDevice.CaptureChannel, paDevice.AudioFormat.Channels); - - Log.LogStatus('InputDevice "'+paDevice.Name+'"@' + - IntToStr(paDevice.AudioFormat.Channels)+'x'+ - FloatToStr(paDevice.AudioFormat.SampleRate)+'Hz ('+ - FloatTostr(inputParams.suggestedLatency)+'sec)' , - 'Portaudio.EnumDevices'); - - // portaudio does not provide a source-type check - paDevice.MicSource := -1; - paDevice.SourceRestore := -1; - - // add a virtual default source (will not change mixer-settings) - SetLength(paDevice.Source, 1); - paDevice.Source[0].Name := DEFAULT_SOURCE_NAME; - - {$IFDEF UsePortmixer} - // use default mixer - mixer := Px_OpenMixer(stream, 0); - - // get input count - sourceCnt := Px_GetNumInputSources(mixer); - SetLength(paDevice.Source, sourceCnt+1); - - // get input names - for sourceIndex := 1 to sourceCnt do - begin - sourceName := Px_GetInputSourceName(mixer, sourceIndex-1); - paDevice.Source[sourceIndex].Name := sourceName; - end; - - Px_CloseMixer(mixer); - {$ENDIF} - - // close test-stream - Pa_CloseStream(stream); - - Inc(SC); - end; - - // adjust size to actual input-device count - SetLength(AudioInputProcessor.DeviceList, SC); - - Log.LogStatus('#Input-Devices: ' + inttostr(SC), 'Portaudio'); - - Result := true; -end; - -function TAudioInput_Portaudio.InitializeRecord(): boolean; -var - err: TPaError; -begin - AudioCore := TAudioCore_Portaudio.GetInstance(); - - // initialize portaudio - err := Pa_Initialize(); - if(err <> paNoError) then - begin - Log.LogError(Pa_GetErrorText(err), 'TAudioInput_Portaudio.InitializeRecord'); - Result := false; - Exit; - end; - - Result := EnumDevices(); -end; - -function TAudioInput_Portaudio.FinalizeRecord: boolean; -begin - CaptureStop; - Pa_Terminate(); - Result := inherited FinalizeRecord(); -end; - -{* - * Portaudio input capture callback. - *} -function MicrophoneCallback(input: Pointer; output: Pointer; frameCount: Longword; - timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; -begin - AudioInputProcessor.HandleMicrophoneData(input, frameCount*4, inputDevice); - result := paContinue; -end; - -{* - * Portaudio test capture callback. - *} -function MicrophoneTestCallback(input: Pointer; output: Pointer; frameCount: Longword; - timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - inputDevice: Pointer): Integer; cdecl; -begin - // this callback is called only once - result := paAbort; -end; - - -initialization - MediaManager.add(TAudioInput_Portaudio.Create); - -end. diff --git a/src/media/UAudioPlaybackBase.pas b/src/media/UAudioPlaybackBase.pas deleted file mode 100644 index 228a438f..00000000 --- a/src/media/UAudioPlaybackBase.pas +++ /dev/null @@ -1,318 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioPlaybackBase; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMusic, - UPath; - -type - TAudioPlaybackBase = class(TInterfacedObject, IAudioPlayback) - protected - OutputDeviceList: TAudioOutputDeviceList; - MusicStream: TAudioPlaybackStream; - function CreatePlaybackStream(): TAudioPlaybackStream; virtual; abstract; - procedure ClearOutputDeviceList(); - function GetLatency(): double; virtual; abstract; - - // open sound or music stream (used by Open() and OpenSound()) - function OpenStream(const Filename: IPath): TAudioPlaybackStream; - function OpenDecodeStream(const Filename: IPath): TAudioDecodeStream; - public - function GetName: string; virtual; abstract; - - function Open(const Filename: IPath): boolean; // true if succeed - procedure Close; - - procedure Play; - procedure Pause; - procedure Stop; - procedure FadeIn(Time: real; TargetVolume: single); - - procedure SetSyncSource(SyncSource: ISyncSource); - - procedure SetPosition(Time: real); - function GetPosition: real; - - function InitializePlayback: boolean; virtual; abstract; - function FinalizePlayback: boolean; virtual; - - //function SetOutputDevice(Device: TAudioOutputDevice): boolean; - function GetOutputDeviceList(): TAudioOutputDeviceList; - - procedure SetAppVolume(Volume: single); virtual; abstract; - procedure SetVolume(Volume: single); - procedure SetLoop(Enabled: boolean); - - procedure Rewind; - function Finished: boolean; - function Length: real; - - // Sounds - function OpenSound(const Filename: IPath): TAudioPlaybackStream; - procedure PlaySound(Stream: TAudioPlaybackStream); - procedure StopSound(Stream: TAudioPlaybackStream); - - // Equalizer - procedure GetFFTData(var Data: TFFTData); - - // Interface for Visualizer - function GetPCMData(var Data: TPCMData): Cardinal; - - function CreateVoiceStream(Channel: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; virtual; abstract; - end; - - -implementation - -uses - ULog, - SysUtils; - -{ TAudioPlaybackBase } - -function TAudioPlaybackBase.FinalizePlayback: boolean; -begin - FreeAndNil(MusicStream); - ClearOutputDeviceList(); - Result := true; -end; - -function TAudioPlaybackBase.Open(const Filename: IPath): boolean; -begin - // free old MusicStream - MusicStream.Free; - - MusicStream := OpenStream(Filename); - if not assigned(MusicStream) then - begin - Result := false; - Exit; - end; - - //MusicStream.AddSoundEffect(TVoiceRemoval.Create()); - - Result := true; -end; - -procedure TAudioPlaybackBase.Close; -begin - FreeAndNil(MusicStream); -end; - -function TAudioPlaybackBase.OpenDecodeStream(const Filename: IPath): TAudioDecodeStream; -var - i: integer; -begin - for i := 0 to AudioDecoders.Count-1 do - begin - Result := IAudioDecoder(AudioDecoders[i]).Open(Filename); - if (assigned(Result)) then - begin - Log.LogInfo('Using decoder ' + IAudioDecoder(AudioDecoders[i]).GetName() + - ' for "' + Filename.ToNative + '"', 'TAudioPlaybackBase.OpenDecodeStream'); - Exit; - end; - end; - Result := nil; -end; - -procedure OnClosePlaybackStream(Stream: TAudioProcessingStream); -var - PlaybackStream: TAudioPlaybackStream; - SourceStream: TAudioSourceStream; -begin - PlaybackStream := TAudioPlaybackStream(Stream); - SourceStream := PlaybackStream.GetSourceStream(); - SourceStream.Free; -end; - -function TAudioPlaybackBase.OpenStream(const Filename: IPath): TAudioPlaybackStream; -var - PlaybackStream: TAudioPlaybackStream; - DecodeStream: TAudioDecodeStream; -begin - Result := nil; - - //Log.LogStatus('Loading Sound: "' + Filename + '"', 'TAudioPlayback_Bass.OpenStream'); - - DecodeStream := OpenDecodeStream(Filename); - if (not assigned(DecodeStream)) then - begin - Log.LogStatus('Could not open "' + Filename.ToNative + '"', 'TAudioPlayback_Bass.OpenStream'); - Exit; - end; - - // create a matching playback-stream for the decoder - PlaybackStream := CreatePlaybackStream(); - if (not PlaybackStream.Open(DecodeStream)) then - begin - FreeAndNil(PlaybackStream); - FreeAndNil(DecodeStream); - Exit; - end; - - PlaybackStream.AddOnCloseHandler(OnClosePlaybackStream); - - Result := PlaybackStream; -end; - -procedure TAudioPlaybackBase.Play; -begin - if assigned(MusicStream) then - MusicStream.Play(); -end; - -procedure TAudioPlaybackBase.Pause; -begin - if assigned(MusicStream) then - MusicStream.Pause(); -end; - -procedure TAudioPlaybackBase.Stop; -begin - if assigned(MusicStream) then - MusicStream.Stop(); -end; - -function TAudioPlaybackBase.Length: real; -begin - if assigned(MusicStream) then - Result := MusicStream.Length - else - Result := 0; -end; - -function TAudioPlaybackBase.GetPosition: real; -begin - if assigned(MusicStream) then - Result := MusicStream.Position - else - Result := 0; -end; - -procedure TAudioPlaybackBase.SetPosition(Time: real); -begin - if assigned(MusicStream) then - MusicStream.Position := Time; -end; - -procedure TAudioPlaybackBase.SetSyncSource(SyncSource: ISyncSource); -begin - if assigned(MusicStream) then - MusicStream.SetSyncSource(SyncSource); -end; - -procedure TAudioPlaybackBase.Rewind; -begin - SetPosition(0); -end; - -function TAudioPlaybackBase.Finished: boolean; -begin - if assigned(MusicStream) then - Result := (MusicStream.Status = ssStopped) - else - Result := true; -end; - -procedure TAudioPlaybackBase.SetVolume(Volume: single); -begin - if assigned(MusicStream) then - MusicStream.Volume := Volume; -end; - -procedure TAudioPlaybackBase.FadeIn(Time: real; TargetVolume: single); -begin - if assigned(MusicStream) then - MusicStream.FadeIn(Time, TargetVolume); -end; - -procedure TAudioPlaybackBase.SetLoop(Enabled: boolean); -begin - if assigned(MusicStream) then - MusicStream.Loop := Enabled; -end; - -// Equalizer -procedure TAudioPlaybackBase.GetFFTData(var data: TFFTData); -begin - if assigned(MusicStream) then - MusicStream.GetFFTData(data); -end; - -{* - * Copies interleaved PCM SInt16 stereo samples into data. - * Returns the number of frames - *} -function TAudioPlaybackBase.GetPCMData(var data: TPCMData): Cardinal; -begin - if assigned(MusicStream) then - Result := MusicStream.GetPCMData(data) - else - Result := 0; -end; - -function TAudioPlaybackBase.OpenSound(const Filename: IPath): TAudioPlaybackStream; -begin - Result := OpenStream(Filename); -end; - -procedure TAudioPlaybackBase.PlaySound(stream: TAudioPlaybackStream); -begin - if assigned(stream) then - stream.Play(); -end; - -procedure TAudioPlaybackBase.StopSound(stream: TAudioPlaybackStream); -begin - if assigned(stream) then - stream.Stop(); -end; - -procedure TAudioPlaybackBase.ClearOutputDeviceList(); -var - DeviceIndex: integer; -begin - for DeviceIndex := 0 to High(OutputDeviceList) do - OutputDeviceList[DeviceIndex].Free(); - SetLength(OutputDeviceList, 0); -end; - -function TAudioPlaybackBase.GetOutputDeviceList(): TAudioOutputDeviceList; -begin - Result := OutputDeviceList; -end; - -end. diff --git a/src/media/UAudioPlayback_Bass.pas b/src/media/UAudioPlayback_Bass.pas deleted file mode 100644 index 1d7a44dc..00000000 --- a/src/media/UAudioPlayback_Bass.pas +++ /dev/null @@ -1,758 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioPlayback_Bass; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -implementation - -uses - Classes, - Math, - UIni, - UMain, - UMusic, - UAudioPlaybackBase, - UAudioCore_Bass, - ULog, - sdl, - bass, - SysUtils; - -type - PHDSP = ^HDSP; - -type - TBassPlaybackStream = class(TAudioPlaybackStream) - private - Handle: HSTREAM; - NeedsRewind: boolean; - PausedSeek: boolean; // true if a seek was performed in pause state - - procedure Reset(); - function IsEOF(): boolean; - protected - function GetLatency(): double; override; - function GetLoop(): boolean; override; - procedure SetLoop(Enabled: boolean); override; - function GetLength(): real; override; - function GetStatus(): TStreamStatus; override; - function GetVolume(): single; override; - procedure SetVolume(Volume: single); override; - function GetPosition: real; override; - procedure SetPosition(Time: real); override; - public - constructor Create(); - destructor Destroy(); override; - - function Open(SourceStream: TAudioSourceStream): boolean; override; - procedure Close(); override; - - procedure Play(); override; - procedure Pause(); override; - procedure Stop(); override; - procedure FadeIn(Time: real; TargetVolume: single); override; - - procedure AddSoundEffect(Effect: TSoundEffect); override; - procedure RemoveSoundEffect(Effect: TSoundEffect); override; - - procedure GetFFTData(var Data: TFFTData); override; - function GetPCMData(var Data: TPCMData): Cardinal; override; - - function GetAudioFormatInfo(): TAudioFormatInfo; override; - - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; - - property EOF: boolean READ IsEOF; - end; - -const - MAX_VOICE_DELAY = 0.020; // 20ms - -type - TBassVoiceStream = class(TAudioVoiceStream) - private - Handle: HSTREAM; - public - function Open(ChannelMap: integer; FormatInfo: TAudioFormatInfo): boolean; override; - procedure Close(); override; - - procedure WriteData(Buffer: PByteArray; BufferSize: integer); override; - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; override; - function IsEOF(): boolean; override; - function IsError(): boolean; override; - end; - -type - TAudioPlayback_Bass = class(TAudioPlaybackBase) - private - function EnumDevices(): boolean; - protected - function GetLatency(): double; override; - function CreatePlaybackStream(): TAudioPlaybackStream; override; - public - function GetName: String; override; - function InitializePlayback(): boolean; override; - function FinalizePlayback: boolean; override; - procedure SetAppVolume(Volume: single); override; - function CreateVoiceStream(ChannelMap: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; override; - end; - - TBassOutputDevice = class(TAudioOutputDevice) - private - BassDeviceID: DWORD; // DeviceID used by BASS - end; - -var - BassCore: TAudioCore_Bass; - - -{ TBassPlaybackStream } - -function PlaybackStreamHandler(handle: HSTREAM; buffer: Pointer; length: DWORD; user: Pointer): DWORD; -{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} -var - PlaybackStream: TBassPlaybackStream; - BytesRead: integer; -begin - PlaybackStream := TBassPlaybackStream(user); - if (not assigned (PlaybackStream)) then - begin - Result := BASS_STREAMPROC_END; - Exit; - end; - - BytesRead := PlaybackStream.ReadData(buffer, length); - // check for errors - if (BytesRead < 0) then - Result := BASS_STREAMPROC_END - // check for EOF - else if (PlaybackStream.EOF) then - Result := BytesRead or BASS_STREAMPROC_END - // no error/EOF - else - Result := BytesRead; -end; - -function TBassPlaybackStream.ReadData(Buffer: PByteArray; BufferSize: integer): integer; -var - AdjustedSize: integer; - RequestedSourceSize, SourceSize: integer; - SkipCount: integer; - SourceFormatInfo: TAudioFormatInfo; - FrameSize: integer; - PadFrame: PByteArray; - //Info: BASS_INFO; - //Latency: double; -begin - Result := -1; - - if (not assigned(SourceStream)) then - Exit; - - // sanity check - if (BufferSize = 0) then - begin - Result := 0; - Exit; - end; - - SourceFormatInfo := SourceStream.GetAudioFormatInfo(); - FrameSize := SourceFormatInfo.FrameSize; - - // check how much data to fetch to be in synch - AdjustedSize := Synchronize(BufferSize, SourceFormatInfo); - - // skip data if we are too far behind - SkipCount := AdjustedSize - BufferSize; - while (SkipCount > 0) do - begin - RequestedSourceSize := Min(SkipCount, BufferSize); - SourceSize := SourceStream.ReadData(Buffer, RequestedSourceSize); - // if an error or EOF occured stop skipping and handle error/EOF with the next ReadData() - if (SourceSize <= 0) then - break; - Dec(SkipCount, SourceSize); - end; - - // get source data (e.g. from a decoder) - RequestedSourceSize := Min(AdjustedSize, BufferSize); - SourceSize := SourceStream.ReadData(Buffer, RequestedSourceSize); - if (SourceSize < 0) then - Exit; - - // set preliminary result - Result := SourceSize; - - // if we are to far ahead, fill output-buffer with last frame of source data - // Note that AdjustedSize is used instead of SourceSize as the SourceSize might - // be less than expected because of errors etc. - if (AdjustedSize < BufferSize) then - begin - // use either the last frame for padding or fill with zero - if (SourceSize >= FrameSize) then - PadFrame := @Buffer[SourceSize-FrameSize] - else - PadFrame := nil; - - FillBufferWithFrame(@Buffer[SourceSize], BufferSize - SourceSize, - PadFrame, FrameSize); - Result := BufferSize; - end; -end; - -constructor TBassPlaybackStream.Create(); -begin - inherited; - Reset(); -end; - -destructor TBassPlaybackStream.Destroy(); -begin - Close(); - inherited; -end; - -function TBassPlaybackStream.Open(SourceStream: TAudioSourceStream): boolean; -var - FormatInfo: TAudioFormatInfo; - FormatFlags: DWORD; -begin - Result := false; - - // close previous stream and reset state - Reset(); - - // sanity check if stream is valid - if not assigned(SourceStream) then - Exit; - - Self.SourceStream := SourceStream; - FormatInfo := SourceStream.GetAudioFormatInfo(); - if (not BassCore.ConvertAudioFormatToBASSFlags(FormatInfo.Format, FormatFlags)) then - begin - Log.LogError('Unhandled sample-format', 'TBassPlaybackStream.Open'); - Exit; - end; - - // create matching playback stream - Handle := BASS_StreamCreate(Round(FormatInfo.SampleRate), FormatInfo.Channels, formatFlags, - @PlaybackStreamHandler, Self); - if (Handle = 0) then - begin - Log.LogError('BASS_StreamCreate failed: ' + BassCore.ErrorGetString(BASS_ErrorGetCode()), - 'TBassPlaybackStream.Open'); - Exit; - end; - - Result := true; -end; - -procedure TBassPlaybackStream.Close(); -begin - // stop and free stream - if (Handle <> 0) then - begin - Bass_StreamFree(Handle); - Handle := 0; - end; - - // Note: PerformOnClose must be called before SourceStream is invalidated - PerformOnClose(); - // unset source-stream - SourceStream := nil; -end; - -procedure TBassPlaybackStream.Reset(); -begin - Close(); - NeedsRewind := false; - PausedSeek := false; -end; - -procedure TBassPlaybackStream.Play(); -var - NeedsFlush: boolean; -begin - if (not assigned(SourceStream)) then - Exit; - - NeedsFlush := true; - - if (BASS_ChannelIsActive(Handle) = BASS_ACTIVE_PAUSED) then - begin - // only paused (and not seeked while paused) streams are not flushed - if (not PausedSeek) then - NeedsFlush := false; - // paused streams do not need a rewind - NeedsRewind := false; - end; - - // rewind if necessary. Cases that require no rewind are: - // - stream was created and never played - // - stream was paused and is resumed now - // - stream was stopped and set to a new position already - if (NeedsRewind) then - SourceStream.Position := 0; - - NeedsRewind := true; - PausedSeek := false; - - // start playing and flush buffers on rewind - BASS_ChannelPlay(Handle, NeedsFlush); -end; - -procedure TBassPlaybackStream.FadeIn(Time: real; TargetVolume: single); -begin - // start stream - Play(); - // start fade-in: slide from fadeStart- to fadeEnd-volume in FadeInTime - BASS_ChannelSlideAttribute(Handle, BASS_ATTRIB_VOL, TargetVolume, Trunc(Time * 1000)); -end; - -procedure TBassPlaybackStream.Pause(); -begin - BASS_ChannelPause(Handle); -end; - -procedure TBassPlaybackStream.Stop(); -begin - BASS_ChannelStop(Handle); -end; - -function TBassPlaybackStream.IsEOF(): boolean; -begin - if (assigned(SourceStream)) then - Result := SourceStream.EOF - else - Result := true; -end; - -function TBassPlaybackStream.GetLatency(): double; -begin - // TODO: should we consider output latency for synching (needs BASS_DEVICE_LATENCY)? - //if (BASS_GetInfo(Info)) then - // Latency := Info.latency / 1000 - //else - // Latency := 0; - Result := 0; -end; - -function TBassPlaybackStream.GetVolume(): single; -var - lVolume: single; -begin - if (not BASS_ChannelGetAttribute(Handle, BASS_ATTRIB_VOL, lVolume)) then - begin - Log.LogError('BASS_ChannelGetAttribute: ' + BassCore.ErrorGetString(), - 'TBassPlaybackStream.GetVolume'); - Result := 0; - Exit; - end; - Result := Round(lVolume); -end; - -procedure TBassPlaybackStream.SetVolume(Volume: single); -begin - // clamp volume - if Volume < 0 then - Volume := 0; - if Volume > 1.0 then - Volume := 1.0; - // set volume - BASS_ChannelSetAttribute(Handle, BASS_ATTRIB_VOL, Volume); -end; - -function TBassPlaybackStream.GetPosition: real; -var - BufferPosByte: QWORD; - BufferPosSec: double; -begin - if assigned(SourceStream) then - begin - BufferPosByte := BASS_ChannelGetData(Handle, nil, BASS_DATA_AVAILABLE); - BufferPosSec := BASS_ChannelBytes2Seconds(Handle, BufferPosByte); - // decrease the decoding position by the amount buffered (and hence not played) - // in the BASS playback stream. - Result := SourceStream.Position - BufferPosSec; - end - else - begin - Result := -1; - end; -end; - -procedure TBassPlaybackStream.SetPosition(Time: real); -var - ChannelState: DWORD; -begin - if assigned(SourceStream) then - begin - ChannelState := BASS_ChannelIsActive(Handle); - if (ChannelState = BASS_ACTIVE_STOPPED) then - begin - // if the stream is stopped, do not rewind when the stream is played next time - NeedsRewind := false - end - else if (ChannelState = BASS_ACTIVE_PAUSED) then - begin - // buffers must be flushed if in paused state but there is no - // BASS_ChannelFlush() function so we have to use BASS_ChannelPlay() called in Play(). - PausedSeek := true; - end; - - // set new position - SourceStream.Position := Time; - end; -end; - -function TBassPlaybackStream.GetLength(): real; -begin - if assigned(SourceStream) then - Result := SourceStream.Length - else - Result := -1; -end; - -function TBassPlaybackStream.GetStatus(): TStreamStatus; -var - State: DWORD; -begin - State := BASS_ChannelIsActive(Handle); - case State of - BASS_ACTIVE_PLAYING, - BASS_ACTIVE_STALLED: - Result := ssPlaying; - BASS_ACTIVE_PAUSED: - Result := ssPaused; - BASS_ACTIVE_STOPPED: - Result := ssStopped; - else - begin - Log.LogError('Unknown status', 'TBassPlaybackStream.GetStatus'); - Result := ssStopped; - end; - end; -end; - -function TBassPlaybackStream.GetLoop(): boolean; -begin - if assigned(SourceStream) then - Result := SourceStream.Loop - else - Result := false; -end; - -procedure TBassPlaybackStream.SetLoop(Enabled: boolean); -begin - if assigned(SourceStream) then - SourceStream.Loop := Enabled; -end; - -procedure DSPProcHandler(handle: HDSP; channel: DWORD; buffer: Pointer; length: DWORD; user: Pointer); -{$IFDEF MSWINDOWS}stdcall;{$ELSE}cdecl;{$ENDIF} -var - Effect: TSoundEffect; -begin - Effect := TSoundEffect(user); - if assigned(Effect) then - Effect.Callback(buffer, length); -end; - -procedure TBassPlaybackStream.AddSoundEffect(Effect: TSoundEffect); -var - DspHandle: HDSP; -begin - if assigned(Effect.engineData) then - begin - Log.LogError('TSoundEffect.engineData already set', 'TBassPlaybackStream.AddSoundEffect'); - Exit; - end; - - DspHandle := BASS_ChannelSetDSP(Handle, @DSPProcHandler, Effect, 0); - if (DspHandle = 0) then - begin - Log.LogError(BassCore.ErrorGetString(), 'TBassPlaybackStream.AddSoundEffect'); - Exit; - end; - - GetMem(Effect.EngineData, SizeOf(HDSP)); - PHDSP(Effect.EngineData)^ := DspHandle; -end; - -procedure TBassPlaybackStream.RemoveSoundEffect(Effect: TSoundEffect); -begin - if not assigned(Effect.EngineData) then - begin - Log.LogError('TSoundEffect.engineData invalid', 'TBassPlaybackStream.RemoveSoundEffect'); - Exit; - end; - - if not BASS_ChannelRemoveDSP(Handle, PHDSP(Effect.EngineData)^) then - begin - Log.LogError(BassCore.ErrorGetString(), 'TBassPlaybackStream.RemoveSoundEffect'); - Exit; - end; - - FreeMem(Effect.EngineData); - Effect.EngineData := nil; -end; - -procedure TBassPlaybackStream.GetFFTData(var Data: TFFTData); -begin - // get FFT channel data (Mono, FFT512 -> 256 values) - BASS_ChannelGetData(Handle, @Data, BASS_DATA_FFT512); -end; - -{* - * Copies interleaved PCM SInt16 stereo samples into data. - * Returns the number of frames - *} -function TBassPlaybackStream.GetPCMData(var Data: TPCMData): Cardinal; -var - Info: BASS_CHANNELINFO; - nBytes: DWORD; -begin - Result := 0; - - FillChar(Data, SizeOf(TPCMData), 0); - - // no support for non-stereo files at the moment - BASS_ChannelGetInfo(Handle, Info); - if (Info.chans <> 2) then - Exit; - - nBytes := BASS_ChannelGetData(Handle, @Data, SizeOf(TPCMData)); - if(nBytes <= 0) then - Result := 0 - else - Result := nBytes div SizeOf(TPCMStereoSample); -end; - -function TBassPlaybackStream.GetAudioFormatInfo(): TAudioFormatInfo; -begin - if assigned(SourceStream) then - Result := SourceStream.GetAudioFormatInfo() - else - Result := nil; -end; - - -{ TBassVoiceStream } - -function TBassVoiceStream.Open(ChannelMap: integer; FormatInfo: TAudioFormatInfo): boolean; -var - Flags: DWORD; -begin - Result := false; - - Close(); - - if (not inherited Open(ChannelMap, FormatInfo)) then - Exit; - - // get channel flags - BassCore.ConvertAudioFormatToBASSFlags(FormatInfo.Format, Flags); - - (* - // distribute the mics equally to both speakers - if ((ChannelMap and CHANNELMAP_LEFT) <> 0) then - Flags := Flags or BASS_SPEAKER_FRONTLEFT; - if ((ChannelMap and CHANNELMAP_RIGHT) <> 0) then - Flags := Flags or BASS_SPEAKER_FRONTRIGHT; - *) - - // create the channel - Handle := BASS_StreamCreate(Round(FormatInfo.SampleRate), 1, Flags, STREAMPROC_PUSH, nil); - - // start the channel - BASS_ChannelPlay(Handle, true); - - Result := true; -end; - -procedure TBassVoiceStream.Close(); -begin - if (Handle <> 0) then - begin - BASS_ChannelStop(Handle); - BASS_StreamFree(Handle); - end; - inherited Close(); -end; - -procedure TBassVoiceStream.WriteData(Buffer: PByteArray; BufferSize: integer); -var QueueSize: DWORD; -begin - if ((Handle <> 0) and (BufferSize > 0)) then - begin - // query the queue size (normally 0) - QueueSize := BASS_StreamPutData(Handle, nil, 0); - // flush the buffer if the delay would be too high - if (QueueSize > MAX_VOICE_DELAY * FormatInfo.BytesPerSec) then - BASS_ChannelPlay(Handle, true); - // send new data to playback buffer - BASS_StreamPutData(Handle, Buffer, BufferSize); - end; -end; - -// Note: we do not need the read-function for the BASS implementation -function TBassVoiceStream.ReadData(Buffer: PByteArray; BufferSize: integer): integer; -begin - Result := -1; -end; - -function TBassVoiceStream.IsEOF(): boolean; -begin - Result := false; -end; - -function TBassVoiceStream.IsError(): boolean; -begin - Result := false; -end; - - -{ TAudioPlayback_Bass } - -function TAudioPlayback_Bass.GetName: String; -begin - Result := 'BASS_Playback'; -end; - -function TAudioPlayback_Bass.EnumDevices(): boolean; -var - BassDeviceID: DWORD; - DeviceIndex: integer; - Device: TBassOutputDevice; - DeviceInfo: BASS_DEVICEINFO; -begin - Result := true; - - ClearOutputDeviceList(); - - // skip "no sound"-device (ID = 0) - BassDeviceID := 1; - - while (true) do - begin - // check for device - if (not BASS_GetDeviceInfo(BassDeviceID, DeviceInfo)) then - Break; - - // set device info - Device := TBassOutputDevice.Create(); - Device.Name := DeviceInfo.name; - Device.BassDeviceID := BassDeviceID; - - // add device to list - SetLength(OutputDeviceList, BassDeviceID); - OutputDeviceList[BassDeviceID-1] := Device; - - Inc(BassDeviceID); - end; -end; - -function TAudioPlayback_Bass.InitializePlayback(): boolean; -begin - Result := false; - - BassCore := TAudioCore_Bass.GetInstance(); - if not BassCore.CheckVersion then - Exit; - - EnumDevices(); - - //Log.BenchmarkStart(4); - //Log.LogStatus('Initializing Playback Subsystem', 'Music Initialize'); - - // TODO: use BASS_DEVICE_LATENCY to determine the latency - if not BASS_Init(-1, 44100, 0, 0, nil) then - begin - Log.LogError('Could not initialize BASS', 'TAudioPlayback_Bass.InitializePlayback'); - Exit; - end; - - //Log.BenchmarkEnd(4); Log.LogBenchmark('--> Bass Init', 4); - - // config playing buffer - //BASS_SetConfig(BASS_CONFIG_UPDATEPERIOD, 10); - //BASS_SetConfig(BASS_CONFIG_BUFFER, 100); - - Result := true; -end; - -function TAudioPlayback_Bass.FinalizePlayback(): boolean; -begin - Close; - BASS_Free; - inherited FinalizePlayback(); - Result := true; -end; - -function TAudioPlayback_Bass.CreatePlaybackStream(): TAudioPlaybackStream; -begin - Result := TBassPlaybackStream.Create(); -end; - -procedure TAudioPlayback_Bass.SetAppVolume(Volume: single); -begin - // set volume for this application (ranges from 0..10000 since BASS 2.4) - BASS_SetConfig(BASS_CONFIG_GVOL_STREAM, Round(Volume*10000)); -end; - -function TAudioPlayback_Bass.CreateVoiceStream(ChannelMap: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; -var - VoiceStream: TAudioVoiceStream; -begin - Result := nil; - - VoiceStream := TBassVoiceStream.Create(); - if (not VoiceStream.Open(ChannelMap, FormatInfo)) then - begin - VoiceStream.Free; - Exit; - end; - - Result := VoiceStream; -end; - -function TAudioPlayback_Bass.GetLatency(): double; -begin - Result := 0; -end; - - -initialization - MediaManager.Add(TAudioPlayback_Bass.Create); - -end. diff --git a/src/media/UAudioPlayback_Portaudio.pas b/src/media/UAudioPlayback_Portaudio.pas deleted file mode 100644 index ddbd03d6..00000000 --- a/src/media/UAudioPlayback_Portaudio.pas +++ /dev/null @@ -1,385 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioPlayback_Portaudio; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - SysUtils, - UMusic; - -implementation - -uses - portaudio, - UAudioCore_Portaudio, - UAudioPlayback_SoftMixer, - ULog, - UIni, - UMain; - -type - TAudioPlayback_Portaudio = class(TAudioPlayback_SoftMixer) - private - paStream: PPaStream; - AudioCore: TAudioCore_Portaudio; - Latency: double; - function OpenDevice(deviceIndex: TPaDeviceIndex): boolean; - function EnumDevices(): boolean; - protected - function InitializeAudioPlaybackEngine(): boolean; override; - function StartAudioPlaybackEngine(): boolean; override; - procedure StopAudioPlaybackEngine(); override; - function FinalizeAudioPlaybackEngine(): boolean; override; - function GetLatency(): double; override; - public - function GetName: String; override; - end; - - TPortaudioOutputDevice = class(TAudioOutputDevice) - private - PaDeviceIndex: TPaDeviceIndex; - end; - - -{ TAudioPlayback_Portaudio } - -function PortaudioAudioCallback(input: Pointer; output: Pointer; frameCount: Longword; - timeInfo: PPaStreamCallbackTimeInfo; statusFlags: TPaStreamCallbackFlags; - userData: Pointer): Integer; cdecl; -var - Engine: TAudioPlayback_Portaudio; -begin - Engine := TAudioPlayback_Portaudio(userData); - // update latency - Engine.Latency := timeInfo.outputBufferDacTime - timeInfo.currentTime; - // call superclass callback - Engine.AudioCallback(output, frameCount * Engine.FormatInfo.FrameSize); - Result := paContinue; -end; - -function TAudioPlayback_Portaudio.GetName: String; -begin - Result := 'Portaudio_Playback'; -end; - -function TAudioPlayback_Portaudio.OpenDevice(deviceIndex: TPaDeviceIndex): boolean; -var - DeviceInfo : PPaDeviceInfo; - SampleRate : double; - OutParams : TPaStreamParameters; - StreamInfo : PPaStreamInfo; - err : TPaError; -begin - Result := false; - - DeviceInfo := Pa_GetDeviceInfo(deviceIndex); - - Log.LogInfo('Audio-Output Device: ' + DeviceInfo^.name, 'TAudioPlayback_Portaudio.OpenDevice'); - - SampleRate := DeviceInfo^.defaultSampleRate; - - with OutParams do - begin - device := deviceIndex; - channelCount := 2; - sampleFormat := paInt16; - suggestedLatency := DeviceInfo^.defaultLowOutputLatency; - hostApiSpecificStreamInfo := nil; - end; - - // check souncard and adjust sample-rate - if not AudioCore.TestDevice(nil, @OutParams, SampleRate) then - begin - Log.LogStatus('TestDevice failed!', 'TAudioPlayback_Portaudio.OpenDevice'); - Exit; - end; - - // open output stream - err := Pa_OpenStream(paStream, nil, @OutParams, SampleRate, - paFramesPerBufferUnspecified, - paNoFlag, @PortaudioAudioCallback, Self); - if(err <> paNoError) then - begin - Log.LogStatus(Pa_GetErrorText(err), 'TAudioPlayback_Portaudio.OpenDevice'); - paStream := nil; - Exit; - end; - - // get estimated latency (will be updated with real latency in the callback) - StreamInfo := Pa_GetStreamInfo(paStream); - if (StreamInfo <> nil) then - Latency := StreamInfo^.outputLatency - else - Latency := 0; - - FormatInfo := TAudioFormatInfo.Create( - OutParams.channelCount, - SampleRate, - asfS16 // FIXME: is paInt16 system-dependant or -independant? - ); - - Result := true; -end; - -function TAudioPlayback_Portaudio.EnumDevices(): boolean; -var - i: integer; - paApiIndex: TPaHostApiIndex; - paApiInfo: PPaHostApiInfo; - deviceName: string; - deviceIndex: TPaDeviceIndex; - deviceInfo: PPaDeviceInfo; - channelCnt: integer; - SC: integer; // soundcard - err: TPaError; - errMsg: string; - paDevice: TPortaudioOutputDevice; - outputParams: TPaStreamParameters; - stream: PPaStream; - streamInfo: PPaStreamInfo; - sampleRate: double; - latency: TPaTime; - cbPolls: integer; - cbWorks: boolean; -begin - Result := false; - -(* - // choose the best available Audio-API - paApiIndex := AudioCore.GetPreferredApiIndex(); - if(paApiIndex = -1) then - begin - Log.LogError('No working Audio-API found', 'TAudioPlayback_Portaudio.EnumDevices'); - Exit; - end; - - paApiInfo := Pa_GetHostApiInfo(paApiIndex); - - SC := 0; - - // init array-size to max. output-devices count - SetLength(OutputDeviceList, paApiInfo^.deviceCount); - for i:= 0 to High(OutputDeviceList) do - begin - // convert API-specific device-index to global index - deviceIndex := Pa_HostApiDeviceIndexToDeviceIndex(paApiIndex, i); - deviceInfo := Pa_GetDeviceInfo(deviceIndex); - - channelCnt := deviceInfo^.maxOutputChannels; - - // current device is no output device -> skip - if (channelCnt <= 0) then - continue; - - // portaudio returns a channel-count of 128 for some devices - // (e.g. the "default"-device), so we have to detect those - // fantasy channel counts. - if (channelCnt > 8) then - channelCnt := 2; - - paDevice := TPortaudioOutputDevice.Create(); - OutputDeviceList[SC] := paDevice; - - // retrieve device-name - deviceName := deviceInfo^.name; - paDevice.Name := deviceName; - paDevice.PaDeviceIndex := deviceIndex; - - if (deviceInfo^.defaultSampleRate > 0) then - sampleRate := deviceInfo^.defaultSampleRate - else - sampleRate := 44100; - - // on vista and xp the defaultLowInputLatency may be set to 0 but it works. - // TODO: correct too low latencies (what is a too low latency, maybe < 10ms?) - latency := deviceInfo^.defaultLowInputLatency; - - // setup desired output parameters - // TODO: retry with input-latency set to 20ms (defaultLowOutputLatency might - // not be set correctly in OSS) - with outputParams do - begin - device := deviceIndex; - channelCount := channelCnt; - sampleFormat := paInt16; - suggestedLatency := latency; - hostApiSpecificStreamInfo := nil; - end; - - // check if mic-callback works (might not be called on some devices) - if (not TAudioCore_Portaudio.TestDevice(nil, @outputParams, sampleRate)) then - begin - // ignore device if callback did not work - Log.LogError('Device "'+paDevice.Name+'" does not respond', - 'TAudioPlayback_Portaudio.InitializeRecord'); - paDevice.Free(); - continue; - end; - - // open device for further info - err := Pa_OpenStream(stream, nil, @outputParams, sampleRate, - paFramesPerBufferUnspecified, paNoFlag, @MicrophoneTestCallback, nil); - if(err <> paNoError) then - begin - // unable to open device -> skip - errMsg := Pa_GetErrorText(err); - Log.LogError('Device error: "'+ deviceName +'" ('+ errMsg +')', - 'TAudioPlayback_Portaudio.InitializeRecord'); - paDevice.Free(); - continue; - end; - - // adjust sample-rate (might be changed by portaudio) - streamInfo := Pa_GetStreamInfo(stream); - if (streamInfo <> nil) then - begin - if (sampleRate <> streamInfo^.sampleRate) then - begin - Log.LogStatus('Portaudio changed Samplerate from ' + FloatToStr(sampleRate) + - ' to ' + FloatToStr(streamInfo^.sampleRate), - 'TAudioInput_Portaudio.InitializeRecord'); - sampleRate := streamInfo^.sampleRate; - end; - end; - - // create audio-format info and resize capture-buffer array - paDevice.AudioFormat := TAudioFormatInfo.Create( - channelCnt, - sampleRate, - asfS16 - ); - SetLength(paDevice.CaptureChannel, paDevice.AudioFormat.Channels); - - Log.LogStatus('OutputDevice "'+paDevice.Name+'"@' + - IntToStr(paDevice.AudioFormat.Channels)+'x'+ - FloatToStr(paDevice.AudioFormat.SampleRate)+'Hz ('+ - FloatTostr(outputParams.suggestedLatency)+'sec)' , - 'TAudioInput_Portaudio.InitializeRecord'); - - // close test-stream - Pa_CloseStream(stream); - - Inc(SC); - end; - - // adjust size to actual input-device count - SetLength(OutputDeviceList, SC); - - Log.LogStatus('#Output-Devices: ' + inttostr(SC), 'Portaudio'); -*) - - Result := true; -end; - -function TAudioPlayback_Portaudio.InitializeAudioPlaybackEngine(): boolean; -var - paApiIndex : TPaHostApiIndex; - paApiInfo : PPaHostApiInfo; - paOutDevice : TPaDeviceIndex; - err: TPaError; -begin - Result := false; - - AudioCore := TAudioCore_Portaudio.GetInstance(); - - // initialize portaudio - err := Pa_Initialize(); - if(err <> paNoError) then - begin - Log.LogError(Pa_GetErrorText(err), 'TAudioInput_Portaudio.InitializeRecord'); - Exit; - end; - - paApiIndex := AudioCore.GetPreferredApiIndex(); - if(paApiIndex = -1) then - begin - Log.LogError('No working Audio-API found', 'TAudioPlayback_Portaudio.InitializeAudioPlaybackEngine'); - Exit; - end; - - EnumDevices(); - - paApiInfo := Pa_GetHostApiInfo(paApiIndex); - Log.LogInfo('Audio-Output API-Type: ' + paApiInfo^.name, 'TAudioPlayback_Portaudio.OpenDevice'); - - paOutDevice := paApiInfo^.defaultOutputDevice; - if (not OpenDevice(paOutDevice)) then - begin - Exit; - end; - - Result := true; -end; - -function TAudioPlayback_Portaudio.StartAudioPlaybackEngine(): boolean; -var - err: TPaError; -begin - Result := false; - - if (paStream = nil) then - Exit; - - err := Pa_StartStream(paStream); - if(err <> paNoError) then - begin - Log.LogStatus('Pa_StartStream: '+Pa_GetErrorText(err), 'UAudioPlayback_Portaudio'); - Exit; - end; - - Result := true; -end; - -procedure TAudioPlayback_Portaudio.StopAudioPlaybackEngine(); -begin - if (paStream <> nil) then - Pa_StopStream(paStream); -end; - -function TAudioPlayback_Portaudio.FinalizeAudioPlaybackEngine(): boolean; -begin - Pa_Terminate(); - Result := true; -end; - -function TAudioPlayback_Portaudio.GetLatency(): double; -begin - Result := Latency; -end; - - -initialization - MediaManager.Add(TAudioPlayback_Portaudio.Create); - -end. diff --git a/src/media/UAudioPlayback_SDL.pas b/src/media/UAudioPlayback_SDL.pas deleted file mode 100644 index 8403ef03..00000000 --- a/src/media/UAudioPlayback_SDL.pas +++ /dev/null @@ -1,182 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioPlayback_SDL; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -implementation - -uses - Classes, - sdl, - SysUtils, - UAudioPlayback_SoftMixer, - UMusic, - ULog, - UIni, - UMain; - -type - TAudioPlayback_SDL = class(TAudioPlayback_SoftMixer) - private - Latency: double; - function EnumDevices(): boolean; - protected - function InitializeAudioPlaybackEngine(): boolean; override; - function StartAudioPlaybackEngine(): boolean; override; - procedure StopAudioPlaybackEngine(); override; - function FinalizeAudioPlaybackEngine(): boolean; override; - function GetLatency(): double; override; - public - function GetName: String; override; - procedure MixBuffers(dst, src: PByteArray; size: Cardinal; volume: Single); override; - end; - - -{ TAudioPlayback_SDL } - -procedure SDLAudioCallback(userdata: Pointer; stream: PByteArray; len: integer); cdecl; -var - Engine: TAudioPlayback_SDL; -begin - Engine := TAudioPlayback_SDL(userdata); - Engine.AudioCallback(stream, len); -end; - -function TAudioPlayback_SDL.GetName: String; -begin - Result := 'SDL_Playback'; -end; - -function TAudioPlayback_SDL.EnumDevices(): boolean; -begin - // Note: SDL does not provide Device-Selection capabilities (will be introduced in 1.3) - ClearOutputDeviceList(); - SetLength(OutputDeviceList, 1); - OutputDeviceList[0] := TAudioOutputDevice.Create(); - OutputDeviceList[0].Name := '[SDL Default-Device]'; - Result := true; -end; - -function TAudioPlayback_SDL.InitializeAudioPlaybackEngine(): boolean; -var - DesiredAudioSpec, ObtainedAudioSpec: TSDL_AudioSpec; - SampleBufferSize: integer; -begin - Result := false; - - EnumDevices(); - - if (SDL_InitSubSystem(SDL_INIT_AUDIO) = -1) then - begin - Log.LogError('SDL_InitSubSystem failed!', 'TAudioPlayback_SDL.InitializeAudioPlaybackEngine'); - Exit; - end; - - SampleBufferSize := IAudioOutputBufferSizeVals[Ini.AudioOutputBufferSizeIndex]; - if (SampleBufferSize <= 0) then - begin - // Automatic setting default - // FIXME: too much glitches with 1024 samples - SampleBufferSize := 2048; //1024; - end; - - FillChar(DesiredAudioSpec, SizeOf(DesiredAudioSpec), 0); - with DesiredAudioSpec do - begin - freq := 44100; - format := AUDIO_S16SYS; - channels := 2; - samples := SampleBufferSize; - callback := @SDLAudioCallback; - userdata := Self; - end; - - // Note: always use the "obtained" parameter, otherwise SDL might try to convert - // the samples itself if the desired format is not available. This might lead - // to problems if for example ALSA does not support 44100Hz and proposes 48000Hz. - // Without the obtained parameter, SDL would try to convert 44.1kHz to 48kHz with - // its crappy (non working) converter resulting in a wrong (too high) pitch. - if(SDL_OpenAudio(@DesiredAudioSpec, @ObtainedAudioSpec) = -1) then - begin - Log.LogStatus('SDL_OpenAudio: ' + SDL_GetError(), 'TAudioPlayback_SDL.InitializeAudioPlaybackEngine'); - Exit; - end; - - FormatInfo := TAudioFormatInfo.Create( - ObtainedAudioSpec.channels, - ObtainedAudioSpec.freq, - asfS16 - ); - - // Note: SDL does not provide info of the internal buffer state. - // So we use the average buffer-size. - Latency := (ObtainedAudioSpec.samples/2) / FormatInfo.SampleRate; - - Log.LogStatus('Opened audio device', 'TAudioPlayback_SDL.InitializeAudioPlaybackEngine'); - - Result := true; -end; - -function TAudioPlayback_SDL.StartAudioPlaybackEngine(): boolean; -begin - SDL_PauseAudio(0); - Result := true; -end; - -procedure TAudioPlayback_SDL.StopAudioPlaybackEngine(); -begin - SDL_PauseAudio(1); -end; - -function TAudioPlayback_SDL.FinalizeAudioPlaybackEngine(): boolean; -begin - SDL_CloseAudio(); - SDL_QuitSubSystem(SDL_INIT_AUDIO); - Result := true; -end; - -function TAudioPlayback_SDL.GetLatency(): double; -begin - Result := Latency; -end; - -procedure TAudioPlayback_SDL.MixBuffers(dst, src: PByteArray; size: Cardinal; volume: Single); -begin - SDL_MixAudio(PUInt8(dst), PUInt8(src), size, Round(volume * SDL_MIX_MAXVOLUME)); -end; - - -initialization - MediaManager.add(TAudioPlayback_SDL.Create); - -end. diff --git a/src/media/UAudioPlayback_SoftMixer.pas b/src/media/UAudioPlayback_SoftMixer.pas deleted file mode 100644 index c87e461d..00000000 --- a/src/media/UAudioPlayback_SoftMixer.pas +++ /dev/null @@ -1,1154 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UAudioPlayback_SoftMixer; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - sdl, - SysUtils, - URingBuffer, - UMusic, - UAudioPlaybackBase; - -type - TAudioPlayback_SoftMixer = class; - - TGenericPlaybackStream = class(TAudioPlaybackStream) - private - Engine: TAudioPlayback_SoftMixer; - - SampleBuffer: PByteArray; - SampleBufferSize: integer; - SampleBufferCount: integer; // number of available bytes in SampleBuffer - SampleBufferPos: integer; - - SourceBuffer: PByteArray; - SourceBufferSize: integer; - SourceBufferCount: integer; // number of available bytes in SourceBuffer - - Converter: TAudioConverter; - Status: TStreamStatus; - InternalLock: PSDL_Mutex; - SoundEffects: TList; - fVolume: single; - - FadeInStartTime, FadeInTime: cardinal; - FadeInStartVolume, FadeInTargetVolume: single; - - NeedsRewind: boolean; - - procedure Reset(); - - procedure ApplySoundEffects(Buffer: PByteArray; BufferSize: integer); - function InitFormatConversion(): boolean; - procedure FlushBuffers(); - - procedure LockSampleBuffer(); {$IFDEF HasInline}inline;{$ENDIF} - procedure UnlockSampleBuffer(); {$IFDEF HasInline}inline;{$ENDIF} - protected - function GetLatency(): double; override; - function GetStatus(): TStreamStatus; override; - function GetVolume(): single; override; - procedure SetVolume(Volume: single); override; - function GetLength(): real; override; - function GetLoop(): boolean; override; - procedure SetLoop(Enabled: boolean); override; - function GetPosition: real; override; - procedure SetPosition(Time: real); override; - public - constructor Create(Engine: TAudioPlayback_SoftMixer); - destructor Destroy(); override; - - function Open(SourceStream: TAudioSourceStream): boolean; override; - procedure Close(); override; - - procedure Play(); override; - procedure Pause(); override; - procedure Stop(); override; - procedure FadeIn(Time: real; TargetVolume: single); override; - - function GetAudioFormatInfo(): TAudioFormatInfo; override; - - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; - - function GetPCMData(var Data: TPCMData): Cardinal; override; - procedure GetFFTData(var Data: TFFTData); override; - - procedure AddSoundEffect(Effect: TSoundEffect); override; - procedure RemoveSoundEffect(Effect: TSoundEffect); override; - end; - - TAudioMixerStream = class - private - Engine: TAudioPlayback_SoftMixer; - - ActiveStreams: TList; - MixerBuffer: PByteArray; - InternalLock: PSDL_Mutex; - - AppVolume: single; - - procedure Lock(); {$IFDEF HasInline}inline;{$ENDIF} - procedure Unlock(); {$IFDEF HasInline}inline;{$ENDIF} - - function GetVolume(): single; - procedure SetVolume(Volume: single); - public - constructor Create(Engine: TAudioPlayback_SoftMixer); - destructor Destroy(); override; - procedure AddStream(Stream: TAudioPlaybackStream); - procedure RemoveStream(Stream: TAudioPlaybackStream); - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; - - property Volume: single read GetVolume write SetVolume; - end; - - TAudioPlayback_SoftMixer = class(TAudioPlaybackBase) - private - MixerStream: TAudioMixerStream; - protected - FormatInfo: TAudioFormatInfo; - - function InitializeAudioPlaybackEngine(): boolean; virtual; abstract; - function StartAudioPlaybackEngine(): boolean; virtual; abstract; - procedure StopAudioPlaybackEngine(); virtual; abstract; - function FinalizeAudioPlaybackEngine(): boolean; virtual; abstract; - procedure AudioCallback(Buffer: PByteArray; Size: integer); {$IFDEF HasInline}inline;{$ENDIF} - - function CreatePlaybackStream(): TAudioPlaybackStream; override; - public - function GetName: String; override; abstract; - function InitializePlayback(): boolean; override; - function FinalizePlayback: boolean; override; - - procedure SetAppVolume(Volume: single); override; - - function CreateVoiceStream(ChannelMap: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; override; - - function GetMixer(): TAudioMixerStream; {$IFDEF HasInline}inline;{$ENDIF} - function GetAudioFormatInfo(): TAudioFormatInfo; - - procedure MixBuffers(DstBuffer, SrcBuffer: PByteArray; Size: Cardinal; Volume: Single); virtual; - end; - -type - TGenericVoiceStream = class(TAudioVoiceStream) - private - VoiceBuffer: TRingBuffer; - BufferLock: PSDL_Mutex; - PlaybackStream: TGenericPlaybackStream; - Engine: TAudioPlayback_SoftMixer; - public - constructor Create(Engine: TAudioPlayback_SoftMixer); - - function Open(ChannelMap: integer; FormatInfo: TAudioFormatInfo): boolean; override; - procedure Close(); override; - procedure WriteData(Buffer: PByteArray; BufferSize: integer); override; - function ReadData(Buffer: PByteArray; BufferSize: integer): integer; override; - function IsEOF(): boolean; override; - function IsError(): boolean; override; - end; - -const - SOURCE_BUFFER_FRAMES = 4096; - -const - MAX_VOICE_DELAY = 0.500; // 20ms - -implementation - -uses - Math, - ULog, - UIni, - UFFT, - UAudioConverter, - UMain; - -{ TAudioMixerStream } - -constructor TAudioMixerStream.Create(Engine: TAudioPlayback_SoftMixer); -begin - inherited Create(); - - Self.Engine := Engine; - - ActiveStreams := TList.Create; - InternalLock := SDL_CreateMutex(); - AppVolume := 1.0; -end; - -destructor TAudioMixerStream.Destroy(); -begin - if assigned(MixerBuffer) then - Freemem(MixerBuffer); - ActiveStreams.Free; - SDL_DestroyMutex(InternalLock); - inherited; -end; - -procedure TAudioMixerStream.Lock(); -begin - SDL_mutexP(InternalLock); -end; - -procedure TAudioMixerStream.Unlock(); -begin - SDL_mutexV(InternalLock); -end; - -function TAudioMixerStream.GetVolume(): single; -begin - Lock(); - Result := AppVolume; - Unlock(); -end; - -procedure TAudioMixerStream.SetVolume(Volume: single); -begin - Lock(); - AppVolume := Volume; - Unlock(); -end; - -procedure TAudioMixerStream.AddStream(Stream: TAudioPlaybackStream); -begin - if not assigned(Stream) then - Exit; - - Lock(); - // check if stream is already in list to avoid duplicates - if (ActiveStreams.IndexOf(Pointer(Stream)) = -1) then - ActiveStreams.Add(Pointer(Stream)); - Unlock(); -end; - -(* - * Sets the entry of stream in the ActiveStreams-List to nil - * but does not remove it from the list (Count is not changed!). - * Otherwise iterations over the elements might fail due to a - * changed Count-property. - * Call ActiveStreams.Pack() to remove the nil-pointers - * or check for nil-pointers when accessing ActiveStreams. - *) -procedure TAudioMixerStream.RemoveStream(Stream: TAudioPlaybackStream); -var - Index: integer; -begin - Lock(); - Index := activeStreams.IndexOf(Pointer(Stream)); - if (Index <> -1) then - begin - // remove entry but do not decrease count-property - ActiveStreams[Index] := nil; - end; - Unlock(); -end; - -function TAudioMixerStream.ReadData(Buffer: PByteArray; BufferSize: integer): integer; -var - i: integer; - Size: integer; - Stream: TGenericPlaybackStream; - NeedsPacking: boolean; -begin - Result := BufferSize; - - // zero target-buffer (silence) - FillChar(Buffer^, BufferSize, 0); - - // resize mixer-buffer if necessary - ReallocMem(MixerBuffer, BufferSize); - if not assigned(MixerBuffer) then - Exit; - - Lock(); - - NeedsPacking := false; - - // mix streams to one stream - for i := 0 to ActiveStreams.Count-1 do - begin - if (ActiveStreams[i] = nil) then - begin - NeedsPacking := true; - continue; - end; - - Stream := TGenericPlaybackStream(ActiveStreams[i]); - // fetch data from current stream - Size := Stream.ReadData(MixerBuffer, BufferSize); - if (Size > 0) then - begin - // mix stream-data with mixer-buffer - // Note: use Self.appVolume instead of Self.Volume to prevent recursive locking - Engine.MixBuffers(Buffer, MixerBuffer, Size, AppVolume * Stream.Volume); - end; - end; - - // remove nil-pointers from list - if (NeedsPacking) then - begin - ActiveStreams.Pack(); - end; - - Unlock(); -end; - - -{ TGenericPlaybackStream } - -constructor TGenericPlaybackStream.Create(Engine: TAudioPlayback_SoftMixer); -begin - inherited Create(); - Self.Engine := Engine; - InternalLock := SDL_CreateMutex(); - SoundEffects := TList.Create; - Status := ssStopped; - Reset(); -end; - -destructor TGenericPlaybackStream.Destroy(); -begin - Close(); - SDL_DestroyMutex(InternalLock); - FreeAndNil(SoundEffects); - inherited; -end; - -procedure TGenericPlaybackStream.Reset(); -begin - SourceStream := nil; - - FreeAndNil(Converter); - - FreeMem(SampleBuffer); - SampleBuffer := nil; - SampleBufferPos := 0; - SampleBufferSize := 0; - SampleBufferCount := 0; - - FreeMem(SourceBuffer); - SourceBuffer := nil; - SourceBufferSize := 0; - SourceBufferCount := 0; - - NeedsRewind := false; - - fVolume := 0; - SoundEffects.Clear; - FadeInTime := 0; -end; - -function TGenericPlaybackStream.Open(SourceStream: TAudioSourceStream): boolean; -begin - Result := false; - - Close(); - - if (not assigned(SourceStream)) then - Exit; - Self.SourceStream := SourceStream; - - if (not InitFormatConversion()) then - begin - // reset decode-stream so it will not be freed on destruction - Self.SourceStream := nil; - Exit; - end; - - SourceBufferSize := SOURCE_BUFFER_FRAMES * SourceStream.GetAudioFormatInfo().FrameSize; - GetMem(SourceBuffer, SourceBufferSize); - fVolume := 1.0; - - Result := true; -end; - -procedure TGenericPlaybackStream.Close(); -begin - // stop audio-callback on this stream - Stop(); - - // Note: PerformOnClose must be called before SourceStream is invalidated - PerformOnClose(); - // and free data - Reset(); -end; - -procedure TGenericPlaybackStream.LockSampleBuffer(); -begin - SDL_mutexP(InternalLock); -end; - -procedure TGenericPlaybackStream.UnlockSampleBuffer(); -begin - SDL_mutexV(InternalLock); -end; - -function TGenericPlaybackStream.InitFormatConversion(): boolean; -var - SrcFormatInfo: TAudioFormatInfo; - DstFormatInfo: TAudioFormatInfo; -begin - Result := false; - - SrcFormatInfo := SourceStream.GetAudioFormatInfo(); - DstFormatInfo := GetAudioFormatInfo(); - - // TODO: selection should not be done here, use a factory (TAudioConverterFactory) instead - {$IF Defined(UseFFmpegResample)} - Converter := TAudioConverter_FFmpeg.Create(); - {$ELSEIF Defined(UseSRCResample)} - Converter := TAudioConverter_SRC.Create(); - {$ELSE} - Converter := TAudioConverter_SDL.Create(); - {$IFEND} - - Result := Converter.Init(SrcFormatInfo, DstFormatInfo); -end; - -procedure TGenericPlaybackStream.Play(); -var - Mixer: TAudioMixerStream; -begin - // only paused streams are not flushed - if (Status = ssPaused) then - NeedsRewind := false; - - // rewind if necessary. Cases that require no rewind are: - // - stream was created and never played - // - stream was paused and is resumed now - // - stream was stopped and set to a new position already - if (NeedsRewind) then - SetPosition(0); - - // update status - Status := ssPlaying; - - NeedsRewind := true; - - // add this stream to the mixer - Mixer := Engine.GetMixer(); - if (Mixer <> nil) then - Mixer.AddStream(Self); -end; - -procedure TGenericPlaybackStream.FadeIn(Time: real; TargetVolume: single); -begin - FadeInTime := Trunc(Time * 1000); - FadeInStartTime := SDL_GetTicks(); - FadeInStartVolume := fVolume; - FadeInTargetVolume := TargetVolume; - Play(); -end; - -procedure TGenericPlaybackStream.Pause(); -var - Mixer: TAudioMixerStream; -begin - if (Status <> ssPlaying) then - Exit; - - Status := ssPaused; - - Mixer := Engine.GetMixer(); - if (Mixer <> nil) then - Mixer.RemoveStream(Self); -end; - -procedure TGenericPlaybackStream.Stop(); -var - Mixer: TAudioMixerStream; -begin - if (Status = ssStopped) then - Exit; - - Status := ssStopped; - - Mixer := Engine.GetMixer(); - if (Mixer <> nil) then - Mixer.RemoveStream(Self); -end; - -function TGenericPlaybackStream.GetLoop(): boolean; -begin - if assigned(SourceStream) then - Result := SourceStream.Loop - else - Result := false; -end; - -procedure TGenericPlaybackStream.SetLoop(Enabled: boolean); -begin - if assigned(SourceStream) then - SourceStream.Loop := Enabled; -end; - -function TGenericPlaybackStream.GetLength(): real; -begin - if assigned(SourceStream) then - Result := SourceStream.Length - else - Result := -1; -end; - -function TGenericPlaybackStream.GetLatency(): double; -begin - Result := Engine.GetLatency(); -end; - -function TGenericPlaybackStream.GetStatus(): TStreamStatus; -begin - Result := Status; -end; - -function TGenericPlaybackStream.GetAudioFormatInfo(): TAudioFormatInfo; -begin - Result := Engine.GetAudioFormatInfo(); -end; - -procedure TGenericPlaybackStream.FlushBuffers(); -begin - SampleBufferCount := 0; - SampleBufferPos := 0; - SourceBufferCount := 0; -end; - -procedure TGenericPlaybackStream.ApplySoundEffects(Buffer: PByteArray; BufferSize: integer); -var - i: integer; -begin - for i := 0 to SoundEffects.Count-1 do - begin - if (SoundEffects[i] <> nil) then - begin - TSoundEffect(SoundEffects[i]).Callback(Buffer, BufferSize); - end; - end; -end; - -function TGenericPlaybackStream.ReadData(Buffer: PByteArray; BufferSize: integer): integer; -var - ConversionInputCount: integer; - ConversionOutputSize: integer; // max. number of converted data (= buffer size) - ConversionOutputCount: integer; // actual number of converted data - SourceSize: integer; - NeededSampleBufferSize: integer; - BytesNeeded: integer; - SourceFormatInfo, OutputFormatInfo: TAudioFormatInfo; - SourceFrameSize, OutputFrameSize: integer; - SkipOutputCount: integer; // number of output-data bytes to skip - SkipSourceCount: integer; // number of source-data bytes to skip - FillCount: integer; // number of bytes to fill with padding data - CopyCount: integer; - PadFrame: PByteArray; -begin - Result := -1; - - // sanity check for the source-stream - if (not assigned(SourceStream)) then - Exit; - - SkipOutputCount := 0; - SkipSourceCount := 0; - FillCount := 0; - - SourceFormatInfo := SourceStream.GetAudioFormatInfo(); - SourceFrameSize := SourceFormatInfo.FrameSize; - OutputFormatInfo := GetAudioFormatInfo(); - OutputFrameSize := OutputFormatInfo.FrameSize; - - // synchronize (adjust buffer size) - BytesNeeded := Synchronize(BufferSize, OutputFormatInfo); - if (BytesNeeded > BufferSize) then - begin - SkipOutputCount := BytesNeeded - BufferSize; - BytesNeeded := BufferSize; - end - else if (BytesNeeded < BufferSize) then - begin - FillCount := BufferSize - BytesNeeded; - end; - - // lock access to sample-buffer - LockSampleBuffer(); - try - - // skip sample-buffer data - SampleBufferPos := SampleBufferPos + SkipOutputCount; - // size of available bytes in SampleBuffer after skipping - SampleBufferCount := SampleBufferCount - SampleBufferPos; - // update byte skip-count - SkipOutputCount := -SampleBufferCount; - - // now that we skipped all buffered data from the last pass, we have to skip - // data directly after fetching it from the source-stream. - if (SkipOutputCount > 0) then - begin - SampleBufferCount := 0; - // convert skip-count to source-format units and resize to a multiple of - // the source frame-size. - SkipSourceCount := Round((SkipOutputCount * OutputFormatInfo.GetRatio(SourceFormatInfo)) / - SourceFrameSize) * SourceFrameSize; - SkipOutputCount := 0; - end; - - // copy data to front of buffer - if ((SampleBufferCount > 0) and (SampleBufferPos > 0)) then - Move(SampleBuffer[SampleBufferPos], SampleBuffer[0], SampleBufferCount); - SampleBufferPos := 0; - - // resize buffer to a reasonable size - if (BufferSize > SampleBufferCount) then - begin - // Note: use BufferSize instead of BytesNeeded to minimize the need for resizing - SampleBufferSize := BufferSize; - ReallocMem(SampleBuffer, SampleBufferSize); - if (not assigned(SampleBuffer)) then - Exit; - end; - - // fill sample-buffer (fetch and convert one block of source data per loop) - while (SampleBufferCount < BytesNeeded) do - begin - // move remaining source data from the previous pass to front of buffer - if (SourceBufferCount > 0) then - begin - Move(SourceBuffer[SourceBufferSize-SourceBufferCount], - SourceBuffer[0], - SourceBufferCount); - end; - - SourceSize := SourceStream.ReadData( - @SourceBuffer[SourceBufferCount], SourceBufferSize-SourceBufferCount); - // break on error (-1) or if no data is available (0), e.g. while seeking - if (SourceSize <= 0) then - begin - // if we do not have data -> exit - if (SourceBufferCount = 0) then - begin - FlushBuffers(); - Exit; - end; - // if we have some data, stop retrieving data from the source stream - // and use the data we have so far - Break; - end; - - SourceBufferCount := SourceBufferCount + SourceSize; - - // end-of-file reached -> stop playback - if (SourceStream.EOF) then - begin - if (Loop) then - SourceStream.Position := 0 - else - Stop(); - end; - - if (SkipSourceCount > 0) then - begin - // skip data and update source buffer count - SourceBufferCount := SourceBufferCount - SkipSourceCount; - SkipSourceCount := -SourceBufferCount; - // continue with next pass if we skipped all data - if (SourceBufferCount <= 0) then - begin - SourceBufferCount := 0; - Continue; - end; - end; - - // calc buffer size (might be bigger than actual resampled byte count) - ConversionOutputSize := Converter.GetOutputBufferSize(SourceBufferCount); - NeededSampleBufferSize := SampleBufferCount + ConversionOutputSize; - - // resize buffer if necessary - if (SampleBufferSize < NeededSampleBufferSize) then - begin - SampleBufferSize := NeededSampleBufferSize; - ReallocMem(SampleBuffer, SampleBufferSize); - if (not assigned(SampleBuffer)) then - begin - FlushBuffers(); - Exit; - end; - end; - - // resample source data (Note: ConversionInputCount might be adjusted by Convert()) - ConversionInputCount := SourceBufferCount; - ConversionOutputCount := Converter.Convert( - SourceBuffer, @SampleBuffer[SampleBufferCount], ConversionInputCount); - if (ConversionOutputCount = -1) then - begin - FlushBuffers(); - Exit; - end; - - // adjust sample- and source-buffer count by the number of converted bytes - SampleBufferCount := SampleBufferCount + ConversionOutputCount; - SourceBufferCount := SourceBufferCount - ConversionInputCount; - end; - - // apply effects - ApplySoundEffects(SampleBuffer, SampleBufferCount); - - // copy data to result buffer - CopyCount := Min(BytesNeeded, SampleBufferCount); - Move(SampleBuffer[0], Buffer[BufferSize - BytesNeeded], CopyCount); - Dec(BytesNeeded, CopyCount); - SampleBufferPos := CopyCount; - - // release buffer lock - finally - UnlockSampleBuffer(); - end; - - // pad the buffer with the last frame if we are to fast - if (FillCount > 0) then - begin - if (CopyCount >= OutputFrameSize) then - PadFrame := @Buffer[CopyCount-OutputFrameSize] - else - PadFrame := nil; - FillBufferWithFrame(@Buffer[CopyCount], FillCount, - PadFrame, OutputFrameSize); - end; - - // BytesNeeded now contains the number of remaining bytes we were not able to fetch - Result := BufferSize - BytesNeeded; -end; - -function TGenericPlaybackStream.GetPCMData(var Data: TPCMData): Cardinal; -var - ByteCount: integer; -begin - Result := 0; - - // just SInt16 stereo support for now - if ((Engine.GetAudioFormatInfo().Format <> asfS16) or - (Engine.GetAudioFormatInfo().Channels <> 2)) then - begin - Exit; - end; - - // zero memory - FillChar(Data, SizeOf(Data), 0); - - // TODO: At the moment just the first samples of the SampleBuffer - // are returned, even if there is newer data in the upper samples. - - LockSampleBuffer(); - ByteCount := Min(SizeOf(Data), SampleBufferCount); - if (ByteCount > 0) then - begin - Move(SampleBuffer[0], Data, ByteCount); - end; - UnlockSampleBuffer(); - - Result := ByteCount div SizeOf(TPCMStereoSample); -end; - -procedure TGenericPlaybackStream.GetFFTData(var Data: TFFTData); -var - i: integer; - Frames: integer; - DataIn: PSingleArray; - AudioFormat: TAudioFormatInfo; -begin - // only works with SInt16 and Float values at the moment - AudioFormat := GetAudioFormatInfo(); - - DataIn := AllocMem(FFTSize * SizeOf(Single)); - if (DataIn = nil) then - Exit; - - LockSampleBuffer(); - // TODO: We just use the first Frames frames, the others are ignored. - Frames := Min(FFTSize, SampleBufferCount div AudioFormat.FrameSize); - // use only first channel and convert data to float-values - case AudioFormat.Format of - asfS16: - begin - for i := 0 to Frames-1 do - DataIn[i] := PSmallInt(@SampleBuffer[i*AudioFormat.FrameSize])^ / -Low(SmallInt); - end; - asfFloat: - begin - for i := 0 to Frames-1 do - DataIn[i] := PSingle(@SampleBuffer[i*AudioFormat.FrameSize])^; - end; - end; - UnlockSampleBuffer(); - - WindowFunc(fwfHanning, FFTSize, DataIn); - PowerSpectrum(FFTSize, DataIn, @Data); - FreeMem(DataIn); - - // resize data to a 0..1 range - for i := 0 to High(TFFTData) do - begin - Data[i] := Sqrt(Data[i]) / 100; - end; -end; - -procedure TGenericPlaybackStream.AddSoundEffect(Effect: TSoundEffect); -begin - if (not assigned(Effect)) then - Exit; - - LockSampleBuffer(); - // check if effect is already in list to avoid duplicates - if (SoundEffects.IndexOf(Pointer(Effect)) = -1) then - SoundEffects.Add(Pointer(Effect)); - UnlockSampleBuffer(); -end; - -procedure TGenericPlaybackStream.RemoveSoundEffect(Effect: TSoundEffect); -begin - LockSampleBuffer(); - SoundEffects.Remove(Effect); - UnlockSampleBuffer(); -end; - -function TGenericPlaybackStream.GetPosition: real; -var - BufferedTime: double; -begin - if assigned(SourceStream) then - begin - LockSampleBuffer(); - - // calc the time of source data that is buffered (in the SampleBuffer and SourceBuffer) - // but not yet outputed - BufferedTime := (SampleBufferCount - SampleBufferPos) / Engine.FormatInfo.BytesPerSec + - SourceBufferCount / SourceStream.GetAudioFormatInfo().BytesPerSec; - // and subtract it from the source position - Result := SourceStream.Position - BufferedTime; - - UnlockSampleBuffer(); - end - else - begin - Result := -1; - end; -end; - -procedure TGenericPlaybackStream.SetPosition(Time: real); -begin - if assigned(SourceStream) then - begin - LockSampleBuffer(); - - SourceStream.Position := Time; - if (Status = ssStopped) then - NeedsRewind := false; - // do not use outdated data - FlushBuffers(); - - AvgSyncDiff := -1; - - UnlockSampleBuffer(); - end; -end; - -function TGenericPlaybackStream.GetVolume(): single; -var - FadeAmount: Single; -begin - LockSampleBuffer(); - // adjust volume if fading is enabled - if (FadeInTime > 0) then - begin - FadeAmount := (SDL_GetTicks() - FadeInStartTime) / FadeInTime; - // check if fade-target is reached - if (FadeAmount >= 1) then - begin - // target reached -> stop fading - FadeInTime := 0; - fVolume := FadeInTargetVolume; - end - else - begin - // fading in progress - fVolume := FadeAmount*FadeInTargetVolume + (1-FadeAmount)*FadeInStartVolume; - end; - end; - // return current volume - Result := fVolume; - UnlockSampleBuffer(); -end; - -procedure TGenericPlaybackStream.SetVolume(Volume: single); -begin - LockSampleBuffer(); - // stop fading - FadeInTime := 0; - // clamp volume - if (Volume > 1.0) then - fVolume := 1.0 - else if (Volume < 0) then - fVolume := 0 - else - fVolume := Volume; - UnlockSampleBuffer(); -end; - - -{ TGenericVoiceStream } - -constructor TGenericVoiceStream.Create(Engine: TAudioPlayback_SoftMixer); -begin - inherited Create(); - Self.Engine := Engine; -end; - -function TGenericVoiceStream.Open(ChannelMap: integer; FormatInfo: TAudioFormatInfo): boolean; -var - BufferSize: integer; -begin - Result := false; - - Close(); - - if (not inherited Open(ChannelMap, FormatInfo)) then - Exit; - - // Note: - // - use Self.FormatInfo instead of FormatInfo as the latter one might have a - // channel size of 2. - // - the buffer-size must be a multiple of the FrameSize - BufferSize := (Ceil(MAX_VOICE_DELAY * Self.FormatInfo.BytesPerSec) div Self.FormatInfo.FrameSize) * - Self.FormatInfo.FrameSize; - VoiceBuffer := TRingBuffer.Create(BufferSize); - - BufferLock := SDL_CreateMutex(); - - - // create a matching playback stream for the voice-stream - PlaybackStream := TGenericPlaybackStream.Create(Engine); - // link voice- and playback-stream - if (not PlaybackStream.Open(Self)) then - begin - PlaybackStream.Free; - Exit; - end; - - // start voice passthrough - PlaybackStream.Play(); - - Result := true; -end; - -procedure TGenericVoiceStream.Close(); -begin - // stop and free the playback stream - FreeAndNil(PlaybackStream); - - // free data - FreeAndNil(VoiceBuffer); - if (BufferLock <> nil) then - SDL_DestroyMutex(BufferLock); - - inherited Close(); -end; - -procedure TGenericVoiceStream.WriteData(Buffer: PByteArray; BufferSize: integer); -begin - // lock access to buffer - SDL_mutexP(BufferLock); - try - if (VoiceBuffer = nil) then - Exit; - VoiceBuffer.Write(Buffer, BufferSize); - finally - SDL_mutexV(BufferLock); - end; -end; - -function TGenericVoiceStream.ReadData(Buffer: PByteArray; BufferSize: integer): integer; -begin - Result := -1; - - // lock access to buffer - SDL_mutexP(BufferLock); - try - if (VoiceBuffer = nil) then - Exit; - Result := VoiceBuffer.Read(Buffer, BufferSize); - finally - SDL_mutexV(BufferLock); - end; -end; - -function TGenericVoiceStream.IsEOF(): boolean; -begin - SDL_mutexP(BufferLock); - Result := (VoiceBuffer = nil); - SDL_mutexV(BufferLock); -end; - -function TGenericVoiceStream.IsError(): boolean; -begin - Result := false; -end; - - -{ TAudioPlayback_SoftMixer } - -function TAudioPlayback_SoftMixer.InitializePlayback: boolean; -begin - Result := false; - - //Log.LogStatus('InitializePlayback', 'UAudioPlayback_SoftMixer'); - - if(not InitializeAudioPlaybackEngine()) then - Exit; - - MixerStream := TAudioMixerStream.Create(Self); - - if(not StartAudioPlaybackEngine()) then - Exit; - - Result := true; -end; - -function TAudioPlayback_SoftMixer.FinalizePlayback: boolean; -begin - Close; - StopAudioPlaybackEngine(); - - FreeAndNil(MixerStream); - FreeAndNil(FormatInfo); - - FinalizeAudioPlaybackEngine(); - inherited FinalizePlayback; - Result := true; -end; - -procedure TAudioPlayback_SoftMixer.AudioCallback(Buffer: PByteArray; Size: integer); -begin - MixerStream.ReadData(Buffer, Size); -end; - -function TAudioPlayback_SoftMixer.GetMixer(): TAudioMixerStream; -begin - Result := MixerStream; -end; - -function TAudioPlayback_SoftMixer.GetAudioFormatInfo(): TAudioFormatInfo; -begin - Result := FormatInfo; -end; - -function TAudioPlayback_SoftMixer.CreatePlaybackStream(): TAudioPlaybackStream; -begin - Result := TGenericPlaybackStream.Create(Self); -end; - -function TAudioPlayback_SoftMixer.CreateVoiceStream(ChannelMap: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; -var - VoiceStream: TGenericVoiceStream; -begin - Result := nil; - - // create a voice stream - VoiceStream := TGenericVoiceStream.Create(Self); - if (not VoiceStream.Open(ChannelMap, FormatInfo)) then - begin - VoiceStream.Free; - Exit; - end; - - Result := VoiceStream; -end; - -procedure TAudioPlayback_SoftMixer.SetAppVolume(Volume: single); -begin - // sets volume only for this application - MixerStream.Volume := Volume; -end; - -procedure TAudioPlayback_SoftMixer.MixBuffers(DstBuffer, SrcBuffer: PByteArray; Size: Cardinal; Volume: Single); -var - SampleIndex: Cardinal; - SampleInt: Integer; - SampleFlt: Single; -begin - SampleIndex := 0; - case FormatInfo.Format of - asfS16: - begin - while (SampleIndex < Size) do - begin - // apply volume and sum with previous mixer value - SampleInt := PSmallInt(@DstBuffer[SampleIndex])^ + - Round(PSmallInt(@SrcBuffer[SampleIndex])^ * Volume); - // clip result - if (SampleInt > High(SmallInt)) then - SampleInt := High(SmallInt) - else if (SampleInt < Low(SmallInt)) then - SampleInt := Low(SmallInt); - // assign result - PSmallInt(@DstBuffer[SampleIndex])^ := SampleInt; - // increase index by one sample - Inc(SampleIndex, SizeOf(SmallInt)); - end; - end; - asfFloat: - begin - while (SampleIndex < Size) do - begin - // apply volume and sum with previous mixer value - SampleFlt := PSingle(@DstBuffer[SampleIndex])^ + - PSingle(@SrcBuffer[SampleIndex])^ * Volume; - // clip result - if (SampleFlt > 1.0) then - SampleFlt := 1.0 - else if (SampleFlt < -1.0) then - SampleFlt := -1.0; - // assign result - PSingle(@DstBuffer[SampleIndex])^ := SampleFlt; - // increase index by one sample - Inc(SampleIndex, SizeOf(Single)); - end; - end; - else - begin - Log.LogError('Incompatible format', 'TAudioMixerStream.MixAudio'); - end; - end; -end; - -end. diff --git a/src/media/UMediaCore_FFmpeg.pas b/src/media/UMediaCore_FFmpeg.pas deleted file mode 100644 index b4951fe1..00000000 --- a/src/media/UMediaCore_FFmpeg.pas +++ /dev/null @@ -1,550 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMediaCore_FFmpeg; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Classes, - ctypes, - sdl, - avcodec, - avformat, - avutil, - avio, - UMusic, - ULog, - UPath; - -type - PPacketQueue = ^TPacketQueue; - TPacketQueue = class - private - FirstListEntry: PAVPacketList; - LastListEntry: PAVPacketList; - PacketCount: integer; - Mutex: PSDL_Mutex; - Condition: PSDL_Cond; - Size: integer; - AbortRequest: boolean; - public - constructor Create(); - destructor Destroy(); override; - - function Put(Packet : PAVPacket): integer; - function PutStatus(StatusFlag: integer; StatusInfo: Pointer): integer; - procedure FreeStatusInfo(var Packet: TAVPacket); - function GetStatusInfo(var Packet: TAVPacket): Pointer; - function Get(var Packet: TAVPacket; Blocking: boolean): integer; - function GetSize(): integer; - procedure Flush(); - procedure Abort(); - function IsAborted(): boolean; - end; - -const - STATUS_PACKET: PChar = 'STATUS_PACKET'; -const - PKT_STATUS_FLAG_EOF = 1; // signal end-of-file - PKT_STATUS_FLAG_FLUSH = 2; // request the decoder to flush its avcodec decode buffers - PKT_STATUS_FLAG_ERROR = 3; // signal an error state - PKT_STATUS_FLAG_EMPTY = 4; // request the decoder to output empty data (silence or black frames) - -type - TMediaCore_FFmpeg = class - private - AVCodecLock: PSDL_Mutex; - public - constructor Create(); - destructor Destroy(); override; - class function GetInstance(): TMediaCore_FFmpeg; - - function GetErrorString(ErrorNum: integer): string; - function FindStreamIDs(FormatCtx: PAVFormatContext; out FirstVideoStream, FirstAudioStream: integer ): boolean; - function FindAudioStreamIndex(FormatCtx: PAVFormatContext): integer; - function ConvertFFmpegToAudioFormat(FFmpegFormat: TSampleFormat; out Format: TAudioSampleFormat): boolean; - procedure LockAVCodec(); - procedure UnlockAVCodec(); - end; - -implementation - -uses - SysUtils; - -function FFmpegStreamOpen(h: PURLContext; filename: PChar; flags: cint): cint; cdecl; forward; -function FFmpegStreamRead(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; forward; -function FFmpegStreamWrite(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; forward; -function FFmpegStreamSeek(h: PURLContext; pos: int64; whence: cint): int64; cdecl; forward; -function FFmpegStreamClose(h: PURLContext): cint; cdecl; forward; - -const - UTF8FileProtocol: TURLProtocol = ( - name: 'ufile'; - url_open: FFmpegStreamOpen; - url_read: FFmpegStreamRead; - url_write: FFmpegStreamWrite; - url_seek: FFmpegStreamSeek; - url_close: FFmpegStreamClose; - ); - -var - Instance: TMediaCore_FFmpeg; - -constructor TMediaCore_FFmpeg.Create(); -begin - inherited; - av_register_protocol(@UTF8FileProtocol); - AVCodecLock := SDL_CreateMutex(); -end; - -destructor TMediaCore_FFmpeg.Destroy(); -begin - SDL_DestroyMutex(AVCodecLock); - inherited; -end; - -class function TMediaCore_FFmpeg.GetInstance(): TMediaCore_FFmpeg; -begin - if (not Assigned(Instance)) then - Instance := TMediaCore_FFmpeg.Create(); - Result := Instance; -end; - -procedure TMediaCore_FFmpeg.LockAVCodec(); -begin - SDL_mutexP(AVCodecLock); -end; - -procedure TMediaCore_FFmpeg.UnlockAVCodec(); -begin - SDL_mutexV(AVCodecLock); -end; - -function TMediaCore_FFmpeg.GetErrorString(ErrorNum: integer): string; -begin - case ErrorNum of - AVERROR_IO: Result := 'AVERROR_IO'; - AVERROR_NUMEXPECTED: Result := 'AVERROR_NUMEXPECTED'; - AVERROR_INVALIDDATA: Result := 'AVERROR_INVALIDDATA'; - AVERROR_NOMEM: Result := 'AVERROR_NOMEM'; - AVERROR_NOFMT: Result := 'AVERROR_NOFMT'; - AVERROR_NOTSUPP: Result := 'AVERROR_NOTSUPP'; - AVERROR_NOENT: Result := 'AVERROR_NOENT'; - AVERROR_PATCHWELCOME: Result := 'AVERROR_PATCHWELCOME'; - else Result := 'AVERROR_#'+inttostr(ErrorNum); - end; -end; - -{ - @param(FormatCtx is a PAVFormatContext returned from av_open_input_file ) - @param(FirstVideoStream is an OUT value of type integer, this is the index of the video stream) - @param(FirstAudioStream is an OUT value of type integer, this is the index of the audio stream) - @returns(@true on success, @false otherwise) -} -function TMediaCore_FFmpeg.FindStreamIDs(FormatCtx: PAVFormatContext; out FirstVideoStream, FirstAudioStream: integer): boolean; -var - i: integer; - Stream: PAVStream; -begin - // find the first video stream - FirstAudioStream := -1; - FirstVideoStream := -1; - - for i := 0 to FormatCtx.nb_streams-1 do - begin - Stream := FormatCtx.streams[i]; - - if (Stream.codec.codec_type = CODEC_TYPE_VIDEO) and - (FirstVideoStream < 0) then - begin - FirstVideoStream := i; - end; - - if (Stream.codec.codec_type = CODEC_TYPE_AUDIO) and - (FirstAudioStream < 0) then - begin - FirstAudioStream := i; - end; - end; - - // return true if either an audio- or video-stream was found - Result := (FirstAudioStream > -1) or - (FirstVideoStream > -1) ; -end; - -function TMediaCore_FFmpeg.FindAudioStreamIndex(FormatCtx: PAVFormatContext): integer; -var - i: integer; - StreamIndex: integer; - Stream: PAVStream; -begin - // find the first audio stream - StreamIndex := -1; - - for i := 0 to FormatCtx^.nb_streams-1 do - begin - Stream := FormatCtx^.streams[i]; - - if (Stream.codec^.codec_type = CODEC_TYPE_AUDIO) then - begin - StreamIndex := i; - Break; - end; - end; - - Result := StreamIndex; -end; - -function TMediaCore_FFmpeg.ConvertFFmpegToAudioFormat(FFmpegFormat: TSampleFormat; out Format: TAudioSampleFormat): boolean; -begin - case FFmpegFormat of - SAMPLE_FMT_U8: Format := asfU8; - SAMPLE_FMT_S16: Format := asfS16; - SAMPLE_FMT_S32: Format := asfS32; - SAMPLE_FMT_FLT: Format := asfFloat; - SAMPLE_FMT_DBL: Format := asfDouble; - else begin - Result := false; - Exit; - end; - end; - Result := true; -end; - - -{** - * UTF-8 Filename wrapper based on: - * http://www.mail-archive.com/libav-user@mplayerhq.hu/msg02460.html - *} - -function FFmpegStreamOpen(h: PURLContext; filename: PChar; flags: cint): cint; cdecl; -var - Stream: TStream; - Mode: word; - ProtPrefix: string; - FilePath: IPath; -begin - // check for protocol prefix ('ufile:') and strip it - ProtPrefix := Format('%s:', [UTF8FileProtocol.name]); - if (StrLComp(filename, PChar(ProtPrefix), Length(ProtPrefix)) = 0) then - begin - Inc(filename, Length(ProtPrefix)); - end; - - FilePath := Path(filename); - - if ((flags and URL_RDWR) <> 0) then - Mode := fmCreate - else if ((flags and URL_WRONLY) <> 0) then - Mode := fmCreate // TODO: fmCreate is Read+Write -> reopen with fmOpenWrite - else - Mode := fmOpenRead; - - Result := 0; - - try - Stream := TBinaryFileStream.Create(FilePath, Mode); - h.priv_data := Stream; - except - Result := AVERROR_NOENT; - end; -end; - -function FFmpegStreamRead(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; -var - Stream: TStream; -begin - Stream := TStream(h.priv_data); - if (Stream = nil) then - raise EInvalidContainer.Create('FFmpegStreamRead on nil'); - try - Result := Stream.Read(buf[0], size); - except - Result := -1; - end; -end; - -function FFmpegStreamWrite(h: PURLContext; buf: PByteArray; size: cint): cint; cdecl; -var - Stream: TStream; -begin - Stream := TStream(h.priv_data); - if (Stream = nil) then - raise EInvalidContainer.Create('FFmpegStreamWrite on nil'); - try - Result := Stream.Write(buf[0], size); - except - Result := -1; - end; -end; - -function FFmpegStreamSeek(h: PURLContext; pos: int64; whence: cint): int64; cdecl; -var - Stream : TStream; - Origin : TSeekOrigin; -begin - Stream := TStream(h.priv_data); - if (Stream = nil) then - raise EInvalidContainer.Create('FFmpegStreamSeek on nil'); - case whence of - 0 {SEEK_SET}: Origin := soBeginning; - 1 {SEEK_CUR}: Origin := soCurrent; - 2 {SEEK_END}: Origin := soEnd; - AVSEEK_SIZE: begin - Result := Stream.Size; - Exit; - end - else - Origin := soBeginning; - end; - Result := Stream.Seek(pos, Origin); -end; - -function FFmpegStreamClose(h: PURLContext): cint; cdecl; -var - Stream : TStream; -begin - Stream := TStream(h.priv_data); - Stream.Free; - Result := 0; -end; - - -{ TPacketQueue } - -constructor TPacketQueue.Create(); -begin - inherited; - - FirstListEntry := nil; - LastListEntry := nil; - PacketCount := 0; - Size := 0; - - Mutex := SDL_CreateMutex(); - Condition := SDL_CreateCond(); -end; - -destructor TPacketQueue.Destroy(); -begin - Flush(); - SDL_DestroyMutex(Mutex); - SDL_DestroyCond(Condition); - inherited; -end; - -procedure TPacketQueue.Abort(); -begin - SDL_LockMutex(Mutex); - - AbortRequest := true; - - SDL_CondBroadcast(Condition); - SDL_UnlockMutex(Mutex); -end; - -function TPacketQueue.IsAborted(): boolean; -begin - SDL_LockMutex(Mutex); - Result := AbortRequest; - SDL_UnlockMutex(Mutex); -end; - -function TPacketQueue.Put(Packet : PAVPacket): integer; -var - CurrentListEntry : PAVPacketList; -begin - Result := -1; - - if (Packet = nil) then - Exit; - - if (PChar(Packet^.data) <> STATUS_PACKET) then - begin - if (av_dup_packet(Packet) < 0) then - Exit; - end; - - CurrentListEntry := av_malloc(SizeOf(TAVPacketList)); - if (CurrentListEntry = nil) then - Exit; - - CurrentListEntry^.pkt := Packet^; - CurrentListEntry^.next := nil; - - SDL_LockMutex(Mutex); - try - if (LastListEntry = nil) then - FirstListEntry := CurrentListEntry - else - LastListEntry^.next := CurrentListEntry; - - LastListEntry := CurrentListEntry; - Inc(PacketCount); - - Size := Size + CurrentListEntry^.pkt.size; - SDL_CondSignal(Condition); - finally - SDL_UnlockMutex(Mutex); - end; - - Result := 0; -end; - -(** - * Adds a status packet (EOF, Flush, etc.) to the end of the queue. - * StatusInfo can be used to pass additional information to the decoder. - * Only assign nil or a valid pointer to data allocated with Getmem() to - * StatusInfo because the pointer will be disposed with Freemem() on a call - * to Flush(). If the packet is removed from the queue it is the decoder's - * responsibility to free the StatusInfo data with FreeStatusInfo(). - *) -function TPacketQueue.PutStatus(StatusFlag: integer; StatusInfo: Pointer): integer; -var - TempPacket: PAVPacket; -begin - // create temp. package - TempPacket := av_malloc(SizeOf(TAVPacket)); - if (TempPacket = nil) then - begin - Result := -1; - Exit; - end; - // init package - av_init_packet(TempPacket^); - TempPacket^.data := Pointer(STATUS_PACKET); - TempPacket^.flags := StatusFlag; - TempPacket^.priv := StatusInfo; - // put a copy of the package into the queue - Result := Put(TempPacket); - // data has been copied -> delete temp. package - av_free(TempPacket); -end; - -procedure TPacketQueue.FreeStatusInfo(var Packet: TAVPacket); -begin - if (Packet.priv <> nil) then - FreeMem(Packet.priv); -end; - -function TPacketQueue.GetStatusInfo(var Packet: TAVPacket): Pointer; -begin - Result := Packet.priv; -end; - -function TPacketQueue.Get(var Packet: TAVPacket; Blocking: boolean): integer; -var - CurrentListEntry: PAVPacketList; -const - WAIT_TIMEOUT = 10; // timeout in ms -begin - Result := -1; - - SDL_LockMutex(Mutex); - try - while (true) do - begin - if (AbortRequest) then - Exit; - - CurrentListEntry := FirstListEntry; - if (CurrentListEntry <> nil) then - begin - FirstListEntry := CurrentListEntry^.next; - if (FirstListEntry = nil) then - LastListEntry := nil; - Dec(PacketCount); - - Size := Size - CurrentListEntry^.pkt.size; - Packet := CurrentListEntry^.pkt; - av_free(CurrentListEntry); - - Result := 1; - Break; - end - else if (not Blocking) then - begin - Result := 0; - Break; - end - else - begin - // block until a new package arrives, - // but do not wait till infinity to avoid deadlocks - if (SDL_CondWaitTimeout(Condition, Mutex, WAIT_TIMEOUT) = SDL_MUTEX_TIMEDOUT) then - begin - Result := 0; - Break; - end; - end; - end; - finally - SDL_UnlockMutex(Mutex); - end; -end; - -function TPacketQueue.GetSize(): integer; -begin - SDL_LockMutex(Mutex); - Result := Size; - SDL_UnlockMutex(Mutex); -end; - -procedure TPacketQueue.Flush(); -var - CurrentListEntry, TempListEntry: PAVPacketList; -begin - SDL_LockMutex(Mutex); - - CurrentListEntry := FirstListEntry; - while(CurrentListEntry <> nil) do - begin - TempListEntry := CurrentListEntry^.next; - // free status data - if (PChar(CurrentListEntry^.pkt.data) = STATUS_PACKET) then - FreeStatusInfo(CurrentListEntry^.pkt); - // free packet data - av_free_packet(@CurrentListEntry^.pkt); - // Note: param must be a pointer to a pointer! - av_freep(@CurrentListEntry); - CurrentListEntry := TempListEntry; - end; - LastListEntry := nil; - FirstListEntry := nil; - PacketCount := 0; - Size := 0; - - SDL_UnlockMutex(Mutex); -end; - -end. diff --git a/src/media/UMediaCore_SDL.pas b/src/media/UMediaCore_SDL.pas deleted file mode 100644 index 74c75e16..00000000 --- a/src/media/UMediaCore_SDL.pas +++ /dev/null @@ -1,63 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMediaCore_SDL; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMusic, - sdl; - -function ConvertAudioFormatToSDL(Format: TAudioSampleFormat; out SDLFormat: UInt16): boolean; - -implementation - -function ConvertAudioFormatToSDL(Format: TAudioSampleFormat; out SDLFormat: UInt16): boolean; -begin - case Format of - asfU8: SDLFormat := AUDIO_U8; - asfS8: SDLFormat := AUDIO_S8; - asfU16LSB: SDLFormat := AUDIO_U16LSB; - asfS16LSB: SDLFormat := AUDIO_S16LSB; - asfU16MSB: SDLFormat := AUDIO_U16MSB; - asfS16MSB: SDLFormat := AUDIO_S16MSB; - asfU16: SDLFormat := AUDIO_U16; - asfS16: SDLFormat := AUDIO_S16; - else begin - Result := false; - Exit; - end; - end; - Result := true; -end; - -end. diff --git a/src/media/UMedia_dummy.pas b/src/media/UMedia_dummy.pas deleted file mode 100644 index c38a8e60..00000000 --- a/src/media/UMedia_dummy.pas +++ /dev/null @@ -1,269 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMedia_dummy; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -implementation - -uses - SysUtils, - math, - UMusic, - UPath; - -type - TMedia_dummy = class( TInterfacedObject, IVideoPlayback, IVideoVisualization, IAudioPlayback, IAudioInput ) - private - DummyOutputDeviceList: TAudioOutputDeviceList; - public - constructor Create(); - function GetName: string; - - function Init(): boolean; - function Finalize(): boolean; - - function Open(const aFileName: IPath): boolean; // true if succeed - procedure Close; - - procedure Play; - procedure Pause; - procedure Stop; - - procedure SetPosition(Time: real); - function GetPosition: real; - - procedure SetSyncSource(SyncSource: ISyncSource); - - procedure GetFrame(Time: Extended); - procedure DrawGL(Screen: integer); - - // IAudioInput - function InitializeRecord: boolean; - function FinalizeRecord: boolean; - procedure CaptureStart; - procedure CaptureStop; - procedure GetFFTData(var data: TFFTData); - function GetPCMData(var data: TPCMData): Cardinal; - - // IAudioPlayback - function InitializePlayback: boolean; - function FinalizePlayback: boolean; - - function GetOutputDeviceList(): TAudioOutputDeviceList; - procedure FadeIn(Time: real; TargetVolume: single); - procedure SetAppVolume(Volume: single); - procedure SetVolume(Volume: single); - procedure SetLoop(Enabled: boolean); - procedure Rewind; - - function Finished: boolean; - function Length: real; - - function OpenSound(const Filename: IPath): TAudioPlaybackStream; - procedure CloseSound(var PlaybackStream: TAudioPlaybackStream); - procedure PlaySound(stream: TAudioPlaybackStream); - procedure StopSound(stream: TAudioPlaybackStream); - - function CreateVoiceStream(Channel: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; - procedure CloseVoiceStream(var VoiceStream: TAudioVoiceStream); - end; - -function TMedia_dummy.GetName: string; -begin - Result := 'dummy'; -end; - -procedure TMedia_dummy.GetFrame(Time: Extended); -begin -end; - -procedure TMedia_dummy.DrawGL(Screen: integer); -begin -end; - -constructor TMedia_dummy.Create(); -begin - inherited; -end; - -function TMedia_dummy.Init(): boolean; -begin - Result := true; -end; - -function TMedia_dummy.Finalize(): boolean; -begin - Result := true; -end; - -function TMedia_dummy.Open(const aFileName : IPath): boolean; // true if succeed -begin - Result := false; -end; - -procedure TMedia_dummy.Close; -begin -end; - -procedure TMedia_dummy.Play; -begin -end; - -procedure TMedia_dummy.Pause; -begin -end; - -procedure TMedia_dummy.Stop; -begin -end; - -procedure TMedia_dummy.SetPosition(Time: real); -begin -end; - -function TMedia_dummy.GetPosition: real; -begin - Result := 0; -end; - -procedure TMedia_dummy.SetSyncSource(SyncSource: ISyncSource); -begin -end; - -// IAudioInput -function TMedia_dummy.InitializeRecord: boolean; -begin - Result := true; -end; - -function TMedia_dummy.FinalizeRecord: boolean; -begin - Result := true; -end; - -procedure TMedia_dummy.CaptureStart; -begin -end; - -procedure TMedia_dummy.CaptureStop; -begin -end; - -procedure TMedia_dummy.GetFFTData(var data: TFFTData); -begin -end; - -function TMedia_dummy.GetPCMData(var data: TPCMData): Cardinal; -begin - Result := 0; -end; - -// IAudioPlayback -function TMedia_dummy.InitializePlayback: boolean; -begin - SetLength(DummyOutputDeviceList, 1); - DummyOutputDeviceList[0] := TAudioOutputDevice.Create(); - DummyOutputDeviceList[0].Name := '[Dummy Device]'; - Result := true; -end; - -function TMedia_dummy.FinalizePlayback: boolean; -begin - Result := true; -end; - -function TMedia_dummy.GetOutputDeviceList(): TAudioOutputDeviceList; -begin - Result := DummyOutputDeviceList; -end; - -procedure TMedia_dummy.SetAppVolume(Volume: single); -begin -end; - -procedure TMedia_dummy.SetVolume(Volume: single); -begin -end; - -procedure TMedia_dummy.SetLoop(Enabled: boolean); -begin -end; - -procedure TMedia_dummy.FadeIn(Time: real; TargetVolume: single); -begin -end; - -procedure TMedia_dummy.Rewind; -begin -end; - -function TMedia_dummy.Finished: boolean; -begin - Result := false; -end; - -function TMedia_dummy.Length: real; -begin - Result := 60; -end; - -function TMedia_dummy.OpenSound(const Filename: IPath): TAudioPlaybackStream; -begin - Result := nil; -end; - -procedure TMedia_dummy.CloseSound(var PlaybackStream: TAudioPlaybackStream); -begin -end; - -procedure TMedia_dummy.PlaySound(stream: TAudioPlaybackStream); -begin -end; - -procedure TMedia_dummy.StopSound(stream: TAudioPlaybackStream); -begin -end; - -function TMedia_dummy.CreateVoiceStream(Channel: integer; FormatInfo: TAudioFormatInfo): TAudioVoiceStream; -begin - Result := nil; -end; - -procedure TMedia_dummy.CloseVoiceStream(var VoiceStream: TAudioVoiceStream); -begin -end; - -initialization - MediaManager.Add(TMedia_dummy.Create); - -end. diff --git a/src/media/UVideo.pas b/src/media/UVideo.pas deleted file mode 100644 index 6db9cd20..00000000 --- a/src/media/UVideo.pas +++ /dev/null @@ -1,966 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UVideo; - -{* - * based on 'An ffmpeg and SDL Tutorial' (http://www.dranger.com/ffmpeg/) - *} - -// uncomment if you want to see the debug stuff -{.$define DebugDisplay} -{.$define DebugFrames} -{.$define VideoBenchmark} -{.$define Info} - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -// use BGR-format for accelerated colorspace conversion with swscale -{$IFDEF UseSWScale} - {$DEFINE PIXEL_FMT_BGR} -{$ENDIF} - -type - {** - * vacStretch: Stretch to screen width and height - * - ignores aspect - * + no borders - * + no image data loss - * vacCrop: Stretch to screen width or height, crop the other dimension - * + keeps aspect - * + no borders - * - frame borders are cropped (image data loss) - * vacLetterBox: Stretch to screen width, add bars at or crop top and bottom - * + keeps aspect - * - borders at top and bottom - * o top/bottom is cropped if width < height (unusual) - *} - TAspectCorrection = (acoStretch, acoCrop, acoLetterBox); - - -implementation - -uses - SysUtils, - Math, - SDL, - avcodec, - avformat, - avutil, - avio, - rational, - {$IFDEF UseSWScale} - swscale, - {$ENDIF} - gl, - glext, - textgl, - UMediaCore_FFmpeg, - UCommon, - UConfig, - ULog, - UMusic, - UGraphicClasses, - UGraphic, - UPath; - -const -{$IFDEF PIXEL_FMT_BGR} - PIXEL_FMT_OPENGL = GL_BGR; - PIXEL_FMT_FFMPEG = PIX_FMT_BGR24; -{$ELSE} - PIXEL_FMT_OPENGL = GL_RGB; - PIXEL_FMT_FFMPEG = PIX_FMT_RGB24; -{$ENDIF} - -type - TRectCoords = record - Left, Right: double; - Upper, Lower: double; - end; - - TVideoPlayback_FFmpeg = class( TInterfacedObject, IVideoPlayback ) - private - fOpened: boolean; //**< stream successfully opened - fPaused: boolean; //**< stream paused - fInitialized: boolean; - fEOF: boolean; //**< end-of-file state - - fLoop: boolean; //**< looping enabled - - fStream: PAVStream; - fStreamIndex : integer; - fFormatContext: PAVFormatContext; - fCodecContext: PAVCodecContext; - fCodec: PAVCodec; - - fAVFrame: PAVFrame; - fAVFrameRGB: PAVFrame; - - fFrameBuffer: PByte; //**< stores a FFmpeg video frame - fFrameTex: GLuint; //**< OpenGL texture for FrameBuffer - fFrameTexValid: boolean; //**< if true, fFrameTex contains the current frame - fTexWidth, fTexHeight: cardinal; - - {$IFDEF UseSWScale} - fSwScaleContext: PSwsContext; - {$ENDIF} - - fAspect: real; //**< width/height ratio - fAspectCorrection: TAspectCorrection; - - fTimeBase: extended; //**< FFmpeg time base per time unit - fTime: extended; //**< video time position (absolute) - fLoopTime: extended; //**< start time of the current loop - - procedure Reset(); - function DecodeFrame(): boolean; - procedure SynchronizeTime(Frame: PAVFrame; var pts: double); - - procedure GetVideoRect(var ScreenRect, TexRect: TRectCoords); - - procedure ShowDebugInfo(); - - public - function GetName: String; - - function Init(): boolean; - function Finalize: boolean; - - function Open(const FileName : IPath): boolean; // true if succeed - procedure Close; - - procedure Play; - procedure Pause; - procedure Stop; - - procedure SetPosition(Time: real); - function GetPosition: real; - - procedure GetFrame(Time: Extended); - procedure DrawGL(Screen: integer); - end; - -var - FFmpegCore: TMediaCore_FFmpeg; - - -// These are called whenever we allocate a frame buffer. -// We use this to store the global_pts in a frame at the time it is allocated. -function PtsGetBuffer(CodecCtx: PAVCodecContext; Frame: PAVFrame): integer; cdecl; -var - pts: Pint64; - VideoPktPts: Pint64; -begin - Result := avcodec_default_get_buffer(CodecCtx, Frame); - VideoPktPts := CodecCtx^.opaque; - if (VideoPktPts <> nil) then - begin - // Note: we must copy the pts instead of passing a pointer, because the packet - // (and with it the pts) might change before a frame is returned by av_decode_video. - pts := av_malloc(sizeof(int64)); - pts^ := VideoPktPts^; - Frame^.opaque := pts; - end; -end; - -procedure PtsReleaseBuffer(CodecCtx: PAVCodecContext; Frame: PAVFrame); cdecl; -begin - if (Frame <> nil) then - av_freep(@Frame^.opaque); - avcodec_default_release_buffer(CodecCtx, Frame); -end; - - -{*------------------------------------------------------------------------------ - * TVideoPlayback_ffmpeg - *------------------------------------------------------------------------------} - -function TVideoPlayback_FFmpeg.GetName: String; -begin - result := 'FFmpeg_Video'; -end; - -function TVideoPlayback_FFmpeg.Init(): boolean; -begin - Result := true; - - if (fInitialized) then - Exit; - fInitialized := true; - - FFmpegCore := TMediaCore_FFmpeg.GetInstance(); - - Reset(); - av_register_all(); - glGenTextures(1, PGLuint(@fFrameTex)); -end; - -function TVideoPlayback_FFmpeg.Finalize(): boolean; -begin - Close(); - glDeleteTextures(1, PGLuint(@fFrameTex)); - Result := true; -end; - -procedure TVideoPlayback_FFmpeg.Reset(); -begin - // close previously opened video - Close(); - - fOpened := False; - fPaused := False; - fTimeBase := 0; - fTime := 0; - fStream := nil; - fStreamIndex := -1; - fFrameTexValid := false; - - fEOF := false; - - // TODO: do we really want this by default? - fLoop := true; - fLoopTime := 0; - - fAspectCorrection := acoCrop; -end; - -function TVideoPlayback_FFmpeg.Open(const FileName : IPath): boolean; // true if succeed -var - errnum: Integer; - AudioStreamIndex: integer; -begin - Result := false; - - Reset(); - - // use custom 'ufile' protocol for UTF-8 support - errnum := av_open_input_file(fFormatContext, PAnsiChar('ufile:'+FileName.ToNative), nil, 0, nil); - if (errnum <> 0) then - begin - Log.LogError('Failed to open file "'+ FileName.ToNative +'" ('+FFmpegCore.GetErrorString(errnum)+')'); - Exit; - end; - - // update video info - if (av_find_stream_info(fFormatContext) < 0) then - begin - Log.LogError('No stream info found', 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - Log.LogInfo('VideoStreamIndex : ' + inttostr(fStreamIndex), 'TVideoPlayback_ffmpeg.Open'); - - // find video stream - FFmpegCore.FindStreamIDs(fFormatContext, fStreamIndex, AudioStreamIndex); - if (fStreamIndex < 0) then - begin - Log.LogError('No video stream found', 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - - fStream := fFormatContext^.streams[fStreamIndex]; - fCodecContext := fStream^.codec; - - fCodec := avcodec_find_decoder(fCodecContext^.codec_id); - if (fCodec = nil) then - begin - Log.LogError('No matching codec found', 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - - // set debug options - fCodecContext^.debug_mv := 0; - fCodecContext^.debug := 0; - - // detect bug-workarounds automatically - fCodecContext^.workaround_bugs := FF_BUG_AUTODETECT; - // error resilience strategy (careful/compliant/agressive/very_aggressive) - //fCodecContext^.error_resilience := FF_ER_CAREFUL; //FF_ER_COMPLIANT; - // allow non spec compliant speedup tricks. - //fCodecContext^.flags2 := fCodecContext^.flags2 or CODEC_FLAG2_FAST; - - // Note: avcodec_open() and avcodec_close() are not thread-safe and will - // fail if called concurrently by different threads. - FFmpegCore.LockAVCodec(); - try - errnum := avcodec_open(fCodecContext, fCodec); - finally - FFmpegCore.UnlockAVCodec(); - end; - if (errnum < 0) then - begin - Log.LogError('No matching codec found', 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - - // register custom callbacks for pts-determination - fCodecContext^.get_buffer := PtsGetBuffer; - fCodecContext^.release_buffer := PtsReleaseBuffer; - - {$ifdef DebugDisplay} - DebugWriteln('Found a matching Codec: '+ fCodecContext^.Codec.Name + sLineBreak + - sLineBreak + - ' Width = '+inttostr(fCodecContext^.width) + - ', Height='+inttostr(fCodecContext^.height) + sLineBreak + - ' Aspect : '+inttostr(fCodecContext^.sample_aspect_ratio.num) + '/' + - inttostr(fCodecContext^.sample_aspect_ratio.den) + sLineBreak + - ' Framerate : '+inttostr(fCodecContext^.time_base.num) + '/' + - inttostr(fCodecContext^.time_base.den)); - {$endif} - - // allocate space for decoded frame and rgb frame - fAVFrame := avcodec_alloc_frame(); - fAVFrameRGB := avcodec_alloc_frame(); - fFrameBuffer := av_malloc(avpicture_get_size(PIXEL_FMT_FFMPEG, - fCodecContext^.width, fCodecContext^.height)); - - if ((fAVFrame = nil) or (fAVFrameRGB = nil) or (fFrameBuffer = nil)) then - begin - Log.LogError('Failed to allocate buffers', 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - - // TODO: pad data for OpenGL to GL_UNPACK_ALIGNMENT - // (otherwise video will be distorted if width/height is not a multiple of the alignment) - errnum := avpicture_fill(PAVPicture(fAVFrameRGB), fFrameBuffer, PIXEL_FMT_FFMPEG, - fCodecContext^.width, fCodecContext^.height); - if (errnum < 0) then - begin - Log.LogError('avpicture_fill failed: ' + FFmpegCore.GetErrorString(errnum), 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - - // calculate some information for video display - fAspect := av_q2d(fCodecContext^.sample_aspect_ratio); - if (fAspect = 0) then - fAspect := fCodecContext^.width / - fCodecContext^.height - else - fAspect := fAspect * fCodecContext^.width / - fCodecContext^.height; - - fTimeBase := 1/av_q2d(fStream^.r_frame_rate); - - // hack to get reasonable timebase (for divx and others) - if (fTimeBase < 0.02) then // 0.02 <-> 50 fps - begin - fTimeBase := av_q2d(fStream^.r_frame_rate); - while (fTimeBase > 50) do - fTimeBase := fTimeBase/10; - fTimeBase := 1/fTimeBase; - end; - - Log.LogInfo('VideoTimeBase: ' + floattostr(fTimeBase), 'TVideoPlayback_ffmpeg.Open'); - Log.LogInfo('Framerate: '+inttostr(floor(1/fTimeBase))+'fps', 'TVideoPlayback_ffmpeg.Open'); - - {$IFDEF UseSWScale} - // if available get a SWScale-context -> faster than the deprecated img_convert(). - // SWScale has accelerated support for PIX_FMT_RGB32/PIX_FMT_BGR24/PIX_FMT_BGR565/PIX_FMT_BGR555. - // Note: PIX_FMT_RGB32 is a BGR- and not an RGB-format (maybe a bug)!!! - // The BGR565-formats (GL_UNSIGNED_SHORT_5_6_5) is way too slow because of its - // bad OpenGL support. The BGR formats have MMX(2) implementations but no speed-up - // could be observed in comparison to the RGB versions. - fSwScaleContext := sws_getContext( - fCodecContext^.width, fCodecContext^.height, - fCodecContext^.pix_fmt, - fCodecContext^.width, fCodecContext^.height, - PIXEL_FMT_FFMPEG, - SWS_FAST_BILINEAR, nil, nil, nil); - if (fSwScaleContext = nil) then - begin - Log.LogError('Failed to get swscale context', 'TVideoPlayback_ffmpeg.Open'); - Close(); - Exit; - end; - {$ENDIF} - - fTexWidth := Round(Power(2, Ceil(Log2(fCodecContext^.width)))); - fTexHeight := Round(Power(2, Ceil(Log2(fCodecContext^.height)))); - - // we retrieve a texture just once with glTexImage2D and update it with glTexSubImage2D later. - // Benefits: glTexSubImage2D is faster and supports non-power-of-two widths/height. - glBindTexture(GL_TEXTURE_2D, fFrameTex); - glTexEnvi(GL_TEXTURE_2D, GL_TEXTURE_ENV_MODE, GL_REPLACE); - glTexImage2D(GL_TEXTURE_2D, 0, 3, fTexWidth, fTexHeight, 0, - PIXEL_FMT_OPENGL, GL_UNSIGNED_BYTE, nil); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - - fOpened := True; - Result := true; -end; - -procedure TVideoPlayback_FFmpeg.Close; -begin - if (fFrameBuffer <> nil) then - av_free(fFrameBuffer); - if (fAVFrameRGB <> nil) then - av_free(fAVFrameRGB); - if (fAVFrame <> nil) then - av_free(fAVFrame); - - fAVFrame := nil; - fAVFrameRGB := nil; - fFrameBuffer := nil; - - if (fCodecContext <> nil) then - begin - // avcodec_close() is not thread-safe - FFmpegCore.LockAVCodec(); - try - avcodec_close(fCodecContext); - finally - FFmpegCore.UnlockAVCodec(); - end; - end; - - if (fFormatContext <> nil) then - av_close_input_file(fFormatContext); - - fCodecContext := nil; - fFormatContext := nil; - - fOpened := False; -end; - -procedure TVideoPlayback_FFmpeg.SynchronizeTime(Frame: PAVFrame; var pts: double); -var - FrameDelay: double; -begin - if (pts <> 0) then - begin - // if we have pts, set video clock to it - fTime := pts; - end else - begin - // if we aren't given a pts, set it to the clock - pts := fTime; - end; - // update the video clock - FrameDelay := av_q2d(fCodecContext^.time_base); - // if we are repeating a frame, adjust clock accordingly - FrameDelay := FrameDelay + Frame^.repeat_pict * (FrameDelay * 0.5); - fTime := fTime + FrameDelay; -end; - -{** - * Decode a new frame from the video stream. - * The decoded frame is stored in fAVFrame. fTime is updated to the new frame's - * time. - * @param pts will be updated to the presentation time of the decoded frame. - * returns true if a frame could be decoded. False if an error or EOF occured. - *} -function TVideoPlayback_FFmpeg.DecodeFrame(): boolean; -var - FrameFinished: Integer; - VideoPktPts: int64; - pbIOCtx: PByteIOContext; - errnum: integer; - AVPacket: TAVPacket; - pts: double; -begin - Result := false; - FrameFinished := 0; - - if fEOF then - Exit; - - // read packets until we have a finished frame (or there are no more packets) - while (FrameFinished = 0) do - begin - errnum := av_read_frame(fFormatContext, AVPacket); - if (errnum < 0) then - begin - // failed to read a frame, check reason - - {$IF (LIBAVFORMAT_VERSION_MAJOR >= 52)} - pbIOCtx := fFormatContext^.pb; - {$ELSE} - pbIOCtx := @fFormatContext^.pb; - {$IFEND} - - // check for end-of-file (EOF is not an error) - if (url_feof(pbIOCtx) <> 0) then - begin - fEOF := true; - Exit; - end; - - // check for errors - if (url_ferror(pbIOCtx) <> 0) then - Exit; - - // url_feof() does not detect an EOF for some mov-files (e.g. deluxe.mov) - // so we have to do it this way. - if ((fFormatContext^.file_size <> 0) and - (pbIOCtx^.pos >= fFormatContext^.file_size)) then - begin - fEOF := true; - Exit; - end; - - // no error -> wait for user input -{ - SDL_Delay(100); // initial version, left for documentation - continue; -} - - // Patch by Hawkear: - // Why should this function loop in an endless loop if there is an error? - // This runs in the main thread, so it halts the whole program - // Therefore, it is better to exit when an error occurs - Exit; - - end; - - // if we got a packet from the video stream, then decode it - if (AVPacket.stream_index = fStreamIndex) then - begin - // save pts to be stored in pFrame in first call of PtsGetBuffer() - VideoPktPts := AVPacket.pts; - fCodecContext^.opaque := @VideoPktPts; - - // decode packet - avcodec_decode_video(fCodecContext, fAVFrame, - frameFinished, AVPacket.data, AVPacket.size); - - // reset opaque data - fCodecContext^.opaque := nil; - - // update pts - if (AVPacket.dts <> AV_NOPTS_VALUE) then - begin - pts := AVPacket.dts; - end - else if ((fAVFrame^.opaque <> nil) and - (Pint64(fAVFrame^.opaque)^ <> AV_NOPTS_VALUE)) then - begin - pts := Pint64(fAVFrame^.opaque)^; - end - else - begin - pts := 0; - end; - - if fStream^.start_time <> AV_NOPTS_VALUE then - pts := pts - fStream^.start_time; - - pts := pts * av_q2d(fStream^.time_base); - - // synchronize time on each complete frame - if (frameFinished <> 0) then - SynchronizeTime(fAVFrame, pts); - end; - - // free the packet from av_read_frame - av_free_packet( @AVPacket ); - end; - - Result := true; -end; - -procedure TVideoPlayback_FFmpeg.GetFrame(Time: Extended); -var - errnum: Integer; - NewTime: Extended; - TimeDifference: Extended; - DropFrameCount: Integer; - i: Integer; - Success: boolean; -const - FRAME_DROPCOUNT = 3; -begin - if not fOpened then - Exit; - - if fPaused then - Exit; - - // requested stream position (relative to the last loop's start) - NewTime := Time - fLoopTime; - - // check if current texture still contains the active frame - if (fFrameTexValid) then - begin - // time since the last frame was returned - TimeDifference := NewTime - fTime; - - {$IFDEF DebugDisplay} - DebugWriteln('Time: '+inttostr(floor(Time*1000)) + sLineBreak + - 'VideoTime: '+inttostr(floor(fTime*1000)) + sLineBreak + - 'TimeBase: '+inttostr(floor(fTimeBase*1000)) + sLineBreak + - 'TimeDiff: '+inttostr(floor(TimeDifference*1000))); - {$endif} - - // check if last time is more than one frame in the past - if (TimeDifference < fTimeBase) then - begin - {$ifdef DebugFrames} - // frame delay debug display - GoldenRec.Spawn(200,15,1,16,0,-1,ColoredStar,$00ff00); - {$endif} - - {$IFDEF DebugDisplay} - DebugWriteln('not getting new frame' + sLineBreak + - 'Time: '+inttostr(floor(Time*1000)) + sLineBreak + - 'VideoTime: '+inttostr(floor(fTime*1000)) + sLineBreak + - 'TimeBase: '+inttostr(floor(fTimeBase*1000)) + sLineBreak + - 'TimeDiff: '+inttostr(floor(TimeDifference*1000))); - {$endif} - - // we do not need a new frame now - Exit; - end; - end; - - {$IFDEF VideoBenchmark} - Log.BenchmarkStart(15); - {$ENDIF} - - // fetch new frame (updates fTime) - Success := DecodeFrame(); - TimeDifference := NewTime - fTime; - - // check if we have to skip frames - if (TimeDifference >= FRAME_DROPCOUNT*fTimeBase) then - begin - {$IFDEF DebugFrames} - //frame drop debug display - GoldenRec.Spawn(200,55,1,16,0,-1,ColoredStar,$ff0000); - {$ENDIF} - {$IFDEF DebugDisplay} - DebugWriteln('skipping frames' + sLineBreak + - 'TimeBase: '+inttostr(floor(fTimeBase*1000)) + sLineBreak + - 'TimeDiff: '+inttostr(floor(TimeDifference*1000))); - {$endif} - - // update video-time - DropFrameCount := Trunc(TimeDifference / fTimeBase); - fTime := fTime + DropFrameCount*fTimeBase; - - // skip half of the frames, this is much smoother than to skip all at once - for i := 1 to DropFrameCount (*div 2*) do - Success := DecodeFrame(); - end; - - // check if we got an EOF or error - if (not Success) then - begin - if fLoop then - begin - // we have to loop, so rewind - SetPosition(0); - // record the start-time of the current loop, so we can - // determine the position in the stream (fTime-fLoopTime) later. - fLoopTime := Time; - end; - Exit; - end; - - // TODO: support for pan&scan - //if (fAVFrame.pan_scan <> nil) then - //begin - // Writeln(Format('PanScan: %d/%d', [fAVFrame.pan_scan.width, fAVFrame.pan_scan.height])); - //end; - - // otherwise we convert the pixeldata from YUV to RGB - {$IFDEF UseSWScale} - errnum := sws_scale(fSwScaleContext, @(fAVFrame.data), @(fAVFrame.linesize), - 0, fCodecContext^.Height, - @(fAVFrameRGB.data), @(fAVFrameRGB.linesize)); - {$ELSE} - // img_convert from lib/ffmpeg/avcodec.pas is actually deprecated. - // If ./configure does not find SWScale then this gives the error - // that the identifier img_convert is not known or similar. - // I think this should be removed, but am not sure whether there should - // be some other replacement or a warning, Therefore, I leave it for now. - // April 2009, mischi - errnum := img_convert(PAVPicture(fAVFrameRGB), PIXEL_FMT_FFMPEG, - PAVPicture(fAVFrame), fCodecContext^.pix_fmt, - fCodecContext^.width, fCodecContext^.height); - {$ENDIF} - - if (errnum < 0) then - begin - Log.LogError('Image conversion failed', 'TVideoPlayback_ffmpeg.GetFrame'); - Exit; - end; - - {$IFDEF VideoBenchmark} - Log.BenchmarkEnd(15); - Log.BenchmarkStart(16); - {$ENDIF} - - // TODO: data is not padded, so we will need to tell OpenGL. - // Or should we add padding with avpicture_fill? (check which one is faster) - //glPixelStorei(GL_UNPACK_ALIGNMENT, 1); - - glBindTexture(GL_TEXTURE_2D, fFrameTex); - glTexSubImage2D(GL_TEXTURE_2D, 0, 0, 0, - fCodecContext^.width, fCodecContext^.height, - PIXEL_FMT_OPENGL, GL_UNSIGNED_BYTE, fAVFrameRGB^.data[0]); - - if (not fFrameTexValid) then - fFrameTexValid := true; - - {$ifdef DebugFrames} - //frame decode debug display - GoldenRec.Spawn(200, 35, 1, 16, 0, -1, ColoredStar, $ffff00); - {$endif} - - {$IFDEF VideoBenchmark} - Log.BenchmarkEnd(16); - Log.LogBenchmark('FFmpeg', 15); - Log.LogBenchmark('Texture', 16); - {$ENDIF} -end; - -procedure TVideoPlayback_FFmpeg.GetVideoRect(var ScreenRect, TexRect: TRectCoords); -var - ScreenAspect: double; // aspect of screen resolution - ScaledVideoWidth, ScaledVideoHeight: double; -begin - // Three aspects to take into account: - // 1. Screen/display resolution (e.g. 1920x1080 -> 16:9) - // 2. Render aspect (fixed to 800x600 -> 4:3) - // 3. Movie aspect (video frame aspect stored in fAspect) - ScreenAspect := ScreenW / ScreenH; - - case fAspectCorrection of - acoStretch: begin - ScaledVideoWidth := RenderW; - ScaledVideoHeight := RenderH; - end; - acoCrop: begin - if (ScreenAspect >= fAspect) then - begin - ScaledVideoWidth := RenderW; - ScaledVideoHeight := RenderH * ScreenAspect/fAspect; - end - else - begin - ScaledVideoHeight := RenderH; - ScaledVideoWidth := RenderW * fAspect/ScreenAspect; - end; - end; - acoLetterBox: begin - ScaledVideoWidth := RenderW; - ScaledVideoHeight := RenderH * ScreenAspect/fAspect; - end - else - raise Exception.Create('Unhandled aspect correction!'); - end; - - // center video - ScreenRect.Left := (RenderW - ScaledVideoWidth) / 2; - ScreenRect.Right := ScreenRect.Left + ScaledVideoWidth; - ScreenRect.Upper := (RenderH - ScaledVideoHeight) / 2; - ScreenRect.Lower := ScreenRect.Upper + ScaledVideoHeight; - - // texture contains right/lower (power-of-2) padding. - // Determine the texture coords of the video frame. - TexRect.Left := 0; - TexRect.Right := fCodecContext^.width / fTexWidth; - TexRect.Upper := 0; - TexRect.Lower := fCodecContext^.height / fTexHeight; -end; - -procedure TVideoPlayback_FFmpeg.DrawGL(Screen: integer); -var - ScreenRect: TRectCoords; - TexRect: TRectCoords; -begin - // have a nice black background to draw on - // (even if there were errors opening the vid) - // TODO: Philipp: IMO TVideoPlayback should not clear the screen at - // all, because clearing is already done by the background class - // at this moment. - if (Screen = 1) then - begin - // It is important that we just clear once before we start - // drawing the first screen otherwise the first screen - // would be cleared by the drawgl called when the second - // screen is drawn - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); - end; - - // exit if there's nothing to draw - if (not fOpened) then - Exit; - - {$IFDEF VideoBenchmark} - Log.BenchmarkStart(15); - {$ENDIF} - - // get texture and screen positions - GetVideoRect(ScreenRect, TexRect); - - // we could use blending for brightness control, but do we need this? - glDisable(GL_BLEND); - - glEnable(GL_TEXTURE_2D); - glBindTexture(GL_TEXTURE_2D, fFrameTex); - glColor3f(1, 1, 1); - glBegin(GL_QUADS); - // upper-left coord - glTexCoord2f(TexRect.Left, TexRect.Upper); - glVertex2f(ScreenRect.Left, ScreenRect.Upper); - // lower-left coord - glTexCoord2f(TexRect.Left, TexRect.Lower); - glVertex2f(ScreenRect.Left, ScreenRect.Lower); - // lower-right coord - glTexCoord2f(TexRect.Right, TexRect.Lower); - glVertex2f(ScreenRect.Right, ScreenRect.Lower); - // upper-right coord - glTexCoord2f(TexRect.Right, TexRect.Upper); - glVertex2f(ScreenRect.Right, ScreenRect.Upper); - glEnd; - glDisable(GL_TEXTURE_2D); - - {$IFDEF VideoBenchmark} - Log.BenchmarkEnd(15); - Log.LogBenchmark('DrawGL', 15); - {$ENDIF} - - {$IF Defined(Info) or Defined(DebugFrames)} - ShowDebugInfo(); - {$IFEND} -end; - -procedure TVideoPlayback_FFmpeg.ShowDebugInfo(); -begin - {$IFDEF Info} - if (fTime+fTimeBase < 0) then - begin - glColor4f(0.7, 1, 0.3, 1); - SetFontStyle (1); - SetFontItalic(False); - SetFontSize(27); - SetFontPos (300, 0); - glPrint('Delay due to negative VideoGap'); - glColor4f(1, 1, 1, 1); - end; - {$ENDIF} - - {$IFDEF DebugFrames} - glColor4f(0, 0, 0, 0.2); - glbegin(GL_QUADS); - glVertex2f(0, 0); - glVertex2f(0, 70); - glVertex2f(250, 70); - glVertex2f(250, 0); - glEnd; - - glColor4f(1, 1, 1, 1); - SetFontStyle (1); - SetFontItalic(False); - SetFontSize(27); - SetFontPos (5, 0); - glPrint('delaying frame'); - SetFontPos (5, 20); - glPrint('fetching frame'); - SetFontPos (5, 40); - glPrint('dropping frame'); - {$ENDIF} -end; - -procedure TVideoPlayback_FFmpeg.Play; -begin -end; - -procedure TVideoPlayback_FFmpeg.Pause; -begin - fPaused := not fPaused; -end; - -procedure TVideoPlayback_FFmpeg.Stop; -begin -end; - -{** - * Sets the stream's position. - * The stream is set to the first keyframe with timestamp <= Time. - * Note that fTime is set to Time no matter if the actual position seeked to is - * at Time or the time of a preceding keyframe. fTime will be updated to the - * actual frame time when GetFrame() is called the next time. - * @param Time new position in seconds - *} -procedure TVideoPlayback_FFmpeg.SetPosition(Time: real); -var - SeekFlags: integer; -begin - if not fOpened then - Exit; - - if (Time < 0) then - Time := 0; - - // TODO: handle fLoop-times - //Time := Time mod VideoDuration; - - // Do not use the AVSEEK_FLAG_ANY here. It will seek to any frame, even - // non keyframes (P-/B-frames). It will produce corrupted video frames as - // FFmpeg does not use the information of the preceding I-frame. - // The picture might be gray or green until the next keyframe occurs. - // Instead seek the first keyframe smaller than the requested time - // (AVSEEK_FLAG_BACKWARD). As this can be some seconds earlier than the - // requested time, let the sync in GetFrame() do its job. - SeekFlags := AVSEEK_FLAG_BACKWARD; - - fTime := Time; - fEOF := false; - fFrameTexValid := false; - - if (av_seek_frame(fFormatContext, fStreamIndex, Floor(Time/fTimeBase), SeekFlags) < 0) then - begin - Log.LogError('av_seek_frame() failed', 'TVideoPlayback_ffmpeg.SetPosition'); - Exit; - end; - - avcodec_flush_buffers(fCodecContext); -end; - -function TVideoPlayback_FFmpeg.GetPosition: real; -begin - Result := fTime; -end; - -initialization - MediaManager.Add(TVideoPlayback_FFmpeg.Create); - -end. diff --git a/src/media/UVisualizer.pas b/src/media/UVisualizer.pas deleted file mode 100644 index b25d68a9..00000000 --- a/src/media/UVisualizer.pas +++ /dev/null @@ -1,552 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UVisualizer; - -(* TODO: - * - fix video/visualizer switching - * - use GL_EXT_framebuffer_object for rendering to a separate framebuffer, - * this will prevent plugins from messing up our render-context - * (-> no stack corruption anymore, no need for Save/RestoreOpenGLState()). - * - create a generic (C-compatible) interface for visualization plugins - * - create a visualization plugin manager - * - write a plugin for projectM in C/C++ (so we need no wrapper anymore) - *) - -{* Note: - * It would be easier to create a seperate Render-Context (RC) for projectM - * and switch to it when necessary. This can be achieved by pbuffers - * (slow and platform specific) or the OpenGL FramebufferObject (FBO) extension - * (fast and plattform-independent but not supported by older graphic-cards/drivers). - * - * See http://oss.sgi.com/projects/ogl-sample/registry/EXT/framebuffer_object.txt - * - * To support as many cards as possible we will stick to the current dirty - * solution for now even if it is a pain to save/restore projectM's state due - * to bugs etc. - * - * This also restricts us to projectM. As other plug-ins might have different - * needs and bugs concerning the OpenGL state, USDX's state would probably be - * corrupted after the plug-in finshed drawing. - *} - -interface - -{$IFDEF FPC} - {$MODE DELPHI} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - UGraphicClasses, - textgl, - math, - gl, - SysUtils, - UIni, - projectM, - UMusic; - -implementation - -uses - UGraphic, - UMain, - UConfig, - UPath, - ULog; - -{$IF PROJECTM_VERSION < 1000000} // < 1.0 -// Initialization data used on projectM 0.9x creation. -// Since projectM 1.0 this data is passed via the config-file. -const - meshX = 32; - meshY = 24; - fps = 30; - textureSize = 512; -{$IFEND} - -type - TGLMatrix = array[0..3, 0..3] of GLdouble; - TGLMatrixStack = array of TGLMatrix; - -type - TVideoPlayback_ProjectM = class( TInterfacedObject, IVideoPlayback, IVideoVisualization ) - private - pm: TProjectM; - ProjectMPath : string; - Initialized: boolean; - - VisualizerStarted: boolean; - VisualizerPaused: boolean; - - VisualTex: GLuint; - PCMData: TPCMData; - RndPCMcount: integer; - - ModelviewMatrixStack: TGLMatrixStack; - ProjectionMatrixStack: TGLMatrixStack; - TextureMatrixStack: TGLMatrixStack; - - procedure VisualizerStart; - procedure VisualizerStop; - - procedure VisualizerTogglePause; - - function GetRandomPCMData(var Data: TPCMData): Cardinal; - - function GetMatrixStackDepth(MatrixMode: GLenum): GLint; - procedure SaveMatrixStack(MatrixMode: GLenum; var MatrixStack: TGLMatrixStack); - procedure RestoreMatrixStack(MatrixMode: GLenum; var MatrixStack: TGLMatrixStack); - procedure SaveOpenGLState(); - procedure RestoreOpenGLState(); - - public - function GetName: String; - - function Init(): boolean; - function Finalize(): boolean; - - function Open(const aFileName: IPath): boolean; // true if succeed - procedure Close; - - procedure Play; - procedure Pause; - procedure Stop; - - procedure SetPosition(Time: real); - function GetPosition: real; - - procedure GetFrame(Time: Extended); - procedure DrawGL(Screen: integer); - end; - - -function TVideoPlayback_ProjectM.GetName: String; -begin - Result := 'ProjectM'; -end; - -function TVideoPlayback_ProjectM.Init(): boolean; -begin - Result := true; - - if (Initialized) then - Exit; - Initialized := true; - - RndPCMcount := 0; - - ProjectMPath := ProjectM_DataDir + PathDelim; - - VisualizerStarted := False; - VisualizerPaused := False; - - {$IFDEF UseTexture} - glGenTextures(1, PglUint(@VisualTex)); - glBindTexture(GL_TEXTURE_2D, VisualTex); - - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR); - glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR); - {$ENDIF} -end; - -function TVideoPlayback_ProjectM.Finalize(): boolean; -begin - VisualizerStop(); - {$IFDEF UseTexture} - glDeleteTextures(1, PglUint(@VisualTex)); - {$ENDIF} - Result := true; -end; - -function TVideoPlayback_ProjectM.Open(const aFileName: IPath): boolean; // true if succeed -begin - Result := false; -end; - -procedure TVideoPlayback_ProjectM.Close; -begin - VisualizerStop(); -end; - -procedure TVideoPlayback_ProjectM.Play; -begin - VisualizerStart(); -end; - -procedure TVideoPlayback_ProjectM.Pause; -begin - VisualizerTogglePause(); -end; - -procedure TVideoPlayback_ProjectM.Stop; -begin - VisualizerStop(); -end; - -procedure TVideoPlayback_ProjectM.SetPosition(Time: real); -begin - if assigned(pm) then - pm.RandomPreset(); -end; - -function TVideoPlayback_ProjectM.GetPosition: real; -begin - Result := 0; -end; - -{** - * Returns the stack depth of the given OpenGL matrix mode stack. - *} -function TVideoPlayback_ProjectM.GetMatrixStackDepth(MatrixMode: GLenum): GLint; -begin - // get number of matrices on stack - case (MatrixMode) of - GL_PROJECTION: - glGetIntegerv(GL_PROJECTION_STACK_DEPTH, @Result); - GL_MODELVIEW: - glGetIntegerv(GL_MODELVIEW_STACK_DEPTH, @Result); - GL_TEXTURE: - glGetIntegerv(GL_TEXTURE_STACK_DEPTH, @Result); - end; -end; - -{** - * Saves the current matrix stack using MatrixMode - * (one of GL_PROJECTION/GL_TEXTURE/GL_MODELVIEW) - * - * Use this function instead of just saving the current matrix with glPushMatrix(). - * OpenGL specifies the depth of the GL_PROJECTION and GL_TEXTURE stacks to be - * at least 2 but projectM already uses 2 stack-entries so overflows might be - * possible on older hardware. - * In contrast to this the GL_MODELVIEW stack-size is at least 32, but this - * function should be used for the modelview stack too. We cannot rely on a - * proper stack management of the underlying visualizer (projectM). - * For example in the projectM versions 1.0 - 1.01 the modelview- and - * projection-matrices were popped without being pushed first. - * - * By saving the whole stack we are on the safe side, so a nasty bug in the - * visualizer does not corrupt USDX. - *} -procedure TVideoPlayback_ProjectM.SaveMatrixStack(MatrixMode: GLenum; - var MatrixStack: TGLMatrixStack); -var - I: integer; - StackDepth: GLint; -begin - glMatrixMode(MatrixMode); - - StackDepth := GetMatrixStackDepth(MatrixMode); - SetLength(MatrixStack, StackDepth); - - // save current matrix stack - for I := StackDepth-1 downto 0 do - begin - // save current matrix - case (MatrixMode) of - GL_PROJECTION: - glGetDoublev(GL_PROJECTION_MATRIX, @MatrixStack[I]); - GL_MODELVIEW: - glGetDoublev(GL_MODELVIEW_MATRIX, @MatrixStack[I]); - GL_TEXTURE: - glGetDoublev(GL_TEXTURE_MATRIX, @MatrixStack[I]); - end; - - // remove matrix from stack - if (I > 0) then - glPopMatrix(); - end; - - // reset default (first) matrix - glLoadIdentity(); -end; - -{** - * Restores the OpenGL matrix stack stored with SaveMatrixStack. - *} -procedure TVideoPlayback_ProjectM.RestoreMatrixStack(MatrixMode: GLenum; - var MatrixStack: TGLMatrixStack); -var - I: integer; - StackDepth: GLint; -begin - glMatrixMode(MatrixMode); - - StackDepth := GetMatrixStackDepth(MatrixMode); - // remove all (except the first) matrices from current stack - for I := 1 to StackDepth-1 do - glPopMatrix(); - - // rebuild stack - for I := 0 to High(MatrixStack) do - begin - glLoadMatrixd(@MatrixStack[I]); - if (I < High(MatrixStack)) then - glPushMatrix(); - end; - - // clean stored stack - SetLength(MatrixStack, 0); -end; - -{** - * Saves the current OpenGL state. - * This is necessary to prevent projectM from corrupting USDX's current - * OpenGL state. - * - * The following steps are performed: - * - All attributes are pushed to the attribute-stack - * - Projection-/Texture-matrices are saved - * - Modelview-matrix is pushed to the Modelview-stack - * - the OpenGL error-state (glGetError) is cleared - *} -procedure TVideoPlayback_ProjectM.SaveOpenGLState(); -begin - // save all OpenGL state-machine attributes - glPushAttrib(GL_ALL_ATTRIB_BITS); - glPushClientAttrib(GL_CLIENT_ALL_ATTRIB_BITS); - - SaveMatrixStack(GL_PROJECTION, ProjectionMatrixStack); - SaveMatrixStack(GL_MODELVIEW, ModelviewMatrixStack); - SaveMatrixStack(GL_TEXTURE, TextureMatrixStack); - - glMatrixMode(GL_MODELVIEW); - - // reset OpenGL error-state - glGetError(); -end; - -{** - * Restores the OpenGL state saved by SaveOpenGLState() - * and resets the error-state. - *} -procedure TVideoPlayback_ProjectM.RestoreOpenGLState(); -begin - // reset OpenGL error-state - glGetError(); - - // restore matrix stacks - RestoreMatrixStack(GL_PROJECTION, ProjectionMatrixStack); - RestoreMatrixStack(GL_MODELVIEW, ModelviewMatrixStack); - RestoreMatrixStack(GL_TEXTURE, TextureMatrixStack); - - // restore all OpenGL state-machine attributes - // (also restores the matrix mode) - glPopClientAttrib(); - glPopAttrib(); -end; - -procedure TVideoPlayback_ProjectM.VisualizerStart; -begin - if VisualizerStarted then - Exit; - - // the OpenGL state must be saved before TProjectM.Create is called - SaveOpenGLState(); - try - - try - {$IF PROJECTM_VERSION >= 1000000} // >= 1.0 - pm := TProjectM.Create(ProjectMPath + 'config.inp'); - {$ELSE} - pm := TProjectM.Create( - meshX, meshY, fps, textureSize, ScreenW, ScreenH, - ProjectMPath + 'presets', ProjectMPath + 'fonts'); - {$IFEND} - except on E: Exception do - begin - // Create() might fail if the config-file is not found - Log.LogError('TProjectM.Create: ' + E.Message, 'TVideoPlayback_ProjectM.VisualizerStart'); - Exit; - end; - end; - - // initialize OpenGL - pm.ResetGL(ScreenW, ScreenH); - // skip projectM default-preset - pm.RandomPreset(); - // projectM >= 1.0 uses the OpenGL FramebufferObject (FBO) extension. - // Unfortunately it does NOT reset the framebuffer-context after - // TProjectM.Create. Either glBindFramebufferEXT(GL_FRAMEBUFFER_EXT, 0) for - // a manual reset or TProjectM.RenderFrame() must be called. - // We use the latter so we do not need to load the FBO extension in USDX. - pm.RenderFrame(); - - VisualizerPaused := false; - VisualizerStarted := true; - finally - RestoreOpenGLState(); - end; -end; - -procedure TVideoPlayback_ProjectM.VisualizerStop; -begin - if VisualizerStarted then - begin - VisualizerPaused := false; - VisualizerStarted := false; - FreeAndNil(pm); - end; -end; - -procedure TVideoPlayback_ProjectM.VisualizerTogglePause; -begin - VisualizerPaused := not VisualizerPaused; -end; - -procedure TVideoPlayback_ProjectM.GetFrame(Time: Extended); -var - nSamples: cardinal; -begin - if not VisualizerStarted then - Exit; - - if VisualizerPaused then - Exit; - - // get audio data - nSamples := AudioPlayback.GetPCMData(PcmData); - - // generate some data if non is available - if (nSamples = 0) then - nSamples := GetRandomPCMData(PcmData); - - // send audio-data to projectM - if (nSamples > 0) then - pm.AddPCM16Data(PSmallInt(@PcmData), nSamples); - - // store OpenGL state (might be messed up otherwise) - SaveOpenGLState(); - try - // setup projectM's OpenGL state - pm.ResetGL(ScreenW, ScreenH); - - // let projectM render a frame - pm.RenderFrame(); - - {$IFDEF UseTexture} - glBindTexture(GL_TEXTURE_2D, VisualTex); - glFlush(); - glCopyTexImage2D(GL_TEXTURE_2D, 0, GL_RGB, 0, 0, VisualWidth, VisualHeight, 0); - {$ENDIF} - finally - // restore USDX OpenGL state - RestoreOpenGLState(); - end; - - // discard projectM's depth buffer information (avoid overlay) - glClear(GL_DEPTH_BUFFER_BIT); -end; - -{** - * Draws the current frame to screen. - * TODO: this is not used yet. Data is directly drawn on GetFrame(). - *} -procedure TVideoPlayback_ProjectM.DrawGL(Screen: integer); -begin - {$IFDEF UseTexture} - // have a nice black background to draw on - if (Screen = 1) then - begin - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); - end; - - // exit if there's nothing to draw - if not VisualizerStarted then - Exit; - - // setup display - glMatrixMode(GL_PROJECTION); - glPushMatrix(); - glLoadIdentity(); - // Use count of screens instead of 1 for the right corner - // otherwise we would draw the visualization streched over both screens - // another point is that we draw over the at this time drawn first - // screen, if Screen = 2 - gluOrtho2D(0, Screens, 0, 1); - glMatrixMode(GL_MODELVIEW); - glPushMatrix(); - glLoadIdentity(); - - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glTexEnvf(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_REPLACE); - glBindTexture(GL_TEXTURE_2D, VisualTex); - glColor4f(1, 1, 1, 1); - - // draw projectM frame - // Screen is 1 to 2. So current screen is from (Screen - 1) to (Screen) - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f((Screen - 1), 0); - glTexCoord2f(1, 0); glVertex2f(Screen, 0); - glTexCoord2f(1, 1); glVertex2f(Screen, 1); - glTexCoord2f(0, 1); glVertex2f((Screen - 1), 1); - glEnd(); - - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - - // restore state - glMatrixMode(GL_PROJECTION); - glPopMatrix(); - glMatrixMode(GL_MODELVIEW); - glPopMatrix(); - {$ENDIF} -end; - -{** - * Produces random "sound"-data in case no audio-data is available. - * Otherwise the visualization will look rather boring. - *} -function TVideoPlayback_ProjectM.GetRandomPCMData(var Data: TPCMData): Cardinal; -var - i: integer; -begin - // Produce some fake PCM data - if (RndPCMcount mod 500 = 0) then - begin - FillChar(Data, SizeOf(TPCMData), 0); - end - else - begin - for i := 0 to 511 do - begin - Data[i][0] := Random(High(Word)+1); - Data[i][1] := Random(High(Word)+1); - end; - end; - Inc(RndPCMcount); - Result := 512; -end; - - -initialization - MediaManager.Add(TVideoPlayback_ProjectM.Create); - -end. diff --git a/src/menu/UDrawTexture.pas b/src/menu/UDrawTexture.pas deleted file mode 100644 index bc136f11..00000000 --- a/src/menu/UDrawTexture.pas +++ /dev/null @@ -1,139 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UDrawTexture; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UTexture; - -procedure DrawLine(X1, Y1, X2, Y2, ColR, ColG, ColB: real); -procedure DrawQuad(X, Y, W, H, ColR, ColG, ColB: real); -procedure DrawTexture(Texture: TTexture); - -implementation - -uses - gl; - -procedure DrawLine(X1, Y1, X2, Y2, ColR, ColG, ColB: real); -begin - glColor3f(ColR, ColG, ColB); - glBegin(GL_LINES); - glVertex2f(x1, y1); - glVertex2f(x2, y2); - glEnd; -end; - -procedure DrawQuad(X, Y, W, H, ColR, ColG, ColB: real); -begin - glColor3f(ColR, ColG, ColB); - glBegin(GL_QUADS); - glVertex2f(x, y); - glVertex2f(x, y+h); - glVertex2f(x+w, y+h); - glVertex2f(x+w, y); - glEnd; -end; - -procedure DrawTexture(Texture: TTexture); -var - x1, x2, x3, x4: real; - y1, y2, y3, y4: real; - xt1, xt2, xt3, xt4: real; - yt1, yt2, yt3, yt4: real; -begin - with Texture do - begin - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha); - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glDepthRange(0, 10); - glDepthFunc(GL_LEQUAL); -// glDepthFunc(GL_GEQUAL); - glEnable(GL_DEPTH_TEST); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); -// glBlendFunc(GL_SRC_COLOR, GL_ZERO); - glBindTexture(GL_TEXTURE_2D, TexNum); - - x1 := x; - x2 := x; - x3 := x+w*scaleW; - x4 := x+w*scaleW; - y1 := y; - y2 := y+h*scaleH; - y3 := y+h*scaleH; - y4 := y; - if Rot <> 0 then - begin - xt1 := x1 - (x + w/2); - xt2 := x2 - (x + w/2); - xt3 := x3 - (x + w/2); - xt4 := x4 - (x + w/2); - yt1 := y1 - (y + h/2); - yt2 := y2 - (y + h/2); - yt3 := y3 - (y + h/2); - yt4 := y4 - (y + h/2); - - x1 := (x + w/2) + xt1 * cos(Rot) - yt1 * sin(Rot); - x2 := (x + w/2) + xt2 * cos(Rot) - yt2 * sin(Rot); - x3 := (x + w/2) + xt3 * cos(Rot) - yt3 * sin(Rot); - x4 := (x + w/2) + xt4 * cos(Rot) - yt4 * sin(Rot); - - y1 := (y + h/2) + yt1 * cos(Rot) + xt1 * sin(Rot); - y2 := (y + h/2) + yt2 * cos(Rot) + xt2 * sin(Rot); - y3 := (y + h/2) + yt3 * cos(Rot) + xt3 * sin(Rot); - y4 := (y + h/2) + yt4 * cos(Rot) + xt4 * sin(Rot); - - end; - -{ - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex3f(x1, y1, z); - glTexCoord2f(0, TexH); glVertex3f(x2, y2, z); - glTexCoord2f(TexW, TexH); glVertex3f(x3, y3, z); - glTexCoord2f(TexW, 0); glVertex3f(x4, y4, z); - glEnd; -} - - glBegin(GL_QUADS); - glTexCoord2f(TexX1*TexW, TexY1*TexH); glVertex3f(x1, y1, z); - glTexCoord2f(TexX1*TexW, TexY2*TexH); glVertex3f(x2, y2, z); - glTexCoord2f(TexX2*TexW, TexY2*TexH); glVertex3f(x3, y3, z); - glTexCoord2f(TexX2*TexW, TexY1*TexH); glVertex3f(x4, y4, z); - glEnd; - end; - glDisable(GL_DEPTH_TEST); - glDisable(GL_TEXTURE_2D); -end; - -end. diff --git a/src/menu/UMenu.pas b/src/menu/UMenu.pas deleted file mode 100644 index 659d4213..00000000 --- a/src/menu/UMenu.pas +++ /dev/null @@ -1,1762 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenu; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - Math, - gl, - SDL, - UPath, - UMenuBackground, - UMenuButton, - UMenuButtonCollection, - UMenuInteract, - UMenuSelectSlide, - UMenuStatic, - UMenuText, - UMusic, - UTexture, - UThemes; - -type -{ Int16 = SmallInt;} - - PMenu = ^TMenu; - TMenu = class - protected - Background: TMenuBackground; - - Interactions: array of TInteract; - SelInteraction: integer; - - ButtonPos: integer; - Button: array of TButton; - - SelectsS: array of TSelectSlide; - ButtonCollection: array of TButtonCollection; - public - Text: array of TText; - Static: array of TStatic; - mX: integer; // mouse X - mY: integer; // mouse Y - - Fade: integer; // fade type - ShowFinish: boolean; // true if there is no fade - RightMbESC: boolean; // true to simulate ESC keypress when RMB is pressed - - destructor Destroy; override; - constructor Create; overload; virtual; - //constructor Create(Back: string); overload; virtual; // Back is a JPG resource name for background - //constructor Create(Back: string; W, H: integer); overload; virtual; // W and H are the number of overlaps - - // interaction - procedure AddInteraction(Typ, Num: integer); - procedure SetInteraction(Num: integer); virtual; - property Interaction: integer read SelInteraction write SetInteraction; - - // procedure load bg, texts, statics and button collections from themebasic - procedure LoadFromTheme(const ThemeBasic: TThemeBasic); - - procedure PrepareButtonCollections(const Collections: AThemeButtonCollection); - procedure AddButtonCollection(const ThemeCollection: TThemeButtonCollection; const Num: byte); - - // background - procedure AddBackground(ThemedSettings: TThemeBackground); - - // static - function AddStatic(ThemeStatic: TThemeStatic): integer; overload; - function AddStatic(X, Y, W, H: real; const TexName: IPath): integer; overload; - function AddStatic(X, Y, W, H: real; const TexName: IPath; Typ: TTextureType): integer; overload; - function AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType): integer; overload; - function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType): integer; overload; - function AddStatic(X, Y, W, H: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType; Color: integer): integer; overload; - function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; const TexName: IPath; Typ: TTextureType; Color: integer): integer; overload; - function AddStatic(X, Y, W, H, Z: real; ColR, ColG, ColB: real; TexX1, TexY1, TexX2, TexY2: real; const TexName: IPath; Typ: TTextureType; Color: integer; Reflection: boolean; ReflectionSpacing: real): integer; overload; - - // text - function AddText(ThemeText: TThemeText): integer; overload; - function AddText(X, Y: real; const Text_: UTF8String): integer; overload; - function AddText(X, Y: real; Style: integer; Size, ColR, ColG, ColB: real; const Text: UTF8String): integer; overload; - function AddText(X, Y, W: real; Style: integer; Size, ColR, ColG, ColB: real; Align: integer; const Text_: UTF8String; Reflection_: boolean; ReflectionSpacing_: real; Z : real): integer; overload; - - // button - procedure SetButtonLength(Length: cardinal); //Function that Set Length of Button Array in one Step instead of register new Memory for every Button - function AddButton(ThemeButton: TThemeButton): integer; overload; - function AddButton(X, Y, W, H: real; const TexName: IPath): integer; overload; - function AddButton(X, Y, W, H: real; const TexName: IPath; Typ: TTextureType; Reflection: boolean): integer; overload; - function AddButton(X, Y, W, H, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt: real; const TexName: IPath; Typ: TTextureType; Reflection: boolean; ReflectionSpacing, DeSelectReflectionSpacing: real): integer; overload; - procedure ClearButtons; - procedure AddButtonText(AddX, AddY: real; const AddText: UTF8String); overload; - procedure AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; const AddText: UTF8String); overload; - procedure AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); overload; - procedure AddButtonText(CustomButton: TButton; AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); overload; - - // select slide - function AddSelectSlide(ThemeSelectS: TThemeSelectSlide; var Data: integer; const Values: array of UTF8String): integer; overload; - function AddSelectSlide(X, Y, W, H, SkipX, SBGW, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt, - TColR, TColG, TColB, TInt, TDColR, TDColG, TDColB, TDInt, - SBGColR, SBGColG, SBGColB, SBGInt, SBGDColR, SBGDColG, SBGDColB, SBGDInt, - STColR, STColG, STColB, STInt, STDColR, STDColG, STDColB, STDInt: real; - const TexName: IPath; Typ: TTextureType; const SBGName: IPath; SBGTyp: TTextureType; - const Caption: UTF8String; var Data: integer): integer; overload; - procedure AddSelectSlideOption(const AddText: UTF8String); overload; - procedure AddSelectSlideOption(SelectNo: cardinal; const AddText: UTF8String); overload; - procedure UpdateSelectSlideOptions(ThemeSelectSlide: TThemeSelectSlide; SelectNum: integer; const Values: array of UTF8String; var Data: integer); - -// function AddWidget(X, Y : UInt16; WidgetSrc : PSDL_Surface): Int16; -// procedure ClearWidgets(MinNumber : Int16); - procedure FadeTo(Screen: PMenu); overload; - procedure FadeTo(Screen: PMenu; aSound: TAudioPlaybackStream); overload; - //popup hack - procedure CheckFadeTo(Screen: PMenu; Msg: UTF8String); - - function DrawBG: boolean; virtual; - function DrawFG: boolean; virtual; - function Draw: boolean; virtual; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown : boolean): boolean; virtual; - function ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; virtual; - function InRegion(X, Y: real; A: TMouseOverRect): boolean; - function InteractAt(X, Y: real): integer; - function CollectionAt(X, Y: real): integer; - procedure OnShow; virtual; - procedure OnShowFinish; virtual; - procedure OnHide; virtual; - - procedure SetAnimationProgress(Progress: real); virtual; - - function IsSelectable(Int: cardinal): boolean; - - procedure InteractNext; virtual; - procedure InteractCustom(CustomSwitch: integer); virtual; - procedure InteractPrev; virtual; - procedure InteractInc; virtual; - procedure InteractDec; virtual; - procedure InteractNextRow; virtual; // this is for the options screen, so button down makes sense - procedure InteractPrevRow; virtual; // this is for the options screen, so button up makes sense - procedure AddBox(X, Y, W, H: real); - end; - -const - MENU_MDOWN = 8; - MENU_MUP = 0; - - pmMove = 1; - pmClick = 2; - pmUnClick = 3; - - iButton = 0; // interaction type - iText = 2; - iSelectS = 3; - iBCollectionChild = 5; - -// fBlack = 0; // fade type -// fWhite = 1; - -implementation - -uses - UCommon, - UCovers, - UDisplay, - UDrawTexture, - UGraphic, - ULog, - UMain, - USkins, - UTime, - //Background types - UMenuBackgroundNone, - UMenuBackgroundColor, - UMenuBackgroundTexture, - UMenuBackgroundVideo, - UMenuBackgroundFade; - -destructor TMenu.Destroy; -begin - if (Background <> nil) then - begin - Background.Destroy; - end; - //Log.LogError('Unloaded Succesful: ' + ClassName); - inherited; -end; - -constructor TMenu.Create; -begin - inherited; - - Fade := 0;//fWhite; - - SetLength(Static, 0); - SetLength(Button, 0); - - //Set ButtonPos to Autoset Length - ButtonPos := -1; - - Background := nil; - - RightMbESC := true; -end; -{ -constructor TMenu.Create(Back: string); -begin - inherited Create; - - if Back <> '' then - begin -// BackImg := Texture.GetTexture(true, Back, TEXTURE_TYPE_PLAIN, 0); - BackImg := Texture.GetTexture(Back, TEXTURE_TYPE_PLAIN, 0); // new theme system - BackImg.W := 800;//640; - BackImg.H := 600;//480; - BackW := 1; - BackH := 1; - end - else - BackImg.TexNum := 0; - - //Set ButtonPos to Autoset Length - ButtonPos := -1; -end; - -constructor TMenu.Create(Back: string; W, H: integer); -begin - Create(Back); - BackImg.W := BackImg.W / W; - BackImg.H := BackImg.H / H; - BackW := W; - BackH := H; -end; } - -function RGBFloatToInt(R, G, B: double): cardinal; -begin - Result := (Trunc(255 * R) shl 16) or - (Trunc(255 * G) shl 8) or - Trunc(255 * B); -end; - -procedure TMenu.AddInteraction(Typ, Num: integer); -var - IntNum: integer; -begin - IntNum := Length(Interactions); - SetLength(Interactions, IntNum+1); - Interactions[IntNum].Typ := Typ; - Interactions[IntNum].Num := Num; - Interaction := 0; -end; - -procedure TMenu.SetInteraction(Num: integer); -var - OldNum, OldTyp: integer; - NewNum, NewTyp: integer; -begin - // set inactive - OldNum := Interactions[Interaction].Num; - OldTyp := Interactions[Interaction].Typ; - - NewNum := Interactions[Num].Num; - NewTyp := Interactions[Num].Typ; - - case OldTyp of - iButton: Button[OldNum].Selected := false; - iText: Text[OldNum].Selected := false; - iSelectS: SelectsS[OldNum].Selected := false; - //Button Collection Mod - iBCollectionChild: - begin - Button[OldNum].Selected := false; - - // deselect collection if next button is not from collection - if (NewTyp <> iButton) or (Button[NewNum].Parent <> Button[OldNum].Parent) then - ButtonCollection[Button[OldNum].Parent-1].Selected := false; - end; - end; - - // set active - SelInteraction := Num; - case NewTyp of - iButton: Button[NewNum].Selected := true; - iText: Text[NewNum].Selected := true; - iSelectS: SelectsS[NewNum].Selected := true; - - //Button Collection Mod - iBCollectionChild: - begin - Button[NewNum].Selected := true; - ButtonCollection[Button[NewNum].Parent-1].Selected := true; - end; - end; -end; - -//---------------------- -//LoadFromTheme - Load BG, Texts, Statics and -//Button Collections from ThemeBasic -//---------------------- -procedure TMenu.LoadFromTheme(const ThemeBasic: TThemeBasic); -var - I: integer; -begin - //Add Button Collections (Set Button CollectionsLength) - //Button Collections are Created when the first ChildButton is Created - PrepareButtonCollections(ThemeBasic.ButtonCollection); - - //Add Background - AddBackground(ThemeBasic.Background); - - //Add Statics and Texts - for I := 0 to High(ThemeBasic.Static) do - AddStatic(ThemeBasic.Static[I]); - - for I := 0 to High(ThemeBasic.Text) do - AddText(ThemeBasic.Text[I]); -end; - -procedure TMenu.AddBackground(ThemedSettings: TThemeBackground); - var - FileExt: string; - - function IsInArray(const Piece: string; const A: array of string): boolean; - var - I: integer; - begin - Result := false; - - for I := 0 to High(A) do - if (A[I] = Piece) then - begin - Result := true; - Exit; - end; - end; - - function TryBGCreate(Typ: cMenuBackground): boolean; - begin - Result := true; - - try - Background := Typ.Create(ThemedSettings); - except - on E: EMenuBackgroundError do - begin //Background failes to create - Freeandnil(Background); - Result := false; - end; - end; - end; - -begin - if (Background <> nil) then - begin - Background.Destroy; - Background := nil; - end; - - case ThemedSettings.BGType of - bgtAuto: begin //Automaticly choose one out of BGT_Texture, BGT_Video or BGT_Color - - if (Length(ThemedSettings.Tex) > 0) then - begin - - //At first some intelligent try to decide which BG to load - FileExt := LowerCase(Skin.GetTextureFileName(ThemedSettings.Tex).GetExtension.ToUTF8); - - if IsInArray(FileExt, SUPPORTED_EXTS_BACKGROUNDTEXTURE) then - TryBGCreate(TMenuBackgroundTexture) - else if IsInArray(FileExt, SUPPORTED_EXTS_BACKGROUNDVIDEO) then - TryBGCreate(TMenuBackgroundVideo); - - //If the intelligent method don't succeed - //do it by trial and error - if (Background = nil) then - begin - //Try Textured Bg - if not TryBGCreate(TMenuBackgroundTexture) then - TryBgCreate(TMenuBackgroundVideo); //Try Video BG - - //Color is fallback if Background = nil - end; - end; - end; - - bgtColor: begin - try - Background := TMenuBackgroundColor.Create(ThemedSettings); - except - on E: EMenuBackgroundError do - begin - Log.LogError(E.Message); - freeandnil(Background); - end; - end; - end; - - bgtTexture: begin - try - Background := TMenuBackgroundTexture.Create(ThemedSettings); - except - on E: EMenuBackgroundError do - begin - Log.LogError(E.Message); - freeandnil(Background); - end; - end; - end; - - bgtVideo: begin - try - Background := TMenuBackgroundVideo.Create(ThemedSettings); - except - on E: EMenuBackgroundError do - begin - Log.LogError(E.Message); - freeandnil(Background); - end; - end; - end; - - bgtNone: begin - try - Background := TMenuBackgroundNone.Create(ThemedSettings); - except - on E: EMenuBackgroundError do - begin - Log.LogError(E.Message); - freeandnil(Background); - end; - end; - end; - - bgtFade: begin - try - Background := TMenuBackgroundFade.Create(ThemedSettings); - except - on E: EMenuBackgroundError do - begin - Log.LogError(E.Message); - freeandnil(Background); - end; - end; - end; - end; - - //Fallback to None Background or Colored Background - if (Background = nil) then - begin - if (ThemedSettings.BGType = bgtColor) then - Background := TMenuBackgroundNone.Create(ThemedSettings) - else - Background := TMenuBackgroundColor.Create(ThemedSettings) - end; -end; - -//---------------------- -//PrepareButtonCollections: -//Add Button Collections (Set Button CollectionsLength) -//---------------------- -procedure TMenu.PrepareButtonCollections(const Collections: AThemeButtonCollection); -var - I: integer; -begin - SetLength(ButtonCollection, Length(Collections)); - for I := 0 to High(ButtonCollection) do - AddButtonCollection(Collections[I], I); -end; - -//---------------------- -//AddButtonCollection: -//Create a Button Collection; -//---------------------- -procedure TMenu.AddButtonCollection(const ThemeCollection: TThemeButtonCollection; const Num: byte); -var - BT, BTLen: integer; - TempCol, TempDCol: cardinal; - -begin - if (Num > High(ButtonCollection)) then - exit; - - TempCol := 0; - - // colorize hack - if (ThemeCollection.Style.Typ = TEXTURE_TYPE_COLORIZED) then - begin - TempCol := RGBFloatToInt(ThemeCollection.Style.ColR, ThemeCollection.Style.ColG, ThemeCollection.Style.ColB); - TempDCol := RGBFloatToInt(ThemeCollection.Style.DColR, ThemeCollection.Style.DColG, ThemeCollection.Style.DColB); - // give encoded color to GetTexture() - ButtonCollection[Num] := TButtonCollection.Create( - Texture.GetTexture(Skin.GetTextureFileName(ThemeCollection.Style.Tex), TEXTURE_TYPE_COLORIZED, TempCol), - Texture.GetTexture(Skin.GetTextureFileName(ThemeCollection.Style.Tex), TEXTURE_TYPE_COLORIZED, TempDCol)); - end - else - begin - ButtonCollection[Num] := TButtonCollection.Create(Texture.GetTexture( - Skin.GetTextureFileName(ThemeCollection.Style.Tex), ThemeCollection.Style.Typ)); - end; - - //Set Parent menu - ButtonCollection[Num].ScreenButton := @Self.Button; - - //Set Attributes - ButtonCollection[Num].FirstChild := ThemeCollection.FirstChild; - ButtonCollection[Num].CountChilds := ThemeCollection.ChildCount; - ButtonCollection[Num].Parent := Num + 1; - - //Set Style - ButtonCollection[Num].X := ThemeCollection.Style.X; - ButtonCollection[Num].Y := ThemeCollection.Style.Y; - ButtonCollection[Num].W := ThemeCollection.Style.W; - ButtonCollection[Num].H := ThemeCollection.Style.H; - if (ThemeCollection.Style.Typ <> TEXTURE_TYPE_COLORIZED) then - begin - ButtonCollection[Num].SelectColR := ThemeCollection.Style.ColR; - ButtonCollection[Num].SelectColG := ThemeCollection.Style.ColG; - ButtonCollection[Num].SelectColB := ThemeCollection.Style.ColB; - ButtonCollection[Num].DeselectColR := ThemeCollection.Style.DColR; - ButtonCollection[Num].DeselectColG := ThemeCollection.Style.DColG; - ButtonCollection[Num].DeselectColB := ThemeCollection.Style.DColB; - end; - ButtonCollection[Num].SelectInt := ThemeCollection.Style.Int; - ButtonCollection[Num].DeselectInt := ThemeCollection.Style.DInt; - ButtonCollection[Num].Texture.TexX1 := 0; - ButtonCollection[Num].Texture.TexY1 := 0; - ButtonCollection[Num].Texture.TexX2 := 1; - ButtonCollection[Num].Texture.TexY2 := 1; - ButtonCollection[Num].SetSelect(false); - - ButtonCollection[Num].Reflection := ThemeCollection.Style.Reflection; - ButtonCollection[Num].Reflectionspacing := ThemeCollection.Style.ReflectionSpacing; - ButtonCollection[Num].DeSelectReflectionspacing := ThemeCollection.Style.DeSelectReflectionSpacing; - - ButtonCollection[Num].Z := ThemeCollection.Style.Z; - - //Some Things from ButtonFading - ButtonCollection[Num].SelectH := ThemeCollection.Style.SelectH; - ButtonCollection[Num].SelectW := ThemeCollection.Style.SelectW; - - ButtonCollection[Num].Fade := ThemeCollection.Style.Fade; - ButtonCollection[Num].FadeText := ThemeCollection.Style.FadeText; - if (ThemeCollection.Style.Typ = TEXTURE_TYPE_COLORIZED) then - begin - ButtonCollection[Num].FadeTex := Texture.GetTexture( - Skin.GetTextureFileName(ThemeCollection.Style.FadeTex), TEXTURE_TYPE_COLORIZED, TempCol) - end - else - begin - ButtonCollection[Num].FadeTex := Texture.GetTexture( - Skin.GetTextureFileName(ThemeCollection.Style.FadeTex), ThemeCollection.Style.Typ); - end; - ButtonCollection[Num].FadeTexPos := ThemeCollection.Style.FadeTexPos; - - BTLen := Length(ThemeCollection.Style.Text); - for BT := 0 to BTLen-1 do - begin - AddButtonText(ButtonCollection[Num], ThemeCollection.Style.Text[BT].X, ThemeCollection.Style.Text[BT].Y, - ThemeCollection.Style.Text[BT].ColR, ThemeCollection.Style.Text[BT].ColG, ThemeCollection.Style.Text[BT].ColB, - ThemeCollection.Style.Text[BT].Font, ThemeCollection.Style.Text[BT].Size, ThemeCollection.Style.Text[BT].Align, - ThemeCollection.Style.Text[BT].Text); - end; -end; - -function TMenu.AddStatic(ThemeStatic: TThemeStatic): integer; -begin - Result := AddStatic(ThemeStatic.X, ThemeStatic.Y, ThemeStatic.W, ThemeStatic.H, ThemeStatic.Z, - ThemeStatic.ColR, ThemeStatic.ColG, ThemeStatic.ColB, - ThemeStatic.TexX1, ThemeStatic.TexY1, ThemeStatic.TexX2, ThemeStatic.TexY2, - Skin.GetTextureFileName(ThemeStatic.Tex), - ThemeStatic.Typ, $FFFFFF, ThemeStatic.Reflection, ThemeStatic.Reflectionspacing); -end; - -function TMenu.AddStatic(X, Y, W, H: real; const TexName: IPath): integer; -begin - Result := AddStatic(X, Y, W, H, TexName, TEXTURE_TYPE_PLAIN); -end; - -function TMenu.AddStatic(X, Y, W, H: real; - ColR, ColG, ColB: real; - const TexName: IPath; - Typ: TTextureType): integer; -begin - Result := AddStatic(X, Y, W, H, ColR, ColG, ColB, TexName, Typ, $FFFFFF); -end; - -function TMenu.AddStatic(X, Y, W, H, Z: real; - ColR, ColG, ColB: real; - const TexName: IPath; - Typ: TTextureType): integer; -begin - Result := AddStatic(X, Y, W, H, Z, ColR, ColG, ColB, TexName, Typ, $FFFFFF); -end; - -function TMenu.AddStatic(X, Y, W, H: real; - const TexName: IPath; - Typ: TTextureType): integer; -var - StatNum: integer; -begin - // adds static - StatNum := Length(Static); - SetLength(Static, StatNum + 1); - Static[StatNum] := TStatic.Create(Texture.GetTexture(TexName, Typ, $FF00FF)); // new skin - - // configures static - Static[StatNum].Texture.X := X; - Static[StatNum].Texture.Y := Y; - Static[StatNum].Texture.W := W; - Static[StatNum].Texture.H := H; - Static[StatNum].Visible := true; - Result := StatNum; -end; - -function TMenu.AddStatic(X, Y, W, H: real; - ColR, ColG, ColB: real; - const TexName: IPath; - Typ: TTextureType; - Color: integer): integer; -begin - Result := AddStatic(X, Y, W, H, 0, ColR, ColG, ColB, TexName, Typ, Color); -end; - -function TMenu.AddStatic(X, Y, W, H, Z: real; - ColR, ColG, ColB: real; - const TexName: IPath; - Typ: TTextureType; - Color: integer): integer; -begin - Result := AddStatic(X, Y, W, H, Z, ColR, ColG, ColB, 0, 0, 1, 1, TexName, Typ, Color, false, 0); -end; - -function TMenu.AddStatic(X, Y, W, H, Z: real; - ColR, ColG, ColB: real; - TexX1, TexY1, TexX2, TexY2: real; - const TexName: IPath; - Typ: TTextureType; - Color: integer; - Reflection: boolean; - ReflectionSpacing: real): integer; -var - StatNum: integer; -begin - // adds static - StatNum := Length(Static); - SetLength(Static, StatNum + 1); - - // colorize hack - if (Typ = TEXTURE_TYPE_COLORIZED) then - begin - // give encoded color to GetTexture() - Static[StatNum] := TStatic.Create(Texture.GetTexture(TexName, Typ, RGBFloatToInt(ColR, ColG, ColB))); - end - else - begin - Static[StatNum] := TStatic.Create(Texture.GetTexture(TexName, Typ, Color)); // new skin - end; - - // configures static - Static[StatNum].Texture.X := X; - Static[StatNum].Texture.Y := Y; - - //Set height and width via sprite size if omitted - if(H = 0) then - Static[StatNum].Texture.H := Static[StatNum].Texture.H - else - Static[StatNum].Texture.H := H; - - if(W = 0) then - Static[StatNum].Texture.W := Static[StatNum].Texture.W - else - Static[StatNum].Texture.W := W; - - Static[StatNum].Texture.Z := Z; - if (Typ <> TEXTURE_TYPE_COLORIZED) then - begin - Static[StatNum].Texture.ColR := ColR; - Static[StatNum].Texture.ColG := ColG; - Static[StatNum].Texture.ColB := ColB; - end; - Static[StatNum].Texture.TexX1 := TexX1; - Static[StatNum].Texture.TexY1 := TexY1; - Static[StatNum].Texture.TexX2 := TexX2; - Static[StatNum].Texture.TexY2 := TexY2; - Static[StatNum].Texture.Alpha := 1; - Static[StatNum].Visible := true; - - //ReflectionMod - Static[StatNum].Reflection := Reflection; - Static[StatNum].ReflectionSpacing := ReflectionSpacing; - - Result := StatNum; -end; - -function TMenu.AddText(ThemeText: TThemeText): integer; -begin - Result := AddText(ThemeText.X, ThemeText.Y, ThemeText.W, ThemeText.Font, ThemeText.Size, - ThemeText.ColR, ThemeText.ColG, ThemeText.ColB, ThemeText.Align, ThemeText.Text, ThemeText.Reflection, ThemeText.ReflectionSpacing, ThemeText.Z); -end; - -function TMenu.AddText(X, Y: real; const Text_: UTF8String): integer; -var - TextNum: integer; -begin - // adds text - TextNum := Length(Text); - SetLength(Text, TextNum + 1); - Text[TextNum] := TText.Create(X, Y, Text_); - Result := TextNum; -end; - -function TMenu.AddText(X, Y: real; - Style: integer; - Size, ColR, ColG, ColB: real; - const Text: UTF8String): integer; -begin - Result := AddText(X, Y, 0, Style, Size, ColR, ColG, ColB, 0, Text, false, 0, 0); -end; - -function TMenu.AddText(X, Y, W: real; - Style: integer; - Size, ColR, ColG, ColB: real; - Align: integer; - const Text_: UTF8String; - Reflection_: boolean; - ReflectionSpacing_: real; - Z : real): integer; -var - TextNum: integer; -begin - // adds text - TextNum := Length(Text); - SetLength(Text, TextNum + 1); - Text[TextNum] := TText.Create(X, Y, W, Style, Size, ColR, ColG, ColB, Align, Text_, Reflection_, ReflectionSpacing_, Z); - Result := TextNum; -end; - -//Function that Set Length of Button boolean in one Step instead of register new Memory for every Button -procedure TMenu.SetButtonLength(Length: cardinal); -begin - if (ButtonPos = -1) and (Length > 0) then - begin - //Set Length of Button - SetLength(Button, Length); - - //Set ButtonPos to start with 0 - ButtonPos := 0; - end; -end; - -// Method to add a button in our TMenu. It returns the assigned ButtonNumber -function TMenu.AddButton(ThemeButton: TThemeButton): integer; -var - BT: integer; - BTLen: integer; -begin - Result := AddButton(ThemeButton.X, ThemeButton.Y, ThemeButton.W, ThemeButton.H, - ThemeButton.ColR, ThemeButton.ColG, ThemeButton.ColB, ThemeButton.Int, - ThemeButton.DColR, ThemeButton.DColG, ThemeButton.DColB, ThemeButton.DInt, - Skin.GetTextureFileName(ThemeButton.Tex), ThemeButton.Typ, - ThemeButton.Reflection, ThemeButton.Reflectionspacing, ThemeButton.DeSelectReflectionspacing); - - Button[Result].Z := ThemeButton.Z; - - //Button Visibility - Button[Result].Visible := ThemeButton.Visible; - - //Some Things from ButtonFading - Button[Result].SelectH := ThemeButton.SelectH; - Button[Result].SelectW := ThemeButton.SelectW; - - Button[Result].Fade := ThemeButton.Fade; - Button[Result].FadeText := ThemeButton.FadeText; - if (ThemeButton.Typ = TEXTURE_TYPE_COLORIZED) then - begin - Button[Result].FadeTex := Texture.GetTexture( - Skin.GetTextureFileName(ThemeButton.FadeTex), TEXTURE_TYPE_COLORIZED, - RGBFloatToInt(ThemeButton.ColR, ThemeButton.ColG, ThemeButton.ColB)); - end - else - begin - Button[Result].FadeTex := Texture.GetTexture( - Skin.GetTextureFileName(ThemeButton.FadeTex), ThemeButton.Typ); - end; - - Button[Result].FadeTexPos := ThemeButton.FadeTexPos; - - BTLen := Length(ThemeButton.Text); - for BT := 0 to BTLen-1 do - begin - AddButtonText(ThemeButton.Text[BT].X, ThemeButton.Text[BT].Y, - ThemeButton.Text[BT].ColR, ThemeButton.Text[BT].ColG, ThemeButton.Text[BT].ColB, - ThemeButton.Text[BT].Font, ThemeButton.Text[BT].Size, ThemeButton.Text[BT].Align, - ThemeButton.Text[BT].Text); - end; - - // bautton collection mod - if (ThemeButton.Parent <> 0) then - begin - // if collection exists then change interaction to child button - if (@ButtonCollection[ThemeButton.Parent-1] <> nil) then - begin - Interactions[High(Interactions)].Typ := iBCollectionChild; - Button[Result].Visible := false; - - for BT := 0 to BTLen-1 do - Button[Result].Text[BT].Alpha := 0; - - Button[Result].Parent := ThemeButton.Parent; - if (ButtonCollection[ThemeButton.Parent-1].Fade) then - Button[Result].Texture.Alpha := 0; - end; - end; - Log.BenchmarkEnd(6); - Log.LogBenchmark('====> Screen Options32', 6); -end; - -function TMenu.AddButton(X, Y, W, H: real; const TexName: IPath): integer; -begin - Result := AddButton(X, Y, W, H, TexName, TEXTURE_TYPE_PLAIN, false); -end; - -function TMenu.AddButton(X, Y, W, H: real; const TexName: IPath; Typ: TTextureType; Reflection: boolean): integer; -begin - Result := AddButton(X, Y, W, H, 1, 1, 1, 1, 1, 1, 1, 0.5, TexName, TEXTURE_TYPE_PLAIN, Reflection, 15, 15); -end; - -function TMenu.AddButton(X, Y, W, H, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt: real; - const TexName: IPath; - Typ: TTextureType; - Reflection: boolean; - ReflectionSpacing, DeSelectReflectionSpacing: real): integer; -begin - // adds button - //SetLength is used once to reduce Memory usement - if (ButtonPos <> -1) then - begin - Result := ButtonPos; - Inc(ButtonPos) - end - else //Old Method -> Reserve new Memory for every Button - begin - Result := Length(Button); - SetLength(Button, Result + 1); - end; - - // colorize hack - if (Typ = TEXTURE_TYPE_COLORIZED) then - begin - // give encoded color to GetTexture() - Button[Result] := TButton.Create(Texture.GetTexture(TexName, Typ, RGBFloatToInt(ColR, ColG, ColB)), - Texture.GetTexture(TexName, Typ, RGBFloatToInt(DColR, DColG, DColB))); - end - else - begin - Button[Result] := TButton.Create(Texture.GetTexture(TexName, Typ)); - end; - - // configures button - Button[Result].X := X; - Button[Result].Y := Y; - Button[Result].W := W; - Button[Result].H := H; - if (Typ <> TEXTURE_TYPE_COLORIZED) then - begin - Button[Result].SelectColR := ColR; - Button[Result].SelectColG := ColG; - Button[Result].SelectColB := ColB; - Button[Result].DeselectColR := DColR; - Button[Result].DeselectColG := DColG; - Button[Result].DeselectColB := DColB; - end; - Button[Result].SelectInt := Int; - Button[Result].DeselectInt := DInt; - Button[Result].Texture.TexX1 := 0; - Button[Result].Texture.TexY1 := 0; - Button[Result].Texture.TexX2 := 1; - Button[Result].Texture.TexY2 := 1; - Button[Result].SetSelect(false); - - Button[Result].Reflection := Reflection; - Button[Result].Reflectionspacing := ReflectionSpacing; - Button[Result].DeSelectReflectionspacing := DeSelectReflectionSpacing; - - // button collection mod - Button[Result].Parent := 0; - - // adds interaction - AddInteraction(iButton, Result); - Interaction := 0; -end; - -procedure TMenu.ClearButtons; -begin - Setlength(Button, 0); -end; - -// method to draw our tmenu and all his child buttons -function TMenu.DrawBG: boolean; -begin - Background.Draw; - Result := true; -end; - -function TMenu.DrawFG: boolean; -var - J: integer; -begin - // We don't forget about newly implemented static for nice skin ... - for J := 0 to High(Static) do - Static[J].Draw; - - // ... and slightly implemented menutext unit - for J := 0 to High(Text) do - Text[J].Draw; - - // Draw all ButtonCollections - for J := 0 to High(ButtonCollection) do - ButtonCollection[J].Draw; - - // Second, we draw all of our buttons - for J := 0 to High(Button) do - Button[J].Draw; - - for J := 0 to High(SelectsS) do - SelectsS[J].Draw; - - // Third, we draw all our widgets - // for J := 0 to Length(WidgetsSrc) - 1 do - // SDL_BlitSurface(WidgetsSrc[J], nil, ParentBackBuf, WidgetsRect[J]); - Result := true; -end; - -function TMenu.Draw: boolean; -begin - DrawBG; - DrawFG; - Result := true; -end; - -{ -function TMenu.GetNextScreen(): PMenu; -begin - Result := NextScreen; -end; -} - -{ -function TMenu.AddWidget(X, Y: UInt16; WidgetSrc: PSDL_Surface): Int16; -var - WidgetNum: Int16; -begin - if (Assigned(WidgetSrc)) then - begin - WidgetNum := Length(WidgetsSrc); - - SetLength(WidgetsSrc, WidgetNum + 1); - SetLength(WidgetsRect, WidgetNum + 1); - - WidgetsSrc[WidgetNum] := WidgetSrc; - WidgetsRect[WidgetNum] := new(PSDL_Rect); - WidgetsRect[WidgetNum]^.x := X; - WidgetsRect[WidgetNum]^.y := Y; - WidgetsRect[WidgetNum]^.w := WidgetSrc^.w; - WidgetsRect[WidgetNum]^.h := WidgetSrc^.h; - - Result := WidgetNum; - end - else - Result := -1; -end; -} - -{ -procedure TMenu.ClearWidgets(MinNumber: Int16); -var - J: Int16; -begin - for J := MinNumber to (Length(WidgetsSrc) - 1) do - begin - SDL_FreeSurface(WidgetsSrc[J]); - dispose(WidgetsRect[J]); - end; - - SetLength(WidgetsSrc, MinNumber); - SetLength(WidgetsRect, MinNumber); -end; -} - -function TMenu.IsSelectable(Int: cardinal): boolean; -begin - Result := true; - case Interactions[Int].Typ of - //Button - iButton: Result := Button[Interactions[Int].Num].Visible and Button[Interactions[Int].Num].Selectable; - - //Select Slide - iSelectS: Result := SelectsS[Interactions[Int].Num].Visible; - - //ButtonCollection Child - iBCollectionChild: - Result := (ButtonCollection[Button[Interactions[Int].Num].Parent - 1].FirstChild - 1 = Int) and ((Interactions[Interaction].Typ <> iBCollectionChild) or (Button[Interactions[Interaction].Num].Parent <> Button[Interactions[Int].Num].Parent)); - end; -end; - -// implemented for the sake of usablility -// [curser down] picks the button left to the actual atm -// this behaviour doesn't make sense for two rows of buttons -procedure TMenu.InteractPrevRow; -var - Int: integer; -begin -// these two procedures just make sense for at least 5 buttons, because we -// usually start a second row when there are more than 4 buttons - Int := Interaction; - - Int := Int - ceil(Length(Interactions) / 2); - - //Set Interaction - if ((Int < 0) or (Int > Length(Interactions) - 1)) then - Int := Interaction // invalid button, keep current one - else - Interaction := Int; // select row above -end; - -procedure TMenu.InteractNextRow; -var - Int: integer; -begin - Int := Interaction; - - Int := Int + ceil(Length(Interactions) / 2); - - //Set Interaction - if ((Int < 0) or (Int > Length(Interactions) - 1)) then - Int := Interaction // invalid button, keep current one - else - Interaction := Int; // select row above -end; - -procedure TMenu.InteractNext; -var - Int: integer; -begin - Int := Interaction; - - // change interaction as long as it's needed - repeat - Int := (Int + 1) mod Length(Interactions); - - //If no Interaction is Selectable Simply Select Next - if (Int = Interaction) then - Break; - - until IsSelectable(Int); - - //Set Interaction - Interaction := Int; -end; - -procedure TMenu.InteractPrev; -var - Int: integer; -begin - Int := Interaction; - - // change interaction as long as it's needed - repeat - Int := Int - 1; - if Int = -1 then - Int := High(Interactions); - - //If no Interaction is Selectable Simply Select Next - if (Int = Interaction) then - Break; - until IsSelectable(Int); - - //Set Interaction - Interaction := Int -end; - -procedure TMenu.InteractCustom(CustomSwitch: integer); -{ needed only for below -var - Num: integer; - Typ: integer; - Again: boolean; -} -begin - //Code Commented atm, because it needs to be Rewritten - //it doesn't work with Button Collections - {then - begin - CustomSwitch:= CustomSwitch*(-1); - Again := true; - // change interaction as long as it's needed - while (Again = true) do - begin - Num := SelInteraction - CustomSwitch; - if Num = -1 then - Num := High(Interactions); - Interaction := Num; - Again := false; // reset, default to accept changing interaction - - // checking newly interacted element - Num := Interactions[Interaction].Num; - Typ := Interactions[Interaction].Typ; - case Typ of - iButton: - begin - if Button[Num].Selectable = false then - Again := true; - end; - end; // case - end; // while - end - else if num>0 then - begin - Again := true; - // change interaction as long as it's needed - while (Again = true) do - begin - Num := (Interaction + CustomSwitch) Mod Length(Interactions); - Interaction := Num; - Again := false; // reset, default to accept changing interaction - - // checking newly interacted element - Num := Interactions[Interaction].Num; - Typ := Interactions[Interaction].Typ; - case Typ of - iButton: - begin - if Button[Num].Selectable = false then - Again := true; - end; - end; // case - end; // while - end } -end; - -procedure TMenu.FadeTo(Screen: PMenu); -begin - Display.Fade := 0; - Display.NextScreen := Screen; -end; - -procedure TMenu.FadeTo(Screen: PMenu; aSound: TAudioPlaybackStream); -begin - FadeTo( Screen ); - AudioPlayback.PlaySound( aSound ); -end; - -procedure OnSaveEncodingError(Value: boolean; Data: Pointer); -begin - Display.CheckOK := Value; - if (Value) then - begin - //Hack to Finish Singscreen correct on Exit with Q Shortcut - if (Display.NextScreenWithCheck = nil) then - begin - if (Display.CurrentScreen = @ScreenSing) then - ScreenSing.Finish - else if (Display.CurrentScreen = @ScreenSingModi) then - ScreenSingModi.Finish; - end; - end - else - begin - Display.NextScreenWithCheck := nil; - end; -end; - -//popup hack -procedure TMenu.CheckFadeTo(Screen: PMenu; Msg: UTF8String); -begin - Display.Fade := 0; - Display.NextScreenWithCheck := Screen; - Display.CheckOK := false; - ScreenPopupCheck.ShowPopup(msg, OnSaveEncodingError, nil, false); -end; - -procedure TMenu.AddButtonText(AddX, AddY: real; const AddText: UTF8String); -begin - AddButtonText(AddX, AddY, 1, 1, 1, AddText); -end; - -procedure TMenu.AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; const AddText: UTF8String); -var - Il: integer; -begin - with Button[High(Button)] do - begin - Il := Length(Text); - SetLength(Text, Il+1); - Text[Il] := TText.Create(X + AddX, Y + AddY, AddText); - Text[Il].ColR := ColR; - Text[Il].ColG := ColG; - Text[Il].ColB := ColB; - Text[Il].Int := 1;//0.5; - end; -end; - -procedure TMenu.AddButtonText(AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); -var - Il: integer; -begin - with Button[High(Button)] do - begin - Il := Length(Text); - SetLength(Text, Il+1); - Text[Il] := TText.Create(X + AddX, Y + AddY, AddText); - Text[Il].ColR := ColR; - Text[Il].ColG := ColG; - Text[Il].ColB := ColB; - Text[Il].Int := 1;//0.5; - Text[Il].Style := Font; - Text[Il].Size := Size; - Text[Il].Align := Align; - end; -end; - -procedure TMenu.AddButtonText(CustomButton: TButton; AddX, AddY: real; ColR, ColG, ColB: real; Font: integer; Size: integer; Align: integer; const AddText: UTF8String); -var - Il: integer; -begin - with CustomButton do - begin - Il := Length(Text); - SetLength(Text, Il+1); - Text[Il] := TText.Create(X + AddX, Y + AddY, AddText); - Text[Il].ColR := ColR; - Text[Il].ColG := ColG; - Text[Il].ColB := ColB; - Text[Il].Int := 1;//0.5; - Text[Il].Style := Font; - Text[Il].Size := Size; - Text[Il].Align := Align; - end; -end; - -function TMenu.AddSelectSlide(ThemeSelectS: TThemeSelectSlide; var Data: integer; const Values: array of UTF8String): integer; -var - SO: integer; -begin - Result := AddSelectSlide(ThemeSelectS.X, ThemeSelectS.Y, ThemeSelectS.W, ThemeSelectS.H, ThemeSelectS.SkipX, ThemeSelectS.SBGW, - ThemeSelectS.ColR, ThemeSelectS.ColG, ThemeSelectS.ColB, ThemeSelectS.Int, - ThemeSelectS.DColR, ThemeSelectS.DColG, ThemeSelectS.DColB, ThemeSelectS.DInt, - ThemeSelectS.TColR, ThemeSelectS.TColG, ThemeSelectS.TColB, ThemeSelectS.TInt, - ThemeSelectS.TDColR, ThemeSelectS.TDColG, ThemeSelectS.TDColB, ThemeSelectS.TDInt, - ThemeSelectS.SBGColR, ThemeSelectS.SBGColG, ThemeSelectS.SBGColB, ThemeSelectS.SBGInt, - ThemeSelectS.SBGDColR, ThemeSelectS.SBGDColG, ThemeSelectS.SBGDColB, ThemeSelectS.SBGDInt, - ThemeSelectS.STColR, ThemeSelectS.STColG, ThemeSelectS.STColB, ThemeSelectS.STInt, - ThemeSelectS.STDColR, ThemeSelectS.STDColG, ThemeSelectS.STDColB, ThemeSelectS.STDInt, - Skin.GetTextureFileName(ThemeSelectS.Tex), TEXTURE_TYPE_COLORIZED, - Skin.GetTextureFileName(ThemeSelectS.TexSBG), TEXTURE_TYPE_COLORIZED, - ThemeSelectS.Text, Data); - for SO := 0 to High(Values) do - AddSelectSlideOption(Values[SO]); - - SelectsS[High(SelectsS)].Text.Size := ThemeSelectS.TextSize; - - SelectsS[High(SelectsS)].Texture.Z := ThemeSelectS.Z; - SelectsS[High(SelectsS)].TextureSBG.Z := ThemeSelectS.Z; - - SelectsS[High(SelectsS)].showArrows := ThemeSelectS.showArrows; - SelectsS[High(SelectsS)].oneItemOnly := ThemeSelectS.oneItemOnly; - - //Generate Lines - SelectsS[High(SelectsS)].GenLines; - - SelectsS[High(SelectsS)].SelectedOption := SelectsS[High(SelectsS)].SelectOptInt; // refresh -end; - -function TMenu.AddSelectSlide(X, Y, W, H, SkipX, SBGW, ColR, ColG, ColB, Int, DColR, DColG, DColB, DInt, - TColR, TColG, TColB, TInt, TDColR, TDColG, TDColB, TDInt, - SBGColR, SBGColG, SBGColB, SBGInt, SBGDColR, SBGDColG, SBGDColB, SBGDInt, - STColR, STColG, STColB, STInt, STDColR, STDColG, STDColB, STDInt: real; - const TexName: IPath; Typ: TTextureType; const SBGName: IPath; SBGTyp: TTextureType; - const Caption: UTF8String; var Data: integer): integer; -var - S: integer; - I: integer; -begin - S := Length(SelectsS); - SetLength(SelectsS, S + 1); - SelectsS[S] := TSelectSlide.Create; - - if (Typ = TEXTURE_TYPE_COLORIZED) then - SelectsS[S].Texture := Texture.GetTexture(TexName, Typ, RGBFloatToInt(ColR, ColG, ColB)) - else - SelectsS[S].Texture := Texture.GetTexture(TexName, Typ); - SelectsS[S].X := X; - SelectsS[S].Y := Y; - SelectsS[S].W := W; - SelectsS[S].H := H; - - SelectsS[S].ColR := ColR; - SelectsS[S].ColG := ColG; - SelectsS[S].ColB := ColB; - SelectsS[S].Int := Int; - SelectsS[S].DColR := DColR; - SelectsS[S].DColG := DColG; - SelectsS[S].DColB := DColB; - SelectsS[S].DInt := DInt; - - if (SBGTyp = TEXTURE_TYPE_COLORIZED) then - SelectsS[S].TextureSBG := Texture.GetTexture(SBGName, SBGTyp, RGBFloatToInt(SBGColR, SBGColG, SBGColB)) - else - SelectsS[S].TextureSBG := Texture.GetTexture(SBGName, SBGTyp); - - SelectsS[High(SelectsS)].Tex_SelectS_ArrowL := Tex_SelectS_ArrowL; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.X := X + W + SkipX; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.Y := Y; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.W := Tex_SelectS_ArrowL.W; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowL.H := Tex_SelectS_ArrowL.H; - - SelectsS[High(SelectsS)].Tex_SelectS_ArrowR := Tex_SelectS_ArrowR; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.X := X + W + SkipX + SBGW - Tex_SelectS_ArrowR.W; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.Y := Y; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.W := Tex_SelectS_ArrowR.W; - SelectsS[High(SelectsS)].Tex_SelectS_ArrowR.H := Tex_SelectS_ArrowR.H; - - SelectsS[S].TextureSBG.X := X + W + SkipX; - SelectsS[S].TextureSBG.Y := Y; - SelectsS[S].SBGW := SBGW; - SelectsS[S].TextureSBG.H := H; - SelectsS[S].SBGColR := SBGColR; - SelectsS[S].SBGColG := SBGColG; - SelectsS[S].SBGColB := SBGColB; - SelectsS[S].SBGInt := SBGInt; - SelectsS[S].SBGDColR := SBGDColR; - SelectsS[S].SBGDColG := SBGDColG; - SelectsS[S].SBGDColB := SBGDColB; - SelectsS[S].SBGDInt := SBGDInt; - - SelectsS[S].Text.X := X + 20; - SelectsS[S].Text.Y := Y + (SelectsS[S].TextureSBG.H / 2) - 15; - SelectsS[S].Text.Text := Caption; - SelectsS[S].Text.Size := 30; - SelectsS[S].Text.Visible := true; - SelectsS[S].TColR := TColR; - SelectsS[S].TColG := TColG; - SelectsS[S].TColB := TColB; - SelectsS[S].TInt := TInt; - SelectsS[S].TDColR := TDColR; - SelectsS[S].TDColG := TDColG; - SelectsS[S].TDColB := TDColB; - SelectsS[S].TDInt := TDInt; - - SelectsS[S].STColR := STColR; - SelectsS[S].STColG := STColG; - SelectsS[S].STColB := STColB; - SelectsS[S].STInt := STInt; - SelectsS[S].STDColR := STDColR; - SelectsS[S].STDColG := STDColG; - SelectsS[S].STDColB := STDColB; - SelectsS[S].STDInt := STDInt; - - // new - SelectsS[S].Texture.TexX1 := 0; - SelectsS[S].Texture.TexY1 := 0; - SelectsS[S].Texture.TexX2 := 1; - SelectsS[S].Texture.TexY2 := 1; - SelectsS[S].TextureSBG.TexX1 := 0; - SelectsS[S].TextureSBG.TexY1 := 0; - SelectsS[S].TextureSBG.TexX2 := 1; - SelectsS[S].TextureSBG.TexY2 := 1; - - // Sets Data to copy the value of selectops to global value; - SelectsS[S].PData := @Data; - // Configures Select options - {//SelectsS[S].TextOpt[0].Text := IntToStr(I+1); - SelectsS[S].TextOpt[0].Size := 30; - SelectsS[S].TextOpt[0].Align := 1; - - SelectsS[S].TextOpt[0].ColR := SelectsS[S].STDColR; - SelectsS[S].TextOpt[0].ColG := SelectsS[S].STDColG; - SelectsS[S].TextOpt[0].ColB := SelectsS[S].STDColB; - SelectsS[S].TextOpt[0].Int := SelectsS[S].STDInt; - SelectsS[S].TextOpt[0].Visible := true; } - - // Sets default value of selectopt from Data; - SelectsS[S].SelectedOption := Data; - - // Disables default selection - SelectsS[S].SetSelect(false); - - {// Configures 3 select options - for I := 0 to 2 do - begin - SelectsS[S].TextOpt[I].X := SelectsS[S].TextureSBG.X + 20 + (50 + 20) + (150 - 20) * I; - SelectsS[S].TextOpt[I].Y := SelectsS[S].TextureSBG.Y + 20; - SelectsS[S].TextOpt[I].Text := IntToStr(I+1); - SelectsS[S].TextOpt[I].Size := 30; - SelectsS[S].TextOpt[I].Align := 1; - - SelectsS[S].TextOpt[I].ColR := SelectsS[S].STDColR; - SelectsS[S].TextOpt[I].ColG := SelectsS[S].STDColG; - SelectsS[S].TextOpt[I].ColB := SelectsS[S].STDColB; - SelectsS[S].TextOpt[I].Int := SelectsS[S].STDInt; - SelectsS[S].TextOpt[I].Visible := true; - end;} - - // adds interaction - AddInteraction(iSelectS, S); - Result := S; -end; - -procedure TMenu.AddSelectSlideOption(const AddText: UTF8String); -begin - AddSelectSlideOption(High(SelectsS), AddText); -end; - -procedure TMenu.AddSelectSlideOption(SelectNo: cardinal; const AddText: UTF8String); -var - SO: integer; -begin - SO := Length(SelectsS[SelectNo].TextOptT); - - SetLength(SelectsS[SelectNo].TextOptT, SO + 1); - SelectsS[SelectNo].TextOptT[SO] := AddText; -{ - SelectsS[S].SelectedOption := SelectsS[S].SelectOptInt; // refresh - - if SO = Selects[S].PData^ then - Selects[S].SelectedOption := SO; -} -end; - -procedure TMenu.UpdateSelectSlideOptions(ThemeSelectSlide: TThemeSelectSlide; - SelectNum: integer; const Values: array of UTF8String; var Data: integer); -var - SO: integer; -begin - SetLength(SelectsS[SelectNum].TextOptT, 0); - for SO := 0 to High(Values) do - AddSelectSlideOption(SelectNum, Values[SO]); - - SelectsS[SelectNum].GenLines; - -// SelectsS[SelectNum].SelectedOption := SelectsS[SelectNum].SelectOptInt; // refresh -// SelectS[SelectNum].SetSelectOpt(Data); -// SelectS[SelectNum].SelectedOption := 0;//Data; - -// Log.LogError(IntToStr(High(SelectsS[SelectNum].TextOptT))); -// if 0 <= High(SelectsS[SelectNum].TextOptT) then - - SelectsS[SelectNum].PData := @Data; - SelectsS[SelectNum].SelectedOption := Data; -end; - -procedure TMenu.InteractInc; -var - Num: integer; - Value: integer; -begin - case Interactions[Interaction].Typ of - iSelectS: begin - Num := Interactions[Interaction].Num; - Value := SelectsS[Num].SelectedOption; -// Value := (Value + 1) Mod (Length(SelectsS[Num].TextOptT)); - - // limit - Value := Value + 1; - if Value <= High(SelectsS[Num].TextOptT) then - SelectsS[Num].SelectedOption := Value; - end; - //Button Collection Mod - iBCollectionChild: - begin - - //Select Next Button in Collection - for Num := 1 to High(Button) do - begin - Value := (Interaction + Num) Mod Length(Button); - if Value = 0 then - begin - InteractNext; - Break; - end; - if (Button[Value].Parent = Button[Interaction].Parent) then - begin - Interaction := Value; - Break; - end; - end; - end; - //interact Next if there is Nothing to Change - else InteractNext; - end; -end; - -procedure TMenu.InteractDec; -var - Num: integer; - Value: integer; -begin - case Interactions[Interaction].Typ of - iSelectS: begin - Num := Interactions[Interaction].Num; - Value := SelectsS[Num].SelectedOption; - Value := Value - 1; -// if Value = -1 then -// Value := High(SelectsS[Num].TextOptT); - - if Value >= 0 then - SelectsS[Num].SelectedOption := Value; - end; - //Button Collection Mod - iBCollectionChild: - begin - //Select Prev Button in Collection - for Num := High(Button) downto 1 do - begin - Value := (Interaction + Num) Mod Length(Button); - if Value = High(Button) then - begin - InteractPrev; - Break; - end; - if (Button[Value].Parent = Button[Interaction].Parent) then - begin - Interaction := Value; - Break; - end; - end; - end; - // interact prev if there is nothing to change - else - begin - InteractPrev; - // if buttoncollection with more than 1 entry then select last entry - if (Button[Interactions[Interaction].Num].Parent <> 0) and (ButtonCollection[Button[Interactions[Interaction].Num].Parent-1].CountChilds > 1) then - begin - //Select Last Child - for Num := High(Button) downto 1 do - begin - Value := (Interaction + Num) Mod Length(Button); - if (Button[Value].Parent = Button[Interaction].Parent) then - begin - Interaction := Value; - Break; - end; - end; - end; - end; - end; -end; - -procedure TMenu.AddBox(X, Y, W, H: real); -begin - AddStatic(X, Y, W, H, 0, 0, 0, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); - AddStatic(X+2, Y+2, W-4, H-4, 1, 1, 1, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); -end; - -procedure TMenu.OnShow; -begin - // FIXME: this needs some work. First, there should be a variable like - // VideoBackground so we can check whether a video-background is enabled or not. - // Second, a video should be stopped if the screen is hidden, but the Video.Stop() - // method is not implemented by now. This is necessary for theme-switching too. - // At the moment videos cannot be turned off without restarting USDX. - - {// check if a background texture was found - if (BackImg.TexNum = 0) then - begin - // try to open an animated background - // Note: newer versions of ffmpeg are able to open images like jpeg - // so do not pass an image's filename to VideoPlayback.Open() - if fileexists( fFileName ) then - begin - if VideoPlayback.Open( fFileName ) then - begin - VideoBGTimer.SetTime(0); - VideoPlayback.Play; - end; - end; - end; } - if (Background = nil) then - AddBackground(DEFAULT_BACKGROUND); - - Background.OnShow; -end; - -procedure TMenu.OnShowFinish; -begin - // nothing -end; - -procedure TMenu.OnHide; -begin - // nothing - Background.OnFinish; -end; - -function TMenu.ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - // nothing - Result := true; -end; - -function TMenu.ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; -var - nBut: integer; - Action: TMouseClickAction; -begin - //default mouse parsing: clicking generates return keypress, - // mousewheel selects in select slide - //override ParseMouse to customize - Result := true; - - if RightMbESC and (MouseButton = SDL_BUTTON_RIGHT) and BtnDown then - begin - //if RightMbESC is set, send ESC keypress - Result:=ParseInput(SDLK_ESCAPE, 0, true); - end; - - nBut := InteractAt(X, Y); - if nBut >= 0 then - begin - //select on mouse-over - if nBut <> Interaction then - SetInteraction(nBut); - - Action := maNone; - - if (BtnDown) then - begin - if (MouseButton = SDL_BUTTON_LEFT) then - begin - //click button or SelectS - if (Interactions[nBut].Typ = iSelectS) then - Action := SelectsS[Interactions[nBut].Num].OnClick((X / Screen.w) * RenderW, (Y / Screen.h) * RenderH) - else - Action := maReturn; - end - else if (MouseButton = SDL_BUTTON_WHEELDOWN) then - begin //forward on select slide with mousewheel - if (Interactions[nBut].Typ = iSelectS) then - Action := maRight; - end - else if (MouseButton = SDL_BUTTON_WHEELUP) then - begin //backward on select slide with mousewheel - if (Interactions[nBut].Typ = iSelectS) then - Action := maLeft; - end; - end; - - // do the action we have to do ;) - case Action of - maReturn: Result := ParseInput(SDLK_RETURN, 0, true); - maLeft: Result := ParseInput(SDLK_LEFT, 0, true); - maRight: Result := ParseInput(SDLK_RIGHT, 0, true); - end; - end - else - begin - nBut := CollectionAt(X, Y); - if (nBut >= 0) and (not ButtonCollection[nBut].Selected) then - begin - // if over button collection, that is not already selected - // -> select first child but don't allow click - nBut := ButtonCollection[nBut].FirstChild - 1; - if nBut <> Interaction then - SetInteraction(nBut); - end; - end; -end; - -function TMenu.InRegion(X, Y: real; A: TMouseOverRect): boolean; -begin - // transfer mousecords to the 800x600 raster we use to draw - X := (X / Screen.w) * RenderW; - Y := (Y / Screen.h) * RenderH; - - // check whether A contains X and Y - Result := (X >= A.X) and (X <= A.X + A.W) and (Y >= A.Y) and (Y <= A.Y + A.H); -end; - -//takes x,y coordinates and returns the interaction number -//of the control at this position -function TMenu.InteractAt(X, Y: real): integer; -var - i, nBut: integer; -begin - Result := -1; - for i := Low(Interactions) to High(Interactions) do - begin - case Interactions[i].Typ of - iButton: - if InRegion(X, Y, Button[Interactions[i].Num].GetMouseOverArea) and - Button[Interactions[i].Num].Visible then - begin - Result:=i; - exit; - end; - iBCollectionChild: - if InRegion(X, Y, Button[Interactions[i].Num].GetMouseOverArea) then - begin - Result:=i; - exit; - end; - iSelectS: - if InRegion(X, Y, SelectSs[Interactions[i].Num].GetMouseOverArea) then - begin - Result:=i; - exit; - end; - end; - end; -end; - -//takes x,y coordinates and returns the button collection id -function TMenu.CollectionAt(X, Y: real): integer; -var - i, nBut: integer; -begin - Result := -1; - for i:= Low(ButtonCollection) to High(ButtonCollection) do - begin - if InRegion(X, Y, ButtonCollection[i].GetMouseOverArea) and - ButtonCollection[i].Visible then - begin - Result:=i; - exit; - end; - end; -end; - -procedure TMenu.SetAnimationProgress(Progress: real); -begin - // nothing -end; - -end. diff --git a/src/menu/UMenuBackgroundFade.pas b/src/menu/UMenuBackgroundFade.pas deleted file mode 100644 index 6d877baa..00000000 --- a/src/menu/UMenuBackgroundFade.pas +++ /dev/null @@ -1,176 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuBackgroundFade; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UThemes, - UTexture, - UMenuBackground, - UPath; - -//TMenuBackgroundFade - Background Fade In for Overlay screens -//-------- - -type - TMenuBackgroundFade = class (TMenuBackground) - private - Tex: TTexture; - Color: TRGB; - Alpha: real; - - useTexture: boolean; - - FadeTime: cardinal; - public - constructor Create(const ThemedSettings: TThemeBackground); override; - procedure OnShow; override; - procedure Draw; override; - destructor Destroy; override; - end; - -const - FADEINTIME = 1500; //Time the bg fades in - -implementation -uses - sdl, - gl, - glext, - USkins, - UCommon, - UGraphic; - -constructor TMenuBackgroundFade.Create(const ThemedSettings: TThemeBackground); -var - texFilename: IPath; -begin - inherited; - FadeTime := 0; - - Color := ThemedSettings.Color; - Alpha := ThemedSettings.Alpha; - if (Length(ThemedSettings.Tex) > 0) then - begin - texFilename := Skin.GetTextureFileName(ThemedSettings.Tex); - Tex := Texture.GetTexture(texFilename, TEXTURE_TYPE_PLAIN); - - UseTexture := (Tex.TexNum <> 0); - end - else - UseTexture := false; - - if (not UseTexture) then - FreeandNil(Tex); -end; - -destructor TMenuBackgroundFade.Destroy; -begin - //Why isn't there any Tex.free method? - {if UseTexture then - FreeandNil(Tex); } - inherited; -end; - -procedure TMenuBackgroundFade.OnShow; -begin - FadeTime := SDL_GetTicks; -end; - -procedure TMenuBackgroundFade.Draw; -var - Progress: real; -begin - if FadeTime = 0 then - Progress := Alpha - else - Progress := Alpha * (SDL_GetTicks - FadeTime) / FADEINTIME; - - if Progress > Alpha then - begin - FadeTime := 0; - Progress := Alpha; - end; - - if (UseTexture) then - begin //Draw Texture to Screen - if (ScreenAct = 1) then //Clear just once when in dual screen mode - glClear(GL_DEPTH_BUFFER_BIT); - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glColorRGB(Color, Progress); - glBindTexture(GL_TEXTURE_2D, Tex.TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY1*Tex.TexH); - glVertex2f(0, 0); - - glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY2*Tex.TexH); - glVertex2f(0, 600); - - glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY2*Tex.TexH); - glVertex2f(800, 600); - - glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY1*Tex.TexH); - glVertex2f(800, 0); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); - end - else - begin //Clear Screen w/ progress Alpha + Color - if (ScreenAct = 1) then //Clear just once when in dual screen mode - glClear(GL_DEPTH_BUFFER_BIT); - - glDisable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glColorRGB(Color, Progress); - - glBegin(GL_QUADS); - glVertex2f(0, 0); - glVertex2f(0, 600); - glVertex2f(800, 600); - glVertex2f(800, 0); - glEnd; - - glDisable(GL_BLEND); - end; -end; - -end. diff --git a/src/menu/UMenuBackgroundTexture.pas b/src/menu/UMenuBackgroundTexture.pas deleted file mode 100644 index f71637ff..00000000 --- a/src/menu/UMenuBackgroundTexture.pas +++ /dev/null @@ -1,126 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuBackgroundTexture; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UThemes, - UTexture, - UMenuBackground, - UPath; - -//TMenuBackgroundColor - Background Color -//-------- - -type - TMenuBackgroundTexture = class (TMenuBackground) - private - Tex: TTexture; - Color: TRGB; - public - constructor Create(const ThemedSettings: TThemeBackground); override; - procedure Draw; override; - destructor Destroy; override; - end; - -const - SUPPORTED_EXTS_BACKGROUNDTEXTURE: array[0..13] of string = ('.png', '.bmp', '.jpg', '.jpeg', '.gif', '.pnm', '.ppm', '.pgm', '.pbm', '.xpm', '.lbm', '.pcx', '.tga', '.tiff'); - -implementation -uses - USkins, - UCommon, - SysUtils, - gl, - glext, - UGraphic; - -constructor TMenuBackgroundTexture.Create(const ThemedSettings: TThemeBackground); -var - texFilename: IPath; -begin - inherited; - - if (Length(ThemedSettings.Tex) = 0) then - raise EMenuBackgroundError.Create('TMenuBackgroundTexture: No texture filename present'); - - Color := ThemedSettings.Color; - - texFilename := Skin.GetTextureFileName(ThemedSettings.Tex); - Tex := Texture.GetTexture(texFilename, TEXTURE_TYPE_PLAIN); - - if (Tex.TexNum = 0) then - begin - freeandnil(Tex); - raise EMenuBackgroundError.Create('TMenuBackgroundTexture: Can''t load texture'); - end; -end; - -destructor TMenuBackgroundTexture.Destroy; -begin - //freeandnil(Tex); <- this causes an Access Violation o0 - inherited; -end; - -procedure TMenuBackgroundTexture.Draw; -begin - If (ScreenAct = 1) then //Clear just once when in dual screen mode - glClear(GL_DEPTH_BUFFER_BIT); - - glColorRGB(Color); - - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - - glBindTexture(GL_TEXTURE_2D, Tex.TexNum); - - glBegin(GL_QUADS); - glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY1*Tex.TexH); - glVertex2f(0, 0); - - glTexCoord2f(Tex.TexX1*Tex.TexW, Tex.TexY2*Tex.TexH); - glVertex2f(0, 600); - - glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY2*Tex.TexH); - glVertex2f(800, 600); - - glTexCoord2f(Tex.TexX2*Tex.TexW, Tex.TexY1*Tex.TexH); - glVertex2f(800, 0); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2D); -end; - -end. diff --git a/src/menu/UMenuBackgroundVideo.pas b/src/menu/UMenuBackgroundVideo.pas deleted file mode 100644 index 9d265764..00000000 --- a/src/menu/UMenuBackgroundVideo.pas +++ /dev/null @@ -1,203 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuBackgroundVideo; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UThemes, - UMenuBackground, - UVideo, - UPath; - -//TMenuBackgroundColor - Background Color -//-------- - -type - //DefaultBGVideoPlayback = TVideoPlayback_FFmpeg; - -{type - TBGVideoPool = class; - - PBGVideoPoolItem = ^TBGVideoPoolItem; - TBGVideoPoolItem = record - Parent: TBGVideoPool; - VideoPlayback = IVideoPlayback; - ReferenceCounter: cardinal; //Number of Creations - end; - - TBGVideo = class - private - myItem: PBGVideoPoolItem; - public - constructor Create(Item: PBGVideoPoolItem); override; - - function GetVideoPlayback: IVideoPlayback; - procedure Draw; - - destructor Destroy; - end; - - TBGVideoPool = class - private - Items: PBGVideoPoolItem; - public - constructor Create; - - function GetBGVideo(filename: IPath): TBGVideo; - procedure RemoveItem( - procedure FreeAllItems; - - destructor Destroy; - end; - -type } - TMenuBackgroundVideo = class (TMenuBackground) - private - fFilename: IPath; - public - constructor Create(const ThemedSettings: TThemeBackground); override; - procedure OnShow; override; - procedure Draw; override; - procedure OnFinish; override; - destructor Destroy; override; - end; - -{var - BGVideoPool: TBGVideoPool; } -const - SUPPORTED_EXTS_BACKGROUNDVIDEO: array[0..6] of string = ('.avi', '.mov', '.divx', '.mpg', '.mp4', '.mpeg', '.m2v'); - -implementation - -uses - gl, - glext, - UMusic, - SysUtils, - UTime, - USkins, - UCommon, - UGraphic; - -constructor TMenuBackgroundVideo.Create(const ThemedSettings: TThemeBackground); -begin - inherited; - if (Length(ThemedSettings.Tex) = 0) then - raise EMenuBackgroundError.Create('TMenuBackgroundVideo: No video filename present'); - - fFileName := Skin.GetTextureFileName(ThemedSettings.Tex); - if fFilename.IsFile and VideoPlayback.Open(fFileName) then - begin - VideoBGTimer.SetTime(0); - VideoPlayback.Play; - end - else - raise EMenuBackgroundError.Create('TMenuBackgroundVideo: Can''t load background video: ' + fFilename.ToNative); -end; - -destructor TMenuBackgroundVideo.Destroy; -begin - -end; - -procedure TMenuBackgroundVideo.OnShow; -begin - if VideoPlayback.Open( fFileName ) then - begin - VideoBGTimer.SetTime(0); - VideoPlayback.Play; - end; -end; - -procedure TMenuBackgroundVideo.OnFinish; -begin - -end; - -procedure TMenuBackgroundVideo.Draw; -begin - If (ScreenAct = 1) then //Clear just once when in dual screen mode - glClear(GL_DEPTH_BUFFER_BIT); - - VideoPlayback.GetFrame(VideoBGTimer.GetTime()); - // FIXME: why do we draw on screen 2? Seems to be wrong. - VideoPlayback.DrawGL(2); -end; - -// Implementation of TBGVideo -//-------- -{constructor TBGVideo.Create(Item: PBGVideoPoolItem); -begin - myItem := PBGVideoPoolItem; - Inc(myItem.ReferenceCounter); -end; - -destructor TBGVideo.Destroy; -begin - Dec(myItem.ReferenceCounter); -end; - -function TBGVideo.GetVideoPlayback: IVideoPlayback; -begin - -end; - -procedure TBGVideo.Draw; -begin - -end; - -// Implementation of TBGVideoPool -//-------- - -constructor TBGVideoPool.Create; -begin - -end; - -destructor TBGVideoPool.Destroy; -begin - -end; - -function TBGVideoPool.GetBGVideo(filename: IPath): TBGVideo; -begin - -end; - -procedure TBGVideoPool.FreeAllItems; -begin - -end; } - -end. diff --git a/src/menu/UMenuButton.pas b/src/menu/UMenuButton.pas deleted file mode 100644 index 868a86f3..00000000 --- a/src/menu/UMenuButton.pas +++ /dev/null @@ -1,647 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuButton; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - TextGL, - UTexture, - gl, - UMenuText, - SDL, - UMenuInteract; - -type - CButton = class of TButton; - - TButton = class - protected - SelectBool: boolean; - - FadeProgress: real; - FadeLastTick: cardinal; - - DeSelectW, - DeSelectH, - PosX, - PosY: real; - - - public - Text: array of TText; - Texture: TTexture; // Button Screen position and size - Texture2: TTexture; // second texture only used for fading full resolution covers - - Colorized: boolean; - DeSelectTexture: TTexture; // texture for colorized hack - - FadeTex: TTexture; //Texture for beautiful fading - FadeTexPos: byte; //Pos of the FadeTexture (0: Top, 1: Left, 2: Bottom, 3: Right) - - DeselectType: integer; // not used yet - Visible: boolean; - - Reflection: boolean; - Reflectionspacing, - DeSelectReflectionspacing: real; - - Fade, - FadeText: boolean; - - Selectable: boolean; - - //Number of the Parent Collection, 0 if in no Collection - Parent: byte; - - SelectColR, - SelectColG, - SelectColB, - SelectInt, - SelectTInt: real; - //Fade Mod - SelectW: real; - SelectH: real; - - DeselectColR, - DeselectColG, - DeselectColB, - DeselectInt, - DeselectTInt: real; - - procedure SetY(Value: real); - procedure SetX(Value: real); - procedure SetW(Value: real); - procedure SetH(Value: real); - - procedure SetSelect(Value: boolean); virtual; - property X: real read PosX write SetX; - property Y: real read PosY write SetY; - property Z: real read Texture.z write Texture.z; - property W: real read DeSelectW write SetW; - property H: real read DeSelectH write SetH; - property Selected: boolean read SelectBool write SetSelect; - - procedure Draw; virtual; - - constructor Create(); overload; - constructor Create(Textura: TTexture); overload; - constructor Create(Textura, DSTexture: TTexture); overload; - destructor Destroy; override; - - function GetMouseOverArea: TMouseOverRect; - end; - -implementation - -uses - SysUtils, - UDrawTexture; - -procedure TButton.SetX(Value: real); -{var - dx: real; - T: integer; // text} -begin - {dY := Value - Texture.y; - - Texture.X := Value; - - for T := 0 to High(Text) do - Text[T].X := Text[T].X + dY;} - - PosX := Value; - if (FadeTex.TexNum = 0) then - Texture.X := Value; - -end; - -procedure TButton.SetY(Value: real); -{var - dY: real; - T: integer; // text} -begin - {dY := Value - PosY; - - - for T := 0 to High(Text) do - Text[T].Y := Text[T].Y + dY;} - - PosY := Value; - if (FadeTex.TexNum = 0) then - Texture.y := Value; -end; - -procedure TButton.SetW(Value: real); -begin - if SelectW = DeSelectW then - SelectW := Value; - - DeSelectW := Value; - - if not Fade then - begin - if SelectBool then - Texture.W := SelectW - else - Texture.W := DeSelectW; - end; -end; - -procedure TButton.SetH(Value: real); -begin - if SelectH = DeSelectH then - SelectH := Value; - - DeSelectH := Value; - - if not Fade then - begin - if SelectBool then - Texture.H := SelectH - else - Texture.H := DeSelectH; - end; -end; - -procedure TButton.SetSelect(Value : boolean); -var - T: integer; -begin - SelectBool := Value; - - if (Value) then - begin - Texture.ColR := SelectColR; - Texture.ColG := SelectColG; - Texture.ColB := SelectColB; - Texture.Int := SelectInt; - - Texture2.ColR := SelectColR; - Texture2.ColG := SelectColG; - Texture2.ColB := SelectColB; - Texture2.Int := SelectInt; - - for T := 0 to High(Text) do - Text[T].Int := SelectTInt; - - //Fade Mod - if Fade then - begin - if (FadeProgress <= 0) then - FadeProgress := 0.125; - end - else - begin - Texture.W := SelectW; - Texture.H := SelectH; - end; - end - else - begin - Texture.ColR := DeselectColR; - Texture.ColG := DeselectColG; - Texture.ColB := DeselectColB; - Texture.Int := DeselectInt; - - Texture2.ColR := DeselectColR; - Texture2.ColG := DeselectColG; - Texture2.ColB := DeselectColB; - Texture2.Int := DeselectInt; - - for T := 0 to High(Text) do - Text[T].Int := DeselectTInt; - - //Fade Mod - if Fade then - begin - if (FadeProgress >= 1) then - FadeProgress := 0.875; - end - else - begin - Texture.W := DeSelectW; - Texture.H := DeSelectH; - end; - end; -end; - -// ***** Public methods ****** // - -procedure TButton.Draw; -var - T: integer; - Tick: cardinal; - Spacing: real; -begin - if Visible then - begin - //Fade Mod - T:=0; - if Fade then - begin - if (FadeProgress < 1) and (FadeProgress > 0) then - begin - Tick := SDL_GetTicks() div 16; - if (Tick <> FadeLastTick) then - begin - FadeLastTick := Tick; - - if SelectBool then - FadeProgress := FadeProgress + 0.125 - else - FadeProgress := FadeProgress - 0.125; - - if (FadeText) then - begin - for T := 0 to high(Text) do - begin - Text[T].MoveX := (SelectW - DeSelectW) * FadeProgress; - Text[T].MoveY := (SelectH - DeSelectH) * FadeProgress; - end; - end; - - end; - end; - - //Method without Fade Texture - if (FadeTex.TexNum = 0) then - begin - Texture.W := DeSelectW + (SelectW - DeSelectW) * FadeProgress; - Texture.H := DeSelectH + (SelectH - DeSelectH) * FadeProgress; - DeSelectTexture.W := Texture.W; - DeSelectTexture.H := Texture.H; - end - else //method with Fade Texture - begin - Texture.W := DeSelectW; - Texture.H := DeSelectH; - DeSelectTexture.W := Texture.W; - DeSelectTexture.H := Texture.H; - - FadeTex.ColR := Texture.ColR; - FadeTex.ColG := Texture.ColG; - FadeTex.ColB := Texture.ColB; - FadeTex.Int := Texture.Int; - - FadeTex.Z := Texture.Z; - - FadeTex.Alpha := Texture.Alpha; - FadeTex.TexX1 := 0; - FadeTex.TexX2 := 1; - FadeTex.TexY1 := 0; - FadeTex.TexY2 := 1; - - case FadeTexPos of - 0: //FadeTex on Top - begin - //Standard Texture - Texture.X := PosX; - Texture.Y := PosY + (SelectH - DeSelectH) * FadeProgress; - DeSelectTexture.X := Texture.X; - DeSelectTexture.Y := Texture.Y; - //Fade Tex - FadeTex.X := PosX; - FadeTex.Y := PosY; - FadeTex.W := Texture.W; - FadeTex.H := (SelectH - DeSelectH) * FadeProgress; - FadeTex.ScaleW := Texture.ScaleW; - //Some Hack that Fixes a little Space between both Textures - FadeTex.TexY2 := 0.9; - end; - 1: //FadeTex on Left - begin - //Standard Texture - Texture.X := PosX + (SelectW - DeSelectW) * FadeProgress; - Texture.Y := PosY; - DeSelectTexture.X := Texture.X; - DeSelectTexture.Y := Texture.Y; - //Fade Tex - FadeTex.X := PosX; - FadeTex.Y := PosY; - FadeTex.H := Texture.H; - FadeTex.W := (SelectW - DeSelectW) * FadeProgress; - FadeTex.ScaleH := Texture.ScaleH; - //Some Hack that Fixes a little Space between both Textures - FadeTex.TexX2 := 0.9; - end; - 2: //FadeTex on Bottom - begin - //Standard Texture - Texture.X := PosX; - Texture.Y := PosY; - DeSelectTexture.X := Texture.X; - DeSelectTexture.Y := Texture.Y; - //Fade Tex - FadeTex.X := PosX; - FadeTex.Y := PosY + (SelectH - DeSelectH) * FadeProgress;; - FadeTex.W := Texture.W; - FadeTex.H := (SelectH - DeSelectH) * FadeProgress; - FadeTex.ScaleW := Texture.ScaleW; - //Some Hack that Fixes a little Space between both Textures - FadeTex.TexY1 := 0.1; - end; - 3: //FadeTex on Right - begin - //Standard Texture - Texture.X := PosX; - Texture.Y := PosY; - DeSelectTexture.X := Texture.X; - DeSelectTexture.Y := Texture.Y; - //Fade Tex - FadeTex.X := PosX + (SelectW - DeSelectW) * FadeProgress; - FadeTex.Y := PosY; - FadeTex.H := Texture.H; - FadeTex.W := (SelectW - DeSelectW) * FadeProgress; - FadeTex.ScaleH := Texture.ScaleH; - //Some Hack that Fixes a little Space between both Textures - FadeTex.TexX1 := 0.1; - end; - end; - end; - end - else if (FadeText) then - begin - Text[T].MoveX := (SelectW - DeSelectW); - Text[T].MoveY := (SelectH - DeSelectH); - end; - - if SelectBool or (FadeProgress > 0) or not Colorized then - DrawTexture(Texture) - else - begin - DeSelectTexture.X := Texture.X; - DeSelectTexture.Y := Texture.Y; - DeSelectTexture.H := Texture.H; - DeSelectTexture.W := Texture.W; - DrawTexture(DeSelectTexture); - end; - - //Draw FadeTex - if (FadeTex.TexNum > 0) then - DrawTexture(FadeTex); - - if Texture2.Alpha > 0 then - begin - Texture2.ScaleW := Texture.ScaleW; - Texture2.ScaleH := Texture.ScaleH; - - Texture2.X := Texture.X; - Texture2.Y := Texture.Y; - Texture2.W := Texture.W; - Texture2.H := Texture.H; - - Texture2.ColR := Texture.ColR; - Texture2.ColG := Texture.ColG; - Texture2.ColB := Texture.ColB; - Texture2.Int := Texture.Int; - - Texture2.Z := Texture.Z; - - DrawTexture(Texture2); - end; - - //Reflection Mod - if (Reflection) then // Draw Reflections - begin - if (FadeProgress <> 0) and (FadeProgress <> 1) then - begin - Spacing := DeSelectReflectionspacing - (DeSelectReflectionspacing - Reflectionspacing) * FadeProgress; - end - else if SelectBool then - Spacing := Reflectionspacing - else - Spacing := DeSelectReflectionspacing; - - if SelectBool or not Colorized then - with Texture do - begin - //Bind Tex and GL Attributes - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - - glDepthRange(0, 10); - glDepthFunc(GL_LEQUAL); - glEnable(GL_DEPTH_TEST); - - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, TexNum); - - //Draw - glBegin(GL_QUADS);//Top Left - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha-0.3); - glTexCoord2f(TexX1*TexW, TexY2*TexH); - glVertex3f(x, y+h*scaleH+ Spacing, z); - - //Bottom Left - glColor4f(ColR * Int, ColG * Int, ColB * Int, 0); - glTexCoord2f(TexX1*TexW, TexY1+TexH*0.5); - glVertex3f(x, y+h*scaleH + h*scaleH/2 + Spacing, z); - - - //Bottom Right - glColor4f(ColR * Int, ColG * Int, ColB * Int, 0); - glTexCoord2f(TexX2*TexW, TexY1+TexH*0.5); - glVertex3f(x+w*scaleW, y+h*scaleH + h*scaleH/2 + Spacing, z); - - //Top Right - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha-0.3); - glTexCoord2f(TexX2*TexW, TexY2*TexH); - glVertex3f(x+w*scaleW, y+h*scaleH + Spacing, z); - glEnd; - - glDisable(GL_TEXTURE_2D); - glDisable(GL_DEPTH_TEST); - glDisable(GL_BLEND); - end - else - with DeSelectTexture do - begin - //Bind Tex and GL Attributes - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - - glDepthRange(0, 10); - glDepthFunc(GL_LEQUAL); - glEnable(GL_DEPTH_TEST); - - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, TexNum); - - //Draw - glBegin(GL_QUADS);//Top Left - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha-0.3); - glTexCoord2f(TexX1*TexW, TexY2*TexH); - glVertex3f(x, y+h*scaleH+ Spacing, z); - - //Bottom Left - glColor4f(ColR * Int, ColG * Int, ColB * Int, 0); - glTexCoord2f(TexX1*TexW, TexY1+TexH*0.5); - glVertex3f(x, y+h*scaleH + h*scaleH/2 + Spacing, z); - - //Bottom Right - glColor4f(ColR * Int, ColG * Int, ColB * Int, 0); - glTexCoord2f(TexX2*TexW, TexY1+TexH*0.5); - glVertex3f(x+w*scaleW, y+h*scaleH + h*scaleH/2 + Spacing, z); - - //Top Right - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha-0.3); - glTexCoord2f(TexX2*TexW, TexY2*TexH); - glVertex3f(x+w*scaleW, y+h*scaleH + Spacing, z); - glEnd; - - glDisable(GL_TEXTURE_2D); - glDisable(GL_DEPTH_TEST); - glDisable(GL_BLEND); - end; - end; - - for T := 0 to High(Text) do - begin - Text[T].Draw; - end; - end; -end; - -function TButton.GetMouseOverArea: TMouseOverRect; -begin - if (FadeTex.TexNum = 0) then - begin - Result.X := Texture.X; - Result.Y := Texture.Y; - Result.W := Texture.W; - Result.H := Texture.H; - end - else - begin - case FadeTexPos of - 0: begin // fade tex on top - Result.X := Texture.X; - Result.Y := FadeTex.Y; - Result.W := Texture.W; - Result.H := FadeTex.H + Texture.H; - end; - - 1: begin // fade tex on left side - Result.X := FadeTex.X; - Result.Y := Texture.Y; - Result.W := FadeTex.W + Texture.W; - Result.H := Texture.H; - end; - - 2: begin // fade tex on bottom - Result.X := Texture.X; - Result.Y := Texture.Y; - Result.W := Texture.W; - Result.H := FadeTex.H + Texture.H; - end; - - 3: begin // fade tex on right side - Result.X := Texture.X; - Result.Y := Texture.Y; - Result.W := FadeTex.W + Texture.W; - Result.H := Texture.H; - end; - end; - end; -end; - - -destructor TButton.Destroy; -begin - inherited; -end; - -constructor TButton.Create(); -begin - inherited Create; - // We initialize all to 0, nil or false - Visible := true; - SelectBool := false; - DeselectType := 0; - Selectable := true; - Reflection := false; - Colorized := false; - - SelectColR := 1; - SelectColG := 1; - SelectColB := 1; - SelectInt := 1; - SelectTInt := 1; - - DeselectColR := 1; - DeselectColG := 1; - DeselectColB := 1; - DeselectInt := 0.5; - DeselectTInt := 1; - - Fade := false; - FadeTex.TexNum := 0; - FadeProgress := 0; - FadeText := false; - SelectW := DeSelectW; - SelectH := DeSelectH; - - PosX := 0; - PosY := 0; - - Parent := 0; -end; - -constructor TButton.Create(Textura: TTexture); -begin - Create(); - Texture := Textura; - DeSelectTexture := Textura; - Texture.ColR := 0; - Texture.ColG := 0.5; - Texture.ColB := 0; - Texture.Int := 1; - Colorized := false; -end; - -// Button has the texture-type "colorized" -// Two textures are generated, one with Col the other one with DCol -// Check UMenu.pas line 680 to see the call ( AddButton() ) -constructor TButton.Create(Textura, DSTexture: TTexture); -begin - Create(); - Texture := Textura; - DeSelectTexture := DSTexture; - Texture.ColR := 1; - Texture.ColG := 1; - Texture.ColB := 1; - Texture.Int := 1; - Colorized := true; -end; - -end. diff --git a/src/menu/UMenuButtonCollection.pas b/src/menu/UMenuButtonCollection.pas deleted file mode 100644 index 8b7a1c3f..00000000 --- a/src/menu/UMenuButtonCollection.pas +++ /dev/null @@ -1,101 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuButtonCollection; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenuButton; - -type - //---------------- - //TButtonCollection - //No Extra Attributes or Functions ATM - //---------------- - AButton = array of TButton; - PAButton = ^AButton; - TButtonCollection = class(TButton) - //num of the First Button, that can be Selected - FirstChild: byte; - CountChilds: byte; - - ScreenButton: PAButton; - - procedure SetSelect(Value : boolean); override; - procedure Draw; override; - end; - -implementation - -procedure TButtonCollection.SetSelect(Value : boolean); -var - Index: integer; -begin - inherited; - - //Set Visible for Every Button that is a Child of this ButtonCollection - if (not Fade) then - for Index := 0 to High(ScreenButton^) do - if (ScreenButton^[Index].Parent = Parent) then - ScreenButton^[Index].Visible := Value; -end; - -procedure TButtonCollection.Draw; -var - I, J: integer; -begin - inherited; - //If fading is activated, Fade Child Buttons - if (Fade) then - begin - for I := 0 to High(ScreenButton^) do - if (ScreenButton^[I].Parent = Parent) then - begin - if (FadeProgress < 0.5) then - begin - ScreenButton^[I].Visible := SelectBool; - - for J := 0 to High(ScreenButton^[I].Text) do - ScreenButton^[I].Text[J].Visible := SelectBool; - end - else - begin - ScreenButton^[I].Texture.Alpha := (FadeProgress-0.666)*3; - - for J := 0 to High(ScreenButton^[I].Text) do - ScreenButton^[I].Text[J].Alpha := (FadeProgress-0.666)*3; - end; - end; - end; -end; - -end. diff --git a/src/menu/UMenuEqualizer.pas b/src/menu/UMenuEqualizer.pas deleted file mode 100644 index 8f57e44a..00000000 --- a/src/menu/UMenuEqualizer.pas +++ /dev/null @@ -1,320 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuEqualizer; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMusic, - UThemes; - -type - //---------------- - //Tms_Equalizer - //Class displaying an equalizer (Songscreen) - //---------------- - Tms_Equalizer = class(TObject) - private - FFTData: TFFTData; // moved here to avoid stack overflows - BandData: array of byte; - RefreshTime: cardinal; - - Source: IAudioPlayback; - - procedure Analyse; - public - X: integer; - Y: integer; - Z: real; - - W: integer; - H: integer; - Space: integer; - - Visible: boolean; - Alpha: real; - Color: TRGB; - - Direction: boolean; - BandLength: integer; - - Reflection: boolean; - Reflectionspacing: real; - - - constructor Create(Source: IAudioPlayback; mySkin: TThemeEqualizer); - - procedure Draw; - procedure SetBands(Value: byte); - function GetBands: byte; - property Bands: byte read GetBands write SetBands; - procedure SetSource(newSource: IAudioPlayback); - end; - -implementation -uses - math, - SDL, - gl, - glext; - -constructor Tms_Equalizer.Create(Source: IAudioPlayback; mySkin: TThemeEqualizer); -var - I: integer; -begin - if (Source <> nil) then - begin - X := mySkin.X; - Y := mySkin.Y; - W := mySkin.W; - H := mySkin.H; - Z := mySkin.Z; - - Space := mySkin.Space; - - Visible := mySkin.Visible; - Alpha := mySkin.Alpha; - Color.R := mySkin.ColR; - Color.G := mySkin.ColG; - Color.B := mySkin.ColB; - - Direction := mySkin.Direction; - Bands := mySkin.Bands; - BandLength := mySkin.Length; - - Reflection := mySkin.Reflection; - Reflectionspacing := mySkin.Reflectionspacing; - - Self.Source := Source; - - - //Check if Visible - if (Bands <= 0) or - (BandLength <= 0) or - (W <= 0) or - (H <= 0) or - (Alpha <= 0) then - Visible := false; - - //ClearArray - for I := low(BandData) to high(BandData) do - BandData[I] := 3; - end - else - Visible := false; -end; - -//-------- -// evaluate FFT-Data -//-------- -procedure Tms_Equalizer.Analyse; -var - I: integer; - ChansPerBand: byte; // channels per band - MaxChannel: integer; - Pos: real; - CurBand: integer; -begin - Source.GetFFTData(FFTData); - - Pos := 0; - // use only the first approx. 92 of 256 FFT-channels (approx. up to 8kHz - ChansPerBand := ceil(92 / Bands); // How much channels are used for one Band - MaxChannel := ChansPerBand * Bands - 1; - - // Change Lengths - for i := 0 to MaxChannel do - begin - // Gain higher freq. data so that the bars are visible - if i > 35 then - FFTData[i] := FFTData[i] * 8 - else if i > 11 then - FFTData[i] := FFTData[i] * 4.5 - else - FFTData[i] := FFTData[i] * 1.1; - - // clamp data - if (FFTData[i] > 1) then - FFTData[i] := 1; - - // Get max. pos - if (FFTData[i] * BandLength > Pos) then - Pos := FFTData[i] * BandLength; - - // Check if this is the last channel in the band - if ((i+1) mod ChansPerBand = 0) then - begin - CurBand := i div ChansPerBand; - - // Smooth delay if new equalizer is lower than the old one - if ((BandData[CurBand] > Pos) and (BandData[CurBand] > 1)) then - BandData[CurBand] := BandData[CurBand] - 1 - else - BandData[CurBand] := Round(Pos); - - Pos := 0; - end; - end; -end; - -//-------- -// Draw SpectrumAnalyser, Call Analyse -//-------- -procedure Tms_Equalizer.Draw; -var - CurTime: cardinal; - PosX, PosY: real; - I, J: integer; - Diff: real; - - function GetAlpha(Diff: single): single; - begin - if Direction then - Result := (Alpha * 0.6) * (0.5 - Diff/(BandLength * (H + Space))) - else - Result := (Alpha * 0.6) * (0.5 - Diff/(Bands * (H + Space))); - end; - -begin - if (Visible) and not (AudioPlayback.Finished) then - begin - //Call Analyse if necessary - CurTime := SDL_GetTicks(); - if (CurTime > RefreshTime) then - begin - Analyse; - - RefreshTime := CurTime + 44; - end; - - //Draw Equalizer Bands - // Setup OpenGL - glColorRGB(Color, Alpha); - glDisable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - - // Set position of the first equalizer bar - PosY := Y; - PosX := X; - - // Draw bars for each band - for I := 0 to High(BandData) do - begin - // Reset to lower or left position depending on the drawing-direction - if Direction then // Vertical bars - // FIXME: Is Y the upper or lower coordinate? - PosY := Y //+ (H + Space) * BandLength - else // Horizontal bars - PosX := X; - - // Draw the bar as a stack of blocks - for J := 1 to BandData[I] do - begin - // Draw block - glBegin(GL_QUADS); - glVertex3f(PosX, PosY, Z); - glVertex3f(PosX, PosY+H, Z); - glVertex3f(PosX+W, PosY+H, Z); - glVertex3f(PosX+W, PosY, Z); - glEnd; - - if (Reflection) and (J <= BandLength div 2) then - begin - Diff := (Y-PosY) + H; - - //Draw Reflection - if Direction then - begin - glBegin(GL_QUADS); - glColorRGB(Color, GetAlpha(Diff)); - glVertex3f(PosX, Diff + Y + ReflectionSpacing, Z); - - //bottom v - glColorRGB(Color, GetAlpha(Diff + H)); - glVertex3f(PosX, Diff + Y+H + ReflectionSpacing, Z); - glVertex3f(PosX+W, Diff + Y+H + ReflectionSpacing, Z); - - glColorRGB(Color, GetAlpha(Diff)); - glVertex3f(PosX+W, Diff + Y + ReflectionSpacing, Z); - glEnd; - end - else - begin - glBegin(GL_QUADS); - glColorRGB(Color, GetAlpha(Diff)); - glVertex3f(PosX, Diff + Y + (H + Space)*Bands + ReflectionSpacing, Z); - glVertex3f(PosX, Diff + Y+H + (H + Space)*Bands + ReflectionSpacing, Z); - glVertex3f(PosX+W, Diff + Y+H + (H + Space)*Bands + ReflectionSpacing, Z); - glVertex3f(PosX+W, Diff + Y + (H + Space)*Bands + ReflectionSpacing, Z); - glColorRGB(Color, GetAlpha(Diff + H)); - glEnd; - end; - - glColorRGB(Color, Alpha); - end; - - - // Calc position of the bar's next block - if Direction then // Vertical bars - PosY := PosY - H - Space - else // Horizontal bars - PosX := PosX + W + Space; - end; - - // Calc position of the next bar - if Direction then // Vertical bars - PosX := PosX + W + Space - else // Horizontal bars - PosY := PosY + H + Space; - end; - - - end; -end; - -procedure Tms_Equalizer.SetBands(Value: byte); -begin - SetLength(BandData, Value); -end; - -function Tms_Equalizer.GetBands: byte; -begin - Result := Length(BandData); -end; - -procedure Tms_Equalizer.SetSource(newSource: IAudioPlayback); -begin - if (newSource <> nil) then - Source := newSource; -end; - -end. \ No newline at end of file diff --git a/src/menu/UMenuInteract.pas b/src/menu/UMenuInteract.pas deleted file mode 100644 index 7cb92025..00000000 --- a/src/menu/UMenuInteract.pas +++ /dev/null @@ -1,54 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuInteract; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -type - TInteract = record // for moving thru menu - Typ: integer; // 0 - button, 1 - select, 2 - Text, 3 - Select SLide, 5 - ButtonCollection Child - Num: integer; // number of this item in proper list like buttons, selects - end; - - { to handle the area where the mouse is over a control } - TMouseOverRect = record - X, Y: Real; - W, H: Real; - end; - - { to handle the on click action } - TMouseClickAction = (maNone, maReturn, maLeft, maRight); - -implementation - -end. - \ No newline at end of file diff --git a/src/menu/UMenuSelectSlide.pas b/src/menu/UMenuSelectSlide.pas deleted file mode 100644 index 11be4c2a..00000000 --- a/src/menu/UMenuSelectSlide.pas +++ /dev/null @@ -1,439 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuSelectSlide; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - gl, - TextGL, - UMenuText, - UTexture, - UMenuInteract; - -type - PSelectSlide = ^TSelectSlide; - TSelectSlide = class - private - SelectBool: boolean; - public - // objects - Text: TText; // Main text describing option - TextOpt: array of TText; // 3 texts in the position of possible options - TextOptT: array of UTF8String; // array of names for possible options - - Texture: TTexture; // Select Texture - TextureSBG: TTexture; // Background Selections Texture -// TextureS: array of TTexture; // Selections Texture (not used) - - Tex_SelectS_ArrowL: TTexture; // Texture for left arrow - Tex_SelectS_ArrowR: TTexture; // Texture for right arrow - - SelectOptInt: integer; - PData: ^integer; - - //For automatically Setting LineCount - Lines: byte; - - //Arrows on/off - showArrows: boolean; //default is false - - //whether to show one item or all that fit into the select - oneItemOnly: boolean; //default is false - - //Visibility - Visible: boolean; - - // for selection and deselection - // main static - ColR: real; - ColG: real; - ColB: real; - Int: real; - DColR: real; - DColG: real; - DColB: real; - DInt: real; - - // main text - TColR: real; - TColG: real; - TColB: real; - TInt: real; - TDColR: real; - TDColG: real; - TDColB: real; - TDInt: real; - - // selection background static - SBGColR: real; - SBGColG: real; - SBGColB: real; - SBGInt: real; - SBGDColR: real; - SBGDColG: real; - SBGDColB: real; - SBGDInt: real; - - // selection text - STColR: real; - STColG: real; - STColB: real; - STInt: real; - STDColR: real; - STDColG: real; - STDColB: real; - STDInt: real; - - // position and size - property X: real read Texture.x write Texture.x; - property Y: real read Texture.y write Texture.y; - property W: real read Texture.w write Texture.w; - property H: real read Texture.h write Texture.h; -// property X2: real read Texture2.x write Texture2.x; -// property Y2: real read Texture2.y write Texture2.y; -// property W2: real read Texture2.w write Texture2.w; -// property H2: real read Texture2.h write Texture2.h; - - property SBGW: real read TextureSBG.w write TextureSBG.w; - - // procedures - procedure SetSelect(Value: boolean); - property Selected: boolean read SelectBool write SetSelect; - procedure SetSelectOpt(Value: integer); - property SelectedOption: integer read SelectOptInt write SetSelectOpt; - procedure Draw; - constructor Create; - - //Automatically Generate Lines (Texts) - procedure genLines; - - function GetMouseOverArea: TMouseOverRect; - function OnClick(X, Y: Real): TMouseClickAction; - end; - -implementation - -uses - math, - SysUtils, - UDrawTexture, - ULog; - -// ------------ Select -constructor TSelectSlide.Create; -begin - inherited Create; - Text := TText.Create; - SetLength(TextOpt, 1); - TextOpt[0] := TText.Create; - Visible := true; -end; - -procedure TSelectSlide.SetSelect(Value: boolean); -{var - SO: integer; - I: integer;} -begin - SelectBool := Value; - if Value then - begin - Texture.ColR := ColR; - Texture.ColG := ColG; - Texture.ColB := ColB; - Texture.Int := Int; - - Text.ColR := TColR; - Text.ColG := TColG; - Text.ColB := TColB; - Text.Int := TInt; - - TextureSBG.ColR := SBGColR; - TextureSBG.ColG := SBGColG; - TextureSBG.ColB := SBGColB; - TextureSBG.Int := SBGInt; - end - else - begin - Texture.ColR := DColR; - Texture.ColG := DColG; - Texture.ColB := DColB; - Texture.Int := DInt; - - Text.ColR := TDColR; - Text.ColG := TDColG; - Text.ColB := TDColB; - Text.Int := TDInt; - - TextureSBG.ColR := SBGDColR; - TextureSBG.ColG := SBGDColG; - TextureSBG.ColB := SBGDColB; - TextureSBG.Int := SBGDInt; - end; -end; - -procedure TSelectSlide.SetSelectOpt(Value: integer); -var - SO: integer; - HalfL: integer; - HalfR: integer; - - procedure DoSelection(Sel: cardinal); - var - I: integer; - begin - for I := Low(TextOpt) to High(TextOpt) do - begin - TextOpt[I].ColR := STDColR; - TextOpt[I].ColG := STDColG; - TextOpt[I].ColB := STDColB; - TextOpt[I].Int := STDInt; - end; - - if (integer(Sel) <= High(TextOpt)) then - begin - TextOpt[Sel].ColR := STColR; - TextOpt[Sel].ColG := STColG; - TextOpt[Sel].ColB := STColB; - TextOpt[Sel].Int := STInt; - end; - end; - -begin - SelectOptInt := Value; - PData^ := Value; - - if (Length(TextOpt) > 0) and (Length(TextOptT) > 0) then - begin - - //First option selected - if (Value <= 0) then - begin - Value := 0; - - Tex_SelectS_ArrowL.alpha := 0; - Tex_SelectS_ArrowR.alpha := 1; - - for SO := Low(TextOpt) to High(TextOpt) do - begin - TextOpt[SO].Text := TextOptT[SO]; - end; - - DoSelection(0); - end - - //Last option selected - else if (Value >= High(TextOptT)) then - begin - Value := High(TextOptT); - - Tex_SelectS_ArrowL.alpha := 1; - Tex_SelectS_ArrowR.alpha := 0; - - for SO := High(TextOpt) downto Low(TextOpt) do - begin - TextOpt[SO].Text := TextOptT[High(TextOptT) - (Lines - SO - 1)]; - end; - DoSelection(Lines - 1); - end - - //in between first and last - else - begin - Tex_SelectS_ArrowL.alpha := 1; - Tex_SelectS_ArrowR.alpha := 1; - - HalfL := Ceil((Lines - 1) / 2); - HalfR := Lines - 1 - HalfL; - - //Selected option is near to the left side - if (Value <= HalfL) then - begin - //Change texts - for SO := Low(TextOpt) to High(TextOpt) do - begin - TextOpt[SO].Text := TextOptT[SO]; - end; - - DoSelection(Value); - end - - //Selected option is near to the right side - else if (Value > High(TextOptT) - HalfR) then - begin - HalfR := High(TextOptT) - Value; - HalfL := Lines - 1 - HalfR; - //Change texts - for SO := High(TextOpt) downto Low(TextOpt) do - begin - TextOpt[SO].Text := TextOptT[High(TextOptT) - (Lines - SO - 1)]; - end; - - DoSelection (HalfL); - end - - else - begin - //Change Texts - for SO := Low(TextOpt) to High(TextOpt) do - begin - TextOpt[SO].Text := TextOptT[Value - HalfL + SO]; - end; - - DoSelection(HalfL); - end; - end; - end; -end; - -procedure TSelectSlide.Draw; -var - SO: integer; -begin - if Visible then - begin - DrawTexture(Texture); - DrawTexture(TextureSBG); - - if showArrows then - begin - DrawTexture(Tex_SelectS_ArrowL); - DrawTexture(Tex_SelectS_ArrowR); - end; - - Text.Draw; - - for SO := Low(TextOpt) to High(TextOpt) do - TextOpt[SO].Draw; - end; -end; - -procedure TSelectSlide.GenLines; -var - maxlength: real; - I: integer; -begin - SetFontStyle(0{Text.Style}); - SetFontSize(Text.Size); - maxlength := 0; - - for I := Low(TextOptT) to High(TextOptT) do - begin - if (glTextWidth(TextOptT[I]) > maxlength) then - maxlength := glTextWidth(TextOptT[I]); - end; - - - if (oneItemOnly = false) then - begin - //show all items - Lines := floor((TextureSBG.W-40) / (maxlength+7)); - if (Lines > Length(TextOptT)) then - Lines := Length(TextOptT); - - if (Lines <= 0) then - Lines := 1; - end - else - begin - //show one item only - Lines := 1; - end; - - //Free old Space used by Texts - for I := Low(TextOpt) to High(TextOpt) do - TextOpt[I].Free; - - setLength (TextOpt, Lines); - - for I := Low(TextOpt) to High(TextOpt) do - begin - TextOpt[I] := TText.Create; - TextOpt[I].Size := Text.Size; - //TextOpt[I].Align := 1; - TextOpt[I].Align := 0; - TextOpt[I].Visible := true; - - TextOpt[I].ColR := STDColR; - TextOpt[I].ColG := STDColG; - TextOpt[I].ColB := STDColB; - TextOpt[I].Int := STDInt; - - //Generate Positions - //TextOpt[I].X := TextureSBG.X + 20 + (TextureSBG.W / Lines) * (I + 0.5); - if (I <> High(TextOpt)) or (High(TextOpt) = 0) or (Length(TextOptT) = Lines) then - TextOpt[I].X := TextureSBG.X + 20 + (TextureSBG.W / Lines) * I - else - TextOpt[I].X := TextureSBG.X + TextureSBG.W - maxlength; - - TextOpt[I].Y := TextureSBG.Y + (TextureSBG.H - Text.Size) / 2; - - //Better Look with 2 Options - if (Lines = 2) and (Length(TextOptT) = 2) then - TextOpt[I].X := TextureSBG.X + 20 + (TextureSBG.W -40 - glTextWidth(TextOptT[1])) * I; - - if (Lines = 1) then - begin - TextOpt[I].Align := 1; //center text - TextOpt[I].X := TextureSBG.X + (TextureSBG.W / 2); - end; - end; -end; - -function TSelectSlide.GetMouseOverArea: TMouseOverRect; -begin - Result.X := Texture.X; - Result.Y := Texture.Y; - Result.W := (TextureSBG.X + TextureSBG.W) - Result.X; - Result.H := Max(Texture.H, TextureSBG.H); -end; - -function TSelectSlide.OnClick(X, Y: Real): TMouseClickAction; - var - AreaW: Real; -begin - // default: press return on click - Result := maReturn; - - // use left sides to inc or dec selection by click - AreaW := TextureSbg.W / 20; - - if (Y >= TextureSBG.Y) and (Y <= TextureSBG.Y + TextureSBG.H) then - begin - if (X >= TextureSBG.X) and (X <= TextureSBG.X + AreaW) then - Result := maLeft // hit left area - else if (X >= TextureSBG.X + TextureSBG.W - AreaW) and (X <= TextureSBG.X + TextureSBG.W) then - Result := maRight; // hit right area - end; -end; - -end. diff --git a/src/menu/UMenuStatic.pas b/src/menu/UMenuStatic.pas deleted file mode 100644 index 72f4eb36..00000000 --- a/src/menu/UMenuStatic.pas +++ /dev/null @@ -1,117 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuStatic; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UTexture, - gl; - -type - TStatic = class - public - Texture: TTexture; // Button Screen position and size - Visible: boolean; - - //Reflection Mod - Reflection: boolean; - Reflectionspacing: real; - - procedure Draw; - constructor Create(Textura: TTexture); overload; - end; - -implementation -uses - UDrawTexture; - -procedure TStatic.Draw; -begin - if Visible then - begin - DrawTexture(Texture); - - //Reflection Mod - if (Reflection) then // Draw Reflections - begin - with Texture do - begin - //Bind Tex and GL Attributes - glEnable(GL_TEXTURE_2D); - glEnable(GL_BLEND); - - glDepthRange(0, 10); - glDepthFunc(GL_LEQUAL); - glEnable(GL_DEPTH_TEST); - - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glBindTexture(GL_TEXTURE_2D, TexNum); - - //Draw - glBegin(GL_QUADS);//Top Left - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha-0.3); - glTexCoord2f(TexX1*TexW, TexY2*TexH); - glVertex3f(x, y+h*scaleH+ Reflectionspacing, z); - - //Bottom Left - glColor4f(ColR * Int, ColG * Int, ColB * Int, 0); - glTexCoord2f(TexX1*TexW, 0.5*TexH+TexY1); - glVertex3f(x, y+h*scaleH + h*scaleH/2 + Reflectionspacing, z); - - - //Bottom Right - glColor4f(ColR * Int, ColG * Int, ColB * Int, 0); - glTexCoord2f(TexX2*TexW, 0.5*TexH+TexY1); - glVertex3f(x+w*scaleW, y+h*scaleH + h*scaleH/2 + Reflectionspacing, z); - - //Top Right - glColor4f(ColR * Int, ColG * Int, ColB * Int, Alpha-0.3); - glTexCoord2f(TexX2*TexW, TexY2*TexH); - glVertex3f(x+w*scaleW, y+h*scaleH + Reflectionspacing, z); - glEnd; - - glDisable(GL_TEXTURE_2D); - glDisable(GL_DEPTH_TEST); - glDisable(GL_BLEND); - end; - end; - end; -end; - -constructor TStatic.Create(Textura: TTexture); -begin - inherited Create; - Texture := Textura; -end; - -end. diff --git a/src/menu/UMenuText.pas b/src/menu/UMenuText.pas deleted file mode 100644 index 276f961b..00000000 --- a/src/menu/UMenuText.pas +++ /dev/null @@ -1,379 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UMenuText; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - math, - SysUtils, - gl, - SDL, - TextGL, - UTexture; - -type - TText = class - private - SelectBool: boolean; - TextString: UTF8String; - TextTiles: array of UTF8String; - - STicks: cardinal; - SelectBlink: boolean; - public - X: real; - Y: real; - Z: real; - MoveX: real; // some modifier for x - position that don't affect the real Y - MoveY: real; // some modifier for y - position that don't affect the real Y - W: real; // text wider than W is broken -// H: real; - Size: real; - ColR: real; - ColG: real; - ColB: real; - Alpha: real; - Int: real; - Style: integer; - Visible: boolean; - Align: integer; // 0 = left, 1 = center, 2 = right - - // reflection - Reflection: boolean; - ReflectionSpacing: real; - - procedure SetSelect(Value: boolean); - property Selected: boolean read SelectBool write SetSelect; - - procedure SetText(Value: UTF8String); - property Text: UTF8String read TextString write SetText; - - procedure DeleteLastLetter; //< Deletes the rightmost letter - - procedure Draw; - constructor Create; overload; - constructor Create(X, Y: real; const Text: UTF8String); overload; - constructor Create(ParX, ParY, ParW: real; ParStyle: integer; ParSize, ParColR, ParColG, ParColB: real; ParAlign: integer; const ParText: UTF8String; ParReflection: boolean; ParReflectionSpacing: real; ParZ: real); overload; - end; - -implementation - -uses - UGraphic, - UUnicodeUtils, - StrUtils; - -procedure TText.SetSelect(Value: boolean); -begin - SelectBool := Value; - - // set cursor visible - SelectBlink := true; - STicks := SDL_GetTicks() div 550; -end; - -procedure TText.SetText(Value: UTF8String); -var - NextPos: cardinal; // next pos of a space etc. - LastPos: cardinal; // last pos " - LastBreak: cardinal; // last break - isBreak: boolean; // true if the break is not caused because the text is out of the area - FirstWord: word; // is first word after break? - Len: word; // length of the tiles array - - function GetNextPos: boolean; - var - T1, {T2,} T3: cardinal; - begin - LastPos := NextPos; - - // next space (if width is given) - if (W > 0) then - T1 := PosEx(' ', Value, LastPos + 1) - else - T1 := Length(Value); - - {// next - - T2 := PosEx('-', Value, LastPos + 1);} - - // next break - T3 := PosEx('\n', Value, LastPos + 1); - - if T1 = 0 then - T1 := Length(Value); - {if T2 = 0 then - T2 := Length(Value); } - if T3 = 0 then - T3 := Length(Value); - - // get nearest pos - NextPos := min(T1, T3{min(T2, T3)}); - - if (LastPos = cardinal(Length(Value))) then - NextPos := 0; - - isBreak := (NextPos = T3) and (NextPos <> cardinal(Length(Value))); - Result := (NextPos <> 0); - end; - - procedure AddBreak(const From, bTo: cardinal); - begin - if (isBreak) or (bTo - From >= 1) then - begin - Inc(Len); - SetLength (TextTiles, Len); - TextTiles[Len-1] := Trim(Copy(Value, From, bTo - From)); - - if isBreak then - LastBreak := bTo + 2 - else - LastBreak := bTo + 1; - FirstWord := 0; - end; - end; - -begin - // set TextString - TextString := Value; - - // set cursor visible - SelectBlink := true; - STicks := SDL_GetTicks() div 550; - - // exit if there is no need to create tiles - if (W <= 0) and (Pos('\n', Value) = 0) then - begin - SetLength (TextTiles, 1); - TextTiles[0] := Value; - Exit; - end; - - // create tiles - // reset text array - SetLength (TextTiles, 0); - Len := 0; - - // reset counter vars - LastPos := 1; - NextPos := 1; - LastBreak := 1; - FirstWord := 1; - - if (W > 0) then - begin - // set font properties - SetFontStyle(Style); - SetFontSize(Size); - end; - - // go through text - while (GetNextPos) do - begin - // break in text - if isBreak then - begin - // look for break before the break - if (glTextWidth(Copy(Value, LastBreak, NextPos - LastBreak + 1)) > W) AND (NextPos-LastPos > 1) then - begin - isBreak := false; - // not the first word after break, so we don't have to break within a word - if (FirstWord > 1) then - begin - // add break before actual position, because there the text fits the area - AddBreak(LastBreak, LastPos); - end - else // first word after break break within the word - begin - // to do - // AddBreak(LastBreak, LastBreak + 155); - end; - end; - - isBreak := true; - // add break from text - AddBreak(LastBreak, NextPos); - end - // text comes out of the text area -> createbreak - else if (glTextWidth(Copy(Value, LastBreak, NextPos - LastBreak + 1)) > W) then - begin - // not the first word after break, so we don't have to break within a word - if (FirstWord > 1) then - begin - // add break before actual position, because there the text fits the area - AddBreak(LastBreak, LastPos); - end - else // first word after break -> break within the word - begin - // to do - // AddBreak(LastBreak, LastBreak + 155); - end; - end; - //end; - Inc(FirstWord) - end; - // add ending - AddBreak(LastBreak, Length(Value)+1); -end; - -procedure TText.DeleteLastLetter; -begin - SetText(UTF8Copy(TextString, 1, LengthUTF8(TextString)-1)); -end; - -procedure TText.Draw; -var - X2, Y2: real; - Text2: UTF8String; - I: integer; - Ticks: cardinal; -begin - if Visible then - begin - SetFontStyle(Style); - SetFontSize(Size); - SetFontItalic(false); - - glColor4f(ColR*Int, ColG*Int, ColB*Int, Alpha); - - // reflection - if Reflection then - SetFontReflection(true, ReflectionSpacing) - else - SetFontReflection(false,0); - - // if selected set blink... - if SelectBool then - begin - Ticks := SDL_GetTicks() div 550; - if Ticks <> STicks then - begin // change visability - STicks := Ticks; - SelectBlink := Not SelectBlink; - end; - end; - - {if (false) then // no width set draw as one long string - begin - if not (SelectBool AND SelectBlink) then - Text2 := Text - else - Text2 := Text + '|'; - - case Align of - 0: X2 := X; - 1: X2 := X - glTextWidth(Text2)/2; - 2: X2 := X - glTextWidth(Text2); - end; - - SetFontPos(X2, Y); - glPrint(Text2); - SetFontStyle(0); // reset to default - end - else - begin} - // now use always: - // draw text as many strings - Y2 := Y + MoveY; - for I := 0 to High(TextTiles) do - begin - if (not (SelectBool and SelectBlink)) or (I <> High(TextTiles)) then - Text2 := TextTiles[I] - else - Text2 := TextTiles[I] + '|'; - - case Align of - 1: X2 := X + MoveX - glTextWidth(Text2)/2; { centered } - 2: X2 := X + MoveX - glTextWidth(Text2); { right aligned } - else X2 := X + MoveX; { left aligned (default) } - end; - - SetFontPos(X2, Y2); - - SetFontZ(Z); - - glPrint(Text2); - - {if Size >= 10 then - Y2 := Y2 + Size * 0.93 - else} - if (Style = 1) then - Y2 := Y2 + Size * 0.93 - else - Y2 := Y2 + Size * 0.72; - end; - SetFontStyle(0); // reset to default - - //end; - end; -end; - -constructor TText.Create; -begin - Create(0, 0, ''); -end; - -constructor TText.Create(X, Y: real; const Text: UTF8String); -begin - Create(X, Y, 0, 0, 30, 0, 0, 0, 0, Text, false, 0, 0); -end; - -constructor TText.Create(ParX, ParY, ParW: real; - ParStyle: integer; - ParSize, ParColR, ParColG, ParColB: real; - ParAlign: integer; - const ParText: UTF8String; - ParReflection: boolean; - ParReflectionSpacing: real; - ParZ: real); -begin - inherited Create; - Alpha := 1; - X := ParX; - Y := ParY; - W := ParW; - Z := ParZ; - Style := ParStyle; - Size := ParSize; - Text := ParText; - ColR := ParColR; - ColG := ParColG; - ColB := ParColB; - Int := 1; - Align := ParAlign; - SelectBool := false; - Visible := true; - Reflection := ParReflection; - ReflectionSpacing := ParReflectionSpacing; -end; - -end. diff --git a/src/screens/UScreenCredits.pas b/src/screens/UScreenCredits.pas deleted file mode 100644 index b1333b4a..00000000 --- a/src/screens/UScreenCredits.pas +++ /dev/null @@ -1,1466 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenCredits; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - SDL, - SDL_Image, - gl, - UMenu, - UDisplay, - UTexture, - UMusic, - UFiles, - UThemes, - UPath, - UGraphicClasses; - -type - TCreditsStages=(InitialDelay, Intro, MainPart, Outro); - - TScreenCredits = class(TMenu) - public - - Credits_X: real; - Credits_Time: cardinal; - Credits_Alpha: cardinal; - CTime: cardinal; - CTime_hold: cardinal; - ESC_Alpha: integer; - - credits_entry: TTexture; - credits_entry_dx: TTexture; - credits_bg_tex: TTexture; - credits_bg_ovl: TTexture; - //credits_bg_logo: TTexture; - credits_bg_scrollbox_left: TTexture; - credits_blindguard: TTexture; - credits_blindy: TTexture; - credits_canni: TTexture; - credits_commandio: TTexture; - credits_lazyjoker: TTexture; - credits_mog: TTexture; - credits_mota: TTexture; - credits_skillmaster: TTexture; - credits_whiteshark: TTexture; - intro_layer01: TTexture; - intro_layer02: TTexture; - intro_layer03: TTexture; - intro_layer04: TTexture; - intro_layer05: TTexture; - intro_layer06: TTexture; - intro_layer07: TTexture; - intro_layer08: TTexture; - intro_layer09: TTexture; - outro_bg: TTexture; - outro_esc: TTexture; - outro_exd: TTexture; - - deluxe_slidein: cardinal; - - CurrentScrollText: string; - NextScrollUpdate: real; - EndofLastScrollingPart: cardinal; - CurrentScrollStart, CurrentScrollEnd: integer; - - CRDTS_Stage: TCreditsStages; - - Fadeout: boolean; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function Draw: boolean; override; - procedure OnShow; override; - procedure OnHide; override; - procedure DrawCredits; - procedure Draw_FunkyText; - end; - -const - Funky_Text: string = - 'Grandma Deluxe has arrived! Thanks to Corvus5 for the massive work on UltraStar, Wome for the nice tune you are hearing, '+ - 'all the people who put massive effort and work in new songs (do not forget UltraStar w/o songs would be nothing), ppl from '+ - 'irc helping us - eBandit and Gabari, scene ppl who really helped instead of compiling and running away. Greetings to DennisTheMenace for betatesting, '+ - 'Demoscene.tv, pouet.net, KakiArts, Sourceforge,..'; - - CRDTS_BG_FILE = 'credits_v5_bg.png'; - CRDTS_OVL_FILE = 'credits_v5_overlay.png'; - CRDTS_blindguard_FILE = 'names_blindguard.png'; - CRDTS_blindy_FILE = 'names_blindy.png'; - CRDTS_canni_FILE = 'names_canni.png'; - CRDTS_commandio_FILE = 'names_commandio.png'; - CRDTS_lazyjoker_FILE = 'names_lazyjoker.png'; - CRDTS_mog_FILE = 'names_mog.png'; - CRDTS_mota_FILE = 'names_mota.png'; - CRDTS_skillmaster_FILE = 'names_skillmaster.png'; - CRDTS_whiteshark_FILE = 'names_whiteshark.png'; - INTRO_L01_FILE = 'intro-l-01.png'; - INTRO_L02_FILE = 'intro-l-02.png'; - INTRO_L03_FILE = 'intro-l-03.png'; - INTRO_L04_FILE = 'intro-l-04.png'; - INTRO_L05_FILE = 'intro-l-05.png'; - INTRO_L06_FILE = 'intro-l-06.png'; - INTRO_L07_FILE = 'intro-l-07.png'; - INTRO_L08_FILE = 'intro-l-08.png'; - INTRO_L09_FILE = 'intro-l-09.png'; - OUTRO_BG_FILE = 'outro-bg.png'; - OUTRO_ESC_FILE = 'outro-esc.png'; - OUTRO_EXD_FILE = 'outro-exit-dark.png'; - - Timings: array[0..21] of cardinal=( - 20, // 0 Delay before Start - - 149, // 1 End first Intro Zoom - 155, // 2 Start 2. Action in Intro - 170, // 3 End Separation in Intro - 271, // 4 beginning Zoomout in Intro - 0, // 5 unused - 261, // 6 Start fade-to-white in Intro - - 271, // 7 Start Main Part - 280, // 8 Start On-Beat-Star Main Part - - 396, // 9 Start BlindGuard - 666, // 10 Start blindy - 936, // 11 Start Canni - 1206, // 12 Start Commandio - 1476, // 13 Start LazyJoker - 1746, // 14 Start Mog - 2016, // 15 Start Mota - 2286, // 16 Start SkillMaster - 2556, // 17 Start WhiteShark - 2826, // 18 Ende Whiteshark - 3096, // 19 Start FadeOut Mainscreen - 3366, // 20 Ende Credits Tune - 60); // 21 start flare in intro - -implementation - -uses - Math, - ULog, - UGraphic, - UMain, - UIni, - USongs, - Textgl, - ULanguage, - UCommon, - UPathUtils; - -function TScreenCredits.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - case PressedKey of - - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - FadeTo(@ScreenMain); - AudioPlayback.PlaySound(SoundLib.Back); - end; -{ - SDLK_SPACE: - begin - setlength(CTime_hold,length(CTime_hold)+1); - CTime_hold[high(CTime_hold)]:=CTime; - end; -} - end; // esac - end; // fi -end; - -constructor TScreenCredits.Create; -var - CreditsPath: IPath; -begin - inherited Create; - - CreditsPath := ResourcesPath.Append('credits', pdAppend); - - credits_bg_tex := Texture.LoadTexture(CreditsPath.Append(CRDTS_BG_FILE), TEXTURE_TYPE_PLAIN, 0); - credits_bg_ovl := Texture.LoadTexture(CreditsPath.Append(CRDTS_OVL_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - - credits_blindguard := Texture.LoadTexture(CreditsPath.Append(CRDTS_blindguard_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_blindy := Texture.LoadTexture(CreditsPath.Append(CRDTS_blindy_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_canni := Texture.LoadTexture(CreditsPath.Append(CRDTS_canni_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_commandio := Texture.LoadTexture(CreditsPath.Append(CRDTS_commandio_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_lazyjoker := Texture.LoadTexture(CreditsPath.Append(CRDTS_lazyjoker_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_mog := Texture.LoadTexture(CreditsPath.Append(CRDTS_mog_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_mota := Texture.LoadTexture(CreditsPath.Append(CRDTS_mota_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_skillmaster := Texture.LoadTexture(CreditsPath.Append(CRDTS_skillmaster_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - credits_whiteshark := Texture.LoadTexture(CreditsPath.Append(CRDTS_whiteshark_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - - intro_layer01 := Texture.LoadTexture(CreditsPath.Append(INTRO_L01_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer02 := Texture.LoadTexture(CreditsPath.Append(INTRO_L02_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer03 := Texture.LoadTexture(CreditsPath.Append(INTRO_L03_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer04 := Texture.LoadTexture(CreditsPath.Append(INTRO_L04_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer05 := Texture.LoadTexture(CreditsPath.Append(INTRO_L05_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer06 := Texture.LoadTexture(CreditsPath.Append(INTRO_L06_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer07 := Texture.LoadTexture(CreditsPath.Append(INTRO_L07_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer08 := Texture.LoadTexture(CreditsPath.Append(INTRO_L08_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - intro_layer09 := Texture.LoadTexture(CreditsPath.Append(INTRO_L09_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - - outro_bg := Texture.LoadTexture(CreditsPath.Append(OUTRO_BG_FILE), TEXTURE_TYPE_PLAIN, 0); - outro_esc := Texture.LoadTexture(CreditsPath.Append(OUTRO_ESC_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - outro_exd := Texture.LoadTexture(CreditsPath.Append(OUTRO_EXD_FILE), TEXTURE_TYPE_TRANSPARENT, 0); - - CRDTS_Stage:=InitialDelay; -end; - -function TScreenCredits.Draw: boolean; -begin - DrawCredits; - Draw := true; -end; - -procedure TScreenCredits.OnShow; -begin - inherited; - - CRDTS_Stage := InitialDelay; - Credits_X := 580; - deluxe_slidein := 0; - Credits_Alpha := 0; -// Music.SetLoop(true); loop loops not, shit - AudioPlayback.Open(soundpath.Append('wome-credits-tune.mp3')); // thank you wetue -// Music.Play; - CTime := 0; -// setlength(CTime_hold,0); -end; - -procedure TScreenCredits.OnHide; -begin - AudioPlayback.Stop; -end; - -Procedure TScreenCredits.Draw_FunkyText; -var - S: integer; - X, Y, A: real; - visibleText: string; -begin - SetFontSize(30); - - // init ScrollingText - if (CTime = Timings[7]) then - begin - // set position of text - Credits_X := 600; - CurrentScrollStart := 1; - CurrentScrollEnd := 1; - end; - - if (CTime > Timings[7]) and - (CurrentScrollStart < length(Funky_Text)) then - begin - X := 0; - visibleText := Copy(Funky_Text, CurrentScrollStart, CurrentScrollEnd); - - for S := 1 to length(visibleText) do - begin - Y := abs(sin((Credits_X + X) * 0.93 { * (((Credits_X + X)) / 1200) } / 100 * pi)); - SetFontPos(Credits_X + X, 538 - Y * (Credits_X + X) * (Credits_X + X) * (Credits_X + X) / 1000000); - - if (Credits_X + X > 32) then - A := 17 - else if (Credits_X + X >= 15) then - A := Credits_X + X - 15 - else - A := 0; - - glColor4f(230 / 255 - 40 / 255 + Y * (Credits_X + X)/ 900, - 200 / 255 - 30 / 255 + Y * (Credits_X + X)/ 1000, - 155 / 255 - 20 / 255 + Y * (Credits_X + X)/ 1100, - A / 17); - glPrint(visibleText[S]); - X := X + glTextWidth(visibleText[S]); - end; - - if (Credits_X < 0) and (CurrentScrollStart < length(Funky_Text)) then - begin - Credits_X := Credits_X + glTextWidth(Funky_Text[CurrentScrollStart]); - inc(CurrentScrollStart); - end; - - visibleText := Copy(Funky_Text, CurrentScrollStart, CurrentScrollEnd); - - if (Credits_X + glTextWidth(visibleText) < 600) and - (CurrentScrollEnd < length(Funky_Text)) then - begin - inc(CurrentScrollEnd); - end; - end; -{ -// timing hack - X:=5; - SetFontStyle(2); - SetFontItalic(false); - SetFontSize(27); - glColor4f(1, 1, 1, 1); - for S := 0 to high(CTime_hold) do - begin - visibleText := inttostr(CTime_hold[S]); - SetFontPos (500, X); - glPrint(visibleText[0]); - X := X + 20; - end; -} -end; - -procedure Start3D; -begin - glMatrixMode(GL_PROJECTION); - glPushMatrix; - glLoadIdentity; - glFrustum(-0.3 * 4 / 3, 0.3 * 4 / 3, -0.3, 0.3, 1, 1000); - glMatrixMode(GL_MODELVIEW); - glLoadIdentity; -end; - -procedure End3D; -begin - glMatrixMode(GL_PROJECTION); - glPopMatrix; - glMatrixMode(GL_MODELVIEW); -end; - -procedure TScreenCredits.DrawCredits; -var - T: cardinal; - Data: TFFTData; - j, k, l: cardinal; - f, g: real; - STime: cardinal; - Delay: cardinal; - myScale: real; - myAngle: real; -const - myLogoCoords: array[0..27,0..1] of cardinal = ( - ( 39,32),( 84,32),(100,16),(125,24), - (154,31),(156,58),(168,32),(203,36), - (258,34),(251,50),(274,93),(294,84), - (232,54),(278,62),(319,34),(336,92), - (347,23),(374,32),(377,58),(361,83), - (385,91),(405,91),(429,35),(423,51), - (450,32),(485,34),(444,91),(486,93) - ); -begin - // dis does teh muiwk y0r to be translated :-) - AudioPlayback.GetFFTData(Data); - - Log.LogStatus('', ' JB-1'); - - T := SDL_GetTicks() div 33; - if T <> Credits_Time then - begin - Credits_Time := T; - inc(CTime); - inc(CTime_hold); - Credits_X := Credits_X-2; - - Log.LogStatus('', ' JB-2'); - if (CRDTS_Stage=InitialDelay) and (CTime = Timings[0]) then - begin -// CTime := Timings[20]; -// CRDTS_Stage := Outro; - CRDTS_Stage := Intro; - CTime := 0; - AudioPlayback.Play; - end; - if (CRDTS_Stage = Intro) and (CTime = Timings[7]) then - begin - CRDTS_Stage := MainPart; - end; - if (CRDTS_Stage = MainPart) and (CTime = Timings[20]) then - begin - CRDTS_Stage := Outro; - end; - end; - - Log.LogStatus('', ' JB-3'); - - // draw background - if CRDTS_Stage = InitialDelay then - begin - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); - end - else - if CRDTS_Stage = Intro then - begin - Start3D; - glPushMatrix; - - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - if CTime < Timings[1] then - begin - myScale := 0.5 + 0.5 * (Timings[1] - CTime) / (Timings[1]); // slowly move layers together - myAngle := cos((CTime) * pi / ((Timings[1]) * 2)); // and make logo face towards camera - end - else - begin // this is the part when the logo stands still - myScale := 0.5; - myAngle := 0; - end; - if CTime > Timings[2] then - begin - myScale := 0.5 + 0.5 * (CTime - Timings[2]) / (Timings[3] - Timings[2]); // get some space between layers - myAngle := 0; - end; -// if CTime > Timings[3] then myScale := 1; // keep the space between layers - glTranslatef(0, 0, -5 + 0.5 * myScale); - if CTime > Timings[3] then - myScale := 1; // keep the space between layers - if CTime > Timings[3] then - begin // make logo rotate left and grow -// myScale := (CTime - Timings[4]) / (Timings[7] - Timings[4]); - glRotatef(20 * sqr(CTime - Timings[3]) / sqr((Timings[7] - Timings[3]) / 2), 0, 0, 1); - glScalef(1 + sqr(CTime - Timings[3]) / (32 * (Timings[7] - Timings[3])), 1 + sqr(CTime - Timings[3]) / (32 * (Timings[7] - Timings[3])), 1); - end; - if CTime < Timings[2] then - glRotatef(30 * myAngle, 0.5 * myScale + myScale, 1 + myScale, 0); -// glScalef(0.5, 0.5, 0.5); - glScalef(4/3, -1, 1); - glColor4f(1, 1, 1, 1); - - glBindTexture(GL_TEXTURE_2D, intro_layer01.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, -0.4 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, -0.4 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, -0.4 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, -0.4 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer02.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, -0.3 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, -0.3 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, -0.3 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, -0.3 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer03.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, -0.2 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, -0.2 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, -0.2 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, -0.2 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer04.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, -0.1 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, -0.1 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, -0.1 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, -0.1 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer05.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, 0 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, 0 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, 0 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, 0 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer06.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, 0.1 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, 0.1 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, 0.1 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, 0.1 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer07.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, 0.2 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, 0.2 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, 0.2 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, 0.2 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer08.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, 0.3 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, 0.3 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, 0.3 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, 0.3 * myScale); - glEnd; - glBindTexture(GL_TEXTURE_2D, intro_layer09.TexNum); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex3f(-1, -1, 0.22 * myScale); - glTexCoord2f(0, 1); glVertex3f(-1, 1, 0.22 * myScale); - glTexCoord2f(1, 1); glVertex3f( 1, 1, 0.22 * myScale); - glTexCoord2f(1, 0); glVertex3f( 1, -1, 0.22 * myScale); - glEnd; - gldisable(gl_texture_2d); - glDisable(GL_BLEND); - - glPopMatrix; - End3D; - - // do some sparkling effects - if (CTime < Timings[1]) and (CTime > Timings[21]) then - begin - for k:= 1 to 3 do - begin - l := 410 + floor((CTime - Timings[21]) / (Timings[1] - Timings[21]) * (536 - 410)) + RandomRange(-5, 5); - j := floor((Timings[1] - CTime) / 22) + RandomRange(285, 301); - GoldenRec.Spawn(l, j, 1, 16, 0, -1, Flare, 0); - end; - end; - - // fade to white at end - if Ctime > Timings[6] then - begin - glColor4f(1, 1, 1, sqr(CTime - Timings[6]) * (CTime - Timings[6]) / sqr(Timings[7] - Timings[6])); - glEnable(GL_BLEND); - glBegin(GL_QUADS); - glVertex2f( 0, 0); - glVertex2f( 0, 600); - glVertex2f(800, 600); - glVertex2f(800, 0); - glEnd; - glDisable(GL_BLEND); - end; - - end; - if (CRDTS_Stage=MainPart) then - // main credits screen background, scroller, logo and girl - begin - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - glColor4f(1, 1, 1, 1); - glBindTexture(GL_TEXTURE_2D, credits_bg_tex.TexNum); - glbegin(gl_quads); - glTexCoord2f( 0, 0); glVertex2f( 0, 0); - glTexCoord2f( 0, 600/1024); glVertex2f( 0, 600); - glTexCoord2f(800/1024, 600/1024); glVertex2f(800, 600); - glTexCoord2f(800/1024, 0); glVertex2f(800, 0); - glEnd; - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - - // draw scroller - Draw_FunkyText; - - //######################################################################### - // draw credits names - - Log.LogStatus('', ' JB-4'); - - // BlindGuard (rotate in from upper left, rotate out to lower right) - STime := Timings[9] - 10; - Delay := Timings[10] - Timings[9]; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(0, 329, 0); - if CTime <= STime + 10 then - glrotatef((CTime - STime) * 9 + 270, 0, 0, 1); - gltranslatef(223, 0, 0); - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - gltranslatef(223, 0, 0); - glrotatef((integer(CTime) - (integer(STime + Delay) - 10)) * -9, 0, 0, 1); - gltranslatef(-223, 0, 0); - end; - glBindTexture(GL_TEXTURE_2D, credits_blindguard.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163, -129); - glTexCoord2f(0, 1); glVertex2f(-163, 129); - glTexCoord2f(1, 1); glVertex2f( 163, 129); - glTexCoord2f(1, 0); glVertex2f( 163, -129); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // Blindy (zoom from 0 to full size and rotation, zoom zo doubble size and shift to upper right) - STime := Timings[10] - 10; - Delay := Timings[11] - Timings[10] + 5; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime+20) and (CTime<=STime+22) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 20 then - begin - j := CTime - Stime; - glscalef(j * j / 400, j * j / 400, j * j / 400); - glrotatef(j * 18.0, 0, 0, 1); - end; - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - j := CTime - (STime + Delay - 10); - f := j * 10.0; - gltranslatef(f * 3, -f, 0); - glscalef(1 + j / 10, 1 + j / 10, 1 + j / 10); - glrotatef(j * 9.0, 0, 0, 1); - end; - glBindTexture(GL_TEXTURE_2D, credits_blindy.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163, -129); - glTexCoord2f(0, 1); glVertex2f(-163, 129); - glTexCoord2f(1, 1); glVertex2f( 163, 129); - glTexCoord2f(1, 0); glVertex2f( 163, -129); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // Canni (shift in from left, shift out to upper right) - STime := Timings[11] - 10; - Delay := Timings[12] - Timings[11] + 5; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 10 then - begin - gltranslatef(((CTime - STime) * 21.0) - 210, 0, 0); - end; - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - j := (CTime - (STime + Delay - 10)) * 21; - gltranslatef(j, -j / 2, 0); - end; - glBindTexture(GL_TEXTURE_2D, credits_canni.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163, -129); - glTexCoord2f(0, 1); glVertex2f(-163, 129); - glTexCoord2f(1, 1); glVertex2f( 163, 129); - glTexCoord2f(1, 0); glVertex2f( 163, -129); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // Commandio (flip in from down, flip out to upper right) - STime := Timings[12] - 10; - Delay := Timings[13] - Timings[12]; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 10 then - f := 258.0 - 25.8 * (CTime - STime) - else - f := 0; - g := 0; - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - j := CTime - (STime + Delay - 10); - g := 32.6 * j; - end; - glBindTexture(GL_TEXTURE_2D, credits_commandio.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163 + g - f * 1.5, -129 + f * 1.5 - g/2); - glTexCoord2f(0, 1); glVertex2f(-163 + g * 1.5, 129 - (g * 1.5 * 258 / 326)); - glTexCoord2f(1, 1); glVertex2f( 163 + g, 129 + g / 4); - glTexCoord2f(1, 0); glVertex2f( 163 + f * 1.5 + g / 4, -129 + f * 1.5 - g / 4); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // lazy joker (just scrolls from left to right, no twinkling stars, no on-beat flashing) - STime := Timings[13] - 35; - Delay := Timings[14] - Timings[13] + 5; - if CTime > STime then - begin - k := 0; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) > 10) and ((CTime - STime) < 20) then - ESC_Alpha := 20; - ESC_Alpha := 10; - f := CTime - STime; - if CTime <= STime + 40 then - j := CTime - STime - else - j := 40; - if (CTime >= STime + Delay - 40) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j * j / 1600); - - glPushMatrix; - gltranslatef(180 + (f - 70), 329, 0); - glBindTexture(GL_TEXTURE_2D, credits_lazyjoker.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163, -129); - glTexCoord2f(0, 1); glVertex2f(-163, 129); - glTexCoord2f(1, 1); glVertex2f( 163, 129); - glTexCoord2f(1, 0); glVertex2f( 163, -129); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // Mog (flip in from right, flip out to lower right) - STime := Timings[14] - 10; - Delay := Timings[15] - Timings[14] + 5; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 10 then - f := 326.0 - 32.6 * (CTime - STime) - else - f := 0; - - g := 0; - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - j := CTime - (STime + Delay - 10); - g := 32.6 * j; - end; - glBindTexture(GL_TEXTURE_2D, credits_mog.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163 + g * 1.5, -129 + g * 1.5); - glTexCoord2f(0, 1); glVertex2f(-163 + g * 1.2, 129 + g); - glTexCoord2f(1, 1); glVertex2f( 163 - f + g / 2, 129 + f * 1.5 + g / 4); - glTexCoord2f(1, 0); glVertex2f( 163 - f + g * 1.5, -129 - f * 1.5); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // Mota (rotate in from upper right, shift out to lower left while shrinking and rotateing) - STime := Timings[15] - 10; - Delay := Timings[16] - Timings[15] + 5; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 10 then - begin - gltranslatef(223, 0, 0); - glrotatef((10 - (CTime - STime)) * 9, 0, 0, 1); - gltranslatef(-223, 0, 0); - end; - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - j := CTime - (STime + Delay - 10); - f := j * 10.0; - gltranslatef(-f * 2, -f, 0); - glscalef(1 - j / 10, 1 - j / 10, 1 - j / 10); - glrotatef(-j * 9.0, 0, 0, 1); - end; - glBindTexture(GL_TEXTURE_2D, credits_mota.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163, -129); - glTexCoord2f(0, 1); glVertex2f(-163, 129); - glTexCoord2f(1, 1); glVertex2f( 163, 129); - glTexCoord2f(1, 0); glVertex2f( 163, -129); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // Skillmaster (shift in from lower right, rotate out to upper right) - STime := Timings[16] - 10; - Delay := Timings[17] - Timings[16] + 5; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 10 then - begin - j := STime + 10 - CTime; - f := j * 10.0; - gltranslatef(+f * 2, +f / 2, 0); - end; - if CTime >= STime + Delay - 10 then - if CTime <= STime + Delay then - begin - j := CTime - (STime + Delay - 10); - gltranslatef(0, -223, 0); - glrotatef(integer(j) * -9, 0, 0, 1); - gltranslatef(0, 223, 0); - glrotatef(j * 9, 0, 0, 1); - end; - glBindTexture(GL_TEXTURE_2D, credits_skillmaster.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163, -129); - glTexCoord2f(0, 1); glVertex2f(-163, 129); - glTexCoord2f(1, 1); glVertex2f( 163, 129); - glTexCoord2f(1, 0); glVertex2f( 163, -129); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - // WhiteShark (flip in from lower left, flip out to upper right) - STime := Timings[17] - 10; - Delay := Timings[18] - Timings[17]; - if CTime > STime then - begin - k := 0; - ESC_Alpha := 20; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.25 then - ESC_Alpha := 5 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - if ((CTime - STime) < 20) then - ESC_Alpha := 20; - if CTime <= STime + 10 then - j := CTime - STime - else - j := 10; - if (CTime >= STime + Delay - 10) then - if (CTime <= STime + Delay) then - j := (STime + Delay) - CTime - else - j := 0; - glColor4f(1, 1, 1, ESC_Alpha / 20 * j / 10); - - if (CTime >= STime + 10) and (CTime <= STime + 12) then - begin - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 0); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 1); - GoldenRec.Spawn(RandomRange(65,390), RandomRange(200,460), 1, 16, 0, -1, PerfectLineTwinkle, 5); - end; - - glPushMatrix; - gltranslatef(223, 329, 0); - if CTime <= STime + 10 then - f := 326.0 - 32.6 * (CTime - STime) - else - f := 0; - - if (CTime >= STime + Delay - 10) and (CTime <= STime + Delay) then - begin - j := CTime - (STime + Delay - 10); - g := 32.6 * j; - end - else - begin - g := 0; - end; - - glBindTexture(GL_TEXTURE_2D, credits_whiteshark.TexNum); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glEnable(GL_TEXTURE_2D); - glbegin(gl_quads); - glTexCoord2f(0, 0); glVertex2f(-163 - f + g, -129 + f / 4 - g / 2); - glTexCoord2f(0, 1); glVertex2f(-163 - f / 4 + g, 129 + g / 2 + f / 4); - glTexCoord2f(1, 1); glVertex2f( 163 - f * 1.2 + g / 4, 129 + f / 2 - g / 4); - glTexCoord2f(1, 0); glVertex2f( 163 - f * 1.5 + g / 4, -129 + f * 1.5 + g / 4); - glEnd; - gldisable(gl_texture_2d); - gldisable(GL_BLEND); - glPopMatrix; - end; - - Log.LogStatus('', ' JB-103'); - - // #################################################################### - // do some twinkle stuff (kinda on beat) - - if (CTime > Timings[8] ) and - (CTime < Timings[19]) then - begin - k := 0; - - try - for j := 0 to 40 do - begin - if (j < length(Data)) and - (k < length(Data)) then - begin - if Data[j] >= Data[k] then - k := j; - end; - end; - except - end; - - if Data[k] > 0.2 then - begin - l := RandomRange(6, 16); - j := RandomRange(0, 27); - - GoldenRec.Spawn(myLogoCoords[j,0], myLogoCoords[j,1], 16-l, l, 0, -1, PerfectNote, 0); - end; - end; - - //################################################# - // draw the rest of the main screen (girl and logo) - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - glColor4f(1, 1, 1, 1); - glBindTexture(GL_TEXTURE_2D, credits_bg_ovl.TexNum); - glbegin(gl_quads); - glTexCoord2f( 0, 0); glVertex2f(800-393, 0); - glTexCoord2f( 0, 600/1024); glVertex2f(800-393, 600); - glTexCoord2f(393/512, 600/1024); glVertex2f(800, 600); - glTexCoord2f(393/512, 0); glVertex2f(800, 0); - glEnd; - -{ - glBindTexture(GL_TEXTURE_2D, credits_bg_logo.TexNum); - glbegin(gl_quads); - glTexCoord2f( 0, 0); glVertex2f( 0, 0); - glTexCoord2f( 0, 112/128); glVertex2f( 0, 112); - glTexCoord2f(497/512, 112/128); glVertex2f(497, 112); - glTexCoord2f(497/512, 0); glVertex2f(497, 0); - glEnd; -} - - gldisable(gl_texture_2d); - glDisable(GL_BLEND); - - // fade out at end of main part - if Ctime > Timings[19] then - begin - glColor4f(0, 0, 0, (CTime - Timings[19]) / (Timings[20] - Timings[19])); - glEnable(GL_BLEND); - glBegin(GL_QUADS); - glVertex2f( 0, 0); - glVertex2f( 0, 600); - glVertex2f(800, 600); - glVertex2f(800, 0); - glEnd; - glDisable(GL_BLEND); - end; - end - else - if (CRDTS_Stage = Outro) then - begin - if CTime = Timings[20] then - begin - CTime_hold := 0; - AudioPlayback.Stop; - AudioPlayback.Open(SoundPath.Append('credits-outro-tune.mp3')); - AudioPlayback.SetVolume(0.2); - AudioPlayback.SetLoop(true); - AudioPlayback.Play; - end; - if CTime_hold > 231 then - begin - AudioPlayback.Play; - Ctime_hold := 0; - end; - glClearColor(0, 0, 0, 0); - glClear(GL_COLOR_BUFFER_BIT or GL_DEPTH_BUFFER_BIT); - - // do something useful - // outro background - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - glColor4f(1, 1, 1, 1); - glBindTexture(GL_TEXTURE_2D, outro_bg.TexNum); - glbegin(gl_quads); - glTexCoord2f( 0, 0); glVertex2f( 0, 0); - glTexCoord2f( 0, 600/1024); glVertex2f( 0, 600); - glTexCoord2f(800/1024, 600/1024); glVertex2f(800, 600); - glTexCoord2f(800/1024, 0); glVertex2f(800, 0); - glEnd; - - // outro overlays - glColor4f(1, 1, 1, (1 + sin(CTime / 15)) / 3 + 1/3); - glBindTexture(GL_TEXTURE_2D, outro_esc.TexNum); - glbegin(gl_quads); - glTexCoord2f( 0, 0); glVertex2f( 0, 0); - glTexCoord2f( 0, 223/256); glVertex2f( 0, 223); - glTexCoord2f(487/512, 223/256); glVertex2f(487, 223); - glTexCoord2f(487/512, 0); glVertex2f(487, 0); - glEnd; - - ESC_Alpha := 20; - if (RandomRange(0,20) > 18) and (ESC_Alpha = 20) then - ESC_Alpha := 0 - else - inc(ESC_Alpha); - if ESC_Alpha > 20 then - ESC_Alpha := 20; - glColor4f(1, 1, 1, ESC_Alpha / 20); - glBindTexture(GL_TEXTURE_2D, outro_exd.TexNum); - glbegin(gl_quads); - glTexCoord2f( 0, 0); glVertex2f(800-310, 600-247); - glTexCoord2f( 0, 247/256); glVertex2f(800-310, 600 ); - glTexCoord2f(310/512, 247/256); glVertex2f(800, 600 ); - glTexCoord2f(310/512, 0); glVertex2f(800, 600-247); - glEnd; - glDisable(GL_TEXTURE_2D); - glDisable(GL_BLEND); - - // outro scrollers? - // ... - end; - -{ - // draw credits runtime counter - SetFontStyle (2); - SetFontItalic(false); - SetFontSize(27); - SetFontPos (5, 5); - glColor4f(1, 1, 1, 1); -// RuntimeStr := 'CTime: ' + inttostr(floor(CTime / 30.320663991914489602156136106092)) + '.' + inttostr(floor(CTime / 3.0320663991914489602156136106092) - floor(CTime / 30.320663991914489602156136106092) * 10); - RuntimeStr := 'CTime: ' + inttostr(CTime); - glPrint (RuntimeStr[1]); -} - - // make the stars shine - GoldenRec.Draw; -end; - -end. diff --git a/src/screens/UScreenEdit.pas b/src/screens/UScreenEdit.pas deleted file mode 100644 index 2111adef..00000000 --- a/src/screens/UScreenEdit.pas +++ /dev/null @@ -1,164 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenEdit; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UThemes; - -type - TScreenEdit = class(TMenu) - public - TextDescription: integer; - TextDescriptionLong: integer; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure InteractNext; override; - procedure InteractPrev; override; - procedure InteractInc; override; - procedure InteractDec; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UMusic, - USkins, - UUnicodeUtils, - SysUtils; - -function TScreenEdit.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - SDL_ModState: word; -begin - Result := true; - - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT + - KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT); - - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end; - SDLK_RETURN: - begin - if Interaction = 0 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenEditConvert); - end; - - if Interaction = 1 then - begin - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end; - end; - - SDLK_DOWN: InteractInc; - SDLK_UP: InteractDec; - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end; -end; - -constructor TScreenEdit.Create; -begin - inherited Create; - - TextDescription := AddText(Theme.Edit.TextDescription); - - LoadFromTheme(Theme.Edit); - - AddButton(Theme.Edit.ButtonConvert); -{ Some ideas for more: - AddButton(Theme.Edit.ButtonEditHeaders); - AddButton(Theme.Edit.ButtonAdjustGap); -} - AddButton(Theme.Edit.ButtonExit); - - Interaction := 0; -end; - -procedure TScreenEdit.InteractNext; -begin - inherited InteractNext; - Text[TextDescription].Text := Theme.Edit.Description[Interaction]; -end; - -procedure TScreenEdit.InteractPrev; -begin - inherited InteractPrev; - Text[TextDescription].Text := Theme.Edit.Description[Interaction]; -end; - -procedure TScreenEdit.InteractDec; -begin - inherited InteractDec; - Text[TextDescription].Text := Theme.Edit.Description[Interaction]; -end; - -procedure TScreenEdit.InteractInc; -begin - inherited InteractInc; - Text[TextDescription].Text := Theme.Edit.Description[Interaction]; -end; - -procedure TScreenEdit.SetAnimationProgress(Progress: real); -begin - Static[0].Texture.ScaleW := Progress; - Static[0].Texture.ScaleH := Progress; -end; - -end. diff --git a/src/screens/UScreenEditConvert.pas b/src/screens/UScreenEditConvert.pas deleted file mode 100644 index b2fb7773..00000000 --- a/src/screens/UScreenEditConvert.pas +++ /dev/null @@ -1,827 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenEditConvert; - -{* - * See - * MIDI Recommended Practice (RP-017): SMF Lyric Meta Event Definition - * http://www.midi.org/techspecs/rp17.php - * MIDI Recommended Practice (RP-026): SMF Language and Display Extensions - * http://www.midi.org/techspecs/rp26.php - * MIDI File Format - * http://www.sonicspot.com/guide/midifiles.html - * KMIDI File Format - * http://gnese.free.fr/Projects/KaraokeTime/Fichiers/karfaq.html - * http://journals.rpungin.fotki.com/karaoke/category/midi - * - * There are two widely spread karaoke formats: - * - KMIDI (.kar), an inofficial midi extension by Tune 1000 - * - Standard Midi files with lyric meta-tags (SMF with lyrics, .mid). - * - * KMIDI uses two tracks, the first just contains a header (mostly track 2) and - * the second the lyrics (track 3). It uses text meta tags for the lyrics. - * SMF uses just one track (normally track 1) and uses lyric meta tags for storage. - * - * Most files are in the KMIDI format. Some Midi files contain both lyric types. - *} - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - math, - UMenu, - SDL, - {$IFDEF UseMIDIPort} - MidiFile, - MidiOut, - {$ENDIF} - ULog, - USongs, - USong, - UMusic, - UThemes, - UPath; - -type - TMidiNote = record - Event: integer; - EventType: integer; - Channel: integer; - Start: real; - Len: real; - Data1: integer; - Data2: integer; - Str: UTF8String; // normally ASCII - end; - - TLyricType = (ltKMIDI, ltSMFLyric); - - TTrack = record - Note: array of TMidiNote; - Name: UTF8String; // normally ASCII - Status: set of (tsNotes, tsLyrics); //< track contains notes, lyrics or both - LyricType: set of TLyricType; - NoteType: (ntNone, ntAvail); - end; - - TNote = record - Start: integer; - Len: integer; - Tone: integer; - Lyric: UTF8String; - NewSentence: boolean; - end; - - TArrayTrack = array of TTrack; - - TScreenEditConvert = class(TMenu) - private - Tracks: TArrayTrack; // current track - ColR: array[0..100] of real; - ColG: array[0..100] of real; - ColB: array[0..100] of real; - Len: real; - SelTrack: integer; // index of selected track - fFileName: IPath; - - {$IFDEF UseMIDIPort} - MidiFile: TMidiFile; - MidiOut: TMidiOutput; - {$ENDIF} - - BPM: real; - Ticks: real; - Note: array of TNote; - - procedure AddLyric(Start: integer; LyricType: TLyricType; Text: UTF8String); - procedure Extract(out Song: TSong; out Lines: TLines); - - {$IFDEF UseMIDIPort} - procedure MidiFile1MidiEvent(event: PMidiEvent); - {$ENDIF} - - function CountSelectedTracks: integer; - - public - constructor Create; override; - procedure OnShow; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function Draw: boolean; override; - procedure OnHide; override; - end; - -implementation - -uses - SysUtils, - TextGL, - gl, - UDrawTexture, - UFiles, - UGraphic, - UIni, - UMain, - UPathUtils, - USkins, - ULanguage, - UTextEncoding, - UUnicodeUtils; - -const - // MIDI/KAR lyrics are specified to be ASCII only. - // Assume backward compatible CP1252 encoding. - DEFAULT_ENCODING = encCP1252; - -const - MIDI_EVENTTYPE_NOTEOFF = $8; - MIDI_EVENTTYPE_NOTEON = $9; - MIDI_EVENTTYPE_META_SYSEX = $F; - - MIDI_EVENT_META = $FF; - MIDI_META_TEXT = $1; - MIDI_META_LYRICS = $5; - -function TScreenEditConvert.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -{$IFDEF UseMIDIPort} -var - SResult: TSaveSongResult; - Playing: boolean; - MidiTrack: TMidiTrack; - Song: TSong; - Lines: TLines; -{$ENDIF} -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - {$IFDEF UseMIDIPort} - if (MidiFile <> nil) then - MidiFile.StopPlaying; - {$ENDIF} - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenEdit); - end; - - SDLK_RETURN: - begin - if Interaction = 0 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - ScreenOpen.Filename := GamePath.Append('file.mid'); - ScreenOpen.BackScreen := @ScreenEditConvert; - FadeTo(@ScreenOpen); - end - else if Interaction = 1 then - begin - {$IFDEF UseMIDIPort} - if (MidiFile <> nil) then - begin - MidiFile.OnMidiEvent := MidiFile1MidiEvent; - //MidiFile.GoToTime(MidiFile.GetTrackLength div 2); - MidiFile.StartPlaying; - end; - {$ENDIF} - end - else if Interaction = 2 then - begin - {$IFDEF UseMIDIPort} - if (MidiFile <> nil) then - begin - MidiFile.OnMidiEvent := nil; - MidiFile.StartPlaying; - end; - {$ENDIF} - end - else if Interaction = 3 then - begin - {$IFDEF UseMIDIPort} - if CountSelectedTracks > 0 then - begin - Extract(Song, Lines); - SResult := SaveSong(Song, Lines, fFileName.SetExtension('.txt'), - false); - FreeAndNil(Song); - if (SResult = ssrOK) then - ScreenPopupInfo.ShowPopup(Language.Translate('INFO_FILE_SAVED')) - else - ScreenPopupError.ShowPopup(Language.Translate('ERROR_SAVE_FILE_FAILED')); - end - else - begin - ScreenPopupError.ShowPopup(Language.Translate('EDITOR_ERROR_NO_TRACK_SELECTED')); - end; - {$ENDIF} - end; - - end; - - SDLK_SPACE: - begin - {$IFDEF UseMIDIPort} - if (MidiFile <> nil) then - begin - if (Tracks[SelTrack].NoteType = ntAvail) and - (Tracks[SelTrack].LyricType <> []) then - begin - if (Tracks[SelTrack].Status = []) then - Tracks[SelTrack].Status := [tsNotes] - else if (Tracks[SelTrack].Status = [tsNotes]) then - Tracks[SelTrack].Status := [tsLyrics] - else if (Tracks[SelTrack].Status = [tsLyrics]) then - Tracks[SelTrack].Status := [tsNotes, tsLyrics] - else if (Tracks[SelTrack].Status = [tsNotes, tsLyrics]) then - Tracks[SelTrack].Status := []; - end - else if (Tracks[SelTrack].NoteType = ntAvail) then - begin - if (Tracks[SelTrack].Status = []) then - Tracks[SelTrack].Status := [tsNotes] - else - Tracks[SelTrack].Status := []; - end - else if (Tracks[SelTrack].LyricType <> []) then - begin - if (Tracks[SelTrack].Status = []) then - Tracks[SelTrack].Status := [tsLyrics] - else - Tracks[SelTrack].Status := []; - end; - - Playing := (MidiFile.GetCurrentTime > 0); - MidiFile.StopPlaying(); - MidiTrack := MidiFile.GetTrack(SelTrack); - if tsNotes in Tracks[SelTrack].Status then - MidiTrack.OnMidiEvent := MidiFile1MidiEvent - else - MidiTrack.OnMidiEvent := nil; - if (Playing) then - MidiFile.ContinuePlaying(); - end; - {$ENDIF} - end; - - SDLK_RIGHT: - begin - InteractNext; - end; - - SDLK_LEFT: - begin - InteractPrev; - end; - - SDLK_DOWN: - begin - Inc(SelTrack); - if SelTrack > High(Tracks) then - SelTrack := 0; - end; - SDLK_UP: - begin - Dec(SelTrack); - if SelTrack < 0 then - SelTrack := High(Tracks); - end; - end; - end; -end; - -procedure TScreenEditConvert.AddLyric(Start: integer; LyricType: TLyricType; Text: UTF8String); -var - N: integer; -begin - // find corresponding note - N := 0; - while (N <= High(Note)) do - begin - if Note[N].Start = Start then - Break; - Inc(N); - end; - - // check if note was found - if (N > High(Note)) then - Exit; - - // set text - if (LyricType = ltKMIDI) then - begin - // end of paragraph - if Copy(Text, 1, 1) = '\' then - begin - Delete(Text, 1, 1); - end - // end of line - else if Copy(Text, 1, 1) = '/' then - begin - Delete(Text, 1, 1); - Note[N].NewSentence := true; - end; - end - else // SMFLyric - begin - // Line Feed -> end of paragraph - if Copy(Text, 1, 1) = #$0A then - begin - Delete(Text, 1, 1); - end - // Carriage Return -> end of line - else if Copy(Text, 1, 1) = #$0D then - begin - Delete(Text, 1, 1); - Note[N].NewSentence := true; - end; - end; - - // overwrite lyric or append - if Note[N].Lyric = '-' then - Note[N].Lyric := Text - else - Note[N].Lyric := Note[N].Lyric + Text; -end; - -procedure TScreenEditConvert.Extract(out Song: TSong; out Lines: TLines); - -var - T: integer; - C: integer; - N: integer; - Nu: integer; - NoteTemp: TNote; - Move: integer; - Max, Min: integer; - LyricType: TLyricType; - Text: UTF8String; -begin - // song info - Song := TSong.Create(); - Song.Clear(); - Song.Resolution := 4; - SetLength(Song.BPM, 1); - Song.BPM[0].BPM := BPM*4; - SetLength(Note, 0); - - // extract notes - for T := 0 to High(Tracks) do - begin - if tsNotes in Tracks[T].Status then - begin - for N := 0 to High(Tracks[T].Note) do - begin - if (Tracks[T].Note[N].EventType = MIDI_EVENTTYPE_NOTEON) and - (Tracks[T].Note[N].Data2 > 0) then - begin - Nu := Length(Note); - SetLength(Note, Nu + 1); - Note[Nu].Start := Round(Tracks[T].Note[N].Start / Ticks); - Note[Nu].Len := Round(Tracks[T].Note[N].Len / Ticks); - Note[Nu].Tone := Tracks[T].Note[N].Data1 - 12*5; - Note[Nu].Lyric := '-'; - end; - end; - end; - end; - - // extract lyrics (and artist + title info) - for T := 0 to High(Tracks) do - begin - if not (tsLyrics in Tracks[T].Status) then - Continue; - - for N := 0 to High(Tracks[T].Note) do - begin - if (Tracks[T].Note[N].Event = MIDI_EVENT_META) then - begin - // determine and validate lyric meta tag - if (ltKMIDI in Tracks[T].LyricType) and - (Tracks[T].Note[N].Data1 = MIDI_META_TEXT) then - begin - Text := Tracks[T].Note[N].Str; - - // check for meta info - if (Length(Text) > 2) and (Text[1] = '@') then - begin - case Text[2] of - 'L': Song.Language := Copy(Text, 3, Length(Text)); // language - 'T': begin // title info - if (Song.Artist = '') then - Song.Artist := Copy(Text, 3, Length(Text)) - else if (Song.Title = '') then - Song.Title := Copy(Text, 3, Length(Text)); - end; - end; - Continue; - end; - - LyricType := ltKMIDI; - end - else if (ltSMFLyric in Tracks[T].LyricType) and - (Tracks[T].Note[N].Data1 = MIDI_META_LYRICS) then - begin - LyricType := ltSMFLyric; - end - else - begin - // unknown meta event - Continue; - end; - - AddLyric(Round(Tracks[T].Note[N].Start / Ticks), LyricType, Tracks[T].Note[N].Str); - end; - end; - end; - - // sort notes - for N := 0 to High(Note) do - for Nu := 0 to High(Note)-1 do - if Note[Nu].Start > Note[Nu+1].Start then - begin - NoteTemp := Note[Nu]; - Note[Nu] := Note[Nu+1]; - Note[Nu+1] := NoteTemp; - end; - - // move to 0 at beginning - Move := Note[0].Start; - for N := 0 to High(Note) do - Note[N].Start := Note[N].Start - Move; - - // copy notes - SetLength(Lines.Line, 1); - Lines.Number := 1; - Lines.High := 0; - Lines.Current := 0; - Lines.Resolution := 0; - Lines.NotesGAP := 0; - Lines.ScoreValue := 0; - - C := 0; - N := 0; - Lines.Line[C].HighNote := -1; - - for Nu := 0 to High(Note) do - begin - if Note[Nu].NewSentence then // new line - begin - SetLength(Lines.Line, Length(Lines.Line)+1); - Lines.Number := Lines.Number + 1; - Lines.High := Lines.High + 1; - C := C + 1; - N := 0; - SetLength(Lines.Line[C].Note, 0); - Lines.Line[C].HighNote := -1; - - //Calculate Start of the Last Sentence - if (C > 0) and (Nu > 0) then - begin - Max := Note[Nu].Start; - Min := Note[Nu-1].Start + Note[Nu-1].Len; - - case (Max - Min) of - 0: Lines.Line[C].Start := Max; - 1: Lines.Line[C].Start := Max; - 2: Lines.Line[C].Start := Max - 1; - 3: Lines.Line[C].Start := Max - 2; - else - if ((Max - Min) > 4) then - Lines.Line[C].Start := Min + 2 - else - Lines.Line[C].Start := Max; - - end; // case - - end; - end; - - // create space for new note - SetLength(Lines.Line[C].Note, Length(Lines.Line[C].Note)+1); - Inc(Lines.Line[C].HighNote); - - // initialize note - Lines.Line[C].Note[N].Start := Note[Nu].Start; - Lines.Line[C].Note[N].Length := Note[Nu].Len; - Lines.Line[C].Note[N].Tone := Note[Nu].Tone; - Lines.Line[C].Note[N].Text := DecodeStringUTF8(Note[Nu].Lyric, DEFAULT_ENCODING); - Lines.Line[C].Note[N].NoteType := ntNormal; - Inc(N); - end; -end; - -function TScreenEditConvert.CountSelectedTracks: integer; -var - T: integer; // track -begin - Result := 0; - for T := 0 to High(Tracks) do - if tsNotes in Tracks[T].Status then - Inc(Result); -end; - -{$IFDEF UseMIDIPort} -procedure TScreenEditConvert.MidiFile1MidiEvent(event: PMidiEvent); -begin - //Log.LogStatus(IntToStr(event.event), 'MIDI'); - try - MidiOut.PutShort(event.event, event.data1, event.data2); - except - MidiFile.StopPlaying(); - end; -end; -{$ENDIF} - -constructor TScreenEditConvert.Create; -var - P: integer; -begin - inherited Create; - AddButton(40, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(15, 5, 0, 0, 0, 'Open'); - //Button[High(Button)].Text[0].Size := 11; - - AddButton(160, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(25, 5, 0, 0, 0, 'Play'); - - AddButton(280, 20, 200, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(25, 5, 0, 0, 0, 'Play Selected'); - - AddButton(500, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(20, 5, 0, 0, 0, 'Save'); - - fFileName := PATH_NONE; - - for P := 0 to 100 do - begin - ColR[P] := Random(10)/10; - ColG[P] := Random(10)/10; - ColB[P] := Random(10)/10; - end; - -end; - -procedure TScreenEditConvert.OnShow; -var - T: integer; // track - N: integer; // note - {$IFDEF UseMIDIPort} - MidiTrack: TMidiTrack; - MidiEvent: PMidiEvent; - {$ENDIF} - FileOpened: boolean; - KMIDITrackIndex, SMFTrackIndex: integer; -begin - inherited; - - Interaction := 0; - -{$IFDEF UseMIDIPort} - MidiOut := TMidiOutput.Create(nil); - Log.LogInfo(MidiOut.ProductName, 'MIDI'); - MidiOut.Open; - MidiFile := nil; - SetLength(Tracks, 0); - - // Filename is only <> PATH_NONE if we called the OpenScreen before - fFilename := ScreenOpen.Filename; - if (fFilename = PATH_NONE) then - Exit; - ScreenOpen.Filename := PATH_NONE; - - FileOpened := false; - if fFileName.Exists then - begin - MidiFile := TMidiFile.Create(nil); - MidiFile.Filename := fFileName; - try - MidiFile.ReadFile; - FileOpened := true; - except - MidiFile.Free; - end; - end; - - if (not FileOpened) then - begin - ScreenPopupError.ShowPopup(Language.Translate('ERROR_FILE_NOT_FOUND')); - Exit; - end; - - Len := 0; - SelTrack := 0; - BPM := MidiFile.Bpm; - Ticks := MidiFile.TicksPerQuarter / 4; - - KMIDITrackIndex := -1; - SMFTrackIndex := -1; - - SetLength(Tracks, MidiFile.NumberOfTracks); - for T := 0 to MidiFile.NumberOfTracks-1 do - Tracks[T].LyricType := []; - - for T := 0 to MidiFile.NumberOfTracks-1 do - begin - MidiTrack := MidiFile.GetTrack(T); - MidiTrack.OnMidiEvent := nil; - Tracks[T].Name := DecodeStringUTF8(MidiTrack.getName, DEFAULT_ENCODING); - Tracks[T].NoteType := ntNone; - Tracks[T].Status := []; - - SetLength(Tracks[T].Note, MidiTrack.getEventCount()); - for N := 0 to MidiTrack.getEventCount-1 do - begin - MidiEvent := MidiTrack.GetEvent(N); - - Tracks[T].Note[N].Start := MidiEvent.time; - Tracks[T].Note[N].Len := MidiEvent.len; - Tracks[T].Note[N].Event := MidiEvent.event; - Tracks[T].Note[N].EventType := MidiEvent.event shr 4; - Tracks[T].Note[N].Channel := MidiEvent.event and $0F; - Tracks[T].Note[N].Data1 := MidiEvent.data1; - Tracks[T].Note[N].Data2 := MidiEvent.data2; - Tracks[T].Note[N].Str := DecodeStringUTF8(MidiEvent.str, DEFAULT_ENCODING); - - if (Tracks[T].Note[N].Event = MIDI_EVENT_META) then - begin - case (Tracks[T].Note[N].Data1) of - MIDI_META_TEXT: begin - // KMIDI lyrics (uses MIDI_META_TEXT events) - if (StrLComp(PAnsiChar(Tracks[T].Note[N].Str), '@KMIDI KARAOKE FILE', 19) = 0) and - (High(Tracks) >= T+1) then - begin - // The '@KMIDI ...' mark is in the first track (mostly named 'Soft Karaoke') - // but the lyrics are in the second track (named 'Words') - Tracks[T+1].LyricType := Tracks[T+1].LyricType + [ltKMIDI]; - KMIDITrackIndex := T+1; - end; - end; - MIDI_META_LYRICS: begin - // lyrics in Standard Midi File format found (uses MIDI_META_LYRICS events) - Tracks[T].LyricType := Tracks[T].LyricType + [ltSMFLyric]; - SMFTrackIndex := T; - end; - end; - end - else if (Tracks[T].Note[N].EventType = MIDI_EVENTTYPE_NOTEON) then - begin - // notes available - Tracks[T].NoteType := ntAvail; - end; - - if Tracks[T].Note[N].Start + Tracks[T].Note[N].Len > Len then - Len := Tracks[T].Note[N].Start + Tracks[T].Note[N].Len; - end; - end; - - // set default lyric track. Prefer KMIDI. - if (KMIDITrackIndex > -1) then - Tracks[KMIDITrackIndex].Status := Tracks[KMIDITrackIndex].Status + [tsLyrics] - else if (SMFTrackIndex > -1) then - Tracks[SMFTrackIndex].Status := Tracks[SMFTrackIndex].Status + [tsLyrics]; -{$ENDIF} -end; - -function TScreenEditConvert.Draw: boolean; -var - Count: integer; - Count2: integer; - Bottom: real; - X: real; - Y: real; - Height: real; - YSkip: real; - TrackName: UTF8String; -begin - // draw static menu - inherited Draw; - - Y := 100; - - Height := min(480, 40 * Length(Tracks)); - Bottom := Y + Height; - - YSkip := Height / Length(Tracks); - - // highlight selected track - DrawQuad(10, Y+SelTrack*YSkip, 780, YSkip, 0.8, 0.8, 0.8); - - // track-selection info - for Count := 0 to High(Tracks) do - if Tracks[Count].Status <> [] then - DrawQuad(10, Y + Count*YSkip, 50, YSkip, 0.8, 0.3, 0.3); - glColor3f(0, 0, 0); - for Count := 0 to High(Tracks) do - begin - if Tracks[Count].NoteType = ntAvail then - begin - if tsNotes in Tracks[Count].Status then - glColor3f(0, 0, 0) - else - glColor3f(0.7, 0.7, 0.7); - SetFontPos(25, Y + Count*YSkip + 10); - SetFontSize(15); - glPrint('N'); - end; - if Tracks[Count].LyricType <> [] then - begin - if tsLyrics in Tracks[Count].Status then - glColor3f(0, 0, 0) - else - glColor3f(0.7, 0.7, 0.7); - SetFontPos(40, Y + Count*YSkip + 10); - SetFontSize(15); - glPrint('L'); - end; - end; - - DrawLine( 10, Y, 10, Bottom, 0, 0, 0); - DrawLine( 60, Y, 60, Bottom, 0, 0, 0); - DrawLine(790, Y, 790, Bottom, 0, 0, 0); - - for Count := 0 to Length(Tracks) do - DrawLine(10, Y + Count*YSkip, 790, Y + Count*YSkip, 0, 0, 0); - - for Count := 0 to High(Tracks) do - begin - SetFontPos(65, Y + Count*YSkip); - SetFontSize(15); - glPrint(Tracks[Count].Name); - end; - - for Count := 0 to High(Tracks) do - begin - for Count2 := 0 to High(Tracks[Count].Note) do - begin - if Tracks[Count].Note[Count2].EventType = MIDI_EVENTTYPE_NOTEON then - DrawQuad(60 + Tracks[Count].Note[Count2].Start/Len * 725, - Y + (Count+1)*YSkip - Tracks[Count].Note[Count2].Data1*35/127, - 3, 3, - ColR[Count], ColG[Count], ColB[Count]); - if Tracks[Count].Note[Count2].EventType = 15 then - DrawLine(60 + Tracks[Count].Note[Count2].Start/Len * 725, Y + 0.75 * YSkip + Count*YSkip, - 60 + Tracks[Count].Note[Count2].Start/Len * 725, Y + YSkip + Count*YSkip, - ColR[Count], ColG[Count], ColB[Count]); - end; - end; - - // playing line - {$IFDEF UseMIDIPort} - if (MidiFile <> nil) then - X := 60 + MidiFile.GetCurrentTime/MidiFile.GetTrackLength*730; - {$ENDIF} - DrawLine(X, Y, X, Bottom, 0.3, 0.3, 0.3); - - Result := true; -end; - -procedure TScreenEditConvert.OnHide; -begin -{$IFDEF UseMIDIPort} - FreeAndNil(MidiFile); - MidiOut.Close; - FreeAndNil(MidiOut); -{$ENDIF} -end; - -end. diff --git a/src/screens/UScreenEditHeader.pas b/src/screens/UScreenEditHeader.pas deleted file mode 100644 index c581215b..00000000 --- a/src/screens/UScreenEditHeader.pas +++ /dev/null @@ -1,445 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenEditHeader; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - USongs, - USong, - UPath, - UThemes; - -type - TScreenEditHeader = class(TMenu) - public - CurrentSong: TSong; - TextTitle: integer; - TextArtist: integer; - TextMp3: integer; - TextBackground: integer; - TextVideo: integer; - TextVideoGAP: integer; - TextRelative: integer; - TextResolution: integer; - TextNotesGAP: integer; - TextStart: integer; - TextGAP: integer; - TextBPM: integer; - StaticTitle: integer; - StaticArtist: integer; - StaticMp3: integer; - StaticBackground: integer; - StaticVideo: integer; - StaticVideoGAP: integer; - StaticRelative: integer; - StaticResolution: integer; - StaticNotesGAP: integer; - StaticStart: integer; - StaticGAP: integer; - StaticBPM: integer; - Sel: array[0..11] of boolean; - procedure SetRoundButtons; - - constructor Create; override; - procedure OnShow; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; -{ function Draw: boolean; override; - procedure Finish;} - end; - -implementation - -uses - UGraphic, - UMusic, - SysUtils, - UFiles, - USkins, - UTexture, - UUnicodeUtils; - -function TScreenEditHeader.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - T: integer; -begin - Result := true; - if (PressedDown) then // Key Down - begin // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE: - begin - //Music.PlayBack; - //FadeTo(@MainScreen); - Result := false; - end; - - SDLK_RETURN: - begin - if Interaction = 1 then - begin - //Save; - end; - end; - - SDLK_RIGHT: - begin - case Interaction of - 0..0: InteractNext; - 1: Interaction := 0; - end; - end; - - SDLK_LEFT: - begin - case Interaction of - 0: Interaction := 1; - 1..1: InteractPrev; - end; - end; - - SDLK_DOWN: - begin - case Interaction of - 0..1: Interaction := 2; - 2..12: InteractNext; - 13: Interaction := 0; - end; - end; - - SDLK_UP: - begin - case Interaction of - 0..1: Interaction := 13; - 2: Interaction := 0; - 3..13: InteractPrev; - end; - end; - - SDLK_BACKSPACE: - begin - T := Interaction - 2 + TextTitle; - if (Interaction >= 2) and (Interaction <= 13) and (Length(Text[T].Text) >= 1) then - begin - Text[T].DeleteLastLetter; - SetRoundButtons; - end; - end; - - end; - case CharCode of - 32..255: - begin - if (Interaction >= 2) and (Interaction <= 13) then - begin - Text[Interaction - 2 + TextTitle].Text := - Text[Interaction - 2 + TextTitle].Text + UCS4ToUTF8String(CharCode); - SetRoundButtons; - end; - end; - end; - end; -end; - -constructor TScreenEditHeader.Create; -begin - inherited Create; - - AddButton(40, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(15, 5, 'Open'); - - AddButton(160, 20, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(20, 5, 'Save'); - - AddBox(80, 60, 640, 550); - - AddText(160, 110 + 0*30, 0, 30, 0, 0, 0, 'Title:'); - AddText(160, 110 + 1*30, 0, 30, 0, 0, 0, 'Artist:'); - AddText(160, 110 + 2*30, 0, 30, 0, 0, 0, 'MP3:'); - - AddText(160, 110 + 4*30, 0, 30, 0, 0, 0, 'Background:'); - AddText(160, 110 + 5*30, 0, 30, 0, 0, 0, 'Video:'); - AddText(160, 110 + 6*30, 0, 30, 0, 0, 0, 'VideoGAP:'); - - AddText(160, 110 + 8*30, 0, 30, 0, 0, 0, 'Relative:'); - AddText(160, 110 + 9*30, 0, 30, 0, 0, 0, 'Resolution:'); - AddText(160, 110 + 10*30, 0, 30, 0, 0, 0, 'NotesGAP:'); - - AddText(160, 110 + 12*30, 0, 30, 0, 0, 0, 'Start:'); - AddText(160, 110 + 13*30, 0, 30, 0, 0, 0, 'GAP:'); - AddText(160, 110 + 14*30, 0, 30, 0, 0, 0, 'BPM:'); - - TextTitle := AddText(340, 110 + 0*30, 0, 30, 0, 0, 0, ''); - TextArtist := AddText(340, 110 + 1*30, 0, 30, 0, 0, 0, ''); - TextMp3 := AddText(340, 110 + 2*30, 0, 30, 0, 0, 0, ''); - - TextBackground := AddText(340, 110 + 4*30, 0, 30, 0, 0, 0, ''); - TextVideo := AddText(340, 110 + 5*30, 0, 30, 0, 0, 0, ''); - TextVideoGAP := AddText(340, 110 + 6*30, 0, 30, 0, 0, 0, ''); - - TextRelative := AddText(340, 110 + 8*30, 0, 30, 0, 0, 0, ''); - TextResolution := AddText(340, 110 + 9*30, 0, 30, 0, 0, 0, ''); - TextNotesGAP := AddText(340, 110 + 10*30, 0, 30, 0, 0, 0, ''); - - TextStart := AddText(340, 110 + 12*30, 0, 30, 0, 0, 0, ''); - TextGAP := AddText(340, 110 + 13*30, 0, 30, 0, 0, 0, ''); - TextBPM := AddText(340, 110 + 14*30, 0, 30, 0, 0, 0, ''); - - StaticTitle := AddStatic(130, 115 + 0*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticArtist := AddStatic(130, 115 + 1*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticMp3 := AddStatic(130, 115 + 2*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticBackground := AddStatic(130, 115 + 4*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticVideo := AddStatic(130, 115 + 5*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticVideoGAP := AddStatic(130, 115 + 6*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticRelative := AddStatic(130, 115 + 8*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticResolution := AddStatic(130, 115 + 9*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticNotesGAP := AddStatic(130, 115 + 10*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticStart := AddStatic(130, 115 + 12*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticGAP := AddStatic(130, 115 + 13*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - StaticBPM := AddStatic(130, 115 + 14*30, 20, 20, 1, 1, 1, Path('RoundButton'), TEXTURE_TYPE_TRANSPARENT, $FF00FF); - - AddInteraction(iText, TextTitle); - AddInteraction(iText, TextArtist); - AddInteraction(iText, TextMp3); - AddInteraction(iText, TextBackground); - AddInteraction(iText, TextVideo); - AddInteraction(iText, TextVideoGAP); - AddInteraction(iText, TextRelative); - AddInteraction(iText, TextResolution); - AddInteraction(iText, TextNotesGAP); - AddInteraction(iText, TextStart); - AddInteraction(iText, TextGAP); - AddInteraction(iText, TextBPM); -end; - -procedure TScreenEditHeader.OnShow; -begin - inherited; - -{ if FileExists(FileName) then // load file - begin - CurrentSong.FileName := FileName; - SkanujPlik(CurrentSong); - - SetLength(TrueBoolStrs, 1); - TrueBoolStrs[0] := 'yes'; - SetLength(FalseBoolStrs, 1); - FalseBoolStrs[0] := 'no'; - - Text[TextTitle].Text := CurrentSong.Title; - Text[TextArtist].Text := CurrentSong.Artist; - Text[TextMP3].Text := CurrentSong.Mp3; - Text[TextBackground].Text := CurrentSong.Background; - Text[TextVideo].Text := CurrentSong.Video; - Text[TextVideoGAP].Text := FloatToStr(CurrentSong.VideoGAP); - Text[TextRelative].Text := BoolToStr(CurrentSong.Relative, true); - Text[TextResolution].Text := IntToStr(CurrentSong.Resolution); - Text[TextNotesGAP].Text := IntToStr(CurrentSong.NotesGAP); - Text[TextStart].Text := FloatToStr(CurrentSong.Start); - Text[TextGAP].Text := FloatToStr(CurrentSong.GAP); - Text[TextBPM].Text := FloatToStr(CurrentSong.BPM[0].BPM); - SetRoundButtons; - end;} - - Interaction := 0; -end; - -(*function TScreenEdit.Draw: boolean; -var - Min: integer; - Sec: integer; - Count: integer; - AktBeat: integer; -begin -{ glClearColor(1,1,1,1); - - // control music - if PlaySentence then - begin - // stop the music - if (Music.Position > PlayStopTime) then - begin - Music.Stop; - PlaySentence := false; - end; - - // click - if (Click) and (PlaySentence) then - begin - AktBeat := Floor(CurrentSong.BPM[0].BPM * (Music.Position - CurrentSong.GAP / 1000) / 60); - Text[TextDebug].Text := IntToStr(AktBeat); - if AktBeat <> LastClick then - begin - for Count := 0 to Czesci[0].Czesc[Czesci[0].Akt].HighNut do - if (Czesci[0].Czesc[Czesci[0].Akt].Nuta[Count].Start = AktBeat) then - begin - Music.PlayClick; - LastClick := AktBeat; - end; - end; - end; // click - end; // if PlaySentence - - Text[TextSentence].Text := IntToStr(Czesci[0].Akt + 1) + ' / ' + IntToStr(Czesci[0].Ilosc); - Text[TextNote].Text := IntToStr(AktNuta + 1) + ' / ' + IntToStr(Czesci[0].Czesc[Czesci[0].Akt].LengthNote); - - // Song info - Text[TextBPM].Text := FloatToStr(CurrentSong.BPM[0].BPM / 4); - Text[TextGAP].Text := FloatToStr(CurrentSong.GAP); - - // Note info - Text[TextNStart].Text := IntToStr(Czesci[0].Czesc[Czesci[0].Akt].Nuta[AktNuta].Start); - Text[TextNDlugosc].Text := IntToStr(Czesci[0].Czesc[Czesci[0].Akt].Nuta[AktNuta].Dlugosc); - Text[TextNTon].Text := IntToStr(Czesci[0].Czesc[Czesci[0].Akt].Nuta[AktNuta].Ton); - Text[TextNText].Text := Czesci[0].Czesc[Czesci[0].Akt].Nuta[AktNuta].Text; - - // draw static menu - inherited Draw; - - // draw notes - SingDrawNoteLines(20, 300, 780, 15); - SingDrawBeatDelimeters(40, 300, 760, 0); - SingDrawCzesc(40, 405, 760, 0); - - // draw text - Lyric.Draw;} - -end;*) - -procedure TScreenEditHeader.SetRoundButtons; -begin - if Length(Text[TextTitle].Text) > 0 then - Static[StaticTitle].Visible := true - else - Static[StaticTitle].Visible := false; - - if Length(Text[TextArtist].Text) > 0 then - Static[StaticArtist].Visible := true - else - Static[StaticArtist].Visible := false; - - if Length(Text[TextMp3].Text) > 0 then - Static[StaticMp3].Visible := true - else - Static[StaticMp3].Visible := false; - - if Length(Text[TextBackground].Text) > 0 then - Static[StaticBackground].Visible := true - else - Static[StaticBackground].Visible := false; - - if Length(Text[TextVideo].Text) > 0 then - Static[StaticVideo].Visible := true - else - Static[StaticVideo].Visible := false; - - try - StrToFloat(Text[TextVideoGAP].Text); - if StrToFloat(Text[TextVideoGAP].Text)<> 0 then - Static[StaticVideoGAP].Visible := true - else - Static[StaticVideoGAP].Visible := false; - except - Static[StaticVideoGAP].Visible := false; - end; - - if LowerCase(Text[TextRelative].Text) = 'yes' then - Static[StaticRelative].Visible := true - else - Static[StaticRelative].Visible := false; - - try - StrToInt(Text[TextResolution].Text); - if (StrToInt(Text[TextResolution].Text) <> 0) and (StrToInt(Text[TextResolution].Text) >= 1) then - Static[StaticResolution].Visible := true - else - Static[StaticResolution].Visible := false; - except - Static[StaticResolution].Visible := false; - end; - - try - StrToInt(Text[TextNotesGAP].Text); - Static[StaticNotesGAP].Visible := true; - except - Static[StaticNotesGAP].Visible := false; - end; - - // start - try - StrToFloat(Text[TextStart].Text); - if (StrToFloat(Text[TextStart].Text) > 0) then - Static[StaticStart].Visible := true - else - Static[StaticStart].Visible := false; - except - Static[StaticStart].Visible := false; - end; - - // GAP - try - StrToFloat(Text[TextGAP].Text); - Static[StaticGAP].Visible := true; - except - Static[StaticGAP].Visible := false; - end; - - // BPM - try - StrToFloat(Text[TextBPM].Text); - if (StrToFloat(Text[TextBPM].Text) > 0) then - Static[StaticBPM].Visible := true - else - Static[StaticBPM].Visible := false; - except - Static[StaticBPM].Visible := false; - end; - -end; - -(*procedure TScreenEdit.Finish; -begin -// -end;*) - -end. diff --git a/src/screens/UScreenEditSub.pas b/src/screens/UScreenEditSub.pas deleted file mode 100644 index 609a689b..00000000 --- a/src/screens/UScreenEditSub.pas +++ /dev/null @@ -1,1520 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenEditSub; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} -{$I switches.inc} - -uses - UMenu, - UMusic, - SDL, - SysUtils, - UFiles, - UTime, - USongs, - USong, - UIni, - ULog, - UTexture, - UMenuText, - UEditorLyrics, - Math, - gl, - {$IFDEF UseMIDIPort} - MidiOut, - {$ENDIF} - UThemes; - -type - TScreenEditSub = class(TMenu) - private - //Variable is True if no Song is loaded - Error: boolean; - - TextNote: integer; - TextSentence: integer; - TextTitle: integer; - TextArtist: integer; - TextMp3: integer; - TextBPM: integer; - TextGAP: integer; - TextDebug: integer; - TextNStart: integer; - TextNLength: integer; - TextNTon: integer; - TextNText: integer; - CurrentNote: integer; - PlaySentence: boolean; - PlaySentenceMidi: boolean; - PlayStopTime: real; - LastClick: integer; - Click: boolean; - CopySrc: integer; - - {$IFDEF UseMIDIPort} - MidiOut: TMidiOutput; - {$endif} - - MidiStart: real; - MidiStop: real; - MidiTime: real; - MidiPos: real; - MidiLastNote: integer; - - TextEditMode: boolean; - - Lyric: TEditorLyrics; - - procedure DivideBPM; - procedure MultiplyBPM; - procedure LyricsCapitalize; - procedure LyricsCorrectSpaces; - procedure FixTimings; - procedure DivideSentence; - procedure JoinSentence; - procedure DivideNote; - procedure DeleteNote; - procedure TransposeNote(Transpose: integer); - procedure ChangeWholeTone(Tone: integer); - procedure MoveAllToEnd(Move: integer); - procedure MoveTextToRight; - procedure MarkSrc; - procedure PasteText; - procedure CopySentence(Src, Dst: integer); - procedure CopySentences(Src, Dst, Num: integer); - //Note Name Mod - function GetNoteName(Note: integer): string; - public - Tex_Background: TTexture; - FadeOut: boolean; - constructor Create; override; - procedure OnShow; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function ParseInputEditText(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; - function Draw: boolean; override; - procedure OnHide; override; - end; - -implementation - -uses - UGraphic, - UDraw, - UNote, - USkins, - ULanguage, - UTextEncoding, - UUnicodeUtils, - UPath; - - -procedure OnSaveEncodingError(Value: boolean; Data: Pointer); -var - SResult: TSaveSongResult; - FilePath: IPath; - Success: boolean; -begin - Success := false; - if (Value) then - begin - CurrentSong.Encoding := encUTF8; - FilePath := CurrentSong.Path.Append(CurrentSong.FileName); - // create backup file - FilePath.CopyFile(Path(FilePath.ToUTF8 + '.ansi.bak'), false); - // store in UTF-8 encoding - SResult := SaveSong(CurrentSong, Lines[0], FilePath, - boolean(Data)); - Success := (SResult = ssrOK); - end; - - if (Success) then - ScreenPopupInfo.ShowPopup(Language.Translate('INFO_FILE_SAVED')) - else - ScreenPopupError.ShowPopup(Language.Translate('ERROR_SAVE_FILE_FAILED')); -end; - -// Method for input parsing. If false is returned, GetNextWindow -// should be checked to know the next window to load; -function TScreenEditSub.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - SDL_ModState: word; - R: real; - SResult: TSaveSongResult; -begin - Result := true; - - if TextEditMode then - begin - Result := ParseInputEditText(PressedKey, CharCode, PressedDown); - end - else - begin - - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT - + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT {+ KMOD_CAPS}); - - if (PressedDown) then // Key Down - begin - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - Ord('S'): - begin - // Save Song - SResult := SaveSong(CurrentSong, Lines[0], CurrentSong.Path.Append(CurrentSong.FileName), - (SDL_ModState = KMOD_LSHIFT)); - if (SResult = ssrOK) then - begin - ScreenPopupInfo.ShowPopup(Language.Translate('INFO_FILE_SAVED')); - end - else if (SResult = ssrEncodingError) then - begin - ScreenPopupCheck.ShowPopup(Language.Translate('ENCODING_ERROR_ASK_FOR_UTF8'), OnSaveEncodingError, - Pointer(SDL_ModState = KMOD_LSHIFT), true); - end - else - begin - ScreenPopupError.ShowPopup(Language.Translate('ERROR_SAVE_FILE_FAILED')); - end; - Exit; - end; - Ord('D'): - begin - // Divide lengths by 2 - DivideBPM; - Exit; - end; - Ord('M'): - begin - // Multiply lengths by 2 - MultiplyBPM; - Exit; - end; - Ord('C'): - begin - // Capitalize letter at the beginning of line - if SDL_ModState = 0 then - LyricsCapitalize; - - // Correct spaces - if SDL_ModState = KMOD_LSHIFT then - LyricsCorrectSpaces; - - // Copy sentence - if SDL_ModState = KMOD_LCTRL then - MarkSrc; - - Exit; - end; - Ord('V'): - begin - // Paste text - if SDL_ModState = KMOD_LCTRL then - begin - if Lines[0].Line[Lines[0].Current].HighNote >= Lines[0].Line[CopySrc].HighNote then - PasteText - else - Log.LogStatus('PasteText: invalid range', 'TScreenEditSub.ParseInput'); - end; - - if SDL_ModState = KMOD_LCTRL + KMOD_LSHIFT then - begin - CopySentence(CopySrc, Lines[0].Current); - end; - end; - Ord('T'): - begin - // Fixes timings between sentences - FixTimings; - Exit; - end; - Ord('P'): - begin - if SDL_ModState = 0 then - begin - // Play Sentence - Click := true; - AudioPlayback.Stop; - R := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[0].Start); - if R <= AudioPlayback.Length then - begin - AudioPlayback.Position := R; - PlayStopTime := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].End_); - PlaySentence := true; - AudioPlayback.Play; - LastClick := -100; - end; - end - else if SDL_ModState = KMOD_LSHIFT then - begin - PlaySentenceMidi := true; - - MidiTime := USTime.GetTime; - MidiStart := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[0].Start); - MidiStop := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].End_); - - LastClick := -100; - end - else if SDL_ModState = KMOD_LSHIFT or KMOD_LCTRL then - begin - PlaySentenceMidi := true; - MidiTime := USTime.GetTime; - MidiStart := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[0].Start); - MidiStop := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].End_); - LastClick := -100; - - PlaySentence := true; - Click := true; - AudioPlayback.Stop; - AudioPlayback.Position := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[0].Start)+0{-0.10}; - PlayStopTime := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].End_)+0; - AudioPlayback.Play; - LastClick := -100; - end; - Exit; - end; - - // Golden Note - Ord('G'): - begin - if (Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType = ntGolden) then - Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType := ntNormal - else - Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType := ntGolden; - - Exit; - end; - - // Freestyle Note - Ord('F'): - begin - if (Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType = ntFreestyle) then - Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType := ntNormal - else - Lines[0].Line[Lines[0].Current].Note[CurrentNote].NoteType := ntFreestyle; - - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - FadeTo(@ScreenSong); - end; - - SDLK_BACKQUOTE: - begin - // Increase Note Length (same as Alt + Right) - Inc(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); - if CurrentNote = Lines[0].Line[Lines[0].Current].HighNote then - Inc(Lines[0].Line[Lines[0].Current].End_); - end; - - SDLK_EQUALS: - begin - // Increase BPM - if SDL_ModState = 0 then - CurrentSong.BPM[0].BPM := Round((CurrentSong.BPM[0].BPM * 5) + 1) / 5; // (1/20) - if SDL_ModState = KMOD_LSHIFT then - CurrentSong.BPM[0].BPM := CurrentSong.BPM[0].BPM + 4; // (1/1) - if SDL_ModState = KMOD_LCTRL then - CurrentSong.BPM[0].BPM := Round((CurrentSong.BPM[0].BPM * 25) + 1) / 25; // (1/100) - end; - - SDLK_MINUS: - begin - // Decrease BPM - if SDL_ModState = 0 then - CurrentSong.BPM[0].BPM := Round((CurrentSong.BPM[0].BPM * 5) - 1) / 5; - if SDL_ModState = KMOD_LSHIFT then - CurrentSong.BPM[0].BPM := CurrentSong.BPM[0].BPM - 4; - if SDL_ModState = KMOD_LCTRL then - CurrentSong.BPM[0].BPM := Round((CurrentSong.BPM[0].BPM * 25) - 1) / 25; - end; - - SDLK_4: - begin - if SDL_ModState = KMOD_LCTRL + KMOD_LSHIFT then - begin - CopySentence(CopySrc, Lines[0].Current); - CopySentence(CopySrc+1, Lines[0].Current+1); - CopySentence(CopySrc+2, Lines[0].Current+2); - CopySentence(CopySrc+3, Lines[0].Current+3); - end; - - if SDL_ModState = KMOD_LCTRL + KMOD_LSHIFT + KMOD_LALT then - begin - CopySentences(CopySrc, Lines[0].Current, 4); - end; - end; - SDLK_5: - begin - if SDL_ModState = KMOD_LCTRL + KMOD_LSHIFT then - begin - CopySentence(CopySrc, Lines[0].Current); - CopySentence(CopySrc+1, Lines[0].Current+1); - CopySentence(CopySrc+2, Lines[0].Current+2); - CopySentence(CopySrc+3, Lines[0].Current+3); - CopySentence(CopySrc+4, Lines[0].Current+4); - end; - - if SDL_ModState = KMOD_LCTRL + KMOD_LSHIFT + KMOD_LALT then - begin - CopySentences(CopySrc, Lines[0].Current, 5); - end; - end; - - SDLK_9: - begin - // Decrease GAP - if SDL_ModState = 0 then - CurrentSong.GAP := CurrentSong.GAP - 10; - if SDL_ModState = KMOD_LSHIFT then - CurrentSong.GAP := CurrentSong.GAP - 1000; - end; - SDLK_0: - begin - // Increase GAP - if SDL_ModState = 0 then - CurrentSong.GAP := CurrentSong.GAP + 10; - if SDL_ModState = KMOD_LSHIFT then - CurrentSong.GAP := CurrentSong.GAP + 1000; - end; - - SDLK_KP_PLUS: - begin - // Increase tone of all notes - if SDL_ModState = 0 then - ChangeWholeTone(1); - if SDL_ModState = KMOD_LSHIFT then - ChangeWholeTone(12); - end; - - SDLK_KP_MINUS: - begin - // Decrease tone of all notes - if SDL_ModState = 0 then - ChangeWholeTone(-1); - if SDL_ModState = KMOD_LSHIFT then - ChangeWholeTone(-12); - end; - - SDLK_SLASH: - begin - if SDL_ModState = 0 then - begin - // Insert start of sentece - if CurrentNote > 0 then - DivideSentence; - end; - - if SDL_ModState = KMOD_LSHIFT then - begin - // Join next sentence with current - if Lines[0].Current < Lines[0].High then - JoinSentence; - end; - - if SDL_ModState = KMOD_LCTRL then - begin - // divide note - DivideNote; - end; - - end; - - SDLK_F4: - begin - // Enter Text Edit Mode - TextEditMode := true; - end; - - SDLK_SPACE: - begin - // Play Sentence - PlaySentenceMidi := false; // stop midi - PlaySentence := true; - Click := false; - AudioPlayback.Stop; - AudioPlayback.Position := GetTimeFromBeat(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - PlayStopTime := (GetTimeFromBeat( - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start + - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length)); - AudioPlayback.Play; - LastClick := -100; - end; - - SDLK_RETURN: - begin - end; - - SDLK_DELETE: - begin - if SDL_ModState = KMOD_LCTRL then - begin - // moves text to right in current sentence - DeleteNote; - end; - end; - - SDLK_PERIOD: - begin - // moves text to right in current sentence - MoveTextToRight; - end; - - SDLK_RIGHT: - begin - // right - if SDL_ModState = 0 then - begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; - Inc(CurrentNote); - if CurrentNote > Lines[0].Line[Lines[0].Current].HighNote then - CurrentNote := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - Lyric.Selected := CurrentNote; - end; - - // ctrl + right - if SDL_ModState = KMOD_LCTRL then - begin - if Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length > 1 then - begin - Dec(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); - Inc(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - if CurrentNote = 0 then - begin - Inc(Lines[0].Line[Lines[0].Current].Start); - end; - end; - end; - - // shift + right - if SDL_ModState = KMOD_LSHIFT then - begin - Inc(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - if CurrentNote = 0 then - begin - Inc(Lines[0].Line[Lines[0].Current].Start); - end; - if CurrentNote = Lines[0].Line[Lines[0].Current].HighNote then - Inc(Lines[0].Line[Lines[0].Current].End_); - end; - - // alt + right - if SDL_ModState = KMOD_LALT then - begin - Inc(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); - if CurrentNote = Lines[0].Line[Lines[0].Current].HighNote then - Inc(Lines[0].Line[Lines[0].Current].End_); - end; - - // alt + ctrl + shift + right = move all from cursor to right - if SDL_ModState = KMOD_LALT + KMOD_LCTRL + KMOD_LSHIFT then - begin - MoveAllToEnd(1); - end; - - end; - - SDLK_LEFT: - begin - // left - if SDL_ModState = 0 then - begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; - Dec(CurrentNote); - if CurrentNote = -1 then - CurrentNote := Lines[0].Line[Lines[0].Current].HighNote; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - Lyric.Selected := CurrentNote; - end; - - // ctrl + left - if SDL_ModState = KMOD_LCTRL then - begin - Dec(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - Inc(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); - if CurrentNote = 0 then - begin - Dec(Lines[0].Line[Lines[0].Current].Start); - end; - end; - - // shift + left - if SDL_ModState = KMOD_LSHIFT then - begin - Dec(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - - // resizing sentences - if CurrentNote = 0 then - begin - Dec(Lines[0].Line[Lines[0].Current].Start); - end; - - if CurrentNote = Lines[0].Line[Lines[0].Current].HighNote then - Dec(Lines[0].Line[Lines[0].Current].End_); - - end; - - // alt + left - if SDL_ModState = KMOD_LALT then - begin - if Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length > 1 then - begin - Dec(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); - if CurrentNote = Lines[0].Line[Lines[0].Current].HighNote then - Dec(Lines[0].Line[Lines[0].Current].End_); - end; - end; - - // alt + ctrl + shift + right = move all from cursor to left - if SDL_ModState = KMOD_LALT + KMOD_LCTRL + KMOD_LSHIFT then - begin - MoveAllToEnd(-1); - end; - - end; - - SDLK_DOWN: - begin - - // skip to next sentence - if SDL_ModState = 0 then - begin - {$IFDEF UseMIDIPort} - MidiOut.PutShort($81, Lines[0].Line[Lines[0].Current].Note[MidiLastNote].Tone + 60, 127); - PlaySentenceMidi := false; - {$ENDIF} - - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; - Inc(Lines[0].Current); - CurrentNote := 0; - if Lines[0].Current > Lines[0].High then - Lines[0].Current := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - - Lyric.AddLine(Lines[0].Current); - Lyric.Selected := 0; - AudioPlayback.Stop; - PlaySentence := false; - end; - - // decrease tone - if SDL_ModState = KMOD_LCTRL then - begin - TransposeNote(-1); - end; - - end; - - SDLK_UP: - begin - - // skip to previous sentence - if SDL_ModState = 0 then - begin - {$IFDEF UseMIDIPort} - MidiOut.PutShort($81, Lines[0].Line[Lines[0].Current].Note[MidiLastNote].Tone + 60, 127); - PlaySentenceMidi := false; - {$endif} - - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; - Dec(Lines[0].Current); - CurrentNote := 0; - if Lines[0].Current = -1 then - Lines[0].Current := Lines[0].High; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - - Lyric.AddLine(Lines[0].Current); - Lyric.Selected := 0; - AudioPlayback.Stop; - PlaySentence := false; - end; - - // increase tone - if SDL_ModState = KMOD_LCTRL then - begin - TransposeNote(1); - end; - end; - - end; // case - end; - end; // if -end; - -function TScreenEditSub.ParseInputEditText(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - SDL_ModState: word; -begin - // used when in Text Edit Mode - Result := true; - - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT - + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT {+ KMOD_CAPS}); - - if (PressedDown) then - begin - // check normal keys - if (IsPrintableChar(CharCode)) then - begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text := - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text + UCS4ToUTF8String(CharCode); - Exit; - end; - - // check special keys - case PressedKey of - - SDLK_ESCAPE: - begin - FadeTo(@ScreenSong); - end; - SDLK_F4, SDLK_RETURN: - begin - // Exit Text Edit Mode - TextEditMode := false; - end; - SDLK_BACKSPACE: - begin - UTF8Delete(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text, - LengthUTF8(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text), 1); - end; - SDLK_RIGHT: - begin - // right - if SDL_ModState = 0 then - begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; - Inc(CurrentNote); - if CurrentNote > Lines[0].Line[Lines[0].Current].HighNote then - CurrentNote := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - Lyric.Selected := CurrentNote; - end; - end; - SDLK_LEFT: - begin - // left - if SDL_ModState = 0 then - begin - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 1; - Dec(CurrentNote); - if CurrentNote = -1 then - CurrentNote := Lines[0].Line[Lines[0].Current].HighNote; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - Lyric.Selected := CurrentNote; - end; - end; - end; - end; -end; - -{ -procedure TScreenEditSub.NewBeat; -begin - // click - for Pet := 0 to Lines[0].Line[Lines[0].Current].HighNut do - if (Lines[0].Line[Lines[0].Current].Note[Pet].Start = Czas.AktBeat) then - Music.PlayClick; -end; -} - -procedure TScreenEditSub.DivideBPM; -var - C: integer; - N: integer; -begin - CurrentSong.BPM[0].BPM := CurrentSong.BPM[0].BPM / 2; - for C := 0 to Lines[0].High do - begin - Lines[0].Line[C].Start := Lines[0].Line[C].Start div 2; - Lines[0].Line[C].End_ := Lines[0].Line[C].End_ div 2; - for N := 0 to Lines[0].Line[C].HighNote do - begin - Lines[0].Line[C].Note[N].Start := Lines[0].Line[C].Note[N].Start div 2; - Lines[0].Line[C].Note[N].Length := Round(Lines[0].Line[C].Note[N].Length / 2); - end; // N - end; // C -end; - -procedure TScreenEditSub.MultiplyBPM; -var - C: integer; - N: integer; -begin - CurrentSong.BPM[0].BPM := CurrentSong.BPM[0].BPM * 2; - for C := 0 to Lines[0].High do - begin - Lines[0].Line[C].Start := Lines[0].Line[C].Start * 2; - Lines[0].Line[C].End_ := Lines[0].Line[C].End_ * 2; - for N := 0 to Lines[0].Line[C].HighNote do - begin - Lines[0].Line[C].Note[N].Start := Lines[0].Line[C].Note[N].Start * 2; - Lines[0].Line[C].Note[N].Length := Lines[0].Line[C].Note[N].Length * 2; - end; // N - end; // C -end; - -procedure TScreenEditSub.LyricsCapitalize; -var - C: integer; - //N: integer; // temporary - S: string; -begin - // temporary - { - for C := 0 to Lines[0].High do - for N := 0 to Lines[0].Line[C].HighNut do - Lines[0].Line[C].Note[N].Text := UTF8LowerCase(Lines[0].Line[C].Note[N].Text); - } - - for C := 0 to Lines[0].High do - begin - S := AnsiUpperCase(Copy(Lines[0].Line[C].Note[0].Text, 1, 1)); - S := S + Copy(Lines[0].Line[C].Note[0].Text, 2, Length(Lines[0].Line[C].Note[0].Text)-1); - Lines[0].Line[C].Note[0].Text := S; - end; // C -end; - -procedure TScreenEditSub.LyricsCorrectSpaces; -var - C: integer; - N: integer; -begin - for C := 0 to Lines[0].High do - begin - // correct starting spaces in the first word - while Copy(Lines[0].Line[C].Note[0].Text, 1, 1) = ' ' do - Lines[0].Line[C].Note[0].Text := Copy(Lines[0].Line[C].Note[0].Text, 2, 100); - - // move spaces on the start to the end of the previous note - for N := 1 to Lines[0].Line[C].HighNote do - begin - while (Copy(Lines[0].Line[C].Note[N].Text, 1, 1) = ' ') do - begin - Lines[0].Line[C].Note[N].Text := Copy(Lines[0].Line[C].Note[N].Text, 2, 100); - Lines[0].Line[C].Note[N-1].Text := Lines[0].Line[C].Note[N-1].Text + ' '; - end; - end; // N - - // correct '-' to '- ' - for N := 0 to Lines[0].Line[C].HighNote do - begin - if Lines[0].Line[C].Note[N].Text = '-' then - Lines[0].Line[C].Note[N].Text := '- '; - end; // N - - // add space to the previous note when the current word is '- ' - for N := 1 to Lines[0].Line[C].HighNote do - begin - if Lines[0].Line[C].Note[N].Text = '- ' then - Lines[0].Line[C].Note[N-1].Text := Lines[0].Line[C].Note[N-1].Text + ' '; - end; // N - - // correct too many spaces at the end of note - for N := 0 to Lines[0].Line[C].HighNote do - begin - while Copy(Lines[0].Line[C].Note[N].Text, Length(Lines[0].Line[C].Note[N].Text)-1, 2) = ' ' do - Lines[0].Line[C].Note[N].Text := Copy(Lines[0].Line[C].Note[N].Text, 1, Length(Lines[0].Line[C].Note[N].Text)-1); - end; // N - - // and correct if there is no space at the end of sentence - N := Lines[0].Line[C].HighNote; - if Copy(Lines[0].Line[C].Note[N].Text, Length(Lines[0].Line[C].Note[N].Text), 1) <> ' ' then - Lines[0].Line[C].Note[N].Text := Lines[0].Line[C].Note[N].Text + ' '; - - end; // C -end; - -procedure TScreenEditSub.FixTimings; -var - C: integer; - S: integer; - Min: integer; - Max: integer; -begin - for C := 1 to Lines[0].High do - begin - with Lines[0].Line[C-1] do - begin - Min := Note[HighNote].Start + Note[HighNote].Length; - Max := Lines[0].Line[C].Note[0].Start; - case (Max - Min) of - 0: S := Max; - 1: S := Max; - 2: S := Max - 1; - 3: S := Max - 2; - else - if ((Max - Min) > 4) then - S := Min + 2 - else - S := Max; - end; // case - - Lines[0].Line[C].Start := S; - end; // with - end; // for -end; - -procedure TScreenEditSub.DivideSentence; -var - C: integer; - CStart: integer; - CNew: integer; - CLen: integer; - N: integer; - NStart: integer; - NHigh: integer; -begin - // increase sentence length by 1 - CLen := Length(Lines[0].Line); - SetLength(Lines[0].Line, CLen + 1); - Inc(Lines[0].Number); - Inc(Lines[0].High); - - // move needed sentences to one forward. newly has the copy of divided sentence - CStart := Lines[0].Current; - for C := CLen-1 downto CStart do - Lines[0].Line[C+1] := Lines[0].Line[C]; - - // clear and set new sentence - CNew := CStart + 1; - NStart := CurrentNote; - Lines[0].Line[CNew].Start := Lines[0].Line[CStart].Note[NStart].Start; - Lines[0].Line[CNew].Lyric := ''; - Lines[0].Line[CNew].End_ := 0; - Lines[0].Line[CNew].BaseNote := 0;//High(integer); // TODO: High (integer) will causes a memory exception later in this procedure. Weird! - Lines[0].Line[CNew].HighNote := -1; - SetLength(Lines[0].Line[CNew].Note, 0); - - // move right notes to new sentences - NHigh := Lines[0].Line[CStart].HighNote; - for N := NStart to NHigh do - begin - // increase sentence counters - with Lines[0].Line[CNew] do - begin - Inc(HighNote); - SetLength(Note, HighNote + 1); - Note[HighNote] := Note[N]; - End_ := Note[HighNote].Start + Note[HighNote].Length; - - if Note[HighNote].Tone < BaseNote then - BaseNote := Note[HighNote].Tone; - end; - end; - - // clear old notes and set sentence counters - Lines[0].Line[CStart].HighNote := NStart - 1; - Lines[0].Line[CStart].End_ := Lines[0].Line[CStart].Note[NStart-1].Start + - Lines[0].Line[CStart].Note[NStart-1].Length; - SetLength(Lines[0].Line[CStart].Note, Lines[0].Line[CStart].HighNote + 1); - - //recalculate BaseNote of the divided Sentence - with Lines[0].Line[CStart] do - begin - BaseNote := High(integer); - - for N := 0 to HighNote do - if Note[N].Tone < BaseNote then - BaseNote := Note[N].Tone; - end; - - Lines[0].Current := Lines[0].Current + 1; - CurrentNote := 0; - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - Lyric.AddLine(Lines[0].Current); -end; - -procedure TScreenEditSub.JoinSentence; -var - C: integer; - N: integer; - NStart: integer; - NDst: integer; -begin - C := Lines[0].Current; - - // set new sentence - NStart := Lines[0].Line[C].HighNote + 1; - Lines[0].Line[C].HighNote := Lines[0].Line[C].HighNote + Lines[0].Line[C+1].HighNote + 1; - SetLength(Lines[0].Line[C].Note, Lines[0].Line[C].HighNote + 1); - - // move right notes to new sentences - for N := 0 to Lines[0].Line[C+1].HighNote do - begin - NDst := NStart + N; - Lines[0].Line[C].Note[NDst] := Lines[0].Line[C+1].Note[N]; - end; - - // increase sentence counters - NDst := Lines[0].Line[C].HighNote; - Lines[0].Line[C].End_ := Lines[0].Line[C].Note[NDst].Start + - Lines[0].Line[C].Note[NDst].Length; - - // move needed sentences to one backward. - for C := Lines[0].Current + 1 to Lines[0].High - 1 do - Lines[0].Line[C] := Lines[0].Line[C+1]; - - // increase sentence length by 1 - SetLength(Lines[0].Line, Length(Lines[0].Line) - 1); - Dec(Lines[0].Number); - Dec(Lines[0].High); -end; - -procedure TScreenEditSub.DivideNote; -var - C: integer; - N: integer; -begin - C := Lines[0].Current; - - with Lines[0].Line[C] do - begin - Inc(HighNote); - SetLength(Note, HighNote + 1); - - // we copy all notes including selected one - for N := HighNote downto CurrentNote+1 do - begin - Note[N] := Note[N-1]; - end; - - // me slightly modify new note - Note[CurrentNote].Length := 1; - Inc(Note[CurrentNote+1].Start); - Dec(Note[CurrentNote+1].Length); - Note[CurrentNote+1].Text := '- '; - Note[CurrentNote+1].Color := 1; - end; -end; - -procedure TScreenEditSub.DeleteNote; -var - C: integer; - N: integer; -begin - C := Lines[0].Current; - - //Do Not delete Last Note - if (Lines[0].High > 0) or (Lines[0].Line[C].HighNote > 0) then - begin - - // we copy all notes from the next to the selected one - for N := CurrentNote+1 to Lines[0].Line[C].HighNote do - begin - Lines[0].Line[C].Note[N-1] := Lines[0].Line[C].Note[N]; - end; - - Dec(Lines[0].Line[C].HighNote); - if (Lines[0].Line[C].HighNote >= 0) then - begin - SetLength(Lines[0].Line[C].Note, Lines[0].Line[C].HighNote + 1); - - // me slightly modify new note - if CurrentNote > Lines[0].Line[C].HighNote then - Dec(CurrentNote); - - Lines[0].Line[C].Note[CurrentNote].Color := 2; - end - //Last Note of current Sentence Deleted - > Delete Sentence - else - begin - //Move all Sentences after the current to the Left - for N := C+1 to Lines[0].High do - Lines[0].Line[N-1] := Lines[0].Line[N]; - - //Delete Last Sentence - SetLength(Lines[0].Line, Lines[0].High); - Lines[0].High := High(Lines[0].Line); - Lines[0].Number := Length(Lines[0].Line); - - CurrentNote := 0; - if (C > 0) then - Lines[0].Current := C - 1 - else - Lines[0].Current := 0; - - Lines[0].Line[Lines[0].Current].Note[CurrentNote].Color := 2; - end; - end; -end; - -procedure TScreenEditSub.TransposeNote(Transpose: integer); -begin - Inc(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Tone, Transpose); -end; - -procedure TScreenEditSub.ChangeWholeTone(Tone: integer); -var - C: integer; - N: integer; -begin - for C := 0 to Lines[0].High do - begin - Lines[0].Line[C].BaseNote := Lines[0].Line[C].BaseNote + Tone; - for N := 0 to Lines[0].Line[C].HighNote do - Lines[0].Line[C].Note[N].Tone := Lines[0].Line[C].Note[N].Tone + Tone; - end; -end; - -procedure TScreenEditSub.MoveAllToEnd(Move: integer); -var - C: integer; - N: integer; - NStart: integer; -begin - for C := Lines[0].Current to Lines[0].High do - begin - NStart := 0; - if C = Lines[0].Current then - NStart := CurrentNote; - for N := NStart to Lines[0].Line[C].HighNote do - begin - Inc(Lines[0].Line[C].Note[N].Start, Move); // move note start - - if N = 0 then - begin // fix beginning - Inc(Lines[0].Line[C].Start, Move); - end; - - if N = Lines[0].Line[C].HighNote then // fix ending - Inc(Lines[0].Line[C].End_, Move); - - end; // for - end; // for -end; - -procedure TScreenEditSub.MoveTextToRight; -var - C: integer; - N: integer; - NHigh: integer; -begin - { - C := Lines[0].Current; - - for N := Lines[0].Line[C].HighNut downto 1 do - begin - Lines[0].Line[C].Note[N].Text := Lines[0].Line[C].Note[N-1].Text; - end; // for - - Lines[0].Line[C].Note[0].Text := '- '; - } - - C := Lines[0].Current; - NHigh := Lines[0].Line[C].HighNote; - - // last word - Lines[0].Line[C].Note[NHigh].Text := Lines[0].Line[C].Note[NHigh-1].Text + Lines[0].Line[C].Note[NHigh].Text; - - // other words - for N := NHigh - 1 downto CurrentNote + 1 do - begin - Lines[0].Line[C].Note[N].Text := Lines[0].Line[C].Note[N-1].Text; - end; // for - Lines[0].Line[C].Note[CurrentNote].Text := '- '; -end; - -procedure TScreenEditSub.MarkSrc; -begin - CopySrc := Lines[0].Current; -end; - -procedure TScreenEditSub.PasteText; -var - C: integer; - N: integer; -begin - C := Lines[0].Current; - - for N := 0 to Lines[0].Line[CopySrc].HighNote do - Lines[0].Line[C].Note[N].Text := Lines[0].Line[CopySrc].Note[N].Text; -end; - -procedure TScreenEditSub.CopySentence(Src, Dst: integer); -var - N: integer; - Time1: integer; - Time2: integer; - TD: integer; -begin - Time1 := Lines[0].Line[Src].Note[0].Start; - Time2 := Lines[0].Line[Dst].Note[0].Start; - TD := Time2-Time1; - - SetLength(Lines[0].Line[Dst].Note, Lines[0].Line[Src].HighNote + 1); - Lines[0].Line[Dst].HighNote := Lines[0].Line[Src].HighNote; - for N := 0 to Lines[0].Line[Src].HighNote do - begin - Lines[0].Line[Dst].Note[N].Text := Lines[0].Line[Src].Note[N].Text; - Lines[0].Line[Dst].Note[N].Length := Lines[0].Line[Src].Note[N].Length; - Lines[0].Line[Dst].Note[N].Tone := Lines[0].Line[Src].Note[N].Tone; - Lines[0].Line[Dst].Note[N].Start := Lines[0].Line[Src].Note[N].Start + TD; - end; - N := Lines[0].Line[Src].HighNote; - Lines[0].Line[Dst].End_ := Lines[0].Line[Dst].Note[N].Start + Lines[0].Line[Dst].Note[N].Length; -end; - -procedure TScreenEditSub.CopySentences(Src, Dst, Num: integer); -var - C: integer; -begin - // create place for new sentences - SetLength(Lines[0].Line, Lines[0].Number + Num - 1); - - // moves sentences next to the destination - for C := Lines[0].High downto Dst + 1 do - begin - Lines[0].Line[C + Num - 1] := Lines[0].Line[C]; - end; - - // prepares new sentences: sets sentence start and create first note - for C := 1 to Num-1 do - begin - Lines[0].Line[Dst + C].Start := Lines[0].Line[Dst + C - 1].Note[0].Start + - (Lines[0].Line[Src + C].Note[0].Start - Lines[0].Line[Src + C - 1].Note[0].Start); - SetLength(Lines[0].Line[Dst + C].Note, 1); - Lines[0].Line[Dst + C].HighNote := 0; - Lines[0].Line[Dst + C].Note[0].Start := Lines[0].Line[Dst + C].Start; - Lines[0].Line[Dst + C].Note[0].Length := 1; - Lines[0].Line[Dst + C].End_ := Lines[0].Line[Dst + C].Start + 1; - end; - - // increase counters - Lines[0].Number := Lines[0].Number + Num - 1; - Lines[0].High := Lines[0].High + Num - 1; - - for C := 0 to Num-1 do - CopySentence(Src + C, Dst + C); -end; - -constructor TScreenEditSub.Create; -begin - inherited Create; - SetLength(Player, 1); - - // line - AddStatic(20, 10, 80, 30, 0, 0, 0, Skin.GetTextureFileName('ButtonF'), TEXTURE_TYPE_COLORIZED); - AddText(40, 17, 1, 18, 1, 1, 1, 'Line'); - TextSentence := AddText(120, 14, 1, 24, 0, 0, 0, '0 / 0'); - - // Note - AddStatic(220, 10, 80, 30, 0, 0, 0, Skin.GetTextureFileName('ButtonF'), TEXTURE_TYPE_COLORIZED); - AddText(242, 17, 1, 18, 1, 1, 1, 'Note'); - TextNote := AddText(320, 14, 1, 24, 0, 0, 0, '0 / 0'); - - // file info - AddStatic(150, 50, 500, 150, 0, 0, 0, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); - AddStatic(151, 52, 498, 146, 1, 1, 1, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); - AddText(180, 65, 0, 24, 0, 0, 0, 'Title:'); - AddText(180, 90, 0, 24, 0, 0, 0, 'Artist:'); - AddText(180, 115, 0, 24, 0, 0, 0, 'Mp3:'); - AddText(180, 140, 0, 24, 0, 0, 0, 'BPM:'); - AddText(180, 165, 0, 24, 0, 0, 0, 'GAP:'); - - TextTitle := AddText(250, 65, 0, 24, 0, 0, 0, 'a'); - TextArtist := AddText(250, 90, 0, 24, 0, 0, 0, 'b'); - TextMp3 := AddText(250, 115, 0, 24, 0, 0, 0, 'c'); - TextBPM := AddText(250, 140, 0, 24, 0, 0, 0, 'd'); - TextGAP := AddText(250, 165, 0, 24, 0, 0, 0, 'e'); - -{ AddInteraction(2, TextTitle); - AddInteraction(2, TextArtist); - AddInteraction(2, TextMp3); - AddInteraction(2, TextBPM); - AddInteraction(2, TextGAP);} - - // note info - AddText(20, 190, 0, 24, 0, 0, 0, 'Start:'); - AddText(20, 215, 0, 24, 0, 0, 0, 'Duration:'); - AddText(20, 240, 0, 24, 0, 0, 0, 'Tone:'); - AddText(20, 265, 0, 24, 0, 0, 0, 'Text:'); - - TextNStart := AddText(120, 190, 0, 24, 0, 0, 0, 'a'); - TextNLength := AddText(120, 215, 0, 24, 0, 0, 0, 'b'); - TextNTon := AddText(120, 240, 0, 24, 0, 0, 0, 'c'); - TextNText := AddText(120, 265, 0, 24, 0, 0, 0, 'd'); - - // debug - TextDebug := AddText(30, 550, 0, 8, 0, 0, 0, ''); - -end; - -procedure TScreenEditSub.OnShow; -var - FileExt: IPath; -begin - inherited; - - Log.LogStatus('Initializing', 'TEditScreen.OnShow'); - Lyric := TEditorLyrics.Create; - - ResetSingTemp; - - try - //Check if File is XML - FileExt := CurrentSong.FileName.GetExtension; - if FileExt.ToUTF8 = '.xml' then - Error := not CurrentSong.LoadXMLSong() - else - begin - // reread header with custom tags - Error := not CurrentSong.Analyse(true); - if not Error then - Error := not CurrentSong.LoadSong; - end; - except - Error := true; - end; - - if Error then - begin - //Error Loading Song -> Go back to Song Screen and Show some Error Message - FadeTo(@ScreenSong); - ScreenPopupError.ShowPopup (Language.Translate('ERROR_CORRUPT_SONG')); - Exit; - end - else - begin - {$IFDEF UseMIDIPort} - MidiOut := TMidiOutput.Create(nil); - if Ini.Debug = 1 then - MidiOut.ProductName := 'Microsoft GS Wavetable SW Synth'; // for my kxproject without midi table - MidiOut.Open; - {$ENDIF} - Text[TextTitle].Text := CurrentSong.Title; - Text[TextArtist].Text := CurrentSong.Artist; - Text[TextMp3].Text := CurrentSong.Mp3.ToUTF8; - - Lines[0].Current := 0; - CurrentNote := 0; - Lines[0].Line[0].Note[0].Color := 2; - AudioPlayback.Open(CurrentSong.Path.Append(CurrentSong.Mp3)); - //Set Down Music Volume for Better hearability of Midi Sounds - //Music.SetVolume(0.4); - - Lyric.Clear; - Lyric.X := 400; - Lyric.Y := 500; - Lyric.Align := atCenter; - Lyric.Size := 42; - Lyric.ColR := 0; - Lyric.ColG := 0; - Lyric.ColB := 0; - Lyric.ColSR := Skin_FontHighlightR; - Lyric.ColSG := Skin_FontHighlightG; - Lyric.ColSB := Skin_FontHighlightB; - Lyric.AddLine(0); - Lyric.Selected := 0; - - NotesH := 7; - NotesW := 4; - - end; - -// Interaction := 0; - TextEditMode := false; -end; - -function TScreenEditSub.Draw: boolean; -var - Pet: integer; - AktBeat: integer; -begin - glClearColor(1,1,1,1); - - // midi music - if PlaySentenceMidi then - begin - {$IFDEF UseMIDIPort} - MidiPos := USTime.GetTime - MidiTime + MidiStart; - - // stop the music - if (MidiPos > MidiStop) then - begin - MidiOut.PutShort($81, Lines[0].Line[Lines[0].Current].Note[MidiLastNote].Tone + 60, 127); - PlaySentenceMidi := false; - end; - {$ENDIF} - - // click - AktBeat := Floor(GetMidBeat(MidiPos - CurrentSong.GAP / 1000)); - Text[TextDebug].Text := IntToStr(AktBeat); - - if AktBeat <> LastClick then - begin - for Pet := 0 to Lines[0].Line[Lines[0].Current].HighNote do - if (Lines[0].Line[Lines[0].Current].Note[Pet].Start = AktBeat) then - begin - - LastClick := AktBeat; - {$IFDEF UseMIDIPort} - if Pet > 0 then - MidiOut.PutShort($81, Lines[0].Line[Lines[0].Current].Note[Pet-1].Tone + 60, 127); - MidiOut.PutShort($91, Lines[0].Line[Lines[0].Current].Note[Pet].Tone + 60, 127); - MidiLastNote := Pet; - {$ENDIF} - - end; - end; - end; // if PlaySentenceMidi - - // mp3 music - if PlaySentence then - begin - // stop the music - if (AudioPlayback.Position > PlayStopTime) then - begin - AudioPlayback.Stop; - PlaySentence := false; - end; - - // click - if (Click) and (PlaySentence) then - begin -// AktBeat := Floor(CurrentSong.BPM[0].BPM * (Music.Position - CurrentSong.GAP / 1000) / 60); - AktBeat := Floor(GetMidBeat(AudioPlayback.Position - CurrentSong.GAP / 1000)); - Text[TextDebug].Text := IntToStr(AktBeat); - if AktBeat <> LastClick then - begin - for Pet := 0 to Lines[0].Line[Lines[0].Current].HighNote do - if (Lines[0].Line[Lines[0].Current].Note[Pet].Start = AktBeat) then - begin - AudioPlayback.PlaySound( SoundLib.Click ); - LastClick := AktBeat; - end; - end; - end; // click - end; // if PlaySentence - - - Text[TextSentence].Text := IntToStr(Lines[0].Current + 1) + ' / ' + IntToStr(Lines[0].Number); - Text[TextNote].Text := IntToStr(CurrentNote + 1) + ' / ' + IntToStr(Lines[0].Line[Lines[0].Current].HighNote + 1); - - // Song info - Text[TextBPM].Text := FloatToStr(CurrentSong.BPM[0].BPM / 4); - Text[TextGAP].Text := FloatToStr(CurrentSong.GAP); - - //Error reading Variables when no Song is loaded - if not Error then - begin - // Note info - Text[TextNStart].Text := IntToStr(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Start); - Text[TextNLength].Text := IntToStr(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Length); - Text[TextNTon].Text := IntToStr(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Tone) + ' ( ' + GetNoteName(Lines[0].Line[Lines[0].Current].Note[CurrentNote].Tone) + ' )'; - Text[TextNText].Text := Lines[0].Line[Lines[0].Current].Note[CurrentNote].Text; - end; - - // Text Edit Mode - if TextEditMode then - Text[TextNText].Text := Text[TextNText].Text + '|'; - - // draw static menu - inherited Draw; - - // draw notes - SingDrawNoteLines(20, 300, 780, 15); - //Error Drawing when no Song is loaded - if not Error then - begin - SingDrawBeatDelimeters(40, 300, 760, 0); - EditDrawLine(40, 405, 760, 0, 15); - end; - - // draw text - Lyric.Draw; - - Result := true; -end; - -procedure TScreenEditSub.OnHide; -begin - {$IFDEF UseMIDIPort} - MidiOut.Close; - MidiOut.Free; - {$ENDIF} - Lyric.Free; - //Music.SetVolume(1.0); -end; - -function TScreenEditSub.GetNoteName(Note: integer): string; -var - N1, N2: integer; -begin - if (Note > 0) then - begin - N1 := Note mod 12; - N2 := Note div 12; - end - else - begin - N1 := (Note + (-Trunc(Note/12)+1)*12) mod 12; - N2 := -1; - end; - - case N1 of - 0: Result := 'c'; - 1: Result := 'c#'; - 2: Result := 'd'; - 3: Result := 'd#'; - 4: Result := 'e'; - 5: Result := 'f'; - 6: Result := 'f#'; - 7: Result := 'g'; - 8: Result := 'g#'; - 9: Result := 'a'; - 10: Result := 'b'; - 11: Result := 'h'; - end; - - case N2 of - 0: Result := UpperCase(Result); //Normal Uppercase Note, 1: Normal lowercase Note - 2: Result := Result + ''''; //One Striped - 3: Result := Result + ''''''; //Two Striped - 4: Result := Result + ''''''''; //etc. - 5: Result := Result + ''''''''''; - 6: Result := Result + ''''''''''''; - 7: Result := Result + ''''''''''''''; - end; -end; - -end. diff --git a/src/screens/UScreenLevel.pas b/src/screens/UScreenLevel.pas deleted file mode 100644 index 1ead9773..00000000 --- a/src/screens/UScreenLevel.pas +++ /dev/null @@ -1,139 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenLevel; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - SysUtils, - UThemes; - -type - TScreenLevel = class(TMenu) - public - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UMain, - UIni, - USong, - UTexture, - UUnicodeUtils; - -function TScreenLevel.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Back); - - if Ini.OnSongClick = sSelectPlayer then - FadeTo(@ScreenMain) - else - FadeTo(@ScreenName); - end; - - SDLK_RETURN: - begin - Ini.Difficulty := Interaction; - Ini.SaveLevel; - AudioPlayback.PlaySound(SoundLib.Start); - //Set Standard Mode - ScreenSong.Mode := smNormal; - FadeTo(@ScreenSong); - end; - - // Up and Down could be done at the same time, - // but I don't want to declare variables inside - // functions like this one, called so many times - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end; -end; - -constructor TScreenLevel.Create; -begin - inherited Create; - - LoadFromTheme(Theme.Level); - - AddButton(Theme.Level.ButtonEasy); - AddButton(Theme.Level.ButtonMedium); - AddButton(Theme.Level.ButtonHard); - - Interaction := 0; -end; - -procedure TScreenLevel.OnShow; -begin - inherited; - - Interaction := Ini.Difficulty; -end; - -procedure TScreenLevel.SetAnimationProgress(Progress: real); -begin - Button[0].Texture.ScaleW := Progress; - Button[1].Texture.ScaleW := Progress; - Button[2].Texture.ScaleW := Progress; -end; - -end. diff --git a/src/screens/UScreenLoading.pas b/src/screens/UScreenLoading.pas deleted file mode 100644 index e368f181..00000000 --- a/src/screens/UScreenLoading.pas +++ /dev/null @@ -1,78 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenLoading; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - SysUtils, - UThemes, - gl; - -type - TScreenLoading = class(TMenu) - public - Fadeout: boolean; - - constructor Create; override; - procedure OnShow; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - end; - -implementation - -uses - UGraphic, - UTime; - -function TScreenLoading.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; -end; - -constructor TScreenLoading.Create; -begin - inherited Create; - - LoadFromTheme(Theme.Loading); - - Fadeout := false; -end; - -procedure TScreenLoading.OnShow; -begin - inherited; -end; - -end. diff --git a/src/screens/UScreenMain.pas b/src/screens/UScreenMain.pas deleted file mode 100644 index ca4ba7cc..00000000 --- a/src/screens/UScreenMain.pas +++ /dev/null @@ -1,266 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenMain; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - SysUtils, - UThemes; - -type - TScreenMain = class(TMenu) - public - TextDescription: integer; - TextDescriptionLong: integer; - - constructor Create; override; - function ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; - PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetInteraction(Num: integer); override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UNote, - UIni, - UTexture, - USongs, - Textgl, - ULanguage, - UParty, - UDLLManager, - UScreenCredits, - USkins, - UUnicodeUtils; - -function TScreenMain.ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; - PressedDown: boolean): boolean; -var - SDL_ModState: word; -begin - Result := true; - - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT + - KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT); - - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): begin - Result := false; - Exit; - end; - Ord('C'): begin - if (SDL_ModState = KMOD_LALT) then - begin - FadeTo(@ScreenCredits, SoundLib.Start); - Exit; - end; - end; - Ord('M'): begin - if (Ini.Players >= 1) and (Length(DLLMan.Plugins) >= 1) then - begin - FadeTo(@ScreenPartyOptions, SoundLib.Start); - Exit; - end; - end; - - Ord('S'): begin - FadeTo(@ScreenStatMain, SoundLib.Start); - Exit; - end; - - Ord('E'): begin - FadeTo(@ScreenEdit, SoundLib.Start); - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE: - begin - Result := false; - end; - - SDLK_RETURN: - begin - //Solo - if (Interaction = 0) then - begin - if (Songs.SongList.Count >= 1) then - begin - if (Ini.Players >= 0) and (Ini.Players <= 3) then - PlayersPlay := Ini.Players + 1; - if (Ini.Players = 4) then - PlayersPlay := 6; - - if Ini.OnSongClick = sSelectPlayer then - FadeTo(@ScreenLevel) - else - begin - ScreenName.Goto_SingScreen := false; - FadeTo(@ScreenName, SoundLib.Start); - end; - end - else //show error message - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_SONGS')); - end; - - //Multi - if Interaction = 1 then - begin - if (Songs.SongList.Count >= 1) then - begin - if (Length(DLLMan.Plugins) >= 1) then - begin - FadeTo(@ScreenPartyOptions, SoundLib.Start); - end - else //show error message, No Plugins Loaded - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_PLUGINS')); - end - else //show error message, No Songs Loaded - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_SONGS')); - end; - - //Stats - if Interaction = 2 then - begin - FadeTo(@ScreenStatMain, SoundLib.Start); - end; - - //Editor - if Interaction = 3 then - begin - {$IFDEF UseMIDIPort} - FadeTo(@ScreenEdit, SoundLib.Start); - {$ELSE} - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_EDITOR')); - {$ENDIF} - end; - - //Options - if Interaction = 4 then - begin - FadeTo(@ScreenOptions, SoundLib.Start); - end; - - //Exit - if Interaction = 5 then - begin - Result := false; - end; - end; - {** - * Up and Down could be done at the same time, - * but I don't want to declare variables inside - * functions like this one, called so many times - *} - SDLK_DOWN: InteractInc; - SDLK_UP: InteractDec; - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end - else // Key Up - case PressedKey of - SDLK_RETURN: - begin - end; - end; -end; - -constructor TScreenMain.Create; -begin - inherited Create; -{** - * Attention ^^: - * New Creation Order needed because of LoadFromTheme - * and Button Collections. - * At First Custom Texts and Statics - * Then LoadFromTheme - * after LoadFromTheme the Buttons and Selects - *} - TextDescription := AddText(Theme.Main.TextDescription); - TextDescriptionLong := AddText(Theme.Main.TextDescriptionLong); - - LoadFromTheme(Theme.Main); - - AddButton(Theme.Main.ButtonSolo); - AddButton(Theme.Main.ButtonMulti); - AddButton(Theme.Main.ButtonStat); - AddButton(Theme.Main.ButtonEditor); - AddButton(Theme.Main.ButtonOptions); - AddButton(Theme.Main.ButtonExit); - - Interaction := 0; -end; - -procedure TScreenMain.OnShow; -begin - inherited; - - { display cursor (on moved) } - Display.SetCursor; - -{** - * Start background music - *} - SoundLib.StartBgMusic; -end; - -procedure TScreenMain.SetInteraction(Num: integer); -begin - inherited SetInteraction(Num); - Text[TextDescription].Text := Theme.Main.Description[Interaction]; - Text[TextDescriptionLong].Text := Theme.Main.DescriptionLong[Interaction]; -end; - -procedure TScreenMain.SetAnimationProgress(Progress: real); -begin - Static[0].Texture.ScaleW := Progress; - Static[0].Texture.ScaleH := Progress; -end; - -end. diff --git a/src/screens/UScreenName.pas b/src/screens/UScreenName.pas deleted file mode 100644 index 42af50d7..00000000 --- a/src/screens/UScreenName.pas +++ /dev/null @@ -1,284 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenName; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - SDL, - UDisplay, - UFiles, - UMenu, - UMusic, - UThemes; - -type - TScreenName = class(TMenu) - public - Goto_SingScreen: boolean; //If true then next Screen in SingScreen - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UCommon, - UGraphic, - UIni, - UNote, - UTexture, - UUnicodeUtils; - - -function TScreenName.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - I: integer; - SDL_ModState: word; -begin - Result := true; - if (PressedDown) then - begin // Key Down - - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT - + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT); - - // check normal keys - if (IsPrintableChar(CharCode)) then - begin - Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + - UCS4ToUTF8String(CharCode); - Exit; - end; - - // check special keys - case PressedKey of - // Templates for Names Mod - SDLK_F1: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[0] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[0]; - end; - SDLK_F2: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[1] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[1]; - end; - SDLK_F3: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[2] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[2]; - end; - SDLK_F4: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[3] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[3]; - end; - SDLK_F5: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[4] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[4]; - end; - SDLK_F6: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[5] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[5]; - end; - SDLK_F7: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[6] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[6]; - end; - SDLK_F8: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[7] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[7]; - end; - SDLK_F9: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[8] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[8]; - end; - SDLK_F10: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[9] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[9]; - end; - SDLK_F11: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[10] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[10]; - end; - SDLK_F12: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[11] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[11]; - end; - - SDLK_BACKSPACE: - begin - Button[Interaction].Text[0].DeleteLastLetter(); - end; - - SDLK_ESCAPE : - begin - Ini.SaveNames; - AudioPlayback.PlaySound(SoundLib.Back); - if GoTo_SingScreen then - FadeTo(@ScreenSong) - else - FadeTo(@ScreenMain); - end; - - SDLK_RETURN: - begin - for I := 1 to 6 do - Ini.Name[I-1] := Button[I-1].Text[0].Text; - Ini.SaveNames; - AudioPlayback.PlaySound(SoundLib.Start); - - if GoTo_SingScreen then - FadeTo(@ScreenSing) - else - FadeTo(@ScreenLevel); - - GoTo_SingScreen := false; - end; - - // Up and Down could be done at the same time, - // but I don't want to declare variables inside - // functions like this one, called so many times - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end; -end; - -constructor TScreenName.Create; -var - I: integer; -begin - inherited Create; - - LoadFromTheme(Theme.Name); - - for I := 1 to 6 do - AddButton(Theme.Name.ButtonPlayer[I]); - - Interaction := 0; -end; - -procedure TScreenName.OnShow; -var - I: integer; -begin - inherited; - - for I := 1 to 6 do - Button[I-1].Text[0].Text := Ini.Name[I-1]; - - for I := 1 to PlayersPlay do - begin - Button[I-1].Visible := true; - Button[I-1].Selectable := true; - end; - - for I := PlayersPlay+1 to 6 do - begin - Button[I-1].Visible := false; - Button[I-1].Selectable := false; - end; - -end; - -procedure TScreenName.SetAnimationProgress(Progress: real); -var - I: integer; -begin - for I := 1 to 6 do - Button[I-1].Texture.ScaleW := Progress; -end; - -end. diff --git a/src/screens/UScreenOpen.pas b/src/screens/UScreenOpen.pas deleted file mode 100644 index 70b883c4..00000000 --- a/src/screens/UScreenOpen.pas +++ /dev/null @@ -1,231 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOpen; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - Math, - SysUtils, - gl, - SDL, - UPath, - UMenu, - UMusic, - UFiles, - UTime, - USongs, - UIni, - ULog, - UTexture, - UMenuText, - ULyrics, - UThemes; - -type - TScreenOpen = class(TMenu) - private - //fTextF: array[0..1] of integer; - fTextN: integer; // text-box ID of filename - fFilename: IPath; - fBackScreen: PMenu; - - procedure AddBox(X, Y, W, H: real); - public - constructor Create; override; - procedure OnShow; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - - {** - * Set by the caller to provide a default filename. - * Set to the selected filename after calling this screen or to PATH_NONE - * if the screen was aborted. - * TODO: maybe pass this value with a callback OnValueChanged() - *} - property Filename: IPath READ fFilename WRITE fFilename; - {** The screen that is shown after this screen is closed (set by the caller) *} - property BackScreen: PMenu READ fBackScreen WRITE fBackScreen; - end; - -implementation - -uses - UGraphic, - UDraw, - UMain, - UScreenEditConvert, - USkins, - UUnicodeUtils; - -function TScreenOpen.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - - if (PressedDown) then // Key Down - begin - // check normal keys - if (IsPrintableChar(CharCode)) then - begin - if (Interaction = 0) then - begin - Text[fTextN].Text := Text[fTextN].Text + UCS4ToUTF8String(CharCode); - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_BACKSPACE: // del - begin - if Interaction = 0 then - begin - Text[fTextN].DeleteLastLetter; - end; - end; - - SDLK_ESCAPE: - begin - //Empty Filename and go to last Screen - fFileName := PATH_NONE; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(fBackScreen); - end; - - SDLK_RETURN: - begin - if (Interaction = 2) then - begin - //Update Filename and go to last Screen - fFileName := Path(Text[fTextN].Text); - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(fBackScreen); - end - else if (Interaction = 1) then - begin - //Empty Filename and go to last Screen - fFileName := PATH_NONE; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(fBackScreen); - end; - end; - - SDLK_LEFT: - begin - InteractPrev; - end; - - SDLK_RIGHT: - begin - InteractNext; - end; - - SDLK_DOWN: - begin - end; - - SDLK_UP: - begin - end; - end; - end; -end; - -procedure TScreenOpen.AddBox(X, Y, W, H: real); -begin - AddStatic(X, Y, W, H, 0, 0, 0, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); - AddStatic(X+2, Y+2, W-4, H-4, 1, 1, 1, Skin.GetTextureFileName('MainBar'), TEXTURE_TYPE_COLORIZED); -end; - -constructor TScreenOpen.Create; -begin - inherited Create; - - fFilename := PATH_NONE; - - // line - { - AddStatic(20, 10, 80, 30, 0, 0, 0, 'MainBar', 'JPG', TEXTURE_TYPE_COLORIZED); - AddText(35, 17, 1, 18, 1, 1, 1, 'line'); - TextSentence := AddText(120, 14, 1, 24, 0, 0, 0, '0 / 0'); - } - - // file list - //AddBox(400, 100, 350, 450); - - //TextF[0] := AddText(430, 155, 0, 24, 0, 0, 0, 'a'); - //TextF[1] := AddText(430, 180, 0, 24, 0, 0, 0, 'a'); - - // file name - AddBox(20, 540, 500, 40); - fTextN := AddText(50, 548, 0, 24, 0, 0, 0, fFileName.ToUTF8); - AddInteraction(iText, fTextN); - - // buttons - {AddButton(540, 540, 100, 40, Skin.SkinPath + Skin.ButtonF); - AddButtonText(10, 5, 0, 0, 0, 'Cancel'); - - AddButton(670, 540, 100, 40, Skin.SkinPath + Skin.ButtonF); - AddButtonText(30, 5, 0, 0, 0, 'OK');} - // buttons - AddButton(540, 540, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(10, 5, 0, 0, 0, 'Cancel'); - - AddButton(670, 540, 100, 40, Skin.GetTextureFileName('ButtonF')); - AddButtonText(30, 5, 0, 0, 0, 'OK'); - -end; - -procedure TScreenOpen.OnShow; -begin - inherited; - - Interaction := 0; - Text[fTextN].Text := fFilename.ToUTF8(); -end; - -(* -function TScreenEditSub.Draw: boolean; -var - Min: integer; - Sec: integer; - AktBeat: integer; -begin - -end; - -procedure TScreenEditSub.Finish; -begin -// -end; -*) - -end. diff --git a/src/screens/UScreenOptions.pas b/src/screens/UScreenOptions.pas deleted file mode 100644 index 3a046400..00000000 --- a/src/screens/UScreenOptions.pas +++ /dev/null @@ -1,234 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptions; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SysUtils, - UMenu, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes; - -type - TScreenOptions = class(TMenu) - public - TextDescription: integer; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure InteractNext; override; - procedure InteractPrev; override; - procedure InteractNextRow; override; - procedure InteractPrevRow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UUnicodeUtils; - -function TScreenOptions.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end; - SDLK_RETURN: - begin - if SelInteraction = 0 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsGame); - end; - - if SelInteraction = 1 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsGraphics); - end; - - if SelInteraction = 2 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsSound); - end; - - if SelInteraction = 3 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsLyrics); - end; - - if SelInteraction = 4 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsThemes); - end; - - if SelInteraction = 5 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsRecord); - end; - - if SelInteraction = 6 then - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenOptionsAdvanced); - end; - - if SelInteraction = 7 then - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end; - end; - SDLK_DOWN: InteractNextRow; - SDLK_UP: InteractPrevRow; - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end; -end; - -constructor TScreenOptions.Create; -//var -// I: integer; // Auto Removed, Unused Variable -begin - inherited Create; - - TextDescription := AddText(Theme.Options.TextDescription); - - LoadFromTheme(Theme.Options); - - AddButton(Theme.Options.ButtonGame); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[0]); - - AddButton(Theme.Options.ButtonGraphics); - if (Length(Button[1].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[1]); - - AddButton(Theme.Options.ButtonSound); - if (Length(Button[2].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[2]); - - AddButton(Theme.Options.ButtonLyrics); - if (Length(Button[3].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[3]); - - AddButton(Theme.Options.ButtonThemes); - if (Length(Button[4].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[4]); - - AddButton(Theme.Options.ButtonRecord); - if (Length(Button[5].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[5]); - - AddButton(Theme.Options.ButtonAdvanced); - if (Length(Button[6].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[6]); - - AddButton(Theme.Options.ButtonExit); - if (Length(Button[7].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - - Interaction := 0; -end; - -procedure TScreenOptions.OnShow; -begin - inherited; -end; - -procedure TScreenOptions.InteractNext; -begin - inherited InteractNext; - Text[TextDescription].Text := Theme.Options.Description[Interaction]; -end; - -procedure TScreenOptions.InteractPrev; -begin - inherited InteractPrev; - Text[TextDescription].Text := Theme.Options.Description[Interaction]; -end; - -procedure TScreenOptions.InteractNextRow; -begin - inherited InteractNextRow; - Text[TextDescription].Text := Theme.Options.Description[Interaction]; -end; - -procedure TScreenOptions.InteractPrevRow; -begin - inherited InteractPrevRow; - Text[TextDescription].Text := Theme.Options.Description[Interaction]; -end; - -procedure TScreenOptions.SetAnimationProgress(Progress: real); -begin - Button[0].Texture.ScaleW := Progress; - Button[1].Texture.ScaleW := Progress; - Button[2].Texture.ScaleW := Progress; - Button[3].Texture.ScaleW := Progress; - Button[4].Texture.ScaleW := Progress; - Button[5].Texture.ScaleW := Progress; - Button[6].Texture.ScaleW := Progress; - Button[7].Texture.ScaleW := Progress; -end; - -end. diff --git a/src/screens/UScreenOptionsAdvanced.pas b/src/screens/UScreenOptionsAdvanced.pas deleted file mode 100644 index 7116ad40..00000000 --- a/src/screens/UScreenOptionsAdvanced.pas +++ /dev/null @@ -1,171 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsAdvanced; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - UMenu, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes; - -type - TScreenOptionsAdvanced = class(TMenu) - public - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - end; - -implementation - -uses - UGraphic, - UUnicodeUtils, - SysUtils; - -function TScreenOptionsAdvanced.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - // Escape -> save nothing - just leave this screen - - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin - //SelectLoadAnimation Hidden because it is useless atm - //if SelInteraction = 7 then begin - if SelInteraction = 6 then - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP : - InteractPrev; - SDLK_RIGHT: - begin - //SelectLoadAnimation Hidden because it is useless atm - //if (SelInteraction >= 0) and (SelInteraction <= 6) then begin - if (SelInteraction >= 0) and (SelInteraction <= 5) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - end; - SDLK_LEFT: - begin - //SelectLoadAnimation Hidden because it is useless atm - //if (SelInteraction >= 0) and (SelInteraction <= 6) then begin - if (SelInteraction >= 0) and (SelInteraction <= 5) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - end; - end; - end; -end; - -constructor TScreenOptionsAdvanced.Create; -//var -// I: integer; // Auto Removed, Unused Variable -begin - inherited Create; - - LoadFromTheme(Theme.OptionsAdvanced); - - //SelectLoadAnimation Hidden because it is useless atm - //AddSelect(Theme.OptionsAdvanced.SelectLoadAnimation, Ini.LoadAnimation, ILoadAnimationTranslated); - Theme.OptionsAdvanced.SelectScreenFade.showArrows := true; - Theme.OptionsAdvanced.SelectScreenFade.oneItemOnly := true; - AddSelectSlide(Theme.OptionsAdvanced.SelectScreenFade, Ini.ScreenFade, IScreenFadeTranslated); - - Theme.OptionsAdvanced.SelectEffectSing.showArrows := true; - Theme.OptionsAdvanced.SelectEffectSing.oneItemOnly := true; - AddSelectSlide(Theme.OptionsAdvanced.SelectEffectSing, Ini.EffectSing, IEffectSingTranslated); - - Theme.OptionsAdvanced.SelectLineBonus.showArrows := true; - Theme.OptionsAdvanced.SelectLineBonus.oneItemOnly := true; - AddSelectSlide(Theme.OptionsAdvanced.SelectLineBonus, Ini.LineBonus, ILineBonusTranslated); - - Theme.OptionsAdvanced.SelectOnSongClick.showArrows := true; - Theme.OptionsAdvanced.SelectOnSongClick.oneItemOnly := true; - AddSelectSlide(Theme.OptionsAdvanced.SelectOnSongClick, Ini.OnSongClick, IOnSongClickTranslated); - - Theme.OptionsAdvanced.SelectAskbeforeDel.showArrows := true; - Theme.OptionsAdvanced.SelectAskbeforeDel.oneItemOnly := true; - AddSelectSlide(Theme.OptionsAdvanced.SelectAskbeforeDel, Ini.AskBeforeDel, IAskbeforeDelTranslated); - - Theme.OptionsAdvanced.SelectPartyPopup.showArrows := true; - Theme.OptionsAdvanced.SelectPartyPopup.oneItemOnly := true; - AddSelectSlide(Theme.OptionsAdvanced.SelectPartyPopup, Ini.PartyPopup, IPartyPopupTranslated); - - AddButton(Theme.OptionsAdvanced.ButtonExit); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - - Interaction := 0; -end; - -procedure TScreenOptionsAdvanced.OnShow; -begin - inherited; - - Interaction := 0; -end; - -end. diff --git a/src/screens/UScreenOptionsGame.pas b/src/screens/UScreenOptionsGame.pas deleted file mode 100644 index caeaad6e..00000000 --- a/src/screens/UScreenOptionsGame.pas +++ /dev/null @@ -1,175 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsGame; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - UMenu, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes, - USongs; - -type - TScreenOptionsGame = class(TMenu) - public - old_Tabs, old_Sorting: integer; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure RefreshSongs; - end; - -implementation - -uses - UGraphic, - UUnicodeUtils, - SysUtils; - -function TScreenOptionsGame.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if PressedDown then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Back); - RefreshSongs; - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin - if SelInteraction = 6 then - begin - AudioPlayback.PlaySound(SoundLib.Back); - RefreshSongs; - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP : - InteractPrev; - SDLK_RIGHT: - begin - if (SelInteraction >= 0) and (SelInteraction <= 5) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - end; - SDLK_LEFT: - begin - if (SelInteraction >= 0) and (SelInteraction <= 5) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - end; - end; - end; -end; - -constructor TScreenOptionsGame.Create; -begin - inherited Create; - - LoadFromTheme(Theme.OptionsGame); - - //Refresh Songs Patch - old_Sorting := Ini.Sorting; - old_Tabs := Ini.Tabs; - - Theme.OptionsGame.SelectPlayers.showArrows := true; - Theme.OptionsGame.SelectPlayers.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectPlayers, Ini.Players, IPlayers); - - Theme.OptionsGame.SelectDifficulty.showArrows := true; - Theme.OptionsGame.SelectDifficulty.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectDifficulty, Ini.Difficulty, IDifficultyTranslated); - - Theme.OptionsGame.SelectLanguage.showArrows := true; - Theme.OptionsGame.SelectLanguage.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectLanguage, Ini.Language, ILanguageTranslated); - - Theme.OptionsGame.SelectTabs.showArrows := true; - Theme.OptionsGame.SelectTabs.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectTabs, Ini.Tabs, ITabsTranslated); - - Theme.OptionsGame.SelectSorting.showArrows := true; - Theme.OptionsGame.SelectSorting.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectSorting, Ini.Sorting, ISortingTranslated); - - Theme.OptionsGame.SelectDebug.showArrows := true; - Theme.OptionsGame.SelectDebug.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGame.SelectDebug, Ini.Debug, IDebugTranslated); - - - - AddButton(Theme.OptionsGame.ButtonExit); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - -end; - -//Refresh Songs Patch -procedure TScreenOptionsGame.RefreshSongs; -begin - if (ini.Sorting <> old_Sorting) or (ini.Tabs <> old_Tabs) then - ScreenSong.Refresh; -end; - -procedure TScreenOptionsGame.OnShow; -begin - inherited; - -// Interaction := 0; -end; - -end. diff --git a/src/screens/UScreenOptionsGraphics.pas b/src/screens/UScreenOptionsGraphics.pas deleted file mode 100644 index 8ca13f09..00000000 --- a/src/screens/UScreenOptionsGraphics.pas +++ /dev/null @@ -1,172 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsGraphics; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes; - -type - TScreenOptionsGraphics = class(TMenu) - public - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - end; - -implementation - -uses - UGraphic, - UMain, - UUnicodeUtils, - SysUtils; - -function TScreenOptionsGraphics.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - // Escape -> save nothing - just leave this screen - - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin -{ if SelInteraction <= 1 then - begin - Restart := true; - end;} - if SelInteraction = 6 then - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - // FIXME: changing the video mode does not work this way in windows - // and MacOSX as all textures will be invalidated through this. - // See the ALT+TAB code too. - {$IF Defined(Linux) or Defined(FreeBSD)} - Reinitialize3D(); - {$IFEND} - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP : - InteractPrev; - SDLK_RIGHT: - begin - if (SelInteraction >= 0) and (SelInteraction < 6) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - end; - SDLK_LEFT: - begin - if (SelInteraction >= 0) and (SelInteraction < 6) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - end; - end; - end; -end; - -constructor TScreenOptionsGraphics.Create; -//var -// I: integer; // Auto Removed, Unused Variable -begin - inherited Create; - LoadFromTheme(Theme.OptionsGraphics); - - Theme.OptionsGraphics.SelectResolution.showArrows := true; - Theme.OptionsGraphics.SelectResolution.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGraphics.SelectResolution, Ini.Resolution, IResolution); - - Theme.OptionsGraphics.SelectFullscreen.showArrows := true; - Theme.OptionsGraphics.SelectFullscreen.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGraphics.SelectFullscreen, Ini.Fullscreen, IFullScreenTranslated); - - Theme.OptionsGraphics.SelectDepth.showArrows := true; - Theme.OptionsGraphics.SelectDepth.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGraphics.SelectDepth, Ini.Depth, IDepth); - - Theme.OptionsGraphics.SelectVisualizer.showArrows := true; - Theme.OptionsGraphics.SelectVisualizer.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGraphics.SelectVisualizer, Ini.VisualizerOption, IVisualizerTranslated); - - Theme.OptionsGraphics.SelectOscilloscope.showArrows := true; - Theme.OptionsGraphics.SelectOscilloscope.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGraphics.SelectOscilloscope, Ini.Oscilloscope, IOscilloscopeTranslated); - - Theme.OptionsGraphics.SelectMovieSize.showArrows := true; - Theme.OptionsGraphics.SelectMovieSize.oneItemOnly := true; - AddSelectSlide(Theme.OptionsGraphics.SelectMovieSize, Ini.MovieSize, IMovieSizeTranslated); - - AddButton(Theme.OptionsGraphics.ButtonExit); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - -end; - -procedure TScreenOptionsGraphics.OnShow; -begin - inherited; - - Interaction := 0; -end; - -end. diff --git a/src/screens/UScreenOptionsLyrics.pas b/src/screens/UScreenOptionsLyrics.pas deleted file mode 100644 index 0ef4e2a6..00000000 --- a/src/screens/UScreenOptionsLyrics.pas +++ /dev/null @@ -1,148 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsLyrics; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes; - -type - TScreenOptionsLyrics = class(TMenu) - public - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - end; - -implementation - -uses - UGraphic, - UUnicodeUtils, - SysUtils; - -function TScreenOptionsLyrics.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - // Escape -> save nothing - just leave this screen - - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin - if SelInteraction = 3 then - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP : - InteractPrev; - SDLK_RIGHT: - begin - if (SelInteraction >= 0) and (SelInteraction <= 3) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - end; - SDLK_LEFT: - begin - if (SelInteraction >= 0) and (SelInteraction <= 3) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - end; - end; - end; -end; - -constructor TScreenOptionsLyrics.Create; -begin - inherited Create; - - LoadFromTheme(Theme.OptionsLyrics); - - Theme.OptionsLyrics.SelectLyricsFont.showArrows := true; - Theme.OptionsLyrics.SelectLyricsFont.oneItemOnly := true; - AddSelectSlide(Theme.OptionsLyrics.SelectLyricsFont, Ini.LyricsFont, ILyricsFontTranslated); - - Theme.OptionsLyrics.SelectLyricsEffect.showArrows := true; - Theme.OptionsLyrics.SelectLyricsEffect.oneItemOnly := true; - AddSelectSlide(Theme.OptionsLyrics.SelectLyricsEffect, Ini.LyricsEffect, ILyricsEffectTranslated); - - Theme.OptionsLyrics.SelectNoteLines.showArrows := true; - Theme.OptionsLyrics.SelectNoteLines.oneItemOnly := true; - AddSelectSlide(Theme.OptionsLyrics.SelectNoteLines, Ini.NoteLines, INoteLinesTranslated); - - AddButton(Theme.OptionsLyrics.ButtonExit); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - -end; - -procedure TScreenOptionsLyrics.OnShow; -begin - inherited; - - Interaction := 0; -end; - -end. diff --git a/src/screens/UScreenOptionsRecord.pas b/src/screens/UScreenOptionsRecord.pas deleted file mode 100644 index 828c20f6..00000000 --- a/src/screens/UScreenOptionsRecord.pas +++ /dev/null @@ -1,813 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsRecord; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UThemes, - UMusic, - URecord, - UMenu; - -type - TDrawState = record - ChannelIndex: integer; - R, G, B: real; // mapped player color (normal) - RD, GD, BD: real; // mapped player color (dark) - end; - - TPeakInfo = record - Volume: single; - Time: cardinal; - end; - - TScreenOptionsRecord = class(TMenu) - private - // max. count of input-channels determined for all devices - MaxChannelCount: integer; - - // current input device - CurrentDeviceIndex: integer; - PreviewDeviceIndex: integer; - - // string arrays for select-slide options - InputSourceNames: array of UTF8String; - InputDeviceNames: array of UTF8String; - - // dynamic generated themes for channel select-sliders - SelectSlideChannelTheme: array of TThemeSelectSlide; - - // indices for widget-updates - SelectInputSourceID: integer; - SelectSlideChannelID: array of integer; - - // interaction IDs - ExitButtonIID: integer; - - // dummy data for non-available channels - ChannelToPlayerMapDummy: integer; - - // preview channel-buffers - PreviewChannel: array of TCaptureBuffer; - ChannelPeak: array of TPeakInfo; - - // Device source volume - SourceVolume: single; - NextVolumePollTime: cardinal; - - procedure StartPreview; - procedure StopPreview; - procedure UpdateInputDevice; - procedure ChangeVolume(VolumeChange: single); - procedure DrawVolume(x, y, Width, Height: single); - procedure DrawVUMeter(const State: TDrawState; x, y, Width, Height: single); - procedure DrawPitch(const State: TDrawState; x, y, Width, Height: single); - public - constructor Create; override; - function Draw: boolean; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure OnHide; override; - end; - -const - PeakDecay = 0.2; // strength of peak-decay (reduction after one sec) - -const - BarHeight = 11; // height of each bar (volume/vu-meter/pitch) - BarUpperSpacing = 1; // spacing between a bar-area and the previous widget - BarLowerSpacing = 3; // spacing between a bar-area and the next widget - SourceBarsTotalHeight = BarHeight + BarUpperSpacing + BarLowerSpacing; - ChannelBarsTotalHeight = 2*BarHeight + BarUpperSpacing + BarLowerSpacing; - -implementation - -uses - SysUtils, - Math, - SDL, - gl, - TextGL, - UGraphic, - UDraw, - UMain, - UMenuSelectSlide, - UMenuText, - UFiles, - UDisplay, - UIni, - UUnicodeUtils, - ULog; - -function TScreenOptionsRecord.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - Ord('+'): - begin - // FIXME: add a nice volume-slider instead - // or at least provide visualization and acceleration if the user holds the key pressed. - ChangeVolume(0.02); - end; - Ord('-'): - begin - // FIXME: add a nice volume-slider instead - // or at least provide visualization and acceleration if the user holds the key pressed. - ChangeVolume(-0.02); - end; - Ord('T'): - begin - if ((SDL_GetModState() and KMOD_SHIFT) <> 0) then - Ini.ThresholdIndex := (Ini.ThresholdIndex + Length(IThresholdVals) - 1) mod Length(IThresholdVals) - else - Ini.ThresholdIndex := (Ini.ThresholdIndex + 1) mod Length(IThresholdVals); - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE: - begin - // TODO: Show Save/Abort screen - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin - if (SelInteraction = ExitButtonIID) then - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP : - InteractPrev; - SDLK_RIGHT: - begin - if (SelInteraction >= 0) and (SelInteraction < ExitButtonIID) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - UpdateInputDevice; - end; - SDLK_LEFT: - begin - if (SelInteraction >= 0) and (SelInteraction < ExitButtonIID) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - UpdateInputDevice; - end; - end; - end; -end; - -constructor TScreenOptionsRecord.Create; -var - DeviceIndex: integer; - SourceIndex: integer; - ChannelIndex: integer; - InputDevice: TAudioInputDevice; - InputDeviceCfg: PInputDeviceConfig; - ChannelTheme: ^TThemeSelectSlide; - //ButtonTheme: TThemeButton; - WidgetYPos: integer; -begin - inherited Create; - - LoadFromTheme(Theme.OptionsRecord); - - // set CurrentDeviceIndex to a valid device - if (Length(AudioInputProcessor.DeviceList) > 0) then - CurrentDeviceIndex := 0 - else - CurrentDeviceIndex := -1; - - PreviewDeviceIndex := -1; - - WidgetYPos := 0; - - // init sliders if at least one device was detected - if (Length(AudioInputProcessor.DeviceList) > 0) then - begin - InputDevice := AudioInputProcessor.DeviceList[CurrentDeviceIndex]; - InputDeviceCfg := @Ini.InputDeviceConfig[InputDevice.CfgIndex]; - - // init device-selection slider - SetLength(InputDeviceNames, Length(AudioInputProcessor.DeviceList)); - for DeviceIndex := 0 to High(AudioInputProcessor.DeviceList) do - begin - InputDeviceNames[DeviceIndex] := AudioInputProcessor.DeviceList[DeviceIndex].Name; - end; - // add device-selection slider (InteractionID: 0) - Theme.OptionsRecord.SelectSlideCard.showArrows := true; - Theme.OptionsRecord.SelectSlideCard.oneItemOnly := true; - AddSelectSlide(Theme.OptionsRecord.SelectSlideCard, CurrentDeviceIndex, InputDeviceNames); - - // init source-selection slider - SetLength(InputSourceNames, Length(InputDevice.Source)); - for SourceIndex := 0 to High(InputDevice.Source) do - begin - InputSourceNames[SourceIndex] := InputDevice.Source[SourceIndex].Name; - end; - - Theme.OptionsRecord.SelectSlideInput.showArrows := true; - Theme.OptionsRecord.SelectSlideInput.oneItemOnly := true; - // add source-selection slider (InteractionID: 1) - SelectInputSourceID := AddSelectSlide(Theme.OptionsRecord.SelectSlideInput, - InputDeviceCfg.Input, InputSourceNames); - - // add space for source volume bar - WidgetYPos := Theme.OptionsRecord.SelectSlideInput.Y + - Theme.OptionsRecord.SelectSlideInput.H + - SourceBarsTotalHeight; - - // find max. channel count of all devices - MaxChannelCount := 0; - for DeviceIndex := 0 to High(AudioInputProcessor.DeviceList) do - begin - if (AudioInputProcessor.DeviceList[DeviceIndex].AudioFormat.Channels > MaxChannelCount) then - MaxChannelCount := AudioInputProcessor.DeviceList[DeviceIndex].AudioFormat.Channels; - end; - - // init channel-to-player mapping sliders - SetLength(SelectSlideChannelID, MaxChannelCount); - SetLength(SelectSlideChannelTheme, MaxChannelCount); - - for ChannelIndex := 0 to MaxChannelCount-1 do - begin - // copy reference slide - SelectSlideChannelTheme[ChannelIndex] := - Theme.OptionsRecord.SelectSlideChannel; - // set current channel-theme - ChannelTheme := @SelectSlideChannelTheme[ChannelIndex]; - // adjust vertical position - ChannelTheme.Y := WidgetYPos; - // calc size of next slide (add space for bars) - WidgetYPos := WidgetYPos + ChannelTheme.H + ChannelBarsTotalHeight; - // append channel index to name - ChannelTheme.Text := ChannelTheme.Text + IntToStr(ChannelIndex+1); - - // show/hide widgets depending on whether the channel exists - if (ChannelIndex < Length(InputDeviceCfg.ChannelToPlayerMap)) then - begin - // current device has this channel - - // add slider - SelectSlideChannelID[ChannelIndex] := AddSelectSlide(ChannelTheme^, - InputDeviceCfg.ChannelToPlayerMap[ChannelIndex], IChannelPlayerTranslated); - end - else - begin - // current device does not have that many channels - - // add slider but hide it and assign a dummy variable to it - SelectSlideChannelID[ChannelIndex] := AddSelectSlide(ChannelTheme^, - ChannelToPlayerMapDummy, IChannelPlayerTranslated); - SelectsS[SelectSlideChannelID[ChannelIndex]].Visible := false; - end; - end; - end; - - // add Exit-button - //ButtonTheme := Theme.OptionsRecord.ButtonExit; - // adjust button position - //if (WidgetYPos <> 0) then - // ButtonTheme.Y := WidgetYPos; - //AddButton(ButtonTheme); - // I uncommented the stuff above, because it's not skinable :X - AddButton(Theme.OptionsRecord.ButtonExit); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - // store InteractionID - if (Length(AudioInputProcessor.DeviceList) > 0) then - ExitButtonIID := MaxChannelCount + 2 - else - ExitButtonIID := 0; - - // set focus - Interaction := 0; -end; - -procedure TScreenOptionsRecord.UpdateInputDevice; -var - SourceIndex: integer; - InputDevice: TAudioInputDevice; - InputDeviceCfg: PInputDeviceConfig; - ChannelIndex: integer; -begin - //Log.LogStatus('Update input-device', 'TScreenOptionsRecord.UpdateCard') ; - - StopPreview(); - - // set CurrentDeviceIndex to a valid device - if (CurrentDeviceIndex > High(AudioInputProcessor.DeviceList)) then - CurrentDeviceIndex := 0; - - // update sliders if at least one device was detected - if (Length(AudioInputProcessor.DeviceList) > 0) then - begin - InputDevice := AudioInputProcessor.DeviceList[CurrentDeviceIndex]; - InputDeviceCfg := @Ini.InputDeviceConfig[InputDevice.CfgIndex]; - - // update source-selection slider - SetLength(InputSourceNames, Length(InputDevice.Source)); - for SourceIndex := 0 to High(InputDevice.Source) do - begin - InputSourceNames[SourceIndex] := InputDevice.Source[SourceIndex].Name; - end; - UpdateSelectSlideOptions(Theme.OptionsRecord.SelectSlideInput, SelectInputSourceID, - InputSourceNames, InputDeviceCfg.Input); - - // update channel-to-player mapping sliders - for ChannelIndex := 0 to MaxChannelCount-1 do - begin - // show/hide widgets depending on whether the channel exists - if (ChannelIndex < Length(InputDeviceCfg.ChannelToPlayerMap)) then - begin - // current device has this channel - - // show slider - UpdateSelectSlideOptions(SelectSlideChannelTheme[ChannelIndex], - SelectSlideChannelID[ChannelIndex], IChannelPlayerTranslated, - InputDeviceCfg.ChannelToPlayerMap[ChannelIndex]); - SelectsS[SelectSlideChannelID[ChannelIndex]].Visible := true; - end - else - begin - // current device does not have that many channels - - // hide slider and assign a dummy variable to it - UpdateSelectSlideOptions(SelectSlideChannelTheme[ChannelIndex], - SelectSlideChannelID[ChannelIndex], IChannelPlayerTranslated, - ChannelToPlayerMapDummy); - SelectsS[SelectSlideChannelID[ChannelIndex]].Visible := false; - end; - end; - end; - - StartPreview(); -end; - -procedure TScreenOptionsRecord.ChangeVolume(VolumeChange: single); -var - InputDevice: TAudioInputDevice; - Volume: single; -begin - // validate CurrentDeviceIndex - if ((CurrentDeviceIndex < 0) or - (CurrentDeviceIndex > High(AudioInputProcessor.DeviceList))) then - begin - Exit; - end; - - InputDevice := AudioInputProcessor.DeviceList[CurrentDeviceIndex]; - if not assigned(InputDevice) then - Exit; - - // set new volume - Volume := InputDevice.GetVolume() + VolumeChange; - InputDevice.SetVolume(Volume); - //DebugWriteln('Volume: ' + floattostr(InputDevice.GetVolume)); - - // volume must be polled again - NextVolumePollTime := 0; -end; - -procedure TScreenOptionsRecord.OnShow; -var - ChannelIndex: integer; -begin - inherited; - - Interaction := 0; - - // create preview sound-buffers - SetLength(PreviewChannel, MaxChannelCount); - for ChannelIndex := 0 to High(PreviewChannel) do - PreviewChannel[ChannelIndex] := TCaptureBuffer.Create(); - - SetLength(ChannelPeak, MaxChannelCount); - - StartPreview(); -end; - -procedure TScreenOptionsRecord.OnHide; -var - ChannelIndex: integer; -begin - StopPreview(); - - // free preview buffers - for ChannelIndex := 0 to High(PreviewChannel) do - PreviewChannel[ChannelIndex].Free; - SetLength(PreviewChannel, 0); - SetLength(ChannelPeak, 0); -end; - -procedure TScreenOptionsRecord.StartPreview; -var - ChannelIndex: integer; - Device: TAudioInputDevice; -begin - if ((CurrentDeviceIndex >= 0) and - (CurrentDeviceIndex <= High(AudioInputProcessor.DeviceList))) then - begin - Device := AudioInputProcessor.DeviceList[CurrentDeviceIndex]; - // set preview channel as active capture channel - for ChannelIndex := 0 to High(Device.CaptureChannel) do - begin - PreviewChannel[ChannelIndex].Clear(); - Device.LinkCaptureBuffer(ChannelIndex, PreviewChannel[ChannelIndex]); - FillChar(ChannelPeak[ChannelIndex], SizeOf(TPeakInfo), 0); - end; - Device.Start(); - PreviewDeviceIndex := CurrentDeviceIndex; - - // volume must be polled again - NextVolumePollTime := 0; - end; -end; - -procedure TScreenOptionsRecord.StopPreview; -var - ChannelIndex: integer; - Device: TAudioInputDevice; -begin - if ((PreviewDeviceIndex >= 0) and - (PreviewDeviceIndex <= High(AudioInputProcessor.DeviceList))) then - begin - Device := AudioInputProcessor.DeviceList[PreviewDeviceIndex]; - Device.Stop; - for ChannelIndex := 0 to High(Device.CaptureChannel) do - Device.LinkCaptureBuffer(ChannelIndex, nil); - end; - PreviewDeviceIndex := -1; -end; - -procedure TScreenOptionsRecord.DrawVolume(x, y, Width, Height: single); -var - x1, y1, x2, y2: single; - VolBarInnerWidth: integer; - Volume: single; -const - VolBarInnerHSpacing = 2; - VolBarInnerVSpacing = 1; -begin - // coordinates for black rect - x1 := x; - y1 := y; - x2 := x1 + Width; - y2 := y1 + Height; - - // init blend mode - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - // draw black background-rect - glColor4f(0, 0, 0, 0.8); - glBegin(GL_QUADS); - glVertex2f(x1, y1); - glVertex2f(x2, y1); - glVertex2f(x2, y2); - glVertex2f(x1, y2); - glEnd(); - - VolBarInnerWidth := Trunc(Width - 2*VolBarInnerHSpacing); - - // TODO: if no volume is available, show some info (a blue bar maybe) - if (SourceVolume >= 0) then - Volume := SourceVolume - else - Volume := 0; - - // coordinates for first half of the volume bar - x1 := x + VolBarInnerHSpacing; - x2 := x1 + VolBarInnerWidth * Volume; - y1 := y1 + VolBarInnerVSpacing; - y2 := y2 - VolBarInnerVSpacing; - - // draw volume-bar - glBegin(GL_QUADS); - // draw volume bar - glColor3f(0.4, 0.3, 0.3); - glVertex2f(x1, y1); - glVertex2f(x1, y2); - glColor3f(1, 0.1, 0.1); - glVertex2f(x2, y2); - glVertex2f(x2, y1); - glEnd(); - - { not needed anymore - // coordinates for separator - x1 := x + VolBarInnerHSpacing; - x2 := x1 + VolBarInnerWidth; - - // draw separator - glBegin(GL_LINE_STRIP); - glColor4f(0.1, 0.1, 0.1, 0.2); - glVertex2f(x1, y2); - glColor4f(0.4, 0.4, 0.4, 0.2); - glVertex2f((x1+x2)/2, y2); - glColor4f(0.1, 0.1, 0.1, 0.2); - glVertex2f(x2, y2); - glEnd(); - } - - glDisable(GL_BLEND); -end; - -procedure TScreenOptionsRecord.DrawVUMeter(const State: TDrawState; x, y, Width, Height: single); -var - x1, y1, x2, y2: single; - Volume, PeakVolume: single; - Delta: single; - VolBarInnerWidth: integer; -const - VolBarInnerHSpacing = 2; - VolBarInnerVSpacing = 1; -begin - // coordinates for black rect - x1 := x; - y1 := y; - x2 := x1 + Width; - y2 := y1 + Height; - - // init blend mode - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - // draw black background-rect - glColor4f(0, 0, 0, 0.8); - glBegin(GL_QUADS); - glVertex2f(x1, y1); - glVertex2f(x2, y1); - glVertex2f(x2, y2); - glVertex2f(x1, y2); - glEnd(); - - VolBarInnerWidth := Trunc(Width - 2*VolBarInnerHSpacing); - - // vertical positions - y1 := y1 + VolBarInnerVSpacing; - y2 := y2 - VolBarInnerVSpacing; - - // coordinates for bevel - x1 := x + VolBarInnerHSpacing; - x2 := x1 + VolBarInnerWidth; - - glBegin(GL_QUADS); - Volume := PreviewChannel[State.ChannelIndex].MaxSampleVolume(); - - // coordinates for volume bar - x1 := x + VolBarInnerHSpacing; - x2 := x1 + VolBarInnerWidth * Volume; - - // draw volume bar - glColor3f(State.RD, State.GD, State.BD); - glVertex2f(x1, y1); - glVertex2f(x1, y2); - glColor3f(State.R, State.G, State.B); - glVertex2f(x2, y2); - glVertex2f(x2, y1); - - Delta := (SDL_GetTicks() - ChannelPeak[State.ChannelIndex].Time)/1000; - PeakVolume := ChannelPeak[State.ChannelIndex].Volume - Delta*Delta*PeakDecay; - - // determine new peak-volume - if (Volume > PeakVolume) then - begin - PeakVolume := Volume; - ChannelPeak[State.ChannelIndex].Volume := Volume; - ChannelPeak[State.ChannelIndex].Time := SDL_GetTicks(); - end; - - x1 := x + VolBarInnerHSpacing + VolBarInnerWidth * PeakVolume; - x2 := x1 + 2; - - // draw peak - glColor3f(0.8, 0.8, 0.8); - glVertex2f(x1, y1); - glVertex2f(x1, y2); - glVertex2f(x2, y2); - glVertex2f(x2, y1); - - // draw threshold - x1 := x + VolBarInnerHSpacing; - x2 := x1 + VolBarInnerWidth * IThresholdVals[Ini.ThresholdIndex]; - - glColor4f(0.3, 0.3, 0.3, 0.6); - glVertex2f(x1, y1); - glVertex2f(x1, y2); - glVertex2f(x2, y2); - glVertex2f(x2, y1); - glEnd(); - - glDisable(GL_BLEND); -end; - -procedure TScreenOptionsRecord.DrawPitch(const State: TDrawState; x, y, Width, Height: single); -var - x1, y1, x2, y2: single; - i: integer; - ToneBoxWidth: real; - ToneString: string; - ToneStringWidth, ToneStringHeight: real; - ToneStringMaxWidth: real; - ToneStringCenterXOffset: real; -const - PitchBarInnerHSpacing = 2; - PitchBarInnerVSpacing = 1; -begin - // calc tone pitch - PreviewChannel[State.ChannelIndex].AnalyzeBuffer(); - - // coordinates for black rect - x1 := x; - y1 := y; - x2 := x + Width; - y2 := y + Height; - - // init blend mode - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - // draw black background-rect - glColor4f(0, 0, 0, 0.8); - glBegin(GL_QUADS); - glVertex2f(x1, y1); - glVertex2f(x2, y1); - glVertex2f(x2, y2); - glVertex2f(x1, y2); - glEnd(); - - // coordinates for tone boxes - ToneBoxWidth := Width / NumHalftones; - y1 := y1 + PitchBarInnerVSpacing; - y2 := y2 - PitchBarInnerVSpacing; - - glBegin(GL_QUADS); - // draw tone boxes - for i := 0 to NumHalftones-1 do - begin - x1 := x + i * ToneBoxWidth + PitchBarInnerHSpacing; - x2 := x1 + ToneBoxWidth - 2*PitchBarInnerHSpacing; - - if ((PreviewChannel[State.ChannelIndex].ToneValid) and - (PreviewChannel[State.ChannelIndex].ToneAbs = i)) then - begin - // highlight current tone-pitch - glColor3f(1, i / (NumHalftones-1), 0) - end - else - begin - // grey other tone-pitches - glColor3f(0.3, i / (NumHalftones-1) * 0.3, 0); - end; - - glVertex2f(x1, y1); - glVertex2f(x2, y1); - glVertex2f(x2, y2); - glVertex2f(x1, y2); - end; - glEnd(); - - glDisable(GL_BLEND); - - /// - // draw the name of the tone - /////// - - ToneString := PreviewChannel[State.ChannelIndex].ToneString; - ToneStringHeight := ChannelBarsTotalHeight; - - // initialize font - // TODO: what about reflection, italic etc.? - SetFontSize(ToneStringHeight); - - // center - // Note: for centering let us assume that G#4 has the max. horizontal extent - ToneStringWidth := glTextWidth(ToneString); - ToneStringMaxWidth := glTextWidth('G#4'); - ToneStringCenterXOffset := (ToneStringMaxWidth-ToneStringWidth) / 2; - - // draw - SetFontPos(x-ToneStringWidth-ToneStringCenterXOffset, y-ToneStringHeight/2); - glColor3f(0, 0, 0); - glPrint(ToneString); -end; - -function TScreenOptionsRecord.Draw: boolean; -var - Device: TAudioInputDevice; - DeviceCfg: PInputDeviceConfig; - SelectSlide: TSelectSlide; - BarXOffset, BarYOffset, BarWidth: real; - ChannelIndex: integer; - State: TDrawState; -begin - DrawBG; - DrawFG; - - if ((PreviewDeviceIndex >= 0) and - (PreviewDeviceIndex <= High(AudioInputProcessor.DeviceList))) then - begin - Device := AudioInputProcessor.DeviceList[PreviewDeviceIndex]; - DeviceCfg := @Ini.InputDeviceConfig[Device.CfgIndex]; - - // update source volume - if (SDL_GetTicks() >= NextVolumePollTime) then - begin - NextVolumePollTime := SDL_GetTicks() + 500; // next poll in 500ms - SourceVolume := Device.GetVolume(); - end; - - // get source select slide - SelectSlide := SelectsS[SelectInputSourceID]; - BarXOffset := SelectSlide.TextureSBG.X; - BarYOffset := SelectSlide.TextureSBG.Y + SelectSlide.TextureSBG.H + BarUpperSpacing; - BarWidth := SelectSlide.TextureSBG.W; - DrawVolume(SelectSlide.TextureSBG.X, BarYOffset, BarWidth, BarHeight); - - for ChannelIndex := 0 to High(Device.CaptureChannel) do - begin - // load player color mapped to current input channel - if (DeviceCfg.ChannelToPlayerMap[ChannelIndex] > 0) then - begin - // set mapped channel to corresponding player-color - LoadColor(State.R, State.G, State.B, 'P'+ IntToStr(DeviceCfg.ChannelToPlayerMap[ChannelIndex]) + 'Dark'); - end - else - begin - // set non-mapped channel to white - State.R := 1; State.G := 1; State.B := 1; - end; - - // dark player colors - State.RD := 0.2 * State.R; - State.GD := 0.2 * State.G; - State.BD := 0.2 * State.B; - - // channel select slide - SelectSlide := SelectsS[SelectSlideChannelID[ChannelIndex]]; - - BarXOffset := SelectSlide.TextureSBG.X; - BarYOffset := SelectSlide.TextureSBG.Y + SelectSlide.TextureSBG.H + BarUpperSpacing; - BarWidth := SelectSlide.TextureSBG.W; - - State.ChannelIndex := ChannelIndex; - - DrawVUMeter(State, BarXOffset, BarYOffset, BarWidth, BarHeight); - DrawPitch(State, BarXOffset, BarYOffset+BarHeight, BarWidth, BarHeight); - end; - end; - - Result := true; -end; - -end. diff --git a/src/screens/UScreenOptionsSound.pas b/src/screens/UScreenOptionsSound.pas deleted file mode 100644 index 7556dceb..00000000 --- a/src/screens/UScreenOptionsSound.pas +++ /dev/null @@ -1,187 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsSound; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - UMenu, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes; - -type - TScreenOptionsSound = class(TMenu) - public - constructor Create; override; - function ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; - PressedDown: boolean): boolean; override; - procedure OnShow; override; - end; - -implementation - -uses - UGraphic, - UUnicodeUtils, - SysUtils; - -function TScreenOptionsSound.ParseInput(PressedKey: cardinal; - CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE: - begin - // Escape -> save nothing - just leave this screen - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin - if SelInteraction = 8 then - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP: - InteractPrev; - SDLK_RIGHT: - begin - if (SelInteraction >= 0) and (SelInteraction < 8) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - end; - SDLK_LEFT: - begin - if (SelInteraction >= 0) and (SelInteraction < 8) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - end; - end; - end; - -{** - * Actually this one isn't pretty - but it does the trick of - * turning the background music on/off in "real time" - * bgm = background music - * TODO: - Fetching the SelectInteraction via something more descriptive - * - Obtaining the current value of a select is imho ugly - *} - if (SelInteraction = 1) then - begin - if TBackgroundMusicOption(SelectsS[1].SelectedOption) = bmoOn then - SoundLib.StartBgMusic - else - SoundLib.PauseBgMusic; - end; - -end; - -constructor TScreenOptionsSound.Create; -begin - inherited Create; - - LoadFromTheme(Theme.OptionsSound); - - Theme.OptionsSound.SelectSlideVoicePassthrough.showArrows := true; - Theme.OptionsSound.SelectSlideVoicePassthrough.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectSlideVoicePassthrough, Ini.VoicePassthrough, IVoicePassthroughTranslated); - - Theme.OptionsSound.SelectBackgroundMusic.showArrows := true; - Theme.OptionsSound.SelectBackgroundMusic.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectBackgroundMusic, Ini.BackgroundMusicOption, IBackgroundMusicTranslated); - - // TODO: - MicBoost needs to be moved to ScreenOptionsRecord - Theme.OptionsSound.SelectMicBoost.showArrows := true; - Theme.OptionsSound.SelectMicBoost.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectMicBoost, Ini.MicBoost, IMicBoostTranslated); - - - Theme.OptionsSound.SelectClickAssist.showArrows := true; - Theme.OptionsSound.SelectClickAssist.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectClickAssist, Ini.ClickAssist, IClickAssistTranslated); - - Theme.OptionsSound.SelectBeatClick.showArrows := true; - Theme.OptionsSound.SelectBeatClick.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectBeatClick, Ini.BeatClick, IBeatClickTranslated); - - Theme.OptionsSound.SelectThreshold.showArrows := true; - Theme.OptionsSound.SelectThreshold.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectThreshold, Ini.ThresholdIndex, IThreshold); - - Theme.OptionsSound.SelectSlidePreviewVolume.showArrows := true; - Theme.OptionsSound.SelectSlidePreviewVolume.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectSlidePreviewVolume, Ini.PreviewVolume, IPreviewVolumeTranslated); - - Theme.OptionsSound.SelectSlidePreviewFading.showArrows := true; - Theme.OptionsSound.SelectSlidePreviewFading.oneItemOnly := true; - AddSelectSlide(Theme.OptionsSound.SelectSlidePreviewFading, Ini.PreviewFading, IPreviewFadingTranslated); - - AddButton(Theme.OptionsSound.ButtonExit); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - - Interaction := 0; -end; - -procedure TScreenOptionsSound.OnShow; -begin - inherited; - Interaction := 0; -end; - -end. diff --git a/src/screens/UScreenOptionsThemes.pas b/src/screens/UScreenOptionsThemes.pas deleted file mode 100644 index dca581a2..00000000 --- a/src/screens/UScreenOptionsThemes.pas +++ /dev/null @@ -1,206 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenOptionsThemes; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - UMenu, - UDisplay, - UMusic, - UFiles, - UIni, - UThemes; - -type - TScreenOptionsThemes = class(TMenu) - private - procedure ReloadTheme; - public - SkinSelect: integer; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure InteractInc; override; - procedure InteractDec; override; - end; - -implementation - -uses - SysUtils, - UGraphic, - UMain, - UPathUtils, - UUnicodeUtils, - USkins; - -function TScreenOptionsThemes.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - // Escape -> save nothing - just leave this screen - - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - SDLK_RETURN: - begin - if SelInteraction = 3 then - begin - Ini.Save; - - // Reload all screens, after Theme changed - // Todo : JB - Check if theme was actually changed - UGraphic.UnLoadScreens(); - UGraphic.LoadScreens(); - - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenOptions); - end; - end; - SDLK_DOWN: - InteractNext; - SDLK_UP : - InteractPrev; - SDLK_RIGHT: - begin - if (SelInteraction >= 0) and (SelInteraction <= 2) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - end; - end; - SDLK_LEFT: - begin - if (SelInteraction >= 0) and (SelInteraction <= 2) then - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - end; - end; - end; - end; -end; - -procedure TScreenOptionsThemes.InteractInc; -begin - inherited InteractInc; - - //Update Skins - if (SelInteraction = 0) then - begin - Skin.OnThemeChange; - UpdateSelectSlideOptions(Theme.OptionsThemes.SelectSkin, SkinSelect, ISkin, Ini.SkinNo); - end; - - ReloadTheme(); -end; - -procedure TScreenOptionsThemes.InteractDec; -begin - inherited InteractDec; - - //Update Skins - if (SelInteraction = 0 ) then - begin - Skin.OnThemeChange; - UpdateSelectSlideOptions (Theme.OptionsThemes.SelectSkin, SkinSelect, ISkin, Ini.SkinNo); - end; - - ReloadTheme(); -end; - -constructor TScreenOptionsThemes.Create; -begin - inherited Create; - - LoadFromTheme(Theme.OptionsThemes); - - Theme.OptionsThemes.SelectTheme.showArrows := true; - Theme.OptionsThemes.SelectTheme.oneItemOnly := true; - AddSelectSlide(Theme.OptionsThemes.SelectTheme, Ini.Theme, ITheme); - - Theme.OptionsThemes.SelectSkin.showArrows := true; - Theme.OptionsThemes.SelectSkin.oneItemOnly := true; - SkinSelect := AddSelectSlide(Theme.OptionsThemes.SelectSkin, Ini.SkinNo, ISkin); - - Theme.OptionsThemes.SelectColor.showArrows := true; - Theme.OptionsThemes.SelectColor.oneItemOnly := true; - AddSelectSlide(Theme.OptionsThemes.SelectColor, Ini.Color, IColorTranslated); - - AddButton(Theme.OptionsThemes.ButtonExit); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); -end; - -procedure TScreenOptionsThemes.OnShow; -begin - inherited; - - Interaction := 0; -end; - -procedure TScreenOptionsThemes.ReloadTheme; -begin - Theme.LoadTheme(ThemePath.Append(ITheme[Ini.Theme] + '.ini'), Ini.Color); - - ScreenOptionsThemes := TScreenOptionsThemes.create(); - ScreenOptionsThemes.onshow; - Display.CurrentScreen := @ScreenOptionsThemes; - - ScreenOptionsThemes.Interaction := self.Interaction; - ScreenOptionsThemes.Draw; - - Display.Draw; - SwapBuffers; - - Self.Destroy; -end; - -end. diff --git a/src/screens/UScreenPartyNewRound.pas b/src/screens/UScreenPartyNewRound.pas deleted file mode 100644 index c4295502..00000000 --- a/src/screens/UScreenPartyNewRound.pas +++ /dev/null @@ -1,463 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenPartyNewRound; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SysUtils, - UMenu, - UDisplay, - UMusic, - UFiles, - UThemes; - -type - TScreenPartyNewRound = class(TMenu) - public - //Texts: - TextRound1: cardinal; - TextRound2: cardinal; - TextRound3: cardinal; - TextRound4: cardinal; - TextRound5: cardinal; - TextRound6: cardinal; - TextRound7: cardinal; - - TextWinner1: cardinal; - TextWinner2: cardinal; - TextWinner3: cardinal; - TextWinner4: cardinal; - TextWinner5: cardinal; - TextWinner6: cardinal; - TextWinner7: cardinal; - - TextNextRound: cardinal; - TextNextRoundNo: cardinal; - TextNextPlayer1: cardinal; - TextNextPlayer2: cardinal; - TextNextPlayer3: cardinal; - - //Statics - StaticRound1: cardinal; - StaticRound2: cardinal; - StaticRound3: cardinal; - StaticRound4: cardinal; - StaticRound5: cardinal; - StaticRound6: cardinal; - StaticRound7: cardinal; - - //Scores - TextScoreTeam1: cardinal; - TextScoreTeam2: cardinal; - TextScoreTeam3: cardinal; - TextNameTeam1: cardinal; - TextNameTeam2: cardinal; - TextNameTeam3: cardinal; - - TextTeam1Players: cardinal; - TextTeam2Players: cardinal; - TextTeam3Players: cardinal; - - StaticTeam1: cardinal; - StaticTeam2: cardinal; - StaticTeam3: cardinal; - StaticNextPlayer1: cardinal; - StaticNextPlayer2: cardinal; - StaticNextPlayer3: cardinal; - - - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UMain, - UIni, - UTexture, - UParty, - UDLLManager, - ULanguage, - USong, - ULog, - UUnicodeUtils; - -function TScreenPartyNewRound.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Back); - CheckFadeTo(@ScreenMain,'MSG_END_PARTY'); - end; - - SDLK_RETURN: - begin - AudioPlayback.PlaySound(SoundLib.Start); - if DLLMan.Selected.LoadSong then - begin - //Select PartyMode ScreenSong - ScreenSong.Mode := smPartyMode; - FadeTo(@ScreenSong); - end - else - begin - FadeTo(@ScreenSingModi); - end; - end; - end; - end; -end; - -constructor TScreenPartyNewRound.Create; -begin - inherited Create; - - TextRound1 := AddText (Theme.PartyNewRound.TextRound1); - TextRound2 := AddText (Theme.PartyNewRound.TextRound2); - TextRound3 := AddText (Theme.PartyNewRound.TextRound3); - TextRound4 := AddText (Theme.PartyNewRound.TextRound4); - TextRound5 := AddText (Theme.PartyNewRound.TextRound5); - TextRound6 := AddText (Theme.PartyNewRound.TextRound6); - TextRound7 := AddText (Theme.PartyNewRound.TextRound7); - - TextWinner1 := AddText (Theme.PartyNewRound.TextWinner1); - TextWinner2 := AddText (Theme.PartyNewRound.TextWinner2); - TextWinner3 := AddText (Theme.PartyNewRound.TextWinner3); - TextWinner4 := AddText (Theme.PartyNewRound.TextWinner4); - TextWinner5 := AddText (Theme.PartyNewRound.TextWinner5); - TextWinner6 := AddText (Theme.PartyNewRound.TextWinner6); - TextWinner7 := AddText (Theme.PartyNewRound.TextWinner7); - - TextNextRound := AddText (Theme.PartyNewRound.TextNextRound); - TextNextRoundNo := AddText (Theme.PartyNewRound.TextNextRoundNo); - TextNextPlayer1 := AddText (Theme.PartyNewRound.TextNextPlayer1); - TextNextPlayer2 := AddText (Theme.PartyNewRound.TextNextPlayer2); - TextNextPlayer3 := AddText (Theme.PartyNewRound.TextNextPlayer3); - - StaticRound1 := AddStatic (Theme.PartyNewRound.StaticRound1); - StaticRound2 := AddStatic (Theme.PartyNewRound.StaticRound2); - StaticRound3 := AddStatic (Theme.PartyNewRound.StaticRound3); - StaticRound4 := AddStatic (Theme.PartyNewRound.StaticRound4); - StaticRound5 := AddStatic (Theme.PartyNewRound.StaticRound5); - StaticRound6 := AddStatic (Theme.PartyNewRound.StaticRound6); - StaticRound7 := AddStatic (Theme.PartyNewRound.StaticRound7); - - //Scores - TextScoreTeam1 := AddText (Theme.PartyNewRound.TextScoreTeam1); - TextScoreTeam2 := AddText (Theme.PartyNewRound.TextScoreTeam2); - TextScoreTeam3 := AddText (Theme.PartyNewRound.TextScoreTeam3); - TextNameTeam1 := AddText (Theme.PartyNewRound.TextNameTeam1); - TextNameTeam2 := AddText (Theme.PartyNewRound.TextNameTeam2); - TextNameTeam3 := AddText (Theme.PartyNewRound.TextNameTeam3); - - //Players - TextTeam1Players := AddText (Theme.PartyNewRound.TextTeam1Players); - TextTeam2Players := AddText (Theme.PartyNewRound.TextTeam2Players); - TextTeam3Players := AddText (Theme.PartyNewRound.TextTeam3Players); - - StaticTeam1 := AddStatic (Theme.PartyNewRound.StaticTeam1); - StaticTeam2 := AddStatic (Theme.PartyNewRound.StaticTeam2); - StaticTeam3 := AddStatic (Theme.PartyNewRound.StaticTeam3); - StaticNextPlayer1 := AddStatic (Theme.PartyNewRound.StaticNextPlayer1); - StaticNextPlayer2 := AddStatic (Theme.PartyNewRound.StaticNextPlayer2); - StaticNextPlayer3 := AddStatic (Theme.PartyNewRound.StaticNextPlayer3); - - LoadFromTheme(Theme.PartyNewRound); -end; - -procedure TScreenPartyNewRound.OnShow; -var - I: integer; - function GetTeamPlayers(const Num: byte): UTF8String; - var - Players: array of UTF8String; - J: byte; - begin - if (Num-1 >= PartySession.Teams.NumTeams) then - exit; - - //Create Players array - SetLength(Players, PartySession.Teams.TeamInfo[Num-1].NumPlayers); - for J := 0 to PartySession.Teams.TeamInfo[Num-1].NumPlayers-1 do - Players[J] := UTF8String(PartySession.Teams.TeamInfo[Num-1].PlayerInfo[J].Name); - - //Implode and Return - Result := Language.Implode(Players); - end; -begin - inherited; - - PartySession.StartRound; - - //Set Visibility of Round Infos - I := Length(PartySession.Rounds); - if (I >= 1) then - begin - Static[StaticRound1].Visible := true; - Text[TextRound1].Visible := true; - Text[TextWinner1].Visible := true; - - //Texts: - Text[TextRound1].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[0].Plugin].Name); - Text[TextWinner1].Text := PartySession.GetWinnerString(0); - end - else - begin - Static[StaticRound1].Visible := false; - Text[TextRound1].Visible := false; - Text[TextWinner1].Visible := false; - end; - - if (I >= 2) then - begin - Static[StaticRound2].Visible := true; - Text[TextRound2].Visible := true; - Text[TextWinner2].Visible := true; - - //Texts: - Text[TextRound2].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[1].Plugin].Name); - Text[TextWinner2].Text := PartySession.GetWinnerString(1); - end - else - begin - Static[StaticRound2].Visible := false; - Text[TextRound2].Visible := false; - Text[TextWinner2].Visible := false; - end; - - if (I >= 3) then - begin - Static[StaticRound3].Visible := true; - Text[TextRound3].Visible := true; - Text[TextWinner3].Visible := true; - - //Texts: - Text[TextRound3].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[2].Plugin].Name); - Text[TextWinner3].Text := PartySession.GetWinnerString(2); - end - else - begin - Static[StaticRound3].Visible := false; - Text[TextRound3].Visible := false; - Text[TextWinner3].Visible := false; - end; - - if (I >= 4) then - begin - Static[StaticRound4].Visible := true; - Text[TextRound4].Visible := true; - Text[TextWinner4].Visible := true; - - //Texts: - Text[TextRound4].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[3].Plugin].Name); - Text[TextWinner4].Text := PartySession.GetWinnerString(3); - end - else - begin - Static[StaticRound4].Visible := false; - Text[TextRound4].Visible := false; - Text[TextWinner4].Visible := false; - end; - - if (I >= 5) then - begin - Static[StaticRound5].Visible := true; - Text[TextRound5].Visible := true; - Text[TextWinner5].Visible := true; - - //Texts: - Text[TextRound5].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[4].Plugin].Name); - Text[TextWinner5].Text := PartySession.GetWinnerString(4); - end - else - begin - Static[StaticRound5].Visible := false; - Text[TextRound5].Visible := false; - Text[TextWinner5].Visible := false; - end; - - if (I >= 6) then - begin - Static[StaticRound6].Visible := true; - Text[TextRound6].Visible := true; - Text[TextWinner6].Visible := true; - - //Texts: - Text[TextRound6].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[5].Plugin].Name); - Text[TextWinner6].Text := PartySession.GetWinnerString(5); - end - else - begin - Static[StaticRound6].Visible := false; - Text[TextRound6].Visible := false; - Text[TextWinner6].Visible := false; - end; - - if (I >= 7) then - begin - Static[StaticRound7].Visible := true; - Text[TextRound7].Visible := true; - Text[TextWinner7].Visible := true; - - //Texts: - Text[TextRound7].Text := Language.Translate(DllMan.Plugins[PartySession.Rounds[6].Plugin].Name); - Text[TextWinner7].Text := PartySession.GetWinnerString(6); - end - else - begin - Static[StaticRound7].Visible := false; - Text[TextRound7].Visible := false; - Text[TextWinner7].Visible := false; - end; - - //Display Scores - if (PartySession.Teams.NumTeams >= 1) then - begin - Text[TextScoreTeam1].Text := InttoStr(PartySession.Teams.TeamInfo[0].Score); - Text[TextNameTeam1].Text := UTF8String(PartySession.Teams.TeamInfo[0].Name); - Text[TextTeam1Players].Text := GetTeamPlayers(1); - - Text[TextScoreTeam1].Visible := true; - Text[TextNameTeam1].Visible := true; - Text[TextTeam1Players].Visible := true; - Static[StaticTeam1].Visible := true; - Static[StaticNextPlayer1].Visible := true; - end - else - begin - Text[TextScoreTeam1].Visible := false; - Text[TextNameTeam1].Visible := false; - Text[TextTeam1Players].Visible := false; - Static[StaticTeam1].Visible := false; - Static[StaticNextPlayer1].Visible := false; - end; - - if (PartySession.Teams.NumTeams >= 2) then - begin - Text[TextScoreTeam2].Text := InttoStr(PartySession.Teams.TeamInfo[1].Score); - Text[TextNameTeam2].Text := UTF8String(PartySession.Teams.TeamInfo[1].Name); - Text[TextTeam2Players].Text := GetTeamPlayers(2); - - Text[TextScoreTeam2].Visible := true; - Text[TextNameTeam2].Visible := true; - Text[TextTeam2Players].Visible := true; - Static[StaticTeam2].Visible := true; - Static[StaticNextPlayer2].Visible := true; - end - else - begin - Text[TextScoreTeam2].Visible := false; - Text[TextNameTeam2].Visible := false; - Text[TextTeam2Players].Visible := false; - Static[StaticTeam2].Visible := false; - Static[StaticNextPlayer2].Visible := false; - end; - - if (PartySession.Teams.NumTeams >= 3) then - begin - Text[TextScoreTeam3].Text := InttoStr(PartySession.Teams.TeamInfo[2].Score); - Text[TextNameTeam3].Text := UTF8String(PartySession.Teams.TeamInfo[2].Name); - Text[TextTeam3Players].Text := GetTeamPlayers(3); - - Text[TextScoreTeam3].Visible := true; - Text[TextNameTeam3].Visible := true; - Text[TextTeam3Players].Visible := true; - Static[StaticTeam3].Visible := true; - Static[StaticNextPlayer3].Visible := true; - end - else - begin - Text[TextScoreTeam3].Visible := false; - Text[TextNameTeam3].Visible := false; - Text[TextTeam3Players].Visible := false; - Static[StaticTeam3].Visible := false; - Static[StaticNextPlayer3].Visible := false; - end; - - //nextRound Texts - Text[TextNextRound].Text := Language.Translate(DllMan.Selected.PluginDesc); - Text[TextNextRoundNo].Text := InttoStr(PartySession.CurRound + 1); - if (PartySession.Teams.NumTeams >= 1) then - begin - Text[TextNextPlayer1].Text := PartySession.Teams.Teaminfo[0].Playerinfo[PartySession.Teams.Teaminfo[0].CurPlayer].Name; - Text[TextNextPlayer1].Visible := true; - end - else - Text[TextNextPlayer1].Visible := false; - - if (PartySession.Teams.NumTeams >= 2) then - begin - Text[TextNextPlayer2].Text := PartySession.Teams.Teaminfo[1].Playerinfo[PartySession.Teams.Teaminfo[1].CurPlayer].Name; - Text[TextNextPlayer2].Visible := true; - end - else - Text[TextNextPlayer2].Visible := false; - - if (PartySession.Teams.NumTeams >= 3) then - begin - Text[TextNextPlayer3].Text := PartySession.Teams.Teaminfo[2].Playerinfo[PartySession.Teams.Teaminfo[2].CurPlayer].Name; - Text[TextNextPlayer3].Visible := true; - end - else - Text[TextNextPlayer3].Visible := false; -end; - -procedure TScreenPartyNewRound.SetAnimationProgress(Progress: real); -begin - {Button[0].Texture.ScaleW := Progress; - Button[1].Texture.ScaleW := Progress; - Button[2].Texture.ScaleW := Progress; } -end; - -end. diff --git a/src/screens/UScreenPartyOptions.pas b/src/screens/UScreenPartyOptions.pas deleted file mode 100644 index 2deffda6..00000000 --- a/src/screens/UScreenPartyOptions.pas +++ /dev/null @@ -1,318 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenPartyOptions; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - SysUtils, - UThemes; - -type - TScreenPartyOptions = class(TMenu) - public - SelectLevel: cardinal; - SelectPlayList: cardinal; - SelectPlayList2: cardinal; - SelectRounds: cardinal; - SelectTeams: cardinal; - SelectPlayers1: cardinal; - SelectPlayers2: cardinal; - SelectPlayers3: cardinal; - - PlayList: integer; - PlayList2: integer; - Rounds: integer; - NumTeams: integer; - NumPlayer1, NumPlayer2, NumPlayer3: integer; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - procedure SetPlaylist2; - end; - -var - IPlaylist: array[0..2] of UTF8String; - IPlaylist2: array of UTF8String; - - const - ITeams: array[0..1] of UTF8String = ('2', '3'); - IPlayers: array[0..3] of UTF8String = ('1', '2', '3', '4'); - IRounds: array[0..5] of UTF8String = ('2', '3', '4', '5', '6', '7'); - -implementation - -uses - UGraphic, - UMain, - UIni, - UTexture, - ULanguage, - UParty, - USong, - UDLLManager, - UPlaylist, - USongs, - UUnicodeUtils; - -function TScreenPartyOptions.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - I, J: integer; - OnlyMultiPlayer: boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end; - - SDLK_RETURN: - begin - //Don'T start when Playlist is Selected and there are no Playlists - if (Playlist = 2) and (Length(PlaylistMan.Playlists) = 0) then - Exit; - // Don't start when SinglePlayer Teams but only Multiplayer Plugins available - OnlyMultiPlayer := true; - for I := 0 to High(DLLMan.Plugins) do - begin - OnlyMultiPlayer := (OnlyMultiPlayer and DLLMan.Plugins[I].TeamModeOnly); - end; - if (OnlyMultiPlayer) and ((NumPlayer1 = 0) or (NumPlayer2 = 0) or ((NumPlayer3 = 0) and (NumTeams = 1))) then - begin - ScreenPopupError.ShowPopup(Language.Translate('ERROR_NO_PLUGINS')); - Exit; - end; - //Save Difficulty - Ini.Difficulty := SelectsS[SelectLevel].SelectedOption; - Ini.SaveLevel; - - //Save Num Teams: - PartySession.Teams.NumTeams := NumTeams + 2; - PartySession.Teams.Teaminfo[0].NumPlayers := NumPlayer1+1; - PartySession.Teams.Teaminfo[1].NumPlayers := NumPlayer2+1; - PartySession.Teams.Teaminfo[2].NumPlayers := NumPlayer3+1; - - //Save Playlist - PlaylistMan.Mode := TSingMode( Playlist ); - PlaylistMan.CurPlayList := High(cardinal); - //if Category Selected Search Category ID - if Playlist = 1 then - begin - J := -1; - for I := 0 to high(CatSongs.Song) do - begin - if CatSongs.Song[I].Main then - Inc(J); - - if J = Playlist2 then - begin - PlaylistMan.CurPlayList := I; - Break; - end; - end; - - //No Categorys or Invalid Entry - if PlaylistMan.CurPlayList = High(cardinal) then - Exit; - end - else - PlaylistMan.CurPlayList := Playlist2; - - //Start Party - PartySession.StartNewParty(Rounds + 2); - - AudioPlayback.PlaySound(SoundLib.Start); - //Go to Player Screen - FadeTo(@ScreenPartyPlayer); - end; - - // Up and Down could be done at the same time, - // but I don't want to declare variables inside - // functions like this one, called so many times - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - SDLK_RIGHT: - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractInc; - - //Change Playlist2 if Playlist is Changed - if (Interaction = 1) then - begin - SetPlaylist2; - end //Change Team3 Players visibility - else if (Interaction = 4) then - begin - SelectsS[7].Visible := (NumTeams = 1); - end; - end; - SDLK_LEFT: - begin - AudioPlayback.PlaySound(SoundLib.Option); - InteractDec; - - //Change Playlist2 if Playlist is Changed - if (Interaction = 1) then - begin - SetPlaylist2; - end //Change Team3 Players visibility - else if (Interaction = 4) then - begin - SelectsS[7].Visible := (NumTeams = 1); - end; - end; - end; - end; -end; - -constructor TScreenPartyOptions.Create; -begin - inherited Create; - //Fill IPlaylist - IPlaylist[0] := Language.Translate('PARTY_PLAYLIST_ALL'); - IPlaylist[1] := Language.Translate('PARTY_PLAYLIST_CATEGORY'); - IPlaylist[2] := Language.Translate('PARTY_PLAYLIST_PLAYLIST'); - - //Fill IPlaylist2 - SetLength(IPlaylist2, 1); - IPlaylist2[0] := '---'; - - //Clear all Selects - NumTeams := 0; - NumPlayer1 := 0; - NumPlayer2 := 0; - NumPlayer3 := 0; - Rounds := 5; - PlayList := 0; - PlayList2 := 0; - - //Load Screen From Theme - LoadFromTheme(Theme.PartyOptions); - - SelectLevel := AddSelectSlide(Theme.PartyOptions.SelectLevel, Ini.Difficulty, Theme.ILevel); - SelectPlayList := AddSelectSlide(Theme.PartyOptions.SelectPlayList, PlayList, IPlaylist); - SelectPlayList2 := AddSelectSlide(Theme.PartyOptions.SelectPlayList2, PlayList2, IPlaylist2); - SelectRounds := AddSelectSlide(Theme.PartyOptions.SelectRounds, Rounds, IRounds); - SelectTeams := AddSelectSlide(Theme.PartyOptions.SelectTeams, NumTeams, ITeams); - SelectPlayers1 := AddSelectSlide(Theme.PartyOptions.SelectPlayers1, NumPlayer1, IPlayers); - SelectPlayers2 := AddSelectSlide(Theme.PartyOptions.SelectPlayers2, NumPlayer2, IPlayers); - SelectPlayers3 := AddSelectSlide(Theme.PartyOptions.SelectPlayers3, NumPlayer3, IPlayers); - - Interaction := 0; - - //Hide Team3 Players - SelectsS[7].Visible := false; -end; - -procedure TScreenPartyOptions.SetPlaylist2; -var - I: integer; -begin - case Playlist of - 0: - begin - SetLength(IPlaylist2, 1); - IPlaylist2[0] := '---'; - end; - 1: - begin - SetLength(IPlaylist2, 0); - for I := 0 to high(CatSongs.Song) do - begin - if (CatSongs.Song[I].Main) then - begin - SetLength(IPlaylist2, Length(IPlaylist2) + 1); - IPlaylist2[high(IPlaylist2)] := CatSongs.Song[I].Artist; - end; - end; - - if (Length(IPlaylist2) = 0) then - begin - SetLength(IPlaylist2, 1); - IPlaylist2[0] := 'No Categories found'; - end; - end; - 2: - begin - if (Length(PlaylistMan.Playlists) > 0) then - begin - SetLength(IPlaylist2, Length(PlaylistMan.Playlists)); - PlaylistMan.GetNames(IPlaylist2); - end - else - begin - SetLength(IPlaylist2, 1); - IPlaylist2[0] := 'No Playlists found'; - end; - end; - end; - - Playlist2 := 0; - UpdateSelectSlideOptions(Theme.PartyOptions.SelectPlayList2, 2, IPlaylist2, Playlist2); -end; - -procedure TScreenPartyOptions.OnShow; -begin - inherited; - - Randomize; -end; - -procedure TScreenPartyOptions.SetAnimationProgress(Progress: real); -begin - {for I := 0 to 6 do - SelectS[I].Texture.ScaleW := Progress;} -end; - -end. diff --git a/src/screens/UScreenPartyPlayer.pas b/src/screens/UScreenPartyPlayer.pas deleted file mode 100644 index 887d5202..00000000 --- a/src/screens/UScreenPartyPlayer.pas +++ /dev/null @@ -1,385 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenPartyPlayer; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - SysUtils, - UThemes; - -type - TScreenPartyPlayer = class(TMenu) - public - Team1Name: cardinal; - Player1Name: cardinal; - Player2Name: cardinal; - Player3Name: cardinal; - Player4Name: cardinal; - - Team2Name: cardinal; - Player5Name: cardinal; - Player6Name: cardinal; - Player7Name: cardinal; - Player8Name: cardinal; - - Team3Name: cardinal; - Player9Name: cardinal; - Player10Name: cardinal; - Player11Name: cardinal; - Player12Name: cardinal; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UMain, - UIni, - UTexture, - UParty, - UUnicodeUtils; - -function TScreenPartyPlayer.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - SDL_ModState: word; - I, J: integer; - - procedure IntNext; - begin - repeat - InteractNext; - until Button[Interaction].Visible; - end; - procedure IntPrev; - begin - repeat - InteractPrev; - until Button[Interaction].Visible; - end; -begin - Result := true; - - if (PressedDown) then - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT - + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT) - else - SDL_ModState := 0; - - begin // Key Down - // check normal keys - case CharCode of - Ord('0')..Ord('9'), - Ord('a')..Ord('z'), - Ord('A')..Ord('Z'), - Ord(' '), Ord('-'), Ord('_'), Ord('!'), Ord(','), Ord('<'), Ord('/'), - Ord('*'), Ord('?'), Ord(''''), Ord('"'): - begin - Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + - UCS4ToUTF8String(CharCode); - Exit; - end; - end; - - // check special keys - case PressedKey of - // Templates for Names Mod - SDLK_F1: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[0] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[0]; - end; - SDLK_F2: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[1] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[1]; - end; - SDLK_F3: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[2] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[2]; - end; - SDLK_F4: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[3] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[3]; - end; - SDLK_F5: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[4] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[4]; - end; - SDLK_F6: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[5] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[5]; - end; - SDLK_F7: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[6] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[6]; - end; - SDLK_F8: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[7] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[7]; - end; - SDLK_F9: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[8] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[8]; - end; - SDLK_F10: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[9] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[9]; - end; - SDLK_F11: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[10] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[10]; - end; - SDLK_F12: - if (SDL_ModState = KMOD_LALT) then - begin - Ini.NameTemplate[11] := Button[Interaction].Text[0].Text; - end - else - begin - Button[Interaction].Text[0].Text := Ini.NameTemplate[11]; - end; - - SDLK_BACKSPACE: - begin - Button[Interaction].Text[0].DeleteLastLetter; - end; - - SDLK_ESCAPE: - begin - Ini.SaveNames; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenPartyOptions); - end; - - SDLK_RETURN: - begin - - //Save PlayerNames - for I := 0 to PartySession.Teams.NumTeams-1 do - begin - PartySession.Teams.Teaminfo[I].Name := PChar(Button[I*5].Text[0].Text); - for J := 0 to PartySession.Teams.Teaminfo[I].NumPlayers-1 do - begin - PartySession.Teams.Teaminfo[I].Playerinfo[J].Name := PChar(Button[I*5 + J+1].Text[0].Text); - PartySession.Teams.Teaminfo[I].Playerinfo[J].TimesPlayed := 0; - end; - end; - - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenPartyNewRound); - end; - - // Up and Down could be done at the same time, - // but I don't want to declare variables inside - // functions like this one, called so many times - SDLK_DOWN: IntNext; - SDLK_UP: IntPrev; - SDLK_RIGHT: IntNext; - SDLK_LEFT: IntPrev; - end; - end; -end; - -constructor TScreenPartyPlayer.Create; -begin - inherited Create; - - LoadFromTheme(Theme.PartyPlayer); - - Team1Name := AddButton(Theme.PartyPlayer.Team1Name); - AddButton(Theme.PartyPlayer.Player1Name); - AddButton(Theme.PartyPlayer.Player2Name); - AddButton(Theme.PartyPlayer.Player3Name); - AddButton(Theme.PartyPlayer.Player4Name); - - Team2Name := AddButton(Theme.PartyPlayer.Team2Name); - AddButton(Theme.PartyPlayer.Player5Name); - AddButton(Theme.PartyPlayer.Player6Name); - AddButton(Theme.PartyPlayer.Player7Name); - AddButton(Theme.PartyPlayer.Player8Name); - - Team3Name := AddButton(Theme.PartyPlayer.Team3Name); - AddButton(Theme.PartyPlayer.Player9Name); - AddButton(Theme.PartyPlayer.Player10Name); - AddButton(Theme.PartyPlayer.Player11Name); - AddButton(Theme.PartyPlayer.Player12Name); - - Interaction := 0; -end; - -procedure TScreenPartyPlayer.OnShow; -var - I: integer; -begin - inherited; - - // Templates for Names Mod - for I := 1 to 4 do - Button[I].Text[0].Text := Ini.Name[I-1]; - - for I := 6 to 9 do - Button[I].Text[0].Text := Ini.Name[I-2]; - - for I := 11 to 14 do - Button[I].Text[0].Text := Ini.Name[I-3]; - - Button[0].Text[0].Text := Ini.NameTeam[0]; - Button[5].Text[0].Text := Ini.NameTeam[1]; - Button[10].Text[0].Text := Ini.NameTeam[2]; - // Templates for Names Mod end - - if (PartySession.Teams.NumTeams>=1) then - begin - Button[0].Visible := true; - Button[1].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=1); - Button[2].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=2); - Button[3].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=3); - Button[4].Visible := (PartySession.Teams.Teaminfo[0].NumPlayers >=4); - end - else - begin - Button[0].Visible := false; - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := false; - Button[4].Visible := false; - end; - - if (PartySession.Teams.NumTeams>=2) then - begin - Button[5].Visible := true; - Button[6].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=1); - Button[7].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=2); - Button[8].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=3); - Button[9].Visible := (PartySession.Teams.Teaminfo[1].NumPlayers >=4); - end - else - begin - Button[5].Visible := false; - Button[6].Visible := false; - Button[7].Visible := false; - Button[8].Visible := false; - Button[9].Visible := false; - end; - - if (PartySession.Teams.NumTeams>=3) then - begin - Button[10].Visible := true; - Button[11].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=1); - Button[12].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=2); - Button[13].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=3); - Button[14].Visible := (PartySession.Teams.Teaminfo[2].NumPlayers >=4); - end - else - begin - Button[10].Visible := false; - Button[11].Visible := false; - Button[12].Visible := false; - Button[13].Visible := false; - Button[14].Visible := false; - end; - -end; - -procedure TScreenPartyPlayer.SetAnimationProgress(Progress: real); -var - I: integer; -begin - for I := 0 to high(Button) do - Button[I].Texture.ScaleW := Progress; -end; - -end. diff --git a/src/screens/UScreenPartyScore.pas b/src/screens/UScreenPartyScore.pas deleted file mode 100644 index 2de240b8..00000000 --- a/src/screens/UScreenPartyScore.pas +++ /dev/null @@ -1,343 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenPartyScore; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SysUtils, - UMenu, - UDisplay, - UMusic, - UThemes; - -type - TScreenPartyScore = class(TMenu) - public - TextScoreTeam1: cardinal; - TextScoreTeam2: cardinal; - TextScoreTeam3: cardinal; - TextNameTeam1: cardinal; - TextNameTeam2: cardinal; - TextNameTeam3: cardinal; - StaticTeam1: cardinal; - StaticTeam1BG: cardinal; - StaticTeam1Deco: cardinal; - StaticTeam2: cardinal; - StaticTeam2BG: cardinal; - StaticTeam2Deco: cardinal; - StaticTeam3: cardinal; - StaticTeam3BG: cardinal; - StaticTeam3Deco: cardinal; - TextWinner: cardinal; - - DecoTex: array[0..5] of integer; - DecoColor: array[0..5] of Record - R, G, B: real; - end; - - MaxScore: word; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UMain, - UParty, - UScreenSingModi, - ULanguage, - UTexture, - USkins, - UUnicodeUtils; - -function TScreenPartyScore.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Start); - if (PartySession.CurRound < High(PartySession.Rounds)) then - FadeTo(@ScreenPartyNewRound) - else - begin - PartySession.EndRound; - FadeTo(@ScreenPartyWin); - end; - end; - - SDLK_RETURN: - begin - AudioPlayback.PlaySound(SoundLib.Start); - if (PartySession.CurRound < High(PartySession.Rounds)) then - FadeTo(@ScreenPartyNewRound) - else - FadeTo(@ScreenPartyWin); - end; - end; - end; -end; - -constructor TScreenPartyScore.Create; -var -// I: integer; // Auto Removed, Unused Variable - Tex: TTexture; - R, G, B: real; - Color: integer; -begin - inherited Create; - - TextScoreTeam1 := AddText (Theme.PartyScore.TextScoreTeam1); - TextScoreTeam2 := AddText (Theme.PartyScore.TextScoreTeam2); - TextScoreTeam3 := AddText (Theme.PartyScore.TextScoreTeam3); - TextNameTeam1 := AddText (Theme.PartyScore.TextNameTeam1); - TextNameTeam2 := AddText (Theme.PartyScore.TextNameTeam2); - TextNameTeam3 := AddText (Theme.PartyScore.TextNameTeam3); - - StaticTeam1 := AddStatic (Theme.PartyScore.StaticTeam1); - StaticTeam1BG := AddStatic (Theme.PartyScore.StaticTeam1BG); - StaticTeam1Deco := AddStatic (Theme.PartyScore.StaticTeam1Deco); - StaticTeam2 := AddStatic (Theme.PartyScore.StaticTeam2); - StaticTeam2BG := AddStatic (Theme.PartyScore.StaticTeam2BG); - StaticTeam2Deco := AddStatic (Theme.PartyScore.StaticTeam2Deco); - StaticTeam3 := AddStatic (Theme.PartyScore.StaticTeam3); - StaticTeam3BG := AddStatic (Theme.PartyScore.StaticTeam3BG); - StaticTeam3Deco := AddStatic (Theme.PartyScore.StaticTeam3Deco); - - TextWinner := AddText (Theme.PartyScore.TextWinner); - - //Load Deco Textures - if Theme.PartyScore.DecoTextures.ChangeTextures then - begin - //Get Color - LoadColor(R, G, B, Theme.PartyScore.DecoTextures.FirstColor); - Color := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - DecoColor[0].R := R; - DecoColor[0].G := G; - DecoColor[0].B := B; - - //Load Texture - Tex := Texture.LoadTexture( - Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.FirstTexture), - Theme.PartyScore.DecoTextures.FirstTyp, Color); - DecoTex[0] := Tex.TexNum; - - //Get Second Color - LoadColor(R, G, B, Theme.PartyScore.DecoTextures.SecondColor); - Color := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - DecoColor[1].R := R; - DecoColor[1].G := G; - DecoColor[1].B := B; - - //Load Second Texture - Tex := Texture.LoadTexture( - Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.SecondTexture), - Theme.PartyScore.DecoTextures.SecondTyp, Color); - DecoTex[1] := Tex.TexNum; - - //Get Third Color - LoadColor(R, G, B, Theme.PartyScore.DecoTextures.ThirdColor); - Color := $10000 * Round(R*255) + $100 * Round(G*255) + Round(B*255); - DecoColor[2].R := R; - DecoColor[2].G := G; - DecoColor[2].B := B; - - //Load Third Texture - Tex := Texture.LoadTexture( - Skin.GetTextureFileName(Theme.PartyScore.DecoTextures.ThirdTexture), - Theme.PartyScore.DecoTextures.ThirdTyp, Color); - DecoTex[2] := Tex.TexNum; - end; - - LoadFromTheme(Theme.PartyScore); -end; - -procedure TScreenPartyScore.OnShow; -var - I, J: integer; - Placings: array [0..5] of byte; -begin - inherited; - - //Get Maxscore - - MaxScore := 0; - for I := 0 to ScreenSingModi.PlayerInfo.NumPlayers - 1 do - begin - if (ScreenSingModi.PlayerInfo.Playerinfo[I].Score > MaxScore) then - MaxScore := ScreenSingModi.PlayerInfo.Playerinfo[I].Score; - end; - - //Get Placings - for I := 0 to ScreenSingModi.PlayerInfo.NumPlayers - 1 do - begin - Placings[I] := 0; - for J := 0 to ScreenSingModi.PlayerInfo.NumPlayers - 1 do - if (ScreenSingModi.PlayerInfo.Playerinfo[J].Score > ScreenSingModi.PlayerInfo.Playerinfo[I].Score) then - Inc(Placings[I]); - end; - - //Set Static Length - Static[StaticTeam1].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[0].Percentage / 100; - Static[StaticTeam2].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[1].Percentage / 100; - Static[StaticTeam3].Texture.ScaleW := ScreenSingModi.PlayerInfo.Playerinfo[2].Percentage / 100; - - //fix: prevents static from drawn out of bounds. - if Static[StaticTeam1].Texture.ScaleW > 99 then Static[StaticTeam1].Texture.ScaleW := 99; - if Static[StaticTeam2].Texture.ScaleW > 99 then Static[StaticTeam2].Texture.ScaleW := 99; - if Static[StaticTeam3].Texture.ScaleW > 99 then Static[StaticTeam3].Texture.ScaleW := 99; - - //End Last Round - PartySession.EndRound; - - //Set Winnertext - Text[TextWinner].Text := Format(Language.Translate('PARTY_SCORE_WINS'), [PartySession.GetWinnerString(PartySession.CurRound)]); - - if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then - begin - Text[TextScoreTeam1].Text := InttoStr(ScreenSingModi.PlayerInfo.Playerinfo[0].Score); - Text[TextNameTeam1].Text := UTF8String(ScreenSingModi.TeamInfo.Teaminfo[0].Name); - - //Set Deco Texture - if Theme.PartyScore.DecoTextures.ChangeTextures then - begin - Static[StaticTeam1Deco].Texture.TexNum := DecoTex[Placings[0]]; - Static[StaticTeam1Deco].Texture.ColR := DecoColor[Placings[0]].R; - Static[StaticTeam1Deco].Texture.ColG := DecoColor[Placings[0]].G; - Static[StaticTeam1Deco].Texture.ColB := DecoColor[Placings[0]].B; - end; - - Text[TextScoreTeam1].Visible := true; - Text[TextNameTeam1].Visible := true; - Static[StaticTeam1].Visible := true; - Static[StaticTeam1BG].Visible := true; - Static[StaticTeam1Deco].Visible := true; - end - else - begin - Text[TextScoreTeam1].Visible := false; - Text[TextNameTeam1].Visible := false; - Static[StaticTeam1].Visible := false; - Static[StaticTeam1BG].Visible := false; - Static[StaticTeam1Deco].Visible := false; - end; - - if (ScreenSingModi.PlayerInfo.NumPlayers >= 2) then - begin - Text[TextScoreTeam2].Text := InttoStr(ScreenSingModi.PlayerInfo.Playerinfo[1].Score); - Text[TextNameTeam2].Text := UTF8String(ScreenSingModi.TeamInfo.Teaminfo[1].Name); - - //Set Deco Texture - if Theme.PartyScore.DecoTextures.ChangeTextures then - begin - Static[StaticTeam2Deco].Texture.TexNum := DecoTex[Placings[1]]; - Static[StaticTeam2Deco].Texture.ColR := DecoColor[Placings[1]].R; - Static[StaticTeam2Deco].Texture.ColG := DecoColor[Placings[1]].G; - Static[StaticTeam2Deco].Texture.ColB := DecoColor[Placings[1]].B; - end; - - Text[TextScoreTeam2].Visible := true; - Text[TextNameTeam2].Visible := true; - Static[StaticTeam2].Visible := true; - Static[StaticTeam2BG].Visible := true; - Static[StaticTeam2Deco].Visible := true; - end - else - begin - Text[TextScoreTeam2].Visible := false; - Text[TextNameTeam2].Visible := false; - Static[StaticTeam2].Visible := false; - Static[StaticTeam2BG].Visible := false; - Static[StaticTeam2Deco].Visible := false; - end; - - if (ScreenSingModi.PlayerInfo.NumPlayers >= 3) then - begin - Text[TextScoreTeam3].Text := InttoStr(ScreenSingModi.PlayerInfo.Playerinfo[2].Score); - Text[TextNameTeam3].Text := UTF8String(ScreenSingModi.TeamInfo.Teaminfo[2].Name); - - //Set Deco Texture - if Theme.PartyScore.DecoTextures.ChangeTextures then - begin - Static[StaticTeam3Deco].Texture.TexNum := DecoTex[Placings[2]]; - Static[StaticTeam3Deco].Texture.ColR := DecoColor[Placings[2]].R; - Static[StaticTeam3Deco].Texture.ColG := DecoColor[Placings[2]].G; - Static[StaticTeam3Deco].Texture.ColB := DecoColor[Placings[2]].B; - end; - - Text[TextScoreTeam3].Visible := true; - Text[TextNameTeam3].Visible := true; - Static[StaticTeam3].Visible := true; - Static[StaticTeam3BG].Visible := true; - Static[StaticTeam3Deco].Visible := true; - end - else - begin - Text[TextScoreTeam3].Visible := false; - Text[TextNameTeam3].Visible := false; - Static[StaticTeam3].Visible := false; - Static[StaticTeam3BG].Visible := false; - Static[StaticTeam3Deco].Visible := false; - end; -end; - -procedure TScreenPartyScore.SetAnimationProgress(Progress: real); -begin - if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then - Static[StaticTeam1].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[0].Percentage / 100; - if (ScreenSingModi.PlayerInfo.NumPlayers >= 2) then - Static[StaticTeam2].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[1].Percentage / 100; - if (ScreenSingModi.PlayerInfo.NumPlayers >= 3) then - Static[StaticTeam3].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[2].Percentage / 100; -end; - -end. diff --git a/src/screens/UScreenPartyWin.pas b/src/screens/UScreenPartyWin.pas deleted file mode 100644 index afa5ce83..00000000 --- a/src/screens/UScreenPartyWin.pas +++ /dev/null @@ -1,302 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenPartyWin; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SysUtils, - UMenu, - UDisplay, - UMusic, - UThemes; - -type - TScreenPartyWin = class(TMenu) - public - TextScoreTeam1: cardinal; - TextScoreTeam2: cardinal; - TextScoreTeam3: cardinal; - TextNameTeam1: cardinal; - TextNameTeam2: cardinal; - TextNameTeam3: cardinal; - StaticTeam1: cardinal; - StaticTeam1BG: cardinal; - StaticTeam1Deco: cardinal; - StaticTeam2: cardinal; - StaticTeam2BG: cardinal; - StaticTeam2Deco: cardinal; - StaticTeam3: cardinal; - StaticTeam3BG: cardinal; - StaticTeam3Deco: cardinal; - TextWinner: cardinal; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - end; - -implementation - -uses - UGraphic, - UMain, - UParty, - UScreenSingModi, - ULanguage, - UUnicodeUtils; - -function TScreenPartyWin.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenMain); - end; - - SDLK_RETURN: - begin - AudioPlayback.PlaySound(SoundLib.Start); - FadeTo(@ScreenMain); - end; - end; - end; -end; - -constructor TScreenPartyWin.Create; -//var -// I: integer; // Auto Removed, Unused Variable -begin - inherited Create; - - TextScoreTeam1 := AddText (Theme.PartyWin.TextScoreTeam1); - TextScoreTeam2 := AddText (Theme.PartyWin.TextScoreTeam2); - TextScoreTeam3 := AddText (Theme.PartyWin.TextScoreTeam3); - TextNameTeam1 := AddText (Theme.PartyWin.TextNameTeam1); - TextNameTeam2 := AddText (Theme.PartyWin.TextNameTeam2); - TextNameTeam3 := AddText (Theme.PartyWin.TextNameTeam3); - - StaticTeam1 := AddStatic (Theme.PartyWin.StaticTeam1); - StaticTeam1BG := AddStatic (Theme.PartyWin.StaticTeam1BG); - StaticTeam1Deco := AddStatic (Theme.PartyWin.StaticTeam1Deco); - StaticTeam2 := AddStatic (Theme.PartyWin.StaticTeam2); - StaticTeam2BG := AddStatic (Theme.PartyWin.StaticTeam2BG); - StaticTeam2Deco := AddStatic (Theme.PartyWin.StaticTeam2Deco); - StaticTeam3 := AddStatic (Theme.PartyWin.StaticTeam3); - StaticTeam3BG := AddStatic (Theme.PartyWin.StaticTeam3BG); - StaticTeam3Deco := AddStatic (Theme.PartyWin.StaticTeam3Deco); - - TextWinner := AddText (Theme.PartyWin.TextWinner); - - LoadFromTheme(Theme.PartyWin); -end; - -procedure TScreenPartyWin.OnShow; -var - I: integer; - Placing: TeamOrderArray; - - Function GetTeamColor(Team: byte): cardinal; - var - NameString: string; - begin - NameString := 'P' + InttoStr(Team+1) + 'Dark'; - - Result := ColorExists(NameString); - end; - -begin - inherited; - - //Get Team Placing - Placing := PartySession.GetTeamOrder; - - //Set Winnertext - Text[TextWinner].Text := Format(Language.Translate('PARTY_SCORE_WINS'), [PartySession.Teams.Teaminfo[Placing[0]].Name]); - if (PartySession.Teams.NumTeams >= 1) then - begin - Text[TextScoreTeam1].Text := InttoStr(PartySession.Teams.TeamInfo[Placing[0]].Score); - Text[TextNameTeam1].Text := string(PartySession.Teams.TeamInfo[Placing[0]].Name); - - Text[TextScoreTeam1].Visible := true; - Text[TextNameTeam1].Visible := true; - Static[StaticTeam1].Visible := true; - Static[StaticTeam1BG].Visible := true; - Static[StaticTeam1Deco].Visible := true; - - //Set Static Color to Team Color - if (Theme.PartyWin.StaticTeam1BG.Color = 'TeamColor') then - begin - I := GetTeamColor(Placing[0]); - if (I <> -1) then - begin - Static[StaticTeam1BG].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam1BG].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam1BG].Texture.ColB := Color[I].RGB.B; - end; - end; - - if (Theme.PartyWin.StaticTeam1.Color = 'TeamColor') then - begin - I := GetTeamColor(Placing[0]); - if (I <> -1) then - begin - Static[StaticTeam1].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam1].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam1].Texture.ColB := Color[I].RGB.B; - end; - end; - end - else - begin - Text[TextScoreTeam1].Visible := false; - Text[TextNameTeam1].Visible := false; - Static[StaticTeam1].Visible := false; - Static[StaticTeam1BG].Visible := false; - Static[StaticTeam1Deco].Visible := false; - end; - - if (PartySession.Teams.NumTeams >= 2) then - begin - Text[TextScoreTeam2].Text := InttoStr(PartySession.Teams.TeamInfo[Placing[1]].Score); - Text[TextNameTeam2].Text := string(PartySession.Teams.TeamInfo[Placing[1]].Name); - - Text[TextScoreTeam2].Visible := true; - Text[TextNameTeam2].Visible := true; - Static[StaticTeam2].Visible := true; - Static[StaticTeam2BG].Visible := true; - Static[StaticTeam2Deco].Visible := true; - - //Set Static Color to Team Color - if (Theme.PartyWin.StaticTeam2BG.Color = 'TeamColor') then - begin - I := GetTeamColor(Placing[1]); - if (I <> -1) then - begin - Static[StaticTeam2BG].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam2BG].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam2BG].Texture.ColB := Color[I].RGB.B; - end; - end; - - if (Theme.PartyWin.StaticTeam2.Color = 'TeamColor') then - begin - I := GetTeamColor(Placing[1]); - if (I <> -1) then - begin - Static[StaticTeam2].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam2].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam2].Texture.ColB := Color[I].RGB.B; - end; - end; - end - else - begin - Text[TextScoreTeam2].Visible := false; - Text[TextNameTeam2].Visible := false; - Static[StaticTeam2].Visible := false; - Static[StaticTeam2BG].Visible := false; - Static[StaticTeam2Deco].Visible := false; - end; - - if (PartySession.Teams.NumTeams >= 3) then - begin - Text[TextScoreTeam3].Text := InttoStr(PartySession.Teams.TeamInfo[Placing[2]].Score); - Text[TextNameTeam3].Text := string(PartySession.Teams.TeamInfo[Placing[2]].Name); - - Text[TextScoreTeam3].Visible := true; - Text[TextNameTeam3].Visible := true; - Static[StaticTeam3].Visible := true; - Static[StaticTeam3BG].Visible := true; - Static[StaticTeam3Deco].Visible := true; - - //Set Static Color to Team Color - if (Theme.PartyWin.StaticTeam3BG.Color = 'TeamColor') then - begin - I := GetTeamColor(Placing[2]); - if (I <> -1) then - begin - Static[StaticTeam3BG].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam3BG].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam3BG].Texture.ColB := Color[I].RGB.B; - end; - end; - - if (Theme.PartyWin.StaticTeam3.Color = 'TeamColor') then - begin - I := GetTeamColor(Placing[2]); - if (I <> -1) then - begin - Static[StaticTeam3].Texture.ColR := Color[I].RGB.R; - Static[StaticTeam3].Texture.ColG := Color[I].RGB.G; - Static[StaticTeam3].Texture.ColB := Color[I].RGB.B; - end; - end; - end - else - begin - Text[TextScoreTeam3].Visible := false; - Text[TextNameTeam3].Visible := false; - Static[StaticTeam3].Visible := false; - Static[StaticTeam3BG].Visible := false; - Static[StaticTeam3Deco].Visible := false; - end; -end; - -procedure TScreenPartyWin.SetAnimationProgress(Progress: real); -begin - {if (ScreenSingModi.PlayerInfo.NumPlayers >= 1) then - Static[StaticTeam1].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[0].Score / maxScore; - if (ScreenSingModi.PlayerInfo.NumPlayers >= 2) then - Static[StaticTeam2].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[1].Score / maxScore; - if (ScreenSingModi.PlayerInfo.NumPlayers >= 3) then - Static[StaticTeam3].Texture.ScaleW := Progress * ScreenSingModi.PlayerInfo.Playerinfo[2].Score / maxScore;} -end; - -end. diff --git a/src/screens/UScreenPopup.pas b/src/screens/UScreenPopup.pas deleted file mode 100644 index fdf4a69c..00000000 --- a/src/screens/UScreenPopup.pas +++ /dev/null @@ -1,308 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenPopup; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SysUtils, - UMenu, - UMusic, - UFiles, - UThemes; - -type - TPopupCheckHandler = procedure(Value: boolean; Data: Pointer); - - TScreenPopupCheck = class(TMenu) - private - fHandler: TPopupCheckHandler; - fHandlerData: Pointer; - - public - Visible: boolean; // whether the menu should be drawn - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure ShowPopup(const Msg: UTF8String; Handler: TPopupCheckHandler; - HandlerData: Pointer; DefaultValue: boolean = false); - function Draw: boolean; override; - end; - -type - TScreenPopup = class(TMenu) - { - private - CurMenu: byte; //Num of the cur. Shown Menu - } - public - Visible: boolean; //Whether the Menu should be Drawn - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure OnHide; override; - procedure ShowPopup(const Msg: UTF8String); - function Draw: boolean; override; - end; - - TScreenPopupError = class(TScreenPopup) - public - constructor Create; - end; - - TScreenPopupInfo = class(TScreenPopup) - public - constructor Create; - end; - -var - //ISelections: array of string; - SelectValue: integer; - -implementation - -uses - UGraphic, - UMain, - UIni, - UTexture, - ULanguage, - UParty, - UPlaylist, - UDisplay, - UUnicodeUtils; - -{ TScreenPopupCheck } - -function TScreenPopupCheck.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - Value: boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Value := false; - Visible := false; - Result := false; - end; - - SDLK_RETURN: - begin - Value := (Interaction = 0); - Visible := false; - Result := false; - end; - - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end; - - if (not Result) then - begin - if (@fHandler <> nil) then - fHandler(Value, fHandlerData); - end; -end; - -constructor TScreenPopupCheck.Create; -begin - inherited Create; - - fHandler := nil; - fHandlerData := nil; - - AddText(Theme.CheckPopup.TextCheck); - - LoadFromTheme(Theme.CheckPopup); - - AddButton(Theme.CheckPopup.Button1); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, 'Button 1'); - - AddButton(Theme.CheckPopup.Button2); - if (Length(Button[1].Text) = 0) then - AddButtonText(14, 20, 'Button 2'); - - Interaction := 0; -end; - -function TScreenPopupCheck.Draw: boolean; -begin - Result := inherited Draw; -end; - -procedure TScreenPopupCheck.OnShow; -begin - inherited; -end; - -procedure TScreenPopupCheck.ShowPopup(const Msg: UTF8String; Handler: TPopupCheckHandler; - HandlerData: Pointer; DefaultValue: boolean); -begin - if (DefaultValue) then - Interaction := 0 - else - Interaction := 1; - Visible := true; //Set Visible - fHandler := Handler; - fHandlerData := HandlerData; - - Text[0].Text := Language.Translate(msg); - - Button[0].Visible := true; - Button[1].Visible := true; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_YES'); - Button[1].Text[0].Text := Language.Translate('SONG_MENU_NO'); - - Background.OnShow -end; - -{ TScreenPopup } - -function TScreenPopup.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - - case PressedKey of - SDLK_Q: - begin - Result := false; - end; - - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Visible := false; - Result := false; - end; - - SDLK_RETURN: - begin - Visible := false; - Result := false; - end; - - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - - SDLK_RIGHT: InteractNext; - SDLK_LEFT: InteractPrev; - end; - end; -end; - -constructor TScreenPopup.Create; -begin - inherited Create; - - AddText(Theme.ErrorPopup.TextError); - - LoadFromTheme(Theme.ErrorPopup); - - AddButton(Theme.ErrorPopup.Button1); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, 'Button 1'); - - Interaction := 0; -end; - -function TScreenPopup.Draw: boolean; -begin - Draw := inherited Draw; -end; - -procedure TScreenPopup.OnShow; -begin - inherited; - -end; - -procedure TScreenPopup.OnHide; -begin -end; - -procedure TScreenPopup.ShowPopup(const Msg: UTF8String); -begin - Interaction := 0; //Reset Interaction - Visible := true; //Set Visible - Background.OnShow; - -{ //dirty hack... Text[0] is invisible for some strange reason - for i:=1 to high(Text) do - if i-1 <= high(msg) then - begin - Text[i].Visible := true; - Text[i].Text := msg[i-1]; - end - else - begin - Text[i].Visible := false; - end;} - Text[0].Text := msg; - - Button[0].Visible := true; - - Button[0].Text[0].Text := 'OK'; -end; - -{ TScreenPopupError } - -constructor TScreenPopupError.Create; -begin - inherited; - Text[1].Text := Language.Translate('MSG_ERROR_TITLE'); -end; - -{ TScreenPopupInfo } - -constructor TScreenPopupInfo.Create; -begin - inherited; - Text[1].Text := Language.Translate('MSG_INFO_TITLE'); -end; - -end. diff --git a/src/screens/UScreenScore.pas b/src/screens/UScreenScore.pas deleted file mode 100644 index ce1b11e5..00000000 --- a/src/screens/UScreenScore.pas +++ /dev/null @@ -1,924 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenScore; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - SysUtils, - UDisplay, - UMusic, - USongs, - UThemes, - gl, - math, - UTexture; - -const - ZBars: real = 0.8; // Z value for the bars - ZRatingPic: real = 0.8; // Z value for the rating pictures - - EaseOut_MaxSteps: real = 10; // that's the speed of the bars (10 is fast | 100 is slower) - - BarRaiseSpeed: cardinal = 0; // Time for raising the bar one step higher (in ms) - -type - TPlayerScoreScreenTexture = record // holds all colorized textures for up to 6 players - //Bar textures - Score_NoteBarLevel_Dark: TTexture; // Note - Score_NoteBarRound_Dark: TTexture; // that's the round thing on top - - Score_NoteBarLevel_Light: TTexture; // LineBonus | Phrasebonus - Score_NoteBarRound_Light: TTexture; - - Score_NoteBarLevel_Lightest: TTexture; // GoldenNotes - Score_NoteBarRound_Lightest: TTexture; - end; - - TPlayerScoreScreenData = record // holds the positions and other data - Bar_Y: real; - Bar_Actual_Height: real; // this one holds the actual height of the bar, while we animate it - BarScore_ActualHeight: real; - BarLine_ActualHeight: real; - BarGolden_ActualHeight: real; - end; - - TPlayerScoreRatingPics = record // a fine array of the rating pictures - RateEaseStep: integer; - RateEaseValue: real; - end; - - TScreenScore = class(TMenu) - private - BarTime: cardinal; - ArrayStartModifier: integer; - public - aPlayerScoreScreenTextures: array[1..6] of TPlayerScoreScreenTexture; - aPlayerScoreScreenDatas: array[1..6] of TPlayerScoreScreenData; - aPlayerScoreScreenRatings: array[1..6] of TPlayerScoreRatingPics; - - BarScore_EaseOut_Step: real; - BarPhrase_EaseOut_Step: real; - BarGolden_EaseOut_Step: real; - - TextArtist: integer; - TextTitle: integer; - - TextArtistTitle: integer; - - TextName: array[1..6] of integer; - TextScore: array[1..6] of integer; - - TextNotes: array[1..6] of integer; - TextNotesScore: array[1..6] of integer; - TextLineBonus: array[1..6] of integer; - TextLineBonusScore: array[1..6] of integer; - TextGoldenNotes: array[1..6] of integer; - TextGoldenNotesScore: array[1..6] of integer; - TextTotal: array[1..6] of integer; - TextTotalScore: array[1..6] of integer; - - PlayerStatic: array[1..6] of array of integer; - PlayerTexts: array[1..6] of array of integer; - - StaticBoxLightest: array[1..6] of integer; - StaticBoxLight: array[1..6] of integer; - StaticBoxDark: array[1..6] of integer; - - StaticBackLevel: array[1..6] of integer; - StaticBackLevelRound: array[1..6] of integer; - StaticLevel: array[1..6] of integer; - StaticLevelRound: array[1..6] of integer; - - Animation: real; - - TextScore_ActualValue: array[1..6] of integer; - TextPhrase_ActualValue: array[1..6] of integer; - TextGolden_ActualValue: array[1..6] of integer; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function ParseMouse(MouseButton: Integer; BtnDown: Boolean; X, Y: integer): boolean; override; - procedure OnShow; override; - procedure OnShowFinish; override; - function Draw: boolean; override; - procedure FillPlayer(Item, P: integer); - - procedure EaseBarIn(PlayerNumber: integer; BarType: string); - procedure EaseScoreIn(PlayerNumber: integer; ScoreType: string); - - procedure FillPlayerItems(PlayerNumber: integer; ScoreType: string); - - procedure DrawBar(BarType: string; PlayerNumber: integer; BarStartPosY: single; NewHeight: real); - - //Rating Picture - procedure ShowRating(PlayerNumber: integer); - function CalculateBouncing(PlayerNumber: integer): real; - procedure DrawRating(PlayerNumber: integer; Rating: integer); - end; - -implementation - -uses - UGraphic, - UScreenSong, - UMenuStatic, - UTime, - UIni, - ULog, - ULanguage, - UNote, - UUnicodeUtils; - - -function TScreenScore.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE, - SDLK_RETURN: - begin - FadeTo(@ScreenTop5); - Exit; - end; - - SDLK_SYSREQ: - begin - Display.SaveScreenShot; - end; - end; - end; -end; - -function TScreenScore.ParseMouse(MouseButton: Integer; BtnDown: Boolean; X, Y: integer): boolean; -begin - Result := True; - if (MouseButton = SDL_BUTTON_LEFT) and BtnDown then begin - //left-click anywhere sends return - ParseInput(SDLK_RETURN, 0, true); - end; -end; - -constructor TScreenScore.Create; -var - Player: integer; - Counter: integer; -begin - inherited Create; - - LoadFromTheme(Theme.Score); - - // These two texts arn't used in the deluxe skin - TextArtist := AddText(Theme.Score.TextArtist); - TextTitle := AddText(Theme.Score.TextTitle); - - TextArtistTitle := AddText(Theme.Score.TextArtistTitle); - - for Player := 1 to 6 do - begin - SetLength(PlayerStatic[Player], Length(Theme.Score.PlayerStatic[Player])); - SetLength(PlayerTexts[Player], Length(Theme.Score.PlayerTexts[Player])); - - for Counter := 0 to High(Theme.Score.PlayerStatic[Player]) do - PlayerStatic[Player, Counter] := AddStatic(Theme.Score.PlayerStatic[Player, Counter]); - - for Counter := 0 to High(Theme.Score.PlayerTexts[Player]) do - PlayerTexts[Player, Counter] := AddText(Theme.Score.PlayerTexts[Player, Counter]); - - TextName[Player] := AddText(Theme.Score.TextName[Player]); - TextScore[Player] := AddText(Theme.Score.TextScore[Player]); - - TextNotes[Player] := AddText(Theme.Score.TextNotes[Player]); - TextNotesScore[Player] := AddText(Theme.Score.TextNotesScore[Player]); - TextLineBonus[Player] := AddText(Theme.Score.TextLineBonus[Player]); - TextLineBonusScore[Player] := AddText(Theme.Score.TextLineBonusScore[Player]); - TextGoldenNotes[Player] := AddText(Theme.Score.TextGoldenNotes[Player]); - TextGoldenNotesScore[Player] := AddText(Theme.Score.TextGoldenNotesScore[Player]); - TextTotal[Player] := AddText(Theme.Score.TextTotal[Player]); - TextTotalScore[Player] := AddText(Theme.Score.TextTotalScore[Player]); - - StaticBoxLightest[Player] := AddStatic(Theme.Score.StaticBoxLightest[Player]); - StaticBoxLight[Player] := AddStatic(Theme.Score.StaticBoxLight[Player]); - StaticBoxDark[Player] := AddStatic(Theme.Score.StaticBoxDark[Player]); - - StaticBackLevel[Player] := AddStatic(Theme.Score.StaticBackLevel[Player]); - StaticBackLevelRound[Player] := AddStatic(Theme.Score.StaticBackLevelRound[Player]); - StaticLevel[Player] := AddStatic(Theme.Score.StaticLevel[Player]); - StaticLevelRound[Player] := AddStatic(Theme.Score.StaticLevelRound[Player]); - - //textures - aPlayerScoreScreenTextures[Player].Score_NoteBarLevel_Dark := Tex_Score_NoteBarLevel_Dark[Player]; - aPlayerScoreScreenTextures[Player].Score_NoteBarRound_Dark := Tex_Score_NoteBarRound_Dark[Player]; - - aPlayerScoreScreenTextures[Player].Score_NoteBarLevel_Light := Tex_Score_NoteBarLevel_Light[Player]; - aPlayerScoreScreenTextures[Player].Score_NoteBarRound_Light := Tex_Score_NoteBarRound_Light[Player]; - - aPlayerScoreScreenTextures[Player].Score_NoteBarLevel_Lightest := Tex_Score_NoteBarLevel_Lightest[Player]; - aPlayerScoreScreenTextures[Player].Score_NoteBarRound_Lightest := Tex_Score_NoteBarRound_Lightest[Player]; - end; - -end; - -procedure TScreenScore.OnShow; -var - P: integer; // player - I: integer; - V: array[1..6] of boolean; // visibility array - -begin - -{** - * Turn backgroundmusic on - *} - SoundLib.StartBgMusic; - - inherited; - - // all statics / texts are loaded at start - so that we have them all even if we change the amount of players - // To show the corrects statics / text from the them, we simply modify the start of the according arrays - // 1 Player -> Player[0].Score (The score for one player starts at 0) - // -> Statics[1] (The statics for the one player screen start at 1) - // 2 Player -> Player[0..1].Score - // -> Statics[2..3] - // 3 Player -> Player[0..5].Score - // -> Statics[4..6] - case PlayersPlay of - 1: ArrayStartModifier := 0; - 2, 4: ArrayStartModifier := 1; - 3, 6: ArrayStartModifier := 3; - else - ArrayStartModifier := 0; //this should never happen - end; - - for P := 1 to PlayersPlay do - begin - // data - aPlayerScoreScreenDatas[P].Bar_Y := Theme.Score.StaticBackLevel[P + ArrayStartModifier].Y; - - // ratings - aPlayerScoreScreenRatings[P].RateEaseStep := 1; - aPlayerScoreScreenRatings[P].RateEaseValue := 20; - end; - - Text[TextArtist].Text := CurrentSong.Artist; - Text[TextTitle].Text := CurrentSong.Title; - Text[TextArtistTitle].Text := CurrentSong.Artist + ' - ' + CurrentSong.Title; - - // set visibility - case PlayersPlay of - 1: begin - V[1] := true; - V[2] := false; - V[3] := false; - V[4] := false; - V[5] := false; - V[6] := false; - end; - 2, 4: begin - V[1] := false; - V[2] := true; - V[3] := true; - V[4] := false; - V[5] := false; - V[6] := false; - end; - 3, 6: begin - V[1] := false; - V[2] := false; - V[3] := false; - V[4] := true; - V[5] := true; - V[6] := true; - end; - end; - - for P := 1 to 6 do - begin - Text[TextName[P]].Visible := V[P]; - Text[TextScore[P]].Visible := V[P]; - - // We set alpha to 0 , so we can nicely blend them in when we need them - Text[TextScore[P]].Alpha := 0; - Text[TextNotesScore[P]].Alpha := 0; - Text[TextNotes[P]].Alpha := 0; - Text[TextLineBonus[P]].Alpha := 0; - Text[TextLineBonusScore[P]].Alpha := 0; - Text[TextGoldenNotes[P]].Alpha := 0; - Text[TextGoldenNotesScore[P]].Alpha := 0; - Text[TextTotal[P]].Alpha := 0; - Text[TextTotalScore[P]].Alpha := 0; - Static[StaticBoxLightest[P]].Texture.Alpha := 0; - Static[StaticBoxLight[P]].Texture.Alpha := 0; - Static[StaticBoxDark[P]].Texture.Alpha := 0; - - Text[TextNotes[P]].Visible := V[P]; - Text[TextNotesScore[P]].Visible := V[P]; - Text[TextLineBonus[P]].Visible := V[P]; - Text[TextLineBonusScore[P]].Visible := V[P]; - Text[TextGoldenNotes[P]].Visible := V[P]; - Text[TextGoldenNotesScore[P]].Visible := V[P]; - Text[TextTotal[P]].Visible := V[P]; - Text[TextTotalScore[P]].Visible := V[P]; - - for I := 0 to high(PlayerStatic[P]) do - Static[PlayerStatic[P, I]].Visible := V[P]; - - for I := 0 to high(PlayerTexts[P]) do - Text[PlayerTexts[P, I]].Visible := V[P]; - - Static[StaticBoxLightest[P]].Visible := V[P]; - Static[StaticBoxLight[P]].Visible := V[P]; - Static[StaticBoxDark[P]].Visible := V[P]; - - // we draw that on our own - Static[StaticBackLevel[P]].Visible := false; - Static[StaticBackLevelRound[P]].Visible := false; - Static[StaticLevel[P]].Visible := false; - Static[StaticLevelRound[P]].Visible := false; - end; -end; - -procedure TScreenScore.onShowFinish; -var - index: integer; -begin - for index := 1 to (PlayersPlay) do - begin - TextScore_ActualValue[index] := 0; - TextPhrase_ActualValue[index] := 0; - TextGolden_ActualValue[index] := 0; - end; - - BarScore_EaseOut_Step := 1; - BarPhrase_EaseOut_Step := 1; - BarGolden_EaseOut_Step := 1; -end; - -function TScreenScore.Draw: boolean; -var - CurrentTime: cardinal; - PlayerCounter: integer; - PStart: integer; - PHigh: integer; -begin -{* - player[0].ScoreInt := 7000; - player[0].ScoreLineInt := 2000; - player[0].ScoreGoldenInt := 1000; - player[0].ScoreTotalInt := 10000; - - player[1].ScoreInt := 2500; - player[1].ScoreLineInt := 1100; - player[1].ScoreGoldenInt := 900; - player[1].ScoreTotalInt := 4500; -*} - - //Draw the Background - DrawBG; - - //Calculate first and last Player on this Screen - if (PlayersPlay > 3) then - begin - case PlayersPlay of - 4: begin - PStart := 1 + ((ScreenAct-1) * 2); - PHigh := 2 + ((ScreenAct-1) * 2); - end; - - 6: begin - PStart := 1 + ((ScreenAct-1) * 3); - PHigh := 3 + ((ScreenAct-1) * 3); - end; - end; - end - else - begin - PStart := 1; - PHigh := PlayersPlay; - end; - - // Let's start to arise the bars - CurrentTime := SDL_GetTicks(); - if((CurrentTime >= BarTime) and ShowFinish) then - begin - BarTime := CurrentTime + BarRaiseSpeed; - - for PlayerCounter := PStart to PHigh do - begin - // We actually arise them in the right order, but we have to draw them in reverse order (golden -> phrase -> mainscore) - if (BarScore_EaseOut_Step < EaseOut_MaxSteps * 10) then - BarScore_EaseOut_Step:= BarScore_EaseOut_Step + 1; - - // PhrasenBonus - if (BarScore_EaseOut_Step >= (EaseOut_MaxSteps * 10)) then - begin - if (BarPhrase_EaseOut_Step < EaseOut_MaxSteps * 10) then - BarPhrase_EaseOut_Step := BarPhrase_EaseOut_Step + 1; - - // GoldenNotebonus - if (BarPhrase_EaseOut_Step >= (EaseOut_MaxSteps * 10)) then - begin - if (BarGolden_EaseOut_Step < EaseOut_MaxSteps * 10) then - BarGolden_EaseOut_Step := BarGolden_EaseOut_Step + 1; - - // Draw golden score bar # - EaseBarIn(PlayerCounter, 'Golden'); - EaseScoreIn(PlayerCounter,'Golden'); - end; - - // Draw phrase score bar # - EaseBarIn(PlayerCounter, 'Line'); - EaseScoreIn(PlayerCounter,'Line'); - end; - - // Draw plain score bar # - EaseBarIn(PlayerCounter, 'Note'); - EaseScoreIn(PlayerCounter,'Note'); - - if (PlayersPlay <= 3) then - //If we play w/ 3 or less players they fit in one screen - //so we don't have to swap the values of themeobjects - //on every draw - FillPlayerItems(PlayerCounter,'Funky'); - - end; - end; - - if (PlayersPlay > 3) then - //more then 3 players don't fit the screen - //so we have to swap the themeobjects values on every draw - for PlayerCounter := PStart to PHigh do - begin - FillPlayerItems(PlayerCounter,'Funky'); - end; - - //Draw Theme Objects - DrawFG; - -(* - //todo: i need a clever method to draw statics with their z value - for I := 0 to Length(Static) - 1 do - Static[I].Draw; - for I := 0 to Length(Text) - 1 do - Text[I].Draw; -*) - - Result := true; -end; - -procedure TscreenScore.FillPlayerItems(PlayerNumber: integer; ScoreType: string); -var - ThemeIndex: integer; -begin - // todo: take the name from player[PlayerNumber].Name instead of the ini when this is done (mog) - Text[TextName[PlayerNumber + ArrayStartModifier]].Text := Ini.Name[PlayerNumber - 1]; - // end todo - - // We have to do this here because we use the same Theme Object - // for players on the first and second screen - case PlayersPlay of - 1, 2, 3: ThemeIndex := PlayerNumber + ArrayStartModifier; - 4: ThemeIndex := ((PlayerNumber-1) mod 2) + 1 + ArrayStartModifier; - 6: ThemeIndex := ((PlayerNumber-1) mod 3) + 1 + ArrayStartModifier; - end; - - //golden - Text[TextGoldenNotesScore[ThemeIndex]].Text := IntToStr(TextGolden_ActualValue[PlayerNumber]); - Text[TextGoldenNotesScore[ThemeIndex]].Alpha := (BarGolden_EaseOut_Step / 100); - - Static[StaticBoxLightest[ThemeIndex]].Texture.Alpha := (BarGolden_EaseOut_Step / 100); - Text[TextGoldenNotes[ThemeIndex]].Alpha := (BarGolden_EaseOut_Step / 100); - - // line bonus - Text[TextLineBonusScore[ThemeIndex]].Text := IntToStr(TextPhrase_ActualValue[PlayerNumber]); - Text[TextLineBonusScore[ThemeIndex]].Alpha := (BarPhrase_EaseOut_Step / 100); - - Static[StaticBoxLight[ThemeIndex]].Texture.Alpha := (BarPhrase_EaseOut_Step / 100); - Text[TextLineBonus[ThemeIndex]].Alpha := (BarPhrase_EaseOut_Step / 100); - - // plain score - Text[TextNotesScore[ThemeIndex]].Text := IntToStr(TextScore_ActualValue[PlayerNumber]); - Text[TextNotes[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - - Static[StaticBoxDark[ThemeIndex]].Texture.Alpha := (BarScore_EaseOut_Step / 100); - Text[TextNotesScore[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - - // total score - Text[TextTotalScore[ThemeIndex]].Text := IntToStr(TextScore_ActualValue[PlayerNumber] + TextPhrase_ActualValue[PlayerNumber] + TextGolden_ActualValue[PlayerNumber]); - Text[TextTotalScore[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - - Text[TextTotal[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - - Text[TextTotal[ThemeIndex]].Alpha := (BarScore_EaseOut_Step / 100); - - if(BarGolden_EaseOut_Step = 100) then - begin - ShowRating(PlayerNumber); - end; -end; - -procedure TScreenScore.ShowRating(PlayerNumber: integer); -var - Rating: integer; - ThemeIndex: integer; -begin - - // We have to do this here because we use the same Theme Object - // for players on the first and second screen - case PlayersPlay of - 1, 2, 3: ThemeIndex := PlayerNumber + ArrayStartModifier; - 4: ThemeIndex := ((PlayerNumber-1) mod 2) + 1 + ArrayStartModifier; - 6: ThemeIndex := ((PlayerNumber-1) mod 3) + 1 + ArrayStartModifier; - end; - - case (Player[PlayerNumber-1].ScoreTotalInt) of - 0..2009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_TONE_DEAF'); - Rating := 0; - end; - 2010..4009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_AMATEUR'); - Rating := 1; - end; - 4010..5009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_WANNABE'); - Rating := 2; - end; - 5010..6009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_HOPEFUL'); - Rating := 3; - end; - 6010..7509: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_RISING_STAR'); - Rating := 4; - end; - 7510..8509: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_LEAD_SINGER'); - Rating := 5; - end; - 8510..9009: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_SUPERSTAR'); - Rating := 6; - end; - 9010..10000: - begin - Text[TextScore[ThemeIndex]].Text := Language.Translate('SING_SCORE_ULTRASTAR'); - Rating := 7; - end; - else - Rating := 0; // Cheata :P - end; - - //todo: this could break if the width is not given, for instance when there's a skin with no picture for ratings - if ( Theme.Score.StaticRatings[ThemeIndex].W > 0 ) and ( aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue > 0 ) then - begin - Text[TextScore[ThemeIndex]].Alpha := aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue / Theme.Score.StaticRatings[ThemeIndex].W; - end; - // end todo - - DrawRating(PlayerNumber, Rating); -end; - -procedure TscreenScore.DrawRating(PlayerNumber: integer; Rating: integer); -var - Posx: real; - Posy: real; - Width: real; -begin - - CalculateBouncing(PlayerNumber); - - PosX := Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].X + (Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].W * 0.5); - PosY := Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].Y + (Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].H * 0.5); ; - - Width := aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue/2; - - glBindTexture(GL_TEXTURE_2D, Tex_Score_Ratings[Rating].TexNum); - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex2f(PosX - Width, PosY - Width); - glTexCoord2f(Tex_Score_Ratings[Rating].TexW, 0); glVertex2f(PosX + Width, PosY - Width); - glTexCoord2f(Tex_Score_Ratings[Rating].TexW, Tex_Score_Ratings[Rating].TexH); glVertex2f(PosX + Width, PosY + Width); - glTexCoord2f(0, Tex_Score_Ratings[Rating].TexH); glVertex2f(PosX - Width, PosY + Width); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2d); -end; - -function TscreenScore.CalculateBouncing(PlayerNumber: integer): real; -var - ReturnValue: real; - p, s: real; - - RaiseStep, MaxVal: real; - EaseOut_Step: integer; -begin - EaseOut_Step := aPlayerScoreScreenRatings[PlayerNumber].RateEaseStep; - MaxVal := Theme.Score.StaticRatings[PlayerNumber + ArrayStartModifier].W; - - RaiseStep := EaseOut_Step; - - if (MaxVal > 0) and (RaiseStep > 0) then - RaiseStep := RaiseStep / MaxVal; - - if (RaiseStep = 1) then - begin - ReturnValue := MaxVal; - end - else - begin - p := MaxVal * 0.4; - - s := p/(2*PI) * arcsin (1); - ReturnValue := MaxVal * power(2,-5 * RaiseStep) * sin( (RaiseStep * MaxVal - s) * (2 * PI) / p) + MaxVal; - - inc(aPlayerScoreScreenRatings[PlayerNumber].RateEaseStep); - aPlayerScoreScreenRatings[PlayerNumber].RateEaseValue := ReturnValue; - end; - - Result := ReturnValue; -end; - -procedure TscreenScore.EaseBarIn(PlayerNumber: integer; BarType: string); -const - RaiseSmoothness: integer = 100; -var - MaxHeight: real; - NewHeight: real; - - Height2Reach: real; - RaiseStep: real; - BarStartPosY: single; - - lTmp: real; - Score: integer; -begin - MaxHeight := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].H; - - // let's get the points according to the bar we draw - // score array starts at 0, which means the score for player 1 is in score[0] - // EaseOut_Step is the actual step in the raising process, like the 20iest step of EaseOut_MaxSteps - if (BarType = 'Note') then - begin - Score := Player[PlayerNumber - 1].ScoreInt; - RaiseStep := BarScore_EaseOut_Step; - BarStartPosY := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].Y + MaxHeight; - end - else if (BarType = 'Line') then - begin - Score := Player[PlayerNumber - 1].ScoreLineInt; - RaiseStep := BarPhrase_EaseOut_Step; - BarStartPosY := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].Y - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight + MaxHeight; - end - else if (BarType = 'Golden') then - begin - Score := Player[PlayerNumber - 1].ScoreGoldenInt; - RaiseStep := BarGolden_EaseOut_Step; - BarStartPosY := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].Y - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight - aPlayerScoreScreenDatas[PlayerNumber].BarLine_ActualHeight + MaxHeight; - end - else - begin - Log.LogCritical('Unknown bar-type: ' + BarType, 'TScreenScore.EaseBarIn'); - Exit; // suppress warnings - end; - - // the height dependend of the score - Height2Reach := (Score / MAX_SONG_SCORE) * MaxHeight; - - if (aPlayerScoreScreenDatas[PlayerNumber].Bar_Actual_Height < Height2Reach) then - begin - // Check http://proto.layer51.com/d.aspx?f=400 for more info on easing functions - // Calculate the actual step according to the maxsteps - RaiseStep := RaiseStep / EaseOut_MaxSteps; - - // quadratic easing out - decelerating to zero velocity - // -end_position * current_time * ( current_time - 2 ) + start_postion - lTmp := (-Height2Reach * RaiseStep * (RaiseStep - 20) + BarStartPosY); - - if ( RaiseSmoothness > 0 ) and ( lTmp > 0 ) then - NewHeight := lTmp / RaiseSmoothness; - - end - else - NewHeight := Height2Reach; - - DrawBar(BarType, PlayerNumber, BarStartPosY, NewHeight); - - if (BarType = 'Note') then - aPlayerScoreScreenDatas[PlayerNumber].BarScore_ActualHeight := NewHeight - else if (BarType = 'Line') then - aPlayerScoreScreenDatas[PlayerNumber].BarLine_ActualHeight := NewHeight - else if (BarType = 'Golden') then - aPlayerScoreScreenDatas[PlayerNumber].BarGolden_ActualHeight := NewHeight; -end; - -procedure TscreenScore.DrawBar(BarType: string; PlayerNumber: integer; BarStartPosY: single; NewHeight: real); -var - Width: real; - BarStartPosX: real; -begin - // this is solely for better readability of the drawing - Width := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].W; - BarStartPosX := Theme.Score.StaticBackLevel[PlayerNumber + ArrayStartModifier].X; - - glColor4f(1, 1, 1, 1); - - // set the texture for the bar - if (BarType = 'Note') then - glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarLevel_Dark.TexNum); - if (BarType = 'Line') then - glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarLevel_Light.TexNum); - if (BarType = 'Golden') then - glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarLevel_Lightest.TexNum); - - //draw it - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex3f(BarStartPosX, BarStartPosY - NewHeight, ZBars); - glTexCoord2f(1, 0); glVertex3f(BarStartPosX + Width, BarStartPosY - NewHeight, ZBars); - glTexCoord2f(1, 1); glVertex3f(BarStartPosX + Width, BarStartPosY, ZBars); - glTexCoord2f(0, 1); glVertex3f(BarStartPosX, BarStartPosY, ZBars); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2d); - - //the round thing on top - if (BarType = 'Note') then - glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarRound_Dark.TexNum); - if (BarType = 'Line') then - glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarRound_Light.TexNum); - if (BarType = 'Golden') then - glBindTexture(GL_TEXTURE_2D, aPlayerScoreScreenTextures[PlayerNumber].Score_NoteBarRound_Lightest.TexNum); - - glEnable(GL_TEXTURE_2D); - glBlendFunc(GL_SRC_ALPHA, GL_ONE_MINUS_SRC_ALPHA); - glEnable(GL_BLEND); - - glBegin(GL_QUADS); - glTexCoord2f(0, 0); glVertex3f(BarStartPosX, (BarStartPosY - Static[StaticLevelRound[PlayerNumber + ArrayStartModifier]].Texture.h) - NewHeight, ZBars); - glTexCoord2f(1, 0); glVertex3f(BarStartPosX + Width, (BarStartPosY - Static[StaticLevelRound[PlayerNumber + ArrayStartModifier]].Texture.h) - NewHeight, ZBars); - glTexCoord2f(1, 1); glVertex3f(BarStartPosX + Width, BarStartPosY - NewHeight, ZBars); - glTexCoord2f(0, 1); glVertex3f(BarStartPosX, BarStartPosY - NewHeight, ZBars); - glEnd; - - glDisable(GL_BLEND); - glDisable(GL_TEXTURE_2d); -end; - -procedure TScreenScore.EaseScoreIn(PlayerNumber: integer; ScoreType: string); -const - RaiseSmoothness: integer = 100; -var - RaiseStep: real; - lTmpA: real; - ScoreReached: integer; - EaseOut_Step: real; - ActualScoreValue: integer; -begin - if (ScoreType = 'Note') then - begin - EaseOut_Step := BarScore_EaseOut_Step; - ActualScoreValue := TextScore_ActualValue[PlayerNumber]; - ScoreReached := Player[PlayerNumber-1].ScoreInt; - end; - if (ScoreType = 'Line') then - begin - EaseOut_Step := BarPhrase_EaseOut_Step; - ActualScoreValue := TextPhrase_ActualValue[PlayerNumber]; - ScoreReached := Player[PlayerNumber-1].ScoreLineInt; - end; - if (ScoreType = 'Golden') then - begin - EaseOut_Step := BarGolden_EaseOut_Step; - ActualScoreValue := TextGolden_ActualValue[PlayerNumber]; - ScoreReached := Player[PlayerNumber-1].ScoreGoldenInt; - end; - - // EaseOut_Step is the actual step in the raising process, like the 20iest step of EaseOut_MaxSteps - RaiseStep := EaseOut_Step; - - if (ActualScoreValue < ScoreReached) then - begin - // Calculate the actual step according to the maxsteps - RaiseStep := RaiseStep / EaseOut_MaxSteps; - - // quadratic easing out - decelerating to zero velocity - // -end_position * current_time * ( current_time - 2 ) + start_postion - lTmpA := (-ScoreReached * RaiseStep * (RaiseStep - 20)); - if ( lTmpA > 0 ) and - ( RaiseSmoothness > 0 ) then - begin - if (ScoreType = 'Note') then - TextScore_ActualValue[PlayerNumber] := floor( lTmpA / RaiseSmoothness); - if (ScoreType = 'Line') then - TextPhrase_ActualValue[PlayerNumber] := floor( lTmpA / RaiseSmoothness); - if (ScoreType = 'Golden') then - TextGolden_ActualValue[PlayerNumber] := floor( lTmpA / RaiseSmoothness); - end; - end - else - begin - if (ScoreType = 'Note') then - TextScore_ActualValue[PlayerNumber] := ScoreReached; - if (ScoreType = 'Line') then - TextPhrase_ActualValue[PlayerNumber] := ScoreReached; - if (ScoreType = 'Golden') then - TextGolden_ActualValue[PlayerNumber] := ScoreReached; - end; -end; - -procedure TScreenScore.FillPlayer(Item, P: integer); -var - S: string; -begin - Text[TextName[Item]].Text := Ini.Name[P]; - - S := IntToStr((Round(Player[P].Score) div 10) * 10); - while (Length(S)<4) do - S := '0' + S; - Text[TextNotesScore[Item]].Text := S; - - // while (Length(S)<5) do S := '0' + S; - // Text[TextTotalScore[Item]].Text := S; - - //fixed: line bonus and golden notes don't show up, - // another bug: total score was shown without added golden-, linebonus - S := IntToStr(Player[P].ScoreTotalInt); - while (Length(S)<5) do - S := '0' + S; - Text[TextTotalScore[Item]].Text := S; - - S := IntToStr(Player[P].ScoreLineInt); - while (Length(S)<4) do - S := '0' + S; - Text[TextLineBonusScore[Item]].Text := S; - - S := IntToStr(Player[P].ScoreGoldenInt); - while (Length(S)<4) do - S := '0' + S; - Text[TextGoldenNotesScore[Item]].Text := S; - //end of fix - -end; - -end. diff --git a/src/screens/UScreenSing.pas b/src/screens/UScreenSing.pas deleted file mode 100644 index 0b7dfba4..00000000 --- a/src/screens/UScreenSing.pas +++ /dev/null @@ -1,1001 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenSing; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - SDL, - TextGL, - gl, - UFiles, - UGraphicClasses, - UIni, - ULog, - ULyrics, - UMenu, - UMusic, - USingScores, - USongs, - UTexture, - UThemes, - UPath, - UTime; - -type - TLyricsSyncSource = class(TInterfacedObject,ISyncSource) - function GetClock(): real; - end; - -type - TScreenSing = class(TMenu) - protected - VideoLoaded: boolean; - Paused: boolean; // pause mod - LyricsSync: TLyricsSyncSource; - NumEmptySentences: integer; - public - // timebar fields - StaticTimeProgress: integer; - TextTimeText: integer; - - StaticP1: integer; - TextP1: integer; - - // shown when game is in 2/4 player modus - StaticP1TwoP: integer; - TextP1TwoP: integer; - - // shown when game is in 3/6 player modus - StaticP1ThreeP: integer; - TextP1ThreeP: integer; - - StaticP2R: integer; - TextP2R: integer; - - StaticP2M: integer; - TextP2M: integer; - - StaticP3R: integer; - TextP3R: integer; - - StaticPausePopup: integer; - - Tex_Background: TTexture; - FadeOut: boolean; - Lyrics: TLyricEngine; - - // score manager: - Scores: TSingScores; - - //the song was sung to the end - SungToEnd: boolean; - - fShowVisualization: boolean; - fCurrentVideoPlaybackEngine: IVideoPlayback; - - constructor Create; override; - procedure OnShow; override; - procedure OnShowFinish; override; - procedure OnHide; override; - - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; - PressedDown: boolean): boolean; override; - function Draw: boolean; override; - - procedure Finish; virtual; - procedure Pause; // toggle pause - - procedure OnSentenceEnd(SentenceIndex: cardinal); // for linebonus + singbar - procedure OnSentenceChange(SentenceIndex: cardinal); // for golden notes - end; - -implementation - -uses - Classes, - Math, - UDraw, - UGraphic, - ULanguage, - UNote, - URecord, - USong, - UDisplay, - UUnicodeUtils; - -// method for input parsing. if false is returned, getnextwindow -// should be checked to know the next window to load; - -function TScreenSing.ParseInput(PressedKey: Cardinal; CharCode: UCS4Char; - PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // key down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - // when not ask before exit then finish now - if (Ini.AskbeforeDel <> 1) then - Finish - // else just pause and let the popup make the work - else if not Paused then - Pause; - - Result := false; - Exit; - end; - Ord('V'): // show visualization - begin - fShowVisualization := not fShowVisualization; - - if fShowVisualization then - fCurrentVideoPlaybackEngine := Visualization - else - fCurrentVideoPlaybackEngine := VideoPlayback; - - if fShowVisualization then - fCurrentVideoPlaybackEngine.play; - - Exit; - end; - Ord('P'): - begin - Pause; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE: - begin - // record sound hack: - //Sound[0].BufferLong - - Finish; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenScore); - end; - - SDLK_SPACE: - begin - Pause; - end; - - SDLK_TAB: // change visualization preset - begin - if fShowVisualization then - fCurrentVideoPlaybackEngine.Position := now; // move to a random position - end; - - SDLK_RETURN: - begin - end; - - // up and down could be done at the same time, - // but i don't want to declare variables inside - // functions like this one, called so many times - SDLK_DOWN: - begin - end; - SDLK_UP: - begin - end; - end; - end; -end; - -// pause mod -procedure TScreenSing.Pause; -var - VideoFile: IPath; -begin - if (not Paused) then // enable pause - begin - // pause time - Paused := true; - - LyricsState.Pause(); - - // pause music - AudioPlayback.Pause; - - // pause video - VideoFile := CurrentSong.Path.Append(CurrentSong.Video); - if (CurrentSong.Video.IsSet) and VideoFile.Exists then - fCurrentVideoPlaybackEngine.Pause; - - end - else // disable pause - begin - LyricsState.Resume(); - - // play music - AudioPlayback.Play; - - // video - VideoFile := CurrentSong.Path.Append(CurrentSong.Video); - if (CurrentSong.Video.IsSet) and VideoFile.Exists then - fCurrentVideoPlaybackEngine.Pause; - - Paused := false; - end; -end; -// pause mod end - -constructor TScreenSing.Create; -begin - inherited Create; - - //too dangerous, a mouse button is quickly pressed by accident - RightMbESC := false; - - fShowVisualization := false; - - fCurrentVideoPlaybackEngine := VideoPlayback; - - // create score class - Scores := TSingScores.Create; - Scores.LoadfromTheme; - - LoadFromTheme(Theme.Sing); - - // timebar - StaticTimeProgress := AddStatic(Theme.Sing.StaticTimeProgress); - TextTimeText := AddText(Theme.Sing.TextTimeText); - - // 1 player | P1 - StaticP1 := AddStatic(Theme.Sing.StaticP1); - TextP1 := AddText(Theme.Sing.TextP1); - - // 2 or 4 players | P1 - StaticP1TwoP := AddStatic(Theme.Sing.StaticP1TwoP); - TextP1TwoP := AddText(Theme.Sing.TextP1TwoP); - - // | P2 - StaticP2R := AddStatic(Theme.Sing.StaticP2R); - TextP2R := AddText(Theme.Sing.TextP2R); - - // 3 or 6 players | P1 - StaticP1ThreeP := AddStatic(Theme.Sing.StaticP1ThreeP); - TextP1ThreeP := AddText(Theme.Sing.TextP1ThreeP); - - // | P2 - StaticP2M := AddStatic(Theme.Sing.StaticP2M); - TextP2M := AddText(Theme.Sing.TextP2M); - - // | P3 - StaticP3R := AddStatic(Theme.Sing.StaticP3R); - TextP3R := AddText(Theme.Sing.TextP3R); - - StaticPausePopup := AddStatic(Theme.Sing.PausePopUp); - - // pausepopup is not visibile at the beginning - Static[StaticPausePopup].Visible := false; - - Lyrics := TLyricEngine.Create( - Theme.LyricBar.UpperX, Theme.LyricBar.UpperY, Theme.LyricBar.UpperW, Theme.LyricBar.UpperH, - Theme.LyricBar.LowerX, Theme.LyricBar.LowerY, Theme.LyricBar.LowerW, Theme.LyricBar.LowerH); - - LyricsSync := TLyricsSyncSource.Create(); -end; - -procedure TScreenSing.OnShow; -var - Index: integer; - V1: boolean; - V1TwoP: boolean; // position of score box in two player mode - V1ThreeP: boolean; // position of score box in three player mode - V2R: boolean; - V2M: boolean; - V3R: boolean; - Color: TRGB; - VideoFile, BgFile: IPath; - success: boolean; -begin - inherited; - - Log.LogStatus('Begin', 'OnShow'); - FadeOut := false; - - //the song was sung to the end - SungToEnd := false; - - // reset video playback engine, to play video clip ... - fCurrentVideoPlaybackEngine := VideoPlayback; - - // setup score manager - Scores.ClearPlayers; // clear old player values - Color.R := 0; - Color.G := 0; - Color.B := 0; // dummy atm <- \(O.o)/? B like bummy? - - // add new players - for Index := 0 to PlayersPlay - 1 do - begin - Scores.AddPlayer(Tex_ScoreBG[Index], Color); - end; - - Scores.Init; // get positions for players - - // prepare players - SetLength(Player, PlayersPlay); - - case PlayersPlay of - 1: - begin - V1 := true; - V1TwoP := false; - V1ThreeP := false; - V2R := false; - V2M := false; - V3R := false; - end; - 2: - begin - V1 := false; - V1TwoP := true; - V1ThreeP := false; - V2R := true; - V2M := false; - V3R := false; - end; - 3: - begin - V1 := false; - V1TwoP := false; - V1ThreeP := true; - V2R := false; - V2M := true; - V3R := true; - end; - 4: - begin // double screen - V1 := false; - V1TwoP := true; - V1ThreeP := false; - V2R := true; - V2M := false; - V3R := false; - end; - 6: - begin // double screen - V1 := false; - V1TwoP := false; - V1ThreeP := true; - V2R := false; - V2M := true; - V3R := true; - end; - - end; - - // this one is shown in 1P mode - Static[StaticP1].Visible := V1; - Text[TextP1].Visible := V1; - - // this one is shown in 2/4P mode - Static[StaticP1TwoP].Visible := V1TwoP; - Text[TextP1TwoP].Visible := V1TwoP; - - Static[StaticP2R].Visible := V2R; - Text[TextP2R].Visible := V2R; - - // this one is shown in 3/6P mode - Static[StaticP1ThreeP].Visible := V1ThreeP; - Text[TextP1ThreeP].Visible := V1ThreeP; - - Static[StaticP2M].Visible := V2M; - Text[TextP2M].Visible := V2M; - - Static[StaticP3R].Visible := V3R; - Text[TextP3R].Visible := V3R; - - // FIXME: sets path and filename to '' - ResetSingTemp; - - CurrentSong := CatSongs.Song[CatSongs.Selected]; - - // FIXME: bad style, put the try-except into loadsong() and not here - try - // check if file is xml - if CurrentSong.FileName.GetExtension.ToUTF8 = '.xml' then - success := CurrentSong.LoadXMLSong() - else - success := CurrentSong.LoadSong(); - except - success := false; - end; - - if (not success) then - begin - // error loading song -> go back to song screen and show some error message - FadeTo(@ScreenSong); - // select new song in party mode - if ScreenSong.Mode = smPartyMode then - ScreenSong.SelectRandomSong(); - if (Length(CurrentSong.LastError) > 0) then - ScreenPopupError.ShowPopup(Format(Language.Translate(CurrentSong.LastError), [CurrentSong.ErrorLineNo])) - else - ScreenPopupError.ShowPopup(Language.Translate('ERROR_CORRUPT_SONG')); - // FIXME: do we need this? - CurrentSong.Path := CatSongs.Song[CatSongs.Selected].Path; - Exit; - end; - - // reset video playback engine, to play video clip ... - fCurrentVideoPlaybackEngine.Close; - fCurrentVideoPlaybackEngine := VideoPlayback; - - {* - * == Background == - * We have four types of backgrounds: - * + Blank : Nothing has been set, this is our fallback - * + Picture : Picture has been set, and exists - otherwise we fallback - * + Video : Video has been set, and exists - otherwise we fallback - * + Visualization: + Off : No visualization - * + WhenNoVideo: Overwrites blank and picture - * + On : Overwrites blank, picture and video - *} - - {* - * set background to: video - *} - VideoLoaded := false; - fShowVisualization := false; - VideoFile := CurrentSong.Path.Append(CurrentSong.Video); - if (CurrentSong.Video.IsSet) and VideoFile.IsFile then - begin - if (fCurrentVideoPlaybackEngine.Open(VideoFile)) then - begin - fShowVisualization := false; - fCurrentVideoPlaybackEngine := VideoPlayback; - fCurrentVideoPlaybackEngine.Position := CurrentSong.VideoGAP + CurrentSong.Start; - fCurrentVideoPlaybackEngine.Play; - VideoLoaded := true; - end; - end; - - {* - * set background to: picture - *} - if (CurrentSong.Background.IsSet) and (VideoLoaded = false) - and (TVisualizerOption(Ini.VisualizerOption) = voOff) then - begin - BgFile := CurrentSong.Path.Append(CurrentSong.Background); - try - Tex_Background := Texture.LoadTexture(BgFile); - except - Log.LogError('Background could not be loaded: ' + BgFile.ToNative); - Tex_Background.TexNum := 0; - end - end - else - begin - Tex_Background.TexNum := 0; - end; - - {* - * set background to: visualization (Overwrites all) - *} - if (TVisualizerOption(Ini.VisualizerOption) in [voOn]) then - begin - fShowVisualization := true; - fCurrentVideoPlaybackEngine := Visualization; - if (fCurrentVideoPlaybackEngine <> nil) then - fCurrentVideoPlaybackEngine.Play; - end; - - {* - * set background to: visualization (Videos are still shown) - *} - if ((TVisualizerOption(Ini.VisualizerOption) in [voWhenNoVideo]) and - (VideoLoaded = false)) then - begin - fShowVisualization := true; - fCurrentVideoPlaybackEngine := Visualization; - if (fCurrentVideoPlaybackEngine <> nil) then - fCurrentVideoPlaybackEngine.Play; - end; - - // prepare lyrics timer - LyricsState.Reset(); - LyricsState.SetCurrentTime(CurrentSong.Start); - LyricsState.StartTime := CurrentSong.Gap; - if (CurrentSong.Finish > 0) then - LyricsState.TotalTime := CurrentSong.Finish / 1000 - else - LyricsState.TotalTime := AudioPlayback.Length; - LyricsState.UpdateBeats(); - - // prepare music - AudioPlayback.Stop(); - AudioPlayback.Position := CurrentSong.Start; - // synchronize music to the lyrics - AudioPlayback.SetSyncSource(LyricsSync); - - // prepare and start voice-capture - AudioInput.CaptureStart; - - // clear the scores of all players - - for Index := 0 to High(Player) do - with Player[Index] do - begin - Score := 0; - ScoreLine := 0; - ScoreGolden := 0; - - ScoreInt := 0; - ScoreLineInt := 0; - ScoreGoldenInt := 0; - ScoreTotalInt := 0; - - ScoreLast := 0; - - LastSentencePerfect := false; - end; - - // main text - Lyrics.Clear(CurrentSong.BPM[0].BPM, CurrentSong.Resolution); - - // set custom options - case Ini.LyricsFont of - 0: // normal fonts - begin - Lyrics.FontStyle := 0; - - Lyrics.LineColor_en.R := Skin_FontR; - Lyrics.LineColor_en.G := Skin_FontG; - Lyrics.LineColor_en.B := Skin_FontB; - Lyrics.LineColor_en.A := 1; - - Lyrics.LineColor_dis.R := 0.4; - Lyrics.LineColor_dis.G := 0.4; - Lyrics.LineColor_dis.B := 0.4; - Lyrics.LineColor_dis.A := 1; - - Lyrics.LineColor_act.R := 0.02; - Lyrics.LineColor_act.G := 0.6; - Lyrics.LineColor_act.B := 0.8; - Lyrics.LineColor_act.A := 1; - end; - 1, 2: // outline fonts (is TScalableOutlineFont) - begin - Lyrics.FontStyle := Ini.LyricsFont + 1; - - Lyrics.LineColor_en.R := 0.75; - Lyrics.LineColor_en.G := 0.75; - Lyrics.LineColor_en.B := 1; - Lyrics.LineColor_en.A := 1; - - Lyrics.LineColor_dis.R := 0.8; - Lyrics.LineColor_dis.G := 0.8; - Lyrics.LineColor_dis.B := 0.8; - Lyrics.LineColor_dis.A := 1; - - Lyrics.LineColor_act.R := 0.5; - Lyrics.LineColor_act.G := 0.5; - Lyrics.LineColor_act.B := 1; - Lyrics.LineColor_act.A := 1; - end; - end; // case - - // initialize lyrics by filling its queue - while (not Lyrics.IsQueueFull) and - (Lyrics.LineCounter <= High(Lines[0].Line)) do - begin - Lyrics.AddLine(@Lines[0].Line[Lyrics.LineCounter]); - end; - - // deactivate pause - Paused := false; - - // kill all stars not killed yet (goldenstarstwinkle mod) - GoldenRec.SentenceChange; - - // set position of line bonus - line bonus end - // set number of empty sentences for line bonus - NumEmptySentences := 0; - for Index := Low(Lines[0].Line) to High(Lines[0].Line) do - if Lines[0].Line[Index].TotalNotes = 0 then - Inc(NumEmptySentences); - - Log.LogStatus('End', 'OnShow'); -end; - -procedure TScreenSing.onShowFinish; -begin - // hide cursor on singscreen show - Display.SetCursor; - - // start lyrics - LyricsState.Resume(); - - // start music - AudioPlayback.Play(); - - // start timer - CountSkipTimeSet; -end; - -procedure TScreenSing.OnHide; -begin - // background texture - if (Tex_Background.TexNum > 0) then - begin - glDeleteTextures(1, PGLuint(@Tex_Background.TexNum)); - Tex_Background.TexNum := 0; - end; - - Background.OnFinish; - Display.SetCursor; -end; - -function TScreenSing.Draw: boolean; -var - Min: integer; - Sec: integer; - T: integer; - CurLyricsTime: real; - Line: TLyricLine; - LastWord: TLyricWord; -begin - Background.Draw; - - // draw background picture (if any, and if no visualizations) - // when we don't check for visualizations the visualizations would - // be overdrawn by the picture when {UNDEFINED UseTexture} in UVisualizer - if (not fShowVisualization) then - SingDrawBackground; - - // set player names (for 2 screens and only singstar skin) - if ScreenAct = 1 then - begin - Text[TextP1].Text := 'P1'; - Text[TextP1TwoP].Text := 'P1'; - Text[TextP1ThreeP].Text := 'P1'; - Text[TextP2R].Text := 'P2'; - Text[TextP2M].Text := 'P2'; - Text[TextP3R].Text := 'P3'; - end; - - if ScreenAct = 2 then - begin - case PlayersPlay of - 4: - begin - Text[TextP1TwoP].Text := 'P3'; - Text[TextP2R].Text := 'P4'; - end; - 6: - begin - Text[TextP1ThreeP].Text := 'P4'; - Text[TextP2M].Text := 'P5'; - Text[TextP3R].Text := 'P6'; - end; - end; // case - end; // if - - //// - // dual screen, part 1 - //////////////////////// - - // Note: ScreenX is the offset of the current screen in dual-screen mode so we - // will move the statics and texts to the correct screen here. - // FIXME: clean up this weird stuff. Commenting this stuff out, nothing - // was missing on screen w/ 6 players - so do we even need this stuff? - {Static[StaticP1].Texture.X := Static[StaticP1].Texture.X + 10 * ScreenX; - - Text[TextP1].X := Text[TextP1].X + 10 * ScreenX; } - - {Static[StaticP1ScoreBG].Texture.X := Static[StaticP1ScoreBG].Texture.X + 10*ScreenX; - Text[TextP1Score].X := Text[TextP1Score].X + 10*ScreenX;} - - {Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X + 10 * ScreenX; - - Text[TextP2R].X := Text[TextP2R].X + 10 * ScreenX; } - - {Static[StaticP2RScoreBG].Texture.X := Static[StaticP2RScoreBG].Texture.X + 10*ScreenX; - Text[TextP2RScore].X := Text[TextP2RScore].X + 10*ScreenX;} - - // end of weird stuff - { - Static[1].Texture.X := Static[1].Texture.X + 10 * ScreenX; } - - { for T := 0 to 1 do - Text[T].X := Text[T].X + 10 * ScreenX; } - - // retrieve current lyrics time, we have to store the value to avoid - // that min- and sec-values do not match - CurLyricsTime := LyricsState.GetCurrentTime(); - Min := Round(CurLyricsTime) div 60; - Sec := Round(CurLyricsTime) mod 60; - - // update static menu with time ... - Text[TextTimeText].Text := ''; - if Min < 10 then - Text[TextTimeText].Text := '0'; - Text[TextTimeText].Text := Text[TextTimeText].Text + IntToStr(Min) + ':'; - if Sec < 10 then - Text[TextTimeText].Text := Text[TextTimeText].Text + '0'; - Text[TextTimeText].Text := Text[TextTimeText].Text + IntToStr(Sec); - - // draw static menu (BG) - // Note: there is no menu and the animated background brakes the video playback - //DrawBG; - - //the song was sung to the end? - Line := Lyrics.GetUpperLine(); - if Line.LastLine then - begin - LastWord := Line.Words[Length(Line.Words)-1]; - if CurLyricsTime >= GetTimeFromBeat(LastWord.Start+LastWord.Length) then - SungToEnd := true; - end; - - // update and draw movie - if (ShowFinish and (VideoLoaded or fShowVisualization)) then - begin - if assigned(fCurrentVideoPlaybackEngine) then - begin - // Just call this once - // when Screens = 2 - if (ScreenAct = 1) then - fCurrentVideoPlaybackEngine.GetFrame(CurrentSong.VideoGAP + LyricsState.GetCurrentTime()); - - fCurrentVideoPlaybackEngine.DrawGL(ScreenAct); - end; - end; - - // draw static menu (FG) - DrawFG; - - // check for music finish - //Log.LogError('Check for music finish: ' + BoolToStr(Music.Finished) + ' ' + FloatToStr(LyricsState.CurrentTime*1000) + ' ' + IntToStr(CurrentSong.Finish)); - if ShowFinish then - begin - if (not AudioPlayback.Finished) and ((CurrentSong.Finish = 0) or - (LyricsState.GetCurrentTime() * 1000 <= CurrentSong.Finish)) then - begin - // analyze song if not paused - if (not Paused) then - Sing(Self); - end - else - begin - if (not FadeOut) then - begin - Finish; - FadeOut := true; - FadeTo(@ScreenScore); - end; - end; - end; - - // always draw custom items - SingDraw; - - // goldennotestarstwinkle - GoldenRec.SpawnRec; - - // draw scores - Scores.Draw; - - //// - // dual screen, part 2 - //////////////////////// - - // Note: ScreenX is the offset of the current screen in dual-screen mode so we - // will move the statics and texts to the correct screen here. - // FIXME: clean up this weird stuff - - {Static[StaticP1].Texture.X := Static[StaticP1].Texture.X - 10 * ScreenX; - Text[TextP1].X := Text[TextP1].X - 10 * ScreenX; - - Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X - 10 * ScreenX; - Text[TextP2R].X := Text[TextP2R].X - 10 * ScreenX; - - // end of weird - - Static[1].Texture.X := Static[1].Texture.X - 10 * ScreenX; - - for T := 0 to 1 do - Text[T].X := Text[T].X - 10 * ScreenX; } - - // draw pausepopup - // FIXME: this is a workaround that the static is drawn over the lyrics, lines, scores and effects - // maybe someone could find a better solution - if Paused then - begin - Static[StaticPausePopup].Visible := true; - Static[StaticPausePopup].Draw; - Static[StaticPausePopup].Visible := false; - end; - - Result := true; -end; - -procedure TScreenSing.Finish; -begin - AudioInput.CaptureStop; - AudioPlayback.Stop; - AudioPlayback.SetSyncSource(nil); - - if (VideoPlayback <> nil) then - VideoPlayback.Close; - - if (Visualization <> nil) then - Visualization.Close; - - // to prevent drawing closed video - VideoLoaded := false; - - // kill all stars and effects - GoldenRec.KillAll; - - if (Ini.SavePlayback = 1) then - begin - Log.BenchmarkStart(0); - Log.LogVoice(0); - Log.LogVoice(1); - Log.LogVoice(2); - Log.BenchmarkEnd(0); - Log.LogBenchmark('Creating files', 0); - end; - - SetFontItalic(false); -end; - -procedure TScreenSing.OnSentenceEnd(SentenceIndex: cardinal); -var - PlayerIndex: byte; - CurrentPlayer: PPLayer; - CurrentScore: real; - Line: PLine; - LinePerfection: real; // perfection of singing performance on the current line - Rating: integer; - LineScore: real; - LineBonus: real; - MaxSongScore: integer; // max. points for the song (without line bonus) - MaxLineScore: real; // max. points for the current line -const - // TODO: move this to a better place - MAX_LINE_RATING = 8; // max. rating for singing performance -begin - Line := @Lines[0].Line[SentenceIndex]; - - // check for empty sentence - if (Line.TotalNotes <= 0) then - Exit; - - // set max song score - if (Ini.LineBonus = 0) then - MaxSongScore := MAX_SONG_SCORE - else - MaxSongScore := MAX_SONG_SCORE - MAX_SONG_LINE_BONUS; - - // Note: ScoreValue is the sum of all note values of the song - MaxLineScore := MaxSongScore * (Line.TotalNotes / Lines[0].ScoreValue); - - for PlayerIndex := 0 to High(Player) do - begin - CurrentPlayer := @Player[PlayerIndex]; - CurrentScore := CurrentPlayer.Score + CurrentPlayer.ScoreGolden; - - // line bonus - - // points for this line - LineScore := CurrentScore - CurrentPlayer.ScoreLast; - - // check for lines with low points - if (MaxLineScore <= 2) then - LinePerfection := 1 - else - // determine LinePerfection - // Note: the "+2" extra points are a little bonus so the player does not - // have to be that perfect to reach the bonus steps. - LinePerfection := LineScore / (MaxLineScore - 2); - - // clamp LinePerfection to range [0..1] - if (LinePerfection < 0) then - LinePerfection := 0 - else if (LinePerfection > 1) then - LinePerfection := 1; - - // add line-bonus if enabled - if (Ini.LineBonus > 0) then - begin - // line-bonus points (same for each line, no matter how long the line is) - LineBonus := MAX_SONG_LINE_BONUS / (Length(Lines[0].Line) - - NumEmptySentences); - // apply line-bonus - CurrentPlayer.ScoreLine := - CurrentPlayer.ScoreLine + LineBonus * LinePerfection; - CurrentPlayer.ScoreLineInt := Floor(CurrentPlayer.ScoreLine / 10) * 10; - // update total score - CurrentPlayer.ScoreTotalInt := - CurrentPlayer.ScoreInt + - CurrentPlayer.ScoreGoldenInt - + CurrentPlayer.ScoreLineInt; - - // spawn rating pop-up - Rating := Round(LinePerfection * MAX_LINE_RATING); - Scores.SpawnPopUp(PlayerIndex, Rating, CurrentPlayer.ScoreTotalInt); - end - else - Scores.RaiseScore(PlayerIndex, CurrentPlayer.ScoreTotalInt); - - // PerfectLineTwinkle (effect), part 1 - if (Ini.EffectSing = 1) then - CurrentPlayer.LastSentencePerfect := (LinePerfection >= 1); - - // refresh last score - CurrentPlayer.ScoreLast := CurrentScore; - end; - - // PerfectLineTwinkle (effect), part 2 - if (Ini.EffectSing = 1) then - GoldenRec.SpawnPerfectLineTwinkle; -end; - - // Called on sentence change - // SentenceIndex: index of the new active sentence -procedure TScreenSing.OnSentenceChange(SentenceIndex: cardinal); -begin - // goldenstarstwinkle - GoldenRec.SentenceChange; - - // fill lyrics queue and set upper line to the current sentence - while (Lyrics.GetUpperLineIndex() < SentenceIndex) or - (not Lyrics.IsQueueFull) do - begin - // add the next line to the queue or a dummy if no more lines are available - if (Lyrics.LineCounter <= High(Lines[0].Line)) then - Lyrics.AddLine(@Lines[0].Line[Lyrics.LineCounter]) - else - Lyrics.AddLine(nil); - end; -end; - -function TLyricsSyncSource.GetClock(): real; -begin - Result := LyricsState.GetCurrentTime(); -end; - -end. - diff --git a/src/screens/UScreenSingModi.pas b/src/screens/UScreenSingModi.pas deleted file mode 100644 index 48d1e9a1..00000000 --- a/src/screens/UScreenSingModi.pas +++ /dev/null @@ -1,582 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenSingModi; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - UMusic, - SDL, - SysUtils, - UFiles, - UTime, - USongs, - UIni, - ULog, - UTexture, - ULyrics, - TextGL, - gl, - UPath, - UThemes, - UScreenSing, - ModiSDK; - -type - TScreenSingModi = class(TScreenSing) - protected - - public - Winner: byte; //Who Wins - PlayerInfo: TPlayerInfo; - TeamInfo: TTeamInfo; - - constructor Create; override; - procedure OnShow; override; - //procedure onShowFinish; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function Draw: boolean; override; - procedure Finish; override; - end; - -type - TCustomSoundEntry = record - Filename : IPath; - Stream : TAudioPlaybackStream; - end; - -var - //Custom Sounds - CustomSounds: array of TCustomSoundEntry; - -//Procedured for Plugin -function LoadTex(const Name: PChar; Typ: TTextureType): TsmallTexture; - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//function Translate (const Name: PChar): PChar; -// {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//Procedure to Print Text -procedure Print(const Style, Size: byte; const X, Y: real; const Text: PChar); - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//Procedure that loads a Custom Sound -function LoadSound(const Name: PChar): cardinal; - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} -//Plays a Custom Sound -procedure PlaySound(const Index: cardinal); - {$IFDEF MSWINDOWS} stdcall; {$ELSE} cdecl; {$ENDIF} - -//Utilys -function ToSentences(Const Lines: TLines): TSentences; - -implementation - -uses - Classes, - Math, - UDLLManager, - UDraw, - UGraphic, - UGraphicClasses, - ULanguage, - UNote, - UPathUtils, - URecord, - USkins; - -// Method for input parsing. If false is returned, GetNextWindow -// should be checked to know the next window to load; -function TScreenSingModi.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - case PressedKey of - - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Finish; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenPartyScore); - end; - - else - Result := inherited ParseInput(PressedKey, CharCode, PressedDown); - end; - end; -end; - -constructor TScreenSingModi.Create; -begin - inherited Create; - -end; - -function ToSentences(Const Lines: TLines): TSentences; -var - I, J: integer; -begin - Result.Current := Lines.Current; - Result.High := Lines.High; - Result.Number := Lines.Number; - Result.Resolution := Lines.Resolution; - Result.NotesGAP := Lines.NotesGAP; - Result.TotalLength := Lines.ScoreValue; - - SetLength(Result.Sentence, Length(Lines.Line)); - for I := low(Result.Sentence) to high(Result.Sentence) do - begin - Result.Sentence[I].Start := Lines.Line[I].Start; - Result.Sentence[I].StartNote := Lines.Line[I].Note[0].Start; - Result.Sentence[I].Lyric := Lines.Line[I].Lyric; - Result.Sentence[I].End_ := Lines.Line[I].End_; - Result.Sentence[I].BaseNote := Lines.Line[I].BaseNote; - Result.Sentence[I].HighNote := Lines.Line[I].HighNote; - Result.Sentence[I].TotalNotes := Lines.Line[I].TotalNotes; - - SetLength(Result.Sentence[I].Note, Length(Lines.Line[I].Note)); - for J := low(Result.Sentence[I].Note) to high(Result.Sentence[I].Note) do - begin - Result.Sentence[I].Note[J].Color := Lines.Line[I].Note[J].Color; - Result.Sentence[I].Note[J].Start := Lines.Line[I].Note[J].Start; - Result.Sentence[I].Note[J].Length := Lines.Line[I].Note[J].Length; - Result.Sentence[I].Note[J].Tone := Lines.Line[I].Note[J].Tone; - //Result.Sentence[I].Note[J].Text := Lines.Line[I].Note[J].Text; - Result.Sentence[I].Note[J].FreeStyle := (Lines.Line[I].Note[J].NoteType = ntFreestyle); - end; - end; -end; - -procedure TScreenSingModi.OnShow; -var - I: integer; -begin - inherited; - - PlayersPlay := TeamInfo.NumTeams; - - if DLLMan.Selected.LoadSong then //Start with Song - begin - inherited; - end - else //Start Without Song - begin - AudioInput.CaptureStart; - end; - -//Set Playerinfo - PlayerInfo.NumPlayers := PlayersPlay; - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - PlayerInfo.Playerinfo[I].Name := PChar(Ini.Name[I]); - PlayerInfo.Playerinfo[I].Score := 0; - PlayerInfo.Playerinfo[I].Bar := 50; - PlayerInfo.Playerinfo[I].Enabled := true; - end; - - for I := PlayerInfo.NumPlayers to high(PlayerInfo.Playerinfo) do - begin - PlayerInfo.Playerinfo[I].Score:= 0; - PlayerInfo.Playerinfo[I].Bar := 0; - PlayerInfo.Playerinfo[I].Enabled := false; - end; - - {Case PlayersPlay of - 1: begin - PlayerInfo.Playerinfo[0].PosX := Static[StaticP1ScoreBG].Texture.X; - PlayerInfo.Playerinfo[0].PosY := Static[StaticP1ScoreBG].Texture.Y + Static[StaticP1ScoreBG].Texture.H; - end; - 2,4: begin - PlayerInfo.Playerinfo[0].PosX := Static[StaticP1TwoPScoreBG].Texture.X; - PlayerInfo.Playerinfo[0].PosY := Static[StaticP1TwoPScoreBG].Texture.Y + Static[StaticP1TwoPScoreBG].Texture.H; - PlayerInfo.Playerinfo[2].PosX := Static[StaticP1TwoPScoreBG].Texture.X; - PlayerInfo.Playerinfo[2].PosY := Static[StaticP1TwoPScoreBG].Texture.Y + Static[StaticP1TwoPScoreBG].Texture.H; - PlayerInfo.Playerinfo[1].PosX := Static[StaticP2RScoreBG].Texture.X; - PlayerInfo.Playerinfo[1].PosY := Static[StaticP2RScoreBG].Texture.Y + Static[StaticP2RScoreBG].Texture.H; - PlayerInfo.Playerinfo[3].PosX := Static[StaticP2RScoreBG].Texture.X; - PlayerInfo.Playerinfo[3].PosY := Static[StaticP2RScoreBG].Texture.Y + Static[StaticP2RScoreBG].Texture.H; - end; - 3,6: begin - PlayerInfo.Playerinfo[0].PosX := Static[StaticP1ThreePScoreBG].Texture.X; - PlayerInfo.Playerinfo[0].PosY := Static[StaticP1ThreePScoreBG].Texture.Y + Static[StaticP1ThreePScoreBG].Texture.H; - PlayerInfo.Playerinfo[3].PosX := Static[StaticP1ThreePScoreBG].Texture.X; - PlayerInfo.Playerinfo[3].PosY := Static[StaticP1ThreePScoreBG].Texture.Y + Static[StaticP1ThreePScoreBG].Texture.H; - PlayerInfo.Playerinfo[1].PosX := Static[StaticP2MScoreBG].Texture.X; - PlayerInfo.Playerinfo[1].PosY := Static[StaticP2MScoreBG].Texture.Y + Static[StaticP2MScoreBG].Texture.H; - PlayerInfo.Playerinfo[4].PosX := Static[StaticP2MScoreBG].Texture.X; - PlayerInfo.Playerinfo[4].PosY := Static[StaticP2MScoreBG].Texture.Y + Static[StaticP2MScoreBG].Texture.H; - PlayerInfo.Playerinfo[2].PosX := Static[StaticP3RScoreBG].Texture.X; - PlayerInfo.Playerinfo[2].PosY := Static[StaticP3RScoreBG].Texture.Y + Static[StaticP3RScoreBG].Texture.H; - PlayerInfo.Playerinfo[5].PosX := Static[StaticP3RScoreBG].Texture.X; - PlayerInfo.Playerinfo[5].PosY := Static[StaticP3RScoreBG].Texture.Y + Static[StaticP3RScoreBG].Texture.H; - end; - end; } - - // play music (I) - //Music.CaptureStart; - //Music.MoveTo(AktSong.Start); - - //Init Plugin - if not DLLMan.PluginInit(TeamInfo, PlayerInfo, ToSentences(Lines[0]), LoadTex, Print, LoadSound, PlaySound) then - begin - //Fehler - Log.LogError('Could not Init Plugin'); - Halt; - end; - - // Set Background (Little Workaround, maybe change sometime) - if (DLLMan.Selected.LoadBack) and (DLLMan.Selected.LoadSong) then - ScreenSing.Tex_Background := Tex_Background; - - Winner := 0; - - //Set Score Visibility - Scores.Visible := DLLMan.Selected.ShowScore; - - {if PlayersPlay = 1 then - begin - Text[TextP1Score].Visible := DLLMan.Selected.ShowScore; - Static[StaticP1ScoreBG].Visible := DLLMan.Selected.ShowScore; - end; - - if (PlayersPlay = 2) or (PlayersPlay = 4) then - begin - Text[TextP1TwoPScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP1TwoPScoreBG].Visible := DLLMan.Selected.ShowScore; - - Text[TextP2RScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP2RScoreBG].Visible := DLLMan.Selected.ShowScore; - end; - - if (PlayersPlay = 3) or (PlayersPlay = 6) then - begin - Text[TextP1ThreePScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP1ThreePScoreBG].Visible := DLLMan.Selected.ShowScore; - - Text[TextP2MScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP2MScoreBG].Visible := DLLMan.Selected.ShowScore; - - Text[TextP3RScore].Visible := DLLMan.Selected.ShowScore; - Static[StaticP3RScoreBG].Visible := DLLMan.Selected.ShowScore; - end; } -end; - -function TScreenSingModi.Draw: boolean; -var - Min: integer; - Sec: integer; - TextStr: string; - S, I: integer; - T: integer; - CurLyricsTime: real; -begin - Result := false; - - //Set Playerinfo - PlayerInfo.NumPlayers := PlayersPlay; - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - PlayerInfo.Playerinfo[I].Name := PChar(Player[I].Name); - if PlayerInfo.Playerinfo[I].Enabled then - begin - if (Player[I].ScoreTotalInt <= MAX_SONG_SCORE) then - PlayerInfo.Playerinfo[I].Score:= Player[I].ScoreTotalInt; - PlayerInfo.Playerinfo[I].Bar := Round(Scores.Players[I].RBPos * 100); - end; - end; - - Background.Draw; - - // draw background picture (if any, and if no visualizations) - // when we don't check for visualizations the visualizations would - // be overdrawn by the picture when {UNDEFINED UseTexture} in UVisualizer - if (DllMan.Selected.LoadSong) and (DllMan.Selected.LoadBack) and (not fShowVisualization) then - SingDrawBackground; - - // set player names (for 2 screens and only Singstar skin) - if ScreenAct = 1 then - begin - Text[TextP1].Text := 'P1'; - Text[TextP1TwoP].Text := 'P1'; // added for ps3 skin - Text[TextP1ThreeP].Text := 'P1'; // added for ps3 skin - Text[TextP2R].Text := 'P2'; - Text[TextP2M].Text := 'P2'; - Text[TextP3R].Text := 'P3'; - end - - Else if ScreenAct = 2 then - begin - case PlayersPlay of - 4: begin - Text[TextP1TwoP].Text := 'P3'; - Text[TextP2R].Text := 'P4'; - end; - 6: begin - Text[TextP1ThreeP].Text := 'P4'; - Text[TextP2M].Text := 'P5'; - Text[TextP3R].Text := 'P6'; - end; - end; // case - end; // if - - // stereo <- and where iss P2M? or P3? - Static[StaticP1].Texture.X := Static[StaticP1].Texture.X + 10*ScreenX; - Text[TextP1].X := Text[TextP1].X + 10*ScreenX; - - {Static[StaticP1ScoreBG].Texture.X := Static[StaticP1ScoreBG].Texture.X + 10*ScreenX; - Text[TextP1Score].X := Text[TextP1Score].X + 10*ScreenX;} - - Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X + 10*ScreenX; - Text[TextP2R].X := Text[TextP2R].X + 10*ScreenX; - - for S := 1 to 1 do - Static[S].Texture.X := Static[S].Texture.X + 10*ScreenX; - - for T := 0 to 1 do - Text[T].X := Text[T].X + 10*ScreenX; - - if DLLMan.Selected.LoadSong then - begin - // update static menu with time ... - CurLyricsTime := LyricsState.GetCurrentTime(); - Min := Round(CurLyricsTime) div 60; - Sec := Round(CurLyricsTime) mod 60; - - Text[TextTimeText].Text := ''; - if Min < 10 then Text[TextTimeText].Text := '0'; - Text[TextTimeText].Text := Text[TextTimeText].Text + IntToStr(Min) + ':'; - if Sec < 10 then Text[TextTimeText].Text := Text[TextTimeText].Text + '0'; - Text[TextTimeText].Text := Text[TextTimeText].Text + IntToStr(Sec); - end; - - // update and draw movie -{ if ShowFinish and CurrentSong.VideoLoaded and DllMan.Selected.LoadVideo then - begin - UpdateSmpeg; // this only draws - end;} - - // update and draw movie - if (ShowFinish and (VideoLoaded or fShowVisualization) and DllMan.Selected.LoadVideo) then - begin - if assigned(fCurrentVideoPlaybackEngine) then - begin - // Just call this once - // when Screens = 2 - if (ScreenAct = 1) then - fCurrentVideoPlaybackEngine.GetFrame(CurrentSong.VideoGAP + LyricsState.GetCurrentTime()); - - fCurrentVideoPlaybackEngine.DrawGL(ScreenAct); - end; - end; - - // draw static menu (FG) - DrawFG; - - if ShowFinish then - begin - if DllMan.Selected.LoadSong then - begin - if (not AudioPlayback.Finished) and ((CurrentSong.Finish = 0) or (LyricsState.GetCurrentTime*1000 <= CurrentSong.Finish)) then - begin - //Pause Mod: - if not Paused then - Sing(Self); // analyze song - end - else - begin - if not FadeOut then - begin - Finish; - FadeOut := true; - FadeTo(@ScreenPartyScore); - end; - end; - end; - end; - - // draw custom items - SingModiDraw(PlayerInfo); // always draw - - //GoldenNoteStarsTwinkle Mod - GoldenRec.SpawnRec; - //GoldenNoteStarsTwinkle Mod - - //Draw Score - Scores.Draw; - - //Update PlayerInfo - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - if PlayerInfo.Playerinfo[I].Enabled then - begin - //PlayerInfo.Playerinfo[I].Bar := Player[I].ScorePercent; - PlayerInfo.Playerinfo[I].Score := Player[I].ScoreTotalInt; - end; - end; - - if ((ShowFinish) and (not Paused)) then - begin - if not DLLMan.PluginDraw(Playerinfo, Lines[0].Current) then - begin - if not FadeOut then - begin - Finish; - FadeOut := true; - FadeTo(@ScreenPartyScore); - end; - end; - end; - - //Change PlayerInfo/Changeables - for I := 0 to PlayerInfo.NumPlayers-1 do - begin - if (Player[I].ScoreTotalInt <> PlayerInfo.Playerinfo[I].Score) then - begin - //Player[I].ScoreTotal := Player[I].ScoreTotal + (PlayerInfo.Playerinfo[I].Score - Player[I].ScoreTotalI); - Player[I].ScoreTotalInt := PlayerInfo.Playerinfo[I].Score; - end; - {if (PlayerInfo.Playerinfo[I].Bar <> Player[I].ScorePercent) then - Player[I].ScorePercentTarget := PlayerInfo.Playerinfo[I].Bar; } - end; - - // back stereo - Static[StaticP1].Texture.X := Static[StaticP1].Texture.X - 10*ScreenX; - Text[TextP1].X := Text[TextP1].X - 10*ScreenX; - - {Static[StaticP1ScoreBG].Texture.X := Static[StaticP1ScoreBG].Texture.X - 10*ScreenX; - Text[TextP1Score].X := Text[TextP1Score].X - 10*ScreenX;} - - Static[StaticP2R].Texture.X := Static[StaticP2R].Texture.X - 10*ScreenX; - Text[TextP2R].X := Text[TextP2R].X - 10*ScreenX; - - {Static[StaticP2RScoreBG].Texture.X := Static[StaticP2RScoreBG].Texture.X - 10*ScreenX; - Text[TextP2RScore].X := Text[TextP2RScore].X - 10*ScreenX;} - - for S := 1 to 1 do - Static[S].Texture.X := Static[S].Texture.X - 10*ScreenX; - - for T := 0 to 1 do - Text[T].X := Text[T].X - 10*ScreenX; - - Result := true; -end; - -procedure TScreenSingModi.Finish; -begin -inherited Finish; - -Winner := DllMan.PluginFinish(PlayerInfo); - -//Log.LogError('Winner: ' + InttoStr(Winner)); - -//DLLMan.UnLoadPlugin; -end; - -function LoadTex(const Name: PChar; Typ: TTextureType): TsmallTexture; -var - TexName: IPath; - Ext: UTF8String; - Tex: TTexture; -begin - //Get texture Name - TexName := Skin.GetTextureFileName(string(Name)); - //Get File Typ - Ext := TexName.GetExtension().ToUTF8; - if (UpperCase(Ext) = '.JPG') then - Ext := 'JPG' - else - Ext := 'BMP'; - - Tex := Texture.LoadTexture(false, TexName, UTexture.TTextureType(Typ), 0); - - Result.TexNum := Tex.TexNum; - Result.W := Tex.W; - Result.H := Tex.H; -end; -{ -function Translate (const Name: PChar): PChar; stdcall; -begin - Result := PChar(Language.Translate(string(Name))); -end; } - -//Procedure to Print Text -procedure Print(const Style, Size: byte; const X, Y: real; const Text: PChar); -begin - SetFontItalic ((Style and 128) = 128); - SetFontStyle(Style and 7); - // FIXME: FONTSIZE - // used by Hold_The_Line / TeamDuell - SetFontSize(Size); - SetFontPos (X, Y); - glPrint (Language.Translate(string(Text))); -end; - -//Procedure that loads a Custom Sound -function LoadSound(const Name: PChar): cardinal; -var - Stream: TAudioPlaybackStream; - i: integer; - Filename: IPath; - SoundFile: IPath; -begin - //Search for Sound in already loaded Sounds - SoundFile := SoundPath.Append(Name); - for i := 0 to High(CustomSounds) do - begin - if (SoundFile.Equals(CustomSounds[i].Filename, true)) then - begin - Result := i; - Exit; - end; - end; - - Stream := AudioPlayback.OpenSound(SoundFile); - if (Stream = nil) then - begin - Result := 0; - Exit; - end; - - SetLength(CustomSounds, Length(CustomSounds)+1); - CustomSounds[High(CustomSounds)].Stream := Stream; - Result := High(CustomSounds); -end; - -//Plays a Custom Sound -procedure PlaySound(const Index: cardinal); -begin - if (Index <= High(CustomSounds)) then - AudioPlayback.PlaySound(CustomSounds[Index].Stream); -end; - -end. - diff --git a/src/screens/UScreenSong.pas b/src/screens/UScreenSong.pas deleted file mode 100644 index a2760ae3..00000000 --- a/src/screens/UScreenSong.pas +++ /dev/null @@ -1,2061 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenSong; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - SDL, - UCommon, - UDisplay, - UPath, - UFiles, - UIni, - ULanguage, - ULog, - UMenu, - UMenuEqualizer, - UMusic, - USong, - USongs, - UTexture, - UThemes, - UTime; - -type - TScreenSong = class(TMenu) - private - Equalizer: Tms_Equalizer; - - PreviewOpened: Integer; // interaction of the Song that is loaded for preview music - // -1 if nothing is opened - - procedure StartMusicPreview(); - procedure StopMusicPreview(); - public - TextArtist: integer; - TextTitle: integer; - TextNumber: integer; - - //Video Icon Mod - VideoIcon: cardinal; - - TextCat: integer; - StaticCat: integer; - - SongCurrent: real; - SongTarget: real; - - HighSpeed: boolean; - CoverFull: boolean; - CoverTime: real; - MusicPreviewTimer: PSDL_TimerID; - - CoverX: integer; - CoverY: integer; - CoverW: integer; - is_jump: boolean; // Jump to Song Mod - is_jump_title:boolean; //Jump to SOng MOd-YTrue if search for Title - - //Party Mod - Mode: TSingMode; - - //party Statics (Joker) - StaticTeam1Joker1: cardinal; - StaticTeam1Joker2: cardinal; - StaticTeam1Joker3: cardinal; - StaticTeam1Joker4: cardinal; - StaticTeam1Joker5: cardinal; - - StaticTeam2Joker1: cardinal; - StaticTeam2Joker2: cardinal; - StaticTeam2Joker3: cardinal; - StaticTeam2Joker4: cardinal; - StaticTeam2Joker5: cardinal; - - StaticTeam3Joker1: cardinal; - StaticTeam3Joker2: cardinal; - StaticTeam3Joker3: cardinal; - StaticTeam3Joker4: cardinal; - StaticTeam3Joker5: cardinal; - - StaticParty: array of cardinal; - TextParty: array of cardinal; - StaticNonParty: array of cardinal; - TextNonParty: array of cardinal; - - constructor Create; override; - procedure SetScroll; - //procedure SetScroll1; - //procedure SetScroll2; - procedure SetScroll3; - procedure SetScroll4; - procedure SetScroll5; - procedure SetScroll6; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; override; - function Draw: boolean; override; - procedure GenerateThumbnails(); - procedure OnShow; override; - procedure OnHide; override; - procedure SelectNext(UnloadCover: boolean); - procedure SelectPrev(UnloadCover: boolean); - procedure SkipTo(Target: cardinal); - procedure FixSelected; //Show Wrong Song when Tabs on Fix - procedure FixSelected2; //Show Wrong Song when Tabs on Fix - procedure ShowCatTL(Cat: integer);// Show Cat in Top left - procedure ShowCatTLCustom(Caption: UTF8String);// Show Custom Text in Top left - procedure HideCatTL;// Show Cat in Tob left - procedure Refresh; //Refresh Song Sorting - procedure ChangeMusic; - //Party Mode - procedure SelectRandomSong; - procedure SetJoker; - procedure SetStatics; - //procedures for Menu - procedure StartSong; - procedure OpenEditor; - procedure DoJoker(Team: byte); - procedure SelectPlayers; - - procedure UnloadDetailedCover; - - //Extensions - procedure DrawExtensions; - end; - -implementation - -uses - Math, - gl, - UCovers, - UDLLManager, - UGraphic, - UMain, - UMenuButton, - UNote, - UParty, - UPlaylist, - UScreenSongMenu, - USkins, - UUnicodeUtils; - -// ***** Public methods ****** // - -//Show Wrong Song when Tabs on Fix -procedure TScreenSong.FixSelected; -var - I, I2: integer; -begin - if CatSongs.VisibleSongs > 0 then - begin - I2:= 0; - for I := Low(CatSongs.Song) to High(Catsongs.Song) do - begin - if CatSongs.Song[I].Visible then - inc(I2); - - if I = Interaction - 1 then - break; - end; - - SongCurrent := I2; - SongTarget := I2; - end; -end; - -procedure TScreenSong.FixSelected2; -var - I, I2: integer; -begin - if CatSongs.VisibleSongs > 0 then - begin - I2:= 0; - for I := Low(CatSongs.Song) to High(Catsongs.Song) do - begin - if CatSongs.Song[I].Visible then - inc(I2); - - if I = Interaction - 1 then - break; - end; - - SongTarget := I2; - end; -end; -//Show Wrong Song when Tabs on Fix End - -procedure TScreenSong.ShowCatTLCustom(Caption: UTF8String);// Show Custom Text in Top left -begin - Text[TextCat].Text := Caption; - Text[TextCat].Visible := true; - Static[StaticCat].Visible := false; -end; - -//Show Cat in Top Left Mod -procedure TScreenSong.ShowCatTL(Cat: integer); -begin - //Change - Text[TextCat].Text := CatSongs.Song[Cat].Artist; - Static[StaticCat].Texture := Texture.GetTexture(Button[Cat].Texture.Name, TEXTURE_TYPE_PLAIN, true); - - //Show - Text[TextCat].Visible := true; - Static[StaticCat].Visible := true; -end; - -procedure TScreenSong.HideCatTL; -begin - //Hide - //Text[TextCat].Visible := false; - Static[StaticCat].Visible := false; - //New -> Show Text specified in Theme - Text[TextCat].Visible := true; - Text[TextCat].Text := Theme.Song.TextCat.Text; -end; -//Show Cat in Top Left Mod End - -// Method for input parsing. If false is returned, GetNextWindow -// should be checked to know the next window to load; -function TScreenSong.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -var - I: integer; - I2: integer; - SDL_ModState: word; - UpperLetter: UCS4Char; - TempStr: UTF8String; -begin - Result := true; - - //Song Screen Extensions (Jumpto + Menu) - if (ScreenSongMenu.Visible) then - begin - Result := ScreenSongMenu.ParseInput(PressedKey, CharCode, PressedDown); - Exit; - end - else if (ScreenSongJumpto.Visible) then - begin - Result := ScreenSongJumpto.ParseInput(PressedKey, CharCode, PressedDown); - Exit; - end; - - if (PressedDown) then - begin // Key Down - - SDL_ModState := SDL_GetModState and (KMOD_LSHIFT + KMOD_RSHIFT - + KMOD_LCTRL + KMOD_RCTRL + KMOD_LALT + KMOD_RALT); - - //Jump to Artist/Titel - if ((SDL_ModState and KMOD_LALT <> 0) and (Mode = smNormal)) then - begin - UpperLetter := UCS4UpperCase(CharCode); - - if (UpperLetter in ([Ord('A')..Ord('Z'), Ord('0') .. Ord('9')]) ) then - begin - I2 := Length(CatSongs.Song); - - //Jump To Titel - if (SDL_ModState = (KMOD_LALT or KMOD_LSHIFT)) then - begin - for I := 1 to High(CatSongs.Song) do - begin - if (CatSongs.Song[(I + Interaction) mod I2].Visible) then - begin - TempStr := CatSongs.Song[(I + Interaction) mod I2].Title; - if (Length(TempStr) > 0) and - (UCS4UpperCase(UTF8ToUCS4String(TempStr)[0]) = UpperLetter) then - begin - SkipTo(CatSongs.VisibleIndex((I + Interaction) mod I2)); - - AudioPlayback.PlaySound(SoundLib.Change); - - ChangeMusic; - SetScroll4; - //Break and Exit - Exit; - end; - end; - end; - end - //Jump to Artist - else if (SDL_ModState = KMOD_LALT) then - begin - for I := 1 to High(CatSongs.Song) do - begin - if (CatSongs.Song[(I + Interaction) mod I2].Visible) then - begin - TempStr := CatSongs.Song[(I + Interaction) mod I2].Artist; - if (Length(TempStr) > 0) and - (UCS4UpperCase(UTF8ToUCS4String(TempStr)[0]) = UpperLetter) then - begin - SkipTo(CatSongs.VisibleIndex((I + Interaction) mod I2)); - - AudioPlayback.PlaySound(SoundLib.Change); - - ChangeMusic; - SetScroll4; - - //Break and Exit - Exit; - end; - end; - end; - end; - end; - - Exit; - end; - - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - - Ord('M'): //Show SongMenu - begin - if (Songs.SongList.Count > 0) then - begin - if (Mode = smNormal) then - begin - if (not CatSongs.Song[Interaction].Main) then // clicked on Song - begin - if CatSongs.CatNumShow = -3 then - begin - ScreenSongMenu.OnShow; - ScreenSongMenu.MenuShow(SM_Playlist); - end - else - begin - ScreenSongMenu.OnShow; - ScreenSongMenu.MenuShow(SM_Main); - end; - end - else - begin - ScreenSongMenu.OnShow; - ScreenSongMenu.MenuShow(SM_Playlist_Load); - end; - end //Party Mode -> Show Party Menu - else - begin - ScreenSongMenu.OnShow; - ScreenSongMenu.MenuShow(SM_Party_Main); - end; - end; - Exit; - end; - - Ord('P'): //Show Playlist Menu - begin - if (Songs.SongList.Count > 0) and (Mode = smNormal) then - begin - ScreenSongMenu.OnShow; - ScreenSongMenu.MenuShow(SM_Playlist_Load); - end; - Exit; - end; - - Ord('J'): //Show Jumpto Menu - begin - if (Songs.SongList.Count > 0) and (Mode = smNormal) then - begin - ScreenSongJumpto.Visible := true; - end; - Exit; - end; - - Ord('E'): - begin - OpenEditor; - Exit; - end; - - Ord('R'): - begin - if (Songs.SongList.Count > 0) and - (Mode = smNormal) then - begin - if (SDL_ModState = KMOD_LSHIFT) and (Ini.TabsAtStartup = 1) then // random category - begin - I2 := 0; // count cats - for I := 0 to High(CatSongs.Song) do - begin - if CatSongs.Song[I].Main then - Inc(I2); - end; - - I2 := Random(I2 + 1); // random and include I2 - - // find cat: - for I := 0 to High(CatSongs.Song) do - begin - if CatSongs.Song[I].Main then - Dec(I2); - if (I2 <= 0) then - begin - // show cat in top left mod - ShowCatTL (I); - - Interaction := I; - - CatSongs.ShowCategoryList; - CatSongs.ClickCategoryButton(I); - SelectNext(true); - FixSelected; - break; - end; - end; - end - else if (SDL_ModState = KMOD_LCTRL) and (Ini.TabsAtStartup = 1) then // random in all categories - begin - repeat - I2 := Random(High(CatSongs.Song) + 1); - until (not CatSongs.Song[I2].Main); - - // search cat - for I := I2 downto 0 do - begin - if CatSongs.Song[I].Main then - break; - end; - - // in I is now the categorie in I2 the song - - // choose cat - CatSongs.ShowCategoryList; - - // show cat in top left mod - ShowCatTL (I); - - CatSongs.ClickCategoryButton(I); - SelectNext(true); - - // Fix: not existing song selected: - //if (I + 1 = I2) then - Inc(I2); - - // choose song - SkipTo(I2 - I); - end - else // random in one category - begin - SkipTo(Random(CatSongs.VisibleSongs)); - end; - AudioPlayback.PlaySound(SoundLib.Change); - - ChangeMusic; - SetScroll4; - end; - Exit; - end; - end; // normal keys - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - if (Mode = smNormal) then - begin - //On Escape goto Cat-List Hack - if (Ini.TabsAtStartup = 1) and (CatSongs.CatNumShow <> -1) then - begin - //Find Category - I := Interaction; - while (not CatSongs.Song[I].Main) do - begin - Dec(I); - if (I < 0) then - break; - end; - if (I <= 1) then - Interaction := High(CatSongs.Song) - else - Interaction := I - 1; - - //Stop Music - StopMusicPreview(); - - CatSongs.ShowCategoryList; - - //Show Cat in Top Left Mod - HideCatTL; - - //Show Wrong Song when Tabs on Fix - SelectNext(true); - FixSelected; - //SelectPrev(true); - //CatSongs.Song[0].Visible := false; - end - else - begin - //On Escape goto Cat-List Hack End - //Tabs off and in Search or Playlist -> Go back to Song view - if (CatSongs.CatNumShow < -1) then - begin - //Atm: Set Empty Filter - CatSongs.SetFilter('', fltAll); - - //Show Cat in Top Left Mod - HideCatTL; - Interaction := 0; - - //Show Wrong Song when Tabs on Fix - SelectNext(true); - FixSelected; - - ChangeMusic; - end - else - begin - StopMusicPreview(); - AudioPlayback.PlaySound(SoundLib.Back); - - FadeTo(@ScreenMain); - end; - - end; - end - //When in party Mode then Ask before Close - else if (Mode = smPartyMode) then - begin - AudioPlayback.PlaySound(SoundLib.Back); - CheckFadeTo(@ScreenMain,'MSG_END_PARTY'); - end; - end; - SDLK_RETURN: - begin - if (Songs.SongList.Count > 0) then - begin - if CatSongs.Song[Interaction].Main then - begin // clicked on Category Button - //Show Cat in Top Left Mod - ShowCatTL (Interaction); - - //I := CatSongs.VisibleIndex(Interaction); - CatSongs.ClickCategoryButton(Interaction); - {I2 := CatSongs.VisibleIndex(Interaction); - SongCurrent := SongCurrent - I + I2; - SongTarget := SongTarget - I + I2; } - - // SetScroll4; - - //Show Wrong Song when Tabs on Fix - SelectNext(true); - FixSelected; - - //Play Music: - ChangeMusic; - end - else - begin // clicked on song - if (Mode = smNormal) then //Normal Mode -> Start Song - begin - //Do the Action that is specified in Ini - case Ini.OnSongClick of - 0: StartSong; - 1: SelectPlayers; - 2:begin - if (CatSongs.CatNumShow = -3) then - ScreenSongMenu.MenuShow(SM_Playlist) - else - ScreenSongMenu.MenuShow(SM_Main); - end; - end; - end - else if (Mode = smPartyMode) then //PartyMode -> Show Menu - begin - if (Ini.PartyPopup = 1) then - ScreenSongMenu.MenuShow(SM_Party_Main) - else - ScreenSong.StartSong; - end; - end; - end; - end; - - SDLK_DOWN: - begin - if (Mode = smNormal) then - begin - //Only Change Cat when not in Playlist or Search Mode - if (CatSongs.CatNumShow > -2) then - begin - //Cat Change Hack - if Ini.TabsAtStartup = 1 then - begin - I := Interaction; - if I <= 0 then - I := 1; - - while not catsongs.Song[I].Main do - begin - Inc (I); - if (I > High(catsongs.Song)) then - I := Low(catsongs.Song); - end; - - Interaction := I; - - //Show Cat in Top Left Mod - ShowCatTL (Interaction); - - CatSongs.ClickCategoryButton(Interaction); - SelectNext(true); - FixSelected; - - //Play Music: - AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; - - end; - - // - //Cat Change Hack End} - end; - end; - end; - SDLK_UP: - begin - if (Mode = smNormal) then - begin - //Only Change Cat when not in Playlist or Search Mode - if (CatSongs.CatNumShow > -2) then - begin - //Cat Change Hack - if Ini.TabsAtStartup = 1 then - begin - I := Interaction; - I2 := 0; - if I <= 0 then - I := 1; - - while not catsongs.Song[I].Main or (I2 = 0) do - begin - if catsongs.Song[I].Main then - Inc(I2); - Dec (I); - if (I < Low(catsongs.Song)) then - I := High(catsongs.Song); - end; - - Interaction := I; - - //Show Cat in Top Left Mod - ShowCatTL (I); - - CatSongs.ClickCategoryButton(I); - SelectNext(true); - FixSelected; - - //Play Music: - AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; - end; - end; - //Cat Change Hack End} - end; - end; - - SDLK_RIGHT: - begin - if (Songs.SongList.Count > 0) and (Mode = smNormal) then - begin - AudioPlayback.PlaySound(SoundLib.Change); - SelectNext(true); - //InteractNext; - //SongTarget := Interaction; - ChangeMusic; - SetScroll4; - end; - end; - - SDLK_LEFT: - begin - if (Songs.SongList.Count > 0)and (Mode = smNormal) then - begin - AudioPlayback.PlaySound(SoundLib.Change); - SelectPrev(true); - ChangeMusic; - SetScroll4; - end; - end; - - SDLK_1: - begin //Joker - if (Mode = smPartyMode) and (PartySession.Teams.NumTeams >= 1) and (PartySession.Teams.Teaminfo[0].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[0].Joker); - SelectRandomSong; - SetJoker; - end; - end; - - SDLK_2: - begin //Joker - if (Mode = smPartyMode) and (PartySession.Teams.NumTeams >= 2) and (PartySession.Teams.Teaminfo[1].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[1].Joker); - SelectRandomSong; - SetJoker; - end; - end; - - SDLK_3: - begin //Joker - if (Mode = smPartyMode) and (PartySession.Teams.NumTeams >= 3) and (PartySession.Teams.Teaminfo[2].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[2].Joker); - SelectRandomSong; - SetJoker; - end; - end; - end; - end; // if (PressedDown) -end; - -function TScreenSong.ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; - var - I, J: Integer; - Btn: Integer; -begin - Result := true; - - if (ScreenSongMenu.Visible) then - begin - Result := ScreenSongMenu.ParseMouse(MouseButton, BtnDown, X, Y); - exit; - end - else if (ScreenSongJumpTo.Visible) then - begin - Result := ScreenSongJumpTo.ParseMouse(MouseButton, BtnDown, X, Y); - exit; - end - else // no extension visible - begin - if (BtnDown) then - begin - //if RightMbESC is set, send ESC keypress - if RightMbESC and (MouseButton = SDL_BUTTON_RIGHT) then - Result:=ParseInput(SDLK_ESCAPE, 0, true) - - //song scrolling with mousewheel - else if (MouseButton = SDL_BUTTON_WHEELDOWN) then - ParseInput(SDLK_RIGHT, 0, true) - - else if (MouseButton = SDL_BUTTON_WHEELUP) then - ParseInput(SDLK_LEFT, 0, true) - - //LMB anywhere starts - else if (MouseButton = SDL_BUTTON_LEFT) then - begin - if (CatSongs.VisibleSongs > 4) then - begin - // select the second visible button left from selected - I := 0; - Btn := Interaction; - while (I < 2) do - begin - Dec(Btn); - if (Btn < 0) then - Btn := High(CatSongs.Song); - - if (CatSongs.Song[Btn].Visible) then - Inc(I); - end; - - // test the 5 front buttons for click - for I := 0 to 4 do - begin - if InRegion(X, Y, Button[Btn].GetMouseOverArea) then - begin - // song cover clicked - if (I = 2) then - begin // Selected Song clicked -> start singing - ParseInput(SDLK_RETURN, 0, true); - end - else - begin // one of the other 4 covers in the front clicked -> select it - J := I - 2; - while (J < 0) do - begin - ParseInput(SDLK_LEFT, 0, true); - Inc(J); - end; - - while (J > 0) do - begin - ParseInput(SDLK_RIGHT, 0, true); - Dec(J); - end; - end; - Break; - end; - - Btn := CatSongs.FindNextVisible(Btn); - if (Btn = -1) then - Break; - end; - end - else - ParseInput(SDLK_RETURN, 0, true); - end; - end; - end; -end; - -constructor TScreenSong.Create; -var - i: integer; -begin - inherited Create; - - LoadFromTheme(Theme.Song); - - TextArtist := AddText(Theme.Song.TextArtist); - TextTitle := AddText(Theme.Song.TextTitle); - TextNumber := AddText(Theme.Song.TextNumber); - - //Show Cat in Top Left mod - TextCat := AddText(Theme.Song.TextCat); - StaticCat := AddStatic(Theme.Song.StaticCat); - - //Show Video Icon Mod - VideoIcon := AddStatic(Theme.Song.VideoIcon); - - //Party Mode - StaticTeam1Joker1 := AddStatic(Theme.Song.StaticTeam1Joker1); - StaticTeam1Joker2 := AddStatic(Theme.Song.StaticTeam1Joker2); - StaticTeam1Joker3 := AddStatic(Theme.Song.StaticTeam1Joker3); - StaticTeam1Joker4 := AddStatic(Theme.Song.StaticTeam1Joker4); - StaticTeam1Joker5 := AddStatic(Theme.Song.StaticTeam1Joker5); - - StaticTeam2Joker1 := AddStatic(Theme.Song.StaticTeam2Joker1); - StaticTeam2Joker2 := AddStatic(Theme.Song.StaticTeam2Joker2); - StaticTeam2Joker3 := AddStatic(Theme.Song.StaticTeam2Joker3); - StaticTeam2Joker4 := AddStatic(Theme.Song.StaticTeam2Joker4); - StaticTeam2Joker5 := AddStatic(Theme.Song.StaticTeam2Joker5); - - StaticTeam3Joker1 := AddStatic(Theme.Song.StaticTeam3Joker1); - StaticTeam3Joker2 := AddStatic(Theme.Song.StaticTeam3Joker2); - StaticTeam3Joker3 := AddStatic(Theme.Song.StaticTeam3Joker3); - StaticTeam3Joker4 := AddStatic(Theme.Song.StaticTeam3Joker4); - StaticTeam3Joker5 := AddStatic(Theme.Song.StaticTeam3Joker5); - - //Load Party or NonParty specific Statics and Texts - SetLength(StaticParty, Length(Theme.Song.StaticParty)); - for i := 0 to High(Theme.Song.StaticParty) do - StaticParty[i] := AddStatic(Theme.Song.StaticParty[i]); - - SetLength(TextParty, Length(Theme.Song.TextParty)); - for i := 0 to High(Theme.Song.TextParty) do - TextParty[i] := AddText(Theme.Song.TextParty[i]); - - SetLength(StaticNonParty, Length(Theme.Song.StaticNonParty)); - for i := 0 to High(Theme.Song.StaticNonParty) do - StaticNonParty[i] := AddStatic(Theme.Song.StaticNonParty[i]); - - SetLength(TextNonParty, Length(Theme.Song.TextNonParty)); - for i := 0 to High(Theme.Song.TextNonParty) do - TextNonParty[i] := AddText(Theme.Song.TextNonParty[i]); - - // Song List - //Songs.LoadSongList; // moved to the UltraStar unit - CatSongs.Refresh; - - GenerateThumbnails(); - - // Randomize Patch - Randomize; - - Equalizer := Tms_Equalizer.Create(AudioPlayback, Theme.Song.Equalizer); - - PreviewOpened := -1; -end; - -procedure TScreenSong.GenerateThumbnails(); -var - I: integer; - CoverButtonIndex: integer; - CoverButton: TButton; - CoverTexture: TTexture; - Cover: TCover; - CoverFile: IPath; - Song: TSong; -begin - if (Length(CatSongs.Song) <= 0) then - Exit; - - // set length of button array once instead for every song - SetButtonLength(Length(CatSongs.Song)); - - // create all buttons - for I := 0 to High(CatSongs.Song) do - begin - CoverButton := nil; - - // create a clickable cover - CoverButtonIndex := AddButton(300 + I*250, 140, 200, 200, PATH_NONE, TEXTURE_TYPE_PLAIN, Theme.Song.Cover.Reflections); - if (CoverButtonIndex > -1) then - CoverButton := Button[CoverButtonIndex]; - if (CoverButton = nil) then - Continue; - - Song := CatSongs.Song[I]; - - CoverFile := Song.Path.Append(Song.Cover); - if (not CoverFile.IsFile()) then - Song.Cover := PATH_NONE; - - if (Song.Cover.IsUnset) then - CoverFile := Skin.GetTextureFileName('SongCover'); - - // load cover and cache its texture - Cover := Covers.FindCover(CoverFile); - if (Cover = nil) then - Cover := Covers.AddCover(CoverFile); - - // use the cached texture - // TODO: this is a workaround until the new song-loading works. - // The TCover object should be added to the song-object. The thumbnails - // should be loaded each time the song-screen is shown (it is real fast). - // This way, we will not waste that much memory and have a link between - // song and cover. - if (Cover <> nil) then - begin - CoverTexture := Cover.GetPreviewTexture(); - Texture.AddTexture(CoverTexture, TEXTURE_TYPE_PLAIN, true); - CoverButton.Texture := CoverTexture; - - // set selected to false -> the right texture will be displayed - CoverButton.Selected := False; - end; - - Cover.Free; - end; - - // reset selection - if (Length(CatSongs.Song) > 0) then - Interaction := 0; -end; - -procedure TScreenSong.SetScroll; -var - VS, B: integer; -begin - VS := CatSongs.VisibleSongs; - if VS > 0 then - begin - // Set Positions - case Theme.Song.Cover.Style of - 3: SetScroll3; - 5:begin - if VS > 5 then - SetScroll5 - else - SetScroll4; - end; - 6: SetScroll6; - else SetScroll4; - end; - - // Set visibility of video icon - Static[VideoIcon].Visible := CatSongs.Song[Interaction].Video.IsSet; - - // Set texts - Text[TextArtist].Text := CatSongs.Song[Interaction].Artist; - Text[TextTitle].Text := CatSongs.Song[Interaction].Title; - if (Ini.TabsAtStartup = 1) and (CatSongs.CatNumShow = -1) then - begin - Text[TextNumber].Text := IntToStr(CatSongs.Song[Interaction].OrderNum) + '/' + IntToStr(CatSongs.CatCount); - Text[TextTitle].Text := '(' + IntToStr(CatSongs.Song[Interaction].CatNumber) + ' ' + Language.Translate('SING_SONGS_IN_CAT') + ')'; - end - else if (CatSongs.CatNumShow = -2) then - Text[TextNumber].Text := IntToStr(CatSongs.VisibleIndex(Interaction)+1) + '/' + IntToStr(VS) - else if (CatSongs.CatNumShow = -3) then - Text[TextNumber].Text := IntToStr(CatSongs.VisibleIndex(Interaction)+1) + '/' + IntToStr(VS) - else if (Ini.TabsAtStartup = 1) then - Text[TextNumber].Text := IntToStr(CatSongs.Song[Interaction].CatNumber) + '/' + IntToStr(CatSongs.Song[Interaction - CatSongs.Song[Interaction].CatNumber].CatNumber) - else - Text[TextNumber].Text := IntToStr(Interaction+1) + '/' + IntToStr(Length(CatSongs.Song)); - end - else - begin - Text[TextNumber].Text := '0/0'; - Text[TextArtist].Text := ''; - Text[TextTitle].Text := ''; - for B := 0 to High(Button) do - Button[B].Visible := false; - - end; -end; - -(* -procedure TScreenSong.SetScroll1; -var - B: integer; // button - //BMin: integer; // button min // Auto Removed, Unused Variable - //BMax: integer; // button max // Auto Removed, Unused Variable - Src: integer; - //Dst: integer; - Count: integer; // Dst is not used. Count is used. - Ready: boolean; - - VisCount: integer; // count of visible (or selectable) buttons - VisInt: integer; // visible position of interacted button - Typ: integer; // 0 when all songs fits the screen - Placed: integer; // number of placed visible buttons -begin - //Src := 0; - //Dst := -1; - Count := 1; - Typ := 0; - Ready := false; - Placed := 0; - - VisCount := 0; - for B := 0 to High(Button) do - if CatSongs.Song[B].Visible then - Inc(VisCount); - - VisInt := 0; - for B := 0 to Interaction-1 do - if CatSongs.Song[B].Visible then - Inc(VisInt); - - if VisCount <= 6 then - begin - Typ := 0; - end - else - begin - if VisInt <= 3 then - begin - Typ := 1; - Count := 7; - Ready := true; - end; - - if (VisCount - VisInt) <= 3 then - begin - Typ := 2; - Count := 7; - Ready := true; - end; - - if not Ready then - begin - Typ := 3; - Src := Interaction; - end; - end; - - - // hide all buttons - for B := 0 to High(Button) do - begin - Button[B].Visible := false; - Button[B].Selectable := CatSongs.Song[B].Visible; - end; - - { - for B := Src to Dst do - begin - //Button[B].Visible := true; - Button[B].Visible := CatSongs.Song[B].Visible; - Button[B].Selectable := Button[B].Visible; - Button[B].Y := 140 + (B-Src) * 60; - end; - } - - if Typ = 0 then - begin - for B := 0 to High(Button) do - begin - if CatSongs.Song[B].Visible then - begin - Button[B].Visible := true; - Button[B].Y := 140 + (Placed) * 60; - Inc(Placed); - end; - end; - end; - - if Typ = 1 then - begin - B := 0; - while (Count > 0) do - begin - if CatSongs.Song[B].Visible then - begin - Button[B].Visible := true; - Button[B].Y := 140 + (Placed) * 60; - Inc(Placed); - Dec(Count); - end; - Inc(B); - end; - end; - - if Typ = 2 then - begin - B := High(Button); - while (Count > 0) do - begin - if CatSongs.Song[B].Visible then - begin - Button[B].Visible := true; - Button[B].Y := 140 + (6-Placed) * 60; - Inc(Placed); - Dec(Count); - end; - Dec(B); - end; - end; - - if Typ = 3 then - begin - B := Src; - Count := 4; - while (Count > 0) do - begin - if CatSongs.Song[B].Visible then - begin - Button[B].Visible := true; - Button[B].Y := 140 + (3+Placed) * 60; - Inc(Placed); - Dec(Count); - end; - Inc(B); - end; - - B := Src-1; - Placed := 0; - Count := 3; - while (Count > 0) do - begin - if CatSongs.Song[B].Visible then - begin - Button[B].Visible := true; - Button[B].Y := 140 + (2-Placed) * 60; - Inc(Placed); - Dec(Count); - end; - Dec(B); - end; - - end; - - if Length(Button) > 0 then - Static[1].Texture.Y := Button[Interaction].Y - 5; // selection texture -end; - -procedure TScreenSong.SetScroll2; -var - B: integer; - //Factor: integer; // factor of position relative to center of screen - //Factor2: real; -begin - // line - for B := 0 to High(Button) do - Button[B].X := 300 + (B - Interaction) * 260; - - if Length(Button) >= 3 then - begin - if Interaction = 0 then - Button[High(Button)].X := 300 - 260; - - if Interaction = High(Button) then - Button[0].X := 300 + 260; - end; - - // circle - { - for B := 0 to High(Button) do - begin - Factor := (B - Interaction); // 0 to center, -1: to left, +1 to right - Factor2 := Factor / Length(Button); - Button[B].X := 300 + 10000 * sin(2*pi*Factor2); - //Button[B].Y := 140 + 50 * ; - end; - } -end; -*) - -procedure TScreenSong.SetScroll3; // with slide -var - B: integer; - //Factor: integer; // factor of position relative to center of screen - //Factor2: real; -begin - SongTarget := Interaction; - - // line - for B := 0 to High(Button) do - begin - Button[B].X := 300 + (B - SongCurrent) * 260; - if (Button[B].X < -Button[B].W) or (Button[B].X > 800) then - Button[B].Visible := false - else - Button[B].Visible := true; - end; - - { - if Length(Button) >= 3 then - begin - if Interaction = 0 then - Button[High(Button)].X := 300 - 260; - - if Interaction = High(Button) then - Button[0].X := 300 + 260; - end; - } - - // circle - { - for B := 0 to High(Button) do - begin - Factor := (B - Interaction); // 0 to center, -1: to left, +1 to right - Factor2 := Factor / Length(Button); - Button[B].X := 300 + 10000 * sin(2*pi*Factor2); - //Button[B].Y := 140 + 50 * ; - end; - } -end; - -(** - * Rotation - *) -procedure TScreenSong.SetScroll4; -var - B: integer; - Angle: real; - Z, Z2: real; - VS: integer; -begin - VS := CatSongs.VisibleSongs(); - - for B := 0 to High(Button) do - begin - Button[B].Visible := CatSongs.Song[B].Visible; - if Button[B].Visible then - begin - // angle between the cover and selected song-cover in radians - Angle := 2*Pi * (CatSongs.VisibleIndex(B) - SongCurrent) / VS; - - // calc z-position from angle - Z := (1 + cos(Angle)) / 2; // scaled to range [0..1] - Z2 := (1 + 2*Z) / 3; // scaled to range [1/3..1] - - // adjust cover's width and height according its z-position - // Note: Theme.Song.Cover.W is not used as width and height are equal - // and Theme.Song.Cover.W is used as circle radius in Scroll5. - Button[B].W := Theme.Song.Cover.H * Z2; - Button[B].H := Button[B].W; - - // set cover position - Button[B].X := Theme.Song.Cover.X + - (0.185 * Theme.Song.Cover.H * VS * sin(Angle)) * Z2 - - ((Button[B].H - Theme.Song.Cover.H)/2); - Button[B].Y := Theme.Song.Cover.Y + - (Theme.Song.Cover.H - Abs(Button[B].H)) * 0.7; - Button[B].Z := Z / 2 + 0.3; - end; - end; -end; - -(** - * rotate - *) -procedure TScreenSong.SetScroll5; -var - B: integer; - Angle: real; - Pos: real; - VS: integer; - Padding: real; - X: real; - { - Theme.Song.CoverW: circle radius - Theme.Song.CoverX: x-pos. of the left edge of the selected cover - Theme.Song.CoverY: y-pos. of the upper edge of the selected cover - Theme.Song.CoverH: cover height - } -begin - VS := CatSongs.VisibleSongs(); - - // Update positions of all buttons - for B := 0 to High(Button) do - begin - Button[B].Visible := CatSongs.Song[B].Visible; // adjust visibility - if Button[B].Visible then // Only change pos for visible buttons - begin - // Pos is the distance to the centered cover in the range [-VS/2..+VS/2] - Pos := (CatSongs.VisibleIndex(B) - SongCurrent); - if (Pos < -VS/2) then - Pos := Pos + VS - else if (Pos > VS/2) then - Pos := Pos - VS; - - // Avoid overlapping of the front covers. - // Use an alternate position for the five front covers. - if (Abs(Pos) < 2.5) then - begin - Angle := Pi * (Pos / 5); // Range: (-1/4*Pi .. +1/4*Pi) - - Button[B].H := Abs(Theme.Song.Cover.H * cos(Angle*0.8)); - Button[B].W := Button[B].H; - - //Button[B].Reflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - Button[B].DeSelectReflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - - Padding := (Button[B].H - Theme.Song.Cover.H)/2; - X := Sin(Angle*1.3) * 0.9; - - Button[B].X := Theme.Song.Cover.X + Theme.Song.Cover.W * X - Padding; - Button[B].Y := (Theme.Song.Cover.Y + (Theme.Song.Cover.H - Abs(Theme.Song.Cover.H * cos(Angle))) * 0.5); - Button[B].Z := 0.95 - Abs(Pos) * 0.01; - end - else - begin - // Transform Pos to range [-1..-1/2, +1/2..+1] - if Pos < 0 then - Pos := Pos/VS - 0.5 - else - Pos := Pos/VS + 0.5; - - // angle in radians [-2Pi..-Pi, +Pi..+2Pi] - Angle := 2*Pi * Pos; - - Button[B].H := 0.6*(Theme.Song.Cover.H-Abs(Theme.Song.Cover.H * cos(Angle/2)*0.8)); - Button[B].W := Button[B].H; - - Padding := (Button[B].H - Theme.Song.Cover.H)/2; - - Button[B].X := Theme.Song.Cover.X+Theme.Song.Cover.H/2-Button[b].H/2+Theme.Song.Cover.W/320*((Theme.Song.Cover.H)*sin(Angle/2)*1.52); - Button[B].Y := Theme.Song.Cover.Y - (Button[B].H - Theme.Song.Cover.H)*0.75; - Button[B].Z := (0.4 - Abs(Pos/4)) -0.00001; //z < 0.49999 is behind the cover 1 is in front of the covers - - //Button[B].Reflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - Button[B].DeSelectReflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - end; - end; - end; -end; - -procedure TScreenSong.SetScroll6; // rotate (slotmachine style) -var - B: integer; - Angle: real; - Pos: real; - VS: integer; - diff: real; - X: real; - Factor: real; - Z, Z2: real; -begin - VS := CatSongs.VisibleSongs; - if VS <= 5 then - begin - // circle - for B := 0 to High(Button) do - begin - Button[B].Visible := CatSongs.Song[B].Visible; - if Button[B].Visible then // optimization for 1000 songs - updates only visible songs, hiding in tabs becomes useful for maintaing good speed - begin - - Factor := 2 * pi * (CatSongs.VisibleIndex(B) - SongCurrent) / VS {CatSongs.VisibleSongs};// 0.5.0 (II): takes another 16ms - - Z := (1 + cos(Factor)) / 2; - Z2 := (1 + 2*Z) / 3; - - Button[B].Y := Theme.Song.Cover.Y + (0.185 * Theme.Song.Cover.H * VS * sin(Factor)) * Z2 - ((Button[B].H - Theme.Song.Cover.H)/2); // 0.5.0 (I): 2 times faster by not calling CatSongs.VisibleSongs - Button[B].Z := Z / 2 + 0.3; - - Button[B].W := Theme.Song.Cover.H * Z2; - - //Button[B].Y := {50 +} 140 + 50 - 50 * Z2; - Button[B].X := Theme.Song.Cover.X + (Theme.Song.Cover.H - Abs(Button[B].H)) * 0.7 ; - Button[B].H := Button[B].W; - end; - end; - end - else - begin - //Change Pos of all Buttons - for B := Low(Button) to High(Button) do - begin - Button[B].Visible := CatSongs.Song[B].Visible; //Adjust Visibility - if Button[B].Visible then //Only Change Pos for Visible Buttons - begin - Pos := (CatSongs.VisibleIndex(B) - SongCurrent); - if (Pos < -VS/2) then - Pos := Pos + VS - else if (Pos > VS/2) then - Pos := Pos - VS; - - if (Abs(Pos) < 2.5) then {fixed Positions} - begin - Angle := Pi * (Pos / 5); - //Button[B].Visible := false; - - Button[B].H := Abs(Theme.Song.Cover.H * cos(Angle*0.8));//Power(Z2, 3); - - Button[B].DeSelectReflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - - Button[B].Z := 0.95 - Abs(Pos) * 0.01; - - Button[B].X := (Theme.Song.Cover.X + (Theme.Song.Cover.H - Abs(Theme.Song.Cover.H * cos(Angle))) * 0.5); - - Button[B].W := Button[B].H; - - Diff := (Button[B].H - Theme.Song.Cover.H)/2; - - X := Sin(Angle*1.3)*0.9; - - Button[B].Y := Theme.Song.Cover.Y + Theme.Song.Cover.W * X - Diff; - end - else - begin {Behind the Front Covers} - - // limit-bg-covers hack - if (abs(VS/2-abs(Pos))>10) then - Button[B].Visible := false; - if VS > 25 then - VS:=25; - // end of limit-bg-covers hack - - if Pos < 0 then - Pos := (Pos - VS/2)/VS - else - Pos := (Pos + VS/2)/VS; - - Angle := Pi * Pos*2; - - Button[B].Z := (0.4 - Abs(Pos/4)) -0.00001; //z < 0.49999 is behind the cover 1 is in front of the covers - - Button[B].H :=0.6*(Theme.Song.Cover.H-Abs(Theme.Song.Cover.H * cos(Angle/2)*0.8));//Power(Z2, 3); - - Button[B].W := Button[B].H; - - Button[B].X := Theme.Song.Cover.X - (Button[B].H - Theme.Song.Cover.H)*0.5; - - Button[B].DeSelectReflectionspacing := 15 * Button[B].H/Theme.Song.Cover.H; - - Button[B].Y := Theme.Song.Cover.Y+Theme.Song.Cover.H/2-Button[b].H/2+Theme.Song.Cover.W/320*(Theme.Song.Cover.H*sin(Angle/2)*1.52); - end; - end; - end; - end; -end; - -procedure TScreenSong.OnShow; -begin - inherited; -{** - * Pause background music, so we can play it again on scorescreen - *} - SoundLib.PauseBgMusic; - - AudioPlayback.Stop; - - if Ini.Players <= 3 then PlayersPlay := Ini.Players + 1; - if Ini.Players = 4 then PlayersPlay := 6; - - //Cat Mod etc - if (Ini.TabsAtStartup = 1) and (CatSongs.CatNumShow = -1) then - begin - CatSongs.ShowCategoryList; - FixSelected; - //Show Cat in Top Left Mod - HideCatTL; - end; - - if Length(CatSongs.Song) > 0 then - begin - //Load Music only when Song Preview is activated - if ( Ini.PreviewVolume <> 0 ) then - StartMusicPreview() - else - PreviewOpened := -1; - - SetScroll; - end; - - //Playlist Mode - if (Mode = smNormal) then - begin - //If Playlist Shown -> Select Next automatically - if (CatSongs.CatNumShow = -3) then - begin - SelectNext(true); - ChangeMusic; - end; - end - //Party Mode - else if (Mode = smPartyMode) then - begin - SelectRandomSong; - //Show Menu directly in PartyMode - //But only if selected in Options - if (Ini.PartyPopup = 1) then - begin - ScreenSongMenu.MenuShow(SM_Party_Main); - end; - end; - - SetJoker; - SetStatics; -end; - -procedure TScreenSong.OnHide; -begin - // if preview is not loaded: load musicfile now; not on cat-main! - if (PreviewOpened <> Interaction) and not CatSongs.Song[Interaction].main then - AudioPlayback.Open(CatSongs.Song[Interaction].Path.Append(CatSongs.Song[Interaction].Mp3)); - - // turn music volume to 100% - AudioPlayback.SetVolume(1.0); - - // if hide then stop music (for party mode popup on exit) - if (Display.NextScreen <> @ScreenSing) and - (Display.NextScreen <> @ScreenSingModi) then - begin - StopMusicPreview(); - end; -end; - -procedure TScreenSong.DrawExtensions; -begin - //Draw Song Menu - if (ScreenSongMenu.Visible) then - begin - ScreenSongMenu.Draw; - end - else if (ScreenSongJumpto.Visible) then - begin - ScreenSongJumpto.Draw; - end -end; - -function TScreenSong.Draw: boolean; -var - dx: real; - dt: real; - I: integer; -begin - dx := SongTarget-SongCurrent; - dt := TimeSkip * 7; - - if dt > 1 then - dt := 1; - - SongCurrent := SongCurrent + dx*dt; - - { - if SongCurrent > Catsongs.VisibleSongs then - begin - SongCurrent := SongCurrent - Catsongs.VisibleSongs; - SongTarget := SongTarget - Catsongs.VisibleSongs; - end; - } - - //Log.BenchmarkStart(5); - - SetScroll; - - //Log.BenchmarkEnd(5); - //Log.LogBenchmark('SetScroll4', 5); - - //Fading Functions, Only if Covertime is under 5 Seconds - if (CoverTime < 5) then - begin - // cover fade - if (CoverTime < 1) and (CoverTime + TimeSkip >= 1) then - begin - // load new texture - Texture.GetTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, false); - Button[Interaction].Texture.Alpha := 1; - Button[Interaction].Texture2 := Texture.GetTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, false); - Button[Interaction].Texture2.Alpha := 1; - end; - - //Update Fading Time - CoverTime := CoverTime + TimeSkip; - - //Update Fading Texture - Button[Interaction].Texture2.Alpha := (CoverTime - 1) * 1.5; - if Button[Interaction].Texture2.Alpha > 1 then - Button[Interaction].Texture2.Alpha := 1; - - end; - - //inherited Draw; - //heres a little Hack, that causes the Statics - //are Drawn after the Buttons because of some Blending Problems. - //This should cause no Problems because all Buttons on this screen - //Has Z Position. - //Draw BG - DrawBG; - - //Instead of Draw FG Procedure: - //We draw Buttons for our own - for I := 0 to Length(Button) - 1 do - Button[I].Draw; - - // Statics - for I := 0 to Length(Static) - 1 do - Static[I].Draw; - - // and texts - for I := 0 to Length(Text) - 1 do - Text[I].Draw; - - Equalizer.Draw; - - DrawExtensions; - - Result := true; -end; - -procedure TScreenSong.SelectNext(UnloadCover: boolean); -var - Skip: integer; - VS: integer; -begin - VS := CatSongs.VisibleSongs; - - if VS > 0 then - begin - if UnloadCover then //that should fix the performance problem on scrolling - UnLoadDetailedCover; - - Skip := 1; - - // this 1 could be changed by CatSongs.FindNextVisible - while (not CatSongs.Song[(Interaction + Skip) mod Length(Interactions)].Visible) do - Inc(Skip); - - SongTarget := SongTarget + 1;//Skip; - - Interaction := (Interaction + Skip) mod Length(Interactions); - - // try to keep all at the beginning - if SongTarget > VS-1 then - begin - SongTarget := SongTarget - VS; - SongCurrent := SongCurrent - VS; - end; - - end; - - // Interaction -> Button, load cover - // show uncached texture - //Button[Interaction].Texture := Texture.GetTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, false); -end; - -procedure TScreenSong.SelectPrev(UnloadCover: boolean); -var - Skip: integer; - VS: integer; -begin - VS := CatSongs.VisibleSongs; - - if VS > 0 then - begin - if UnloadCover then - UnLoadDetailedCover; //that should fix the performance problem on scrolling - - Skip := 1; - - while (not CatSongs.Song[(Interaction - Skip + Length(Interactions)) mod Length(Interactions)].Visible) do - Inc(Skip); - SongTarget := SongTarget - 1;//Skip; - - Interaction := (Interaction - Skip + Length(Interactions)) mod Length(Interactions); - - // try to keep all at the beginning - if SongTarget < 0 then - begin - SongTarget := SongTarget + CatSongs.VisibleSongs; - SongCurrent := SongCurrent + CatSongs.VisibleSongs; - end; - - // show uncached texture - //Button[Interaction].Texture := Texture.GetTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, false); - end; -end; - -procedure TScreenSong.StartMusicPreview(); -var - Song: TSong; -begin - AudioPlayback.Close(); - - Song := CatSongs.Song[Interaction]; - if not assigned(Song) then - Exit; - - //fix: if main cat than there is nothing to play - if Song.main then - Exit; - - if AudioPlayback.Open(Song.Path.Append(Song.Mp3)) then - begin - PreviewOpened := Interaction; - - AudioPlayback.Position := AudioPlayback.Length / 4; - // set preview volume - if (Ini.PreviewFading = 0) then - begin - // music fade disabled: start with full volume - AudioPlayback.SetVolume(IPreviewVolumeVals[Ini.PreviewVolume]); - AudioPlayback.Play() - end - else - begin - // music fade enabled: start muted and fade-in - AudioPlayback.SetVolume(0); - AudioPlayback.FadeIn(Ini.PreviewFading, IPreviewVolumeVals[Ini.PreviewVolume]); - end; - end; -end; - -procedure TScreenSong.StopMusicPreview(); -begin - // Cancel pending preview requests - SDL_RemoveTimer(MusicPreviewTimer); - - // Stop preview of previous song - AudioPlayback.Stop; -end; - -procedure StartMusicPreview(data: Pointer); -var - ScreenSong: TScreenSong; -begin - ScreenSong := TScreenSong(data); - if (ScreenSong <> nil) then - ScreenSong.StartMusicPreview(); -end; - -function MusicPreviewTimerCallback(interval: UInt32; param: Pointer): UInt32; cdecl; -begin - // delegate execution to main-thread - MainThreadExec(@StartMusicPreview, param); - // stop timer - Result := 0; -end; - -// Changes previewed song -procedure TScreenSong.ChangeMusic; -begin - StopMusicPreview(); - PreviewOpened := -1; - - // Preview song if activated and current selection is not a category cover - if (CatSongs.VisibleSongs > 0) and - (not CatSongs.Song[Interaction].Main) and - (Ini.PreviewVolume <> 0) then - begin - // Delay song fading to prevent the song from being played while scrolling - MusicPreviewTimer := SDL_AddTimer(200, MusicPreviewTimerCallback, Self); - end; -end; - -procedure TScreenSong.SkipTo(Target: cardinal); -var - i: integer; -begin - UnLoadDetailedCover; - - Interaction := High(CatSongs.Song); - SongTarget := 0; - - for i := 1 to Target+1 do - SelectNext(false); - - FixSelected2; -end; - -procedure TScreenSong.SelectRandomSong; -var - I, I2: integer; -begin - case PlaylistMan.Mode of - smNormal: // all songs just select random song - begin - // when tabs are activated then use tab method - if (Ini.TabsAtStartup = 1) then - begin - repeat - I2 := Low(CatSongs.Song) + Random(High(CatSongs.Song) + 1 - Low(CatSongs.Song)); - until CatSongs.Song[I2].Main = false; - - // search cat - for I := I2 downto Low(CatSongs.Song) do - begin - if CatSongs.Song[I].Main then - break; - end; - // I is the cat number, I2 is the no of the song within this cat - - // choose cat - CatSongs.ShowCategoryList; - - // show cat in top left mod - ShowCatTL(I); - - CatSongs.ClickCategoryButton(I); - SelectNext(true); - - // choose song - SkipTo(I2 - I); - end - // when tabs are deactivated use easy method - else - SkipTo(Random(CatSongs.VisibleSongs)); - end; - smPartyMode: // one category select category and select random song - begin - CatSongs.ShowCategoryList; - CatSongs.ClickCategoryButton(PlaylistMan.CurPlayList); - ShowCatTL(PlaylistMan.CurPlayList); - - SelectNext(true); - FixSelected2; - - SkipTo(Random(CatSongs.VisibleSongs)); - end; - smPlaylistRandom: // playlist: select playlist and select random song - begin - PlaylistMan.SetPlayList(PlaylistMan.CurPlayList); - - SkipTo(Random(CatSongs.VisibleSongs)); - FixSelected2; - end; - end; - - AudioPlayback.PlaySound(SoundLib.Change); - ChangeMusic; - SetScroll; -end; - -procedure TScreenSong.SetJoker; -begin - // If Party Mode - if Mode = smPartyMode then //Show Joker that are available - begin - if (PartySession.Teams.NumTeams >= 1) then - begin - Static[StaticTeam1Joker1].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 1); - Static[StaticTeam1Joker2].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 2); - Static[StaticTeam1Joker3].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 3); - Static[StaticTeam1Joker4].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 4); - Static[StaticTeam1Joker5].Visible := (PartySession.Teams.Teaminfo[0].Joker >= 5); - end - else - begin - Static[StaticTeam1Joker1].Visible := false; - Static[StaticTeam1Joker2].Visible := false; - Static[StaticTeam1Joker3].Visible := false; - Static[StaticTeam1Joker4].Visible := false; - Static[StaticTeam1Joker5].Visible := false; - end; - - if (PartySession.Teams.NumTeams >= 2) then - begin - Static[StaticTeam2Joker1].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 1); - Static[StaticTeam2Joker2].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 2); - Static[StaticTeam2Joker3].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 3); - Static[StaticTeam2Joker4].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 4); - Static[StaticTeam2Joker5].Visible := (PartySession.Teams.Teaminfo[1].Joker >= 5); - end - else - begin - Static[StaticTeam2Joker1].Visible := false; - Static[StaticTeam2Joker2].Visible := false; - Static[StaticTeam2Joker3].Visible := false; - Static[StaticTeam2Joker4].Visible := false; - Static[StaticTeam2Joker5].Visible := false; - end; - - if (PartySession.Teams.NumTeams >= 3) then - begin - Static[StaticTeam3Joker1].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 1); - Static[StaticTeam3Joker2].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 2); - Static[StaticTeam3Joker3].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 3); - Static[StaticTeam3Joker4].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 4); - Static[StaticTeam3Joker5].Visible := (PartySession.Teams.Teaminfo[2].Joker >= 5); - end - else - begin - Static[StaticTeam3Joker1].Visible := false; - Static[StaticTeam3Joker2].Visible := false; - Static[StaticTeam3Joker3].Visible := false; - Static[StaticTeam3Joker4].Visible := false; - Static[StaticTeam3Joker5].Visible := false; - end; - end - else - begin //Hide all - Static[StaticTeam1Joker1].Visible := false; - Static[StaticTeam1Joker2].Visible := false; - Static[StaticTeam1Joker3].Visible := false; - Static[StaticTeam1Joker4].Visible := false; - Static[StaticTeam1Joker5].Visible := false; - - Static[StaticTeam2Joker1].Visible := false; - Static[StaticTeam2Joker2].Visible := false; - Static[StaticTeam2Joker3].Visible := false; - Static[StaticTeam2Joker4].Visible := false; - Static[StaticTeam2Joker5].Visible := false; - - Static[StaticTeam3Joker1].Visible := false; - Static[StaticTeam3Joker2].Visible := false; - Static[StaticTeam3Joker3].Visible := false; - Static[StaticTeam3Joker4].Visible := false; - Static[StaticTeam3Joker5].Visible := false; - end; -end; - -procedure TScreenSong.SetStatics; -var - I: integer; - Visible: boolean; -begin - //Set Visibility of Party Statics and Text - Visible := (Mode = smPartyMode); - - for I := 0 to High(StaticParty) do - Static[StaticParty[I]].Visible := Visible; - - for I := 0 to High(TextParty) do - Text[TextParty[I]].Visible := Visible; - - //Set Visibility of Non Party Statics and Text - Visible := not Visible; - - for I := 0 to High(StaticNonParty) do - Static[StaticNonParty[I]].Visible := Visible; - - for I := 0 to High(TextNonParty) do - Text[TextNonParty[I]].Visible := Visible; -end; - -//Procedures for Menu - -procedure TScreenSong.StartSong; -begin - CatSongs.Selected := Interaction; - StopMusicPreview(); - - //Party Mode - if (Mode = smPartyMode) then - begin - FadeTo(@ScreenSingModi); - end - else - begin - FadeTo(@ScreenSing); - end; -end; - -procedure TScreenSong.SelectPlayers; -begin - CatSongs.Selected := Interaction; - StopMusicPreview(); - - ScreenName.Goto_SingScreen := true; - FadeTo(@ScreenName); -end; - -procedure TScreenSong.OpenEditor; -begin - if (Songs.SongList.Count > 0) and - (not CatSongs.Song[Interaction].Main) and - (Mode = smNormal) then - begin - StopMusicPreview(); - AudioPlayback.PlaySound(SoundLib.Start); - CurrentSong := CatSongs.Song[Interaction]; - FadeTo(@ScreenEditSub); - end; -end; - -//Team No of Team (0-5) -procedure TScreenSong.DoJoker (Team: byte); -begin - if (Mode = smPartyMode) and - (PartySession.Teams.NumTeams >= Team + 1) and - (PartySession.Teams.Teaminfo[Team].Joker > 0) then - begin - //Use Joker - Dec(PartySession.Teams.Teaminfo[Team].Joker); - SelectRandomSong; - SetJoker; - end; -end; - -//Detailed Cover Unloading. Unloads the Detailed, uncached Cover of the cur. Song -procedure TScreenSong.UnloadDetailedCover; -begin - CoverTime := 0; - - // show cached texture - Button[Interaction].Texture := Texture.GetTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, true); - Button[Interaction].Texture2.Alpha := 0; - - if Button[Interaction].Texture.Name <> Skin.GetTextureFileName('SongCover') then - Texture.UnloadTexture(Button[Interaction].Texture.Name, TEXTURE_TYPE_PLAIN, false); -end; - -procedure TScreenSong.Refresh; -begin - { - CatSongs.Refresh; - CatSongs.ShowCategoryList; - Interaction := 0; - SelectNext(true); - FixSelected; - } -end; - -end. diff --git a/src/screens/UScreenSongJumpto.pas b/src/screens/UScreenSongJumpto.pas deleted file mode 100644 index 7f82bbec..00000000 --- a/src/screens/UScreenSongJumpto.pas +++ /dev/null @@ -1,244 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenSongJumpto; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SDL, - SysUtils, - UMenu, - UDisplay, - UMusic, - UFiles, - USongs, - UThemes; - -type - TScreenSongJumpto = class(TMenu) - private - //For ChangeMusic - fLastPlayed: integer; - fVisible: boolean; - fSelectType: TSongFilter; - fVisSongs: integer; - - procedure SetTextFound(Count: Cardinal); - - //Visible //Whether the Menu should be Drawn - //Whether the Menu should be Drawn - procedure SetVisible(Value: boolean); - public - constructor Create; override; - - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - function Draw: boolean; override; - - property Visible: boolean read fVisible write SetVisible; - end; - -implementation - -uses - UGraphic, - UMain, - UIni, - UTexture, - ULanguage, - UParty, - UScreenSong, - ULog, - UUnicodeUtils; - -function TScreenSongJumpto.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - if (IsAlphaNumericChar(CharCode) or - IsPunctuationChar(CharCode)) then - begin - if (Interaction = 0) then - begin - Button[0].Text[0].Text := Button[0].Text[0].Text + UCS4ToUTF8String(CharCode); - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); - end; - end; - - // check special keys - case PressedKey of - SDLK_BACKSPACE: - begin - if (Interaction = 0) and (Length(Button[0].Text[0].Text) > 0) then - begin - Button[0].Text[0].DeleteLastLetter(); - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); - end; - end; - - SDLK_RETURN, - SDLK_ESCAPE: - begin - Visible := false; - AudioPlayback.PlaySound(SoundLib.Back); - if (fVisSongs = 0) and (Length(Button[0].Text[0].Text) > 0) then - begin - ScreenSong.UnLoadDetailedCover; - Button[0].Text[0].Text := ''; - CatSongs.SetFilter('', fltAll); - SetTextFound(0); - end; - end; - - SDLK_DOWN: - begin - {SelectNext; - Button[0].Text[0].Selected := (Interaction = 0);} - end; - - SDLK_UP: - begin - {SelectPrev; - Button[0].Text[0].Selected := (Interaction = 0); } - end; - - SDLK_RIGHT: - begin - Interaction := 1; - InteractInc; - if (Length(Button[0].Text[0].Text) > 0) then - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); - Interaction := 0; - end; - SDLK_LEFT: - begin - Interaction := 1; - InteractDec; - if (Length(Button[0].Text[0].Text) > 0) then - SetTextFound(CatSongs.SetFilter(Button[0].Text[0].Text, fSelectType)); - Interaction := 0; - end; - end; - end; -end; - -constructor TScreenSongJumpto.Create; -begin - inherited Create; - - AddText(Theme.SongJumpto.TextFound); - - LoadFromTheme(Theme.SongJumpto); - - AddButton(Theme.SongJumpto.ButtonSearchText); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, ''); - - fSelectType := fltAll; - AddSelectSlide(Theme.SongJumpto.SelectSlideType, PInteger(@fSelectType)^, Theme.SongJumpto.IType); - - Interaction := 0; - fLastPlayed := 0; -end; - -procedure TScreenSongJumpto.SetVisible(Value: boolean); -begin -//If change from invisible to Visible then OnShow - if (fVisible = false) and (Value = true) then - OnShow; - - fVisible := Value; -end; - -procedure TScreenSongJumpto.OnShow; -begin - inherited; - - //Reset Screen if no Old Search is Displayed - if (CatSongs.CatNumShow <> -2) then - begin - SelectsS[0].SetSelectOpt(0); - - Button[0].Text[0].Text := ''; - Text[0].Text := Theme.SongJumpto.NoSongsFound; - end; - - //Select Input - Interaction := 0; - Button[0].Text[0].Selected := true; - - fLastPlayed := ScreenSong.Interaction; -end; - -function TScreenSongJumpto.Draw: boolean; -begin - Result := inherited Draw; -end; - -procedure TScreenSongJumpto.SetTextFound(Count: cardinal); -begin - if (Count = 0) then - begin - Text[0].Text := Theme.SongJumpto.NoSongsFound; - if (Length(Button[0].Text[0].Text) = 0) then - ScreenSong.HideCatTL - else - ScreenSong.ShowCatTLCustom(Format(Theme.SongJumpto.CatText, [Button[0].Text[0].Text])); - end - else - begin - Text[0].Text := Format(Theme.SongJumpto.SongsFound, [Count]); - - //Set CatTopLeftText - ScreenSong.ShowCatTLCustom(Format(Theme.SongJumpto.CatText, [Button[0].Text[0].Text])); - end; - - //Set visSongs - fVisSongs := Count; - - //Fix SongSelection - ScreenSong.Interaction := high(CatSongs.Song); - ScreenSong.SelectNext(true); - ScreenSong.FixSelected; - - //Play Correct Music - if (ScreenSong.Interaction <> fLastPlayed) then - begin - fLastPlayed := ScreenSong.Interaction; - - ScreenSong.ChangeMusic; - end; -end; - -end. diff --git a/src/screens/UScreenSongMenu.pas b/src/screens/UScreenSongMenu.pas deleted file mode 100644 index ec893c7a..00000000 --- a/src/screens/UScreenSongMenu.pas +++ /dev/null @@ -1,661 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenSongMenu; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - UDisplay, - UMusic, - UFiles, - SysUtils, - UThemes; - -type - TScreenSongMenu = class(TMenu) - private - CurMenu: byte; // num of the cur. shown menu - public - Visible: boolean; // whether the menu should be drawn - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - function Draw: boolean; override; - procedure MenuShow(sMenu: byte); - procedure HandleReturn; - end; - -const - SM_Main = 1; - - SM_PlayList = 64 or 1; - SM_Playlist_Add = 64 or 2; - SM_Playlist_New = 64 or 3; - - SM_Playlist_DelItem = 64 or 5; - - SM_Playlist_Load = 64 or 8 or 1; - SM_Playlist_Del = 64 or 8 or 5; - - SM_Party_Main = 128 or 1; - SM_Party_Joker = 128 or 2; - -var - ISelections: array of UTF8String; - SelectValue: integer; - -implementation - -uses - UGraphic, - UMain, - UIni, - UTexture, - ULanguage, - UParty, - UPlaylist, - USongs, - UUnicodeUtils; - -function TScreenSongMenu.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // key down - if (CurMenu = SM_Playlist_New) and (Interaction=0) then - begin - // check normal keys - if IsAlphaNumericChar(CharCode) or - (CharCode in [Ord(' '), Ord('-'), Ord('_'), Ord('!'), - Ord(','), Ord('<'), Ord('/'), Ord('*'), - Ord('?'), Ord(''''), Ord('"')]) then - begin - Button[Interaction].Text[0].Text := Button[Interaction].Text[0].Text + - UCS4ToUTF8String(CharCode); - exit; - end; - - // check special keys - case PressedKey of - SDLK_BACKSPACE: - begin - Button[Interaction].Text[0].DeleteLastLetter; - exit; - end; - end; - end; - - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE: - begin - AudioPlayback.PlaySound(SoundLib.Back); - Visible := false; - end; - - SDLK_RETURN: - begin - HandleReturn; - end; - - SDLK_DOWN: InteractNext; - SDLK_UP: InteractPrev; - - SDLK_RIGHT: - begin - if (Interaction=3) then - InteractInc; - end; - SDLK_LEFT: - begin - if (Interaction=3) then - InteractDec; - end; - - SDLK_1: - begin // jocker - // use joker - case CurMenu of - SM_Party_Main: - begin - ScreenSong.DoJoker(0) - end; - end; - end; - SDLK_2: - begin // jocker - // use joker - case CurMenu of - SM_Party_Main: - begin - ScreenSong.DoJoker(1) - end; - end; - end; - SDLK_3: - begin // jocker - // use joker - case CurMenu of - SM_Party_Main: - begin - ScreenSong.DoJoker(2) - end; - end; - end; - end; // case - end; // if -end; - -constructor TScreenSongMenu.Create; -begin - inherited Create; - - // create dummy selectslide entrys - SetLength(ISelections, 1); - ISelections[0] := 'Dummy'; - - AddText(Theme.SongMenu.TextMenu); - - LoadFromTheme(Theme.SongMenu); - - AddButton(Theme.SongMenu.Button1); - if (Length(Button[0].Text) = 0) then - AddButtonText(14, 20, 'Button 1'); - - AddButton(Theme.SongMenu.Button2); - if (Length(Button[1].Text) = 0) then - AddButtonText(14, 20, 'Button 2'); - - AddButton(Theme.SongMenu.Button3); - if (Length(Button[2].Text) = 0) then - AddButtonText(14, 20, 'Button 3'); - - AddSelectSlide(Theme.SongMenu.SelectSlide3, SelectValue, ISelections); - - AddButton(Theme.SongMenu.Button4); - if (Length(Button[3].Text) = 0) then - AddButtonText(14, 20, 'Button 4'); - - Interaction := 0; -end; - -function TScreenSongMenu.Draw: boolean; -begin - Result := inherited Draw; -end; - -procedure TScreenSongMenu.OnShow; -begin - inherited; -end; - -procedure TScreenSongMenu.MenuShow(sMenu: byte); -begin - Interaction := 0; // reset interaction - Visible := true; // set visible - case sMenu of - SM_Main: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_MAIN'); - - Button[0].Visible := true; - Button[1].Visible := true; - Button[2].Visible := true; - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_PLAY'); - Button[1].Text[0].Text := Language.Translate('SONG_MENU_CHANGEPLAYERS'); - Button[2].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_ADD'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_EDIT'); - end; - - SM_PlayList: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PLAYLIST'); - - Button[0].Visible := true; - Button[1].Visible := true; - Button[2].Visible := true; - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_PLAY'); - Button[1].Text[0].Text := Language.Translate('SONG_MENU_CHANGEPLAYERS'); - Button[2].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_DEL'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_EDIT'); - end; - - SM_Playlist_Add: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PLAYLIST_ADD'); - - Button[0].Visible := true; - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := true; - SelectsS[0].Visible := true; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_ADD_NEW'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_ADD_EXISTING'); - - SetLength(ISelections, Length(PlaylistMan.Playlists)); - PlaylistMan.GetNames(ISelections); - - if (Length(ISelections)>=1) then - begin - UpdateSelectSlideOptions(Theme.SongMenu.SelectSlide3, 0, ISelections, SelectValue); - end - else - begin - Button[3].Visible := false; - SelectsS[0].Visible := false; - Button[2].Visible := true; - Button[2].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_NOEXISTING'); - end; - end; - - SM_Playlist_New: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PLAYLIST_NEW'); - - Button[0].Visible := true; - Button[1].Visible := false; - Button[2].Visible := true; - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_NEW_UNNAMED'); - Button[2].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_NEW_CREATE'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_CANCEL'); - end; - - SM_Playlist_DelItem: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PLAYLIST_DELITEM'); - - Button[0].Visible := true; - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_YES'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_CANCEL'); - end; - - SM_Playlist_Load: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PLAYLIST_LOAD'); - - // show delete curent playlist button when playlist is opened - Button[0].Visible := (CatSongs.CatNumShow = -3); - - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := true; - SelectsS[0].Visible := true; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_DELCURRENT'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_LOAD'); - - SetLength(ISelections, Length(PlaylistMan.Playlists)); - PlaylistMan.GetNames(ISelections); - - if (Length(ISelections)>=1) then - begin - UpdateSelectSlideOptions(Theme.SongMenu.SelectSlide3, 0, ISelections, SelectValue); - Interaction := 3; - end - else - begin - Button[3].Visible := false; - SelectsS[0].Visible := false; - Button[2].Visible := true; - Button[2].Text[0].Text := Language.Translate('SONG_MENU_PLAYLIST_NOEXISTING'); - Interaction := 2; - end; - end; - - SM_Playlist_Del: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PLAYLIST_DEL'); - - Button[0].Visible := true; - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_YES'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_CANCEL'); - end; - - SM_Party_Main: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PARTY_MAIN'); - - Button[0].Visible := true; - Button[1].Visible := false; - Button[2].Visible := false; - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := Language.Translate('SONG_MENU_PLAY'); - //Button[1].Text[0].Text := Language.Translate('SONG_MENU_JOKER'); - //Button[2].Text[0].Text := Language.Translate('SONG_MENU_PLAYMODI'); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_JOKER'); - end; - - SM_Party_Joker: - begin - CurMenu := sMenu; - Text[0].Text := Language.Translate('SONG_MENU_NAME_PARTY_JOKER'); - - Button[0].Visible := (PartySession.Teams.NumTeams >= 1) and (PartySession.Teams.Teaminfo[0].Joker > 0); - Button[1].Visible := (PartySession.Teams.NumTeams >= 2) and (PartySession.Teams.Teaminfo[1].Joker > 0); - Button[2].Visible := (PartySession.Teams.NumTeams >= 3) and (PartySession.Teams.Teaminfo[2].Joker > 0); - Button[3].Visible := true; - SelectsS[0].Visible := false; - - Button[0].Text[0].Text := UTF8String(PartySession.Teams.Teaminfo[0].Name); - Button[1].Text[0].Text := UTF8String(PartySession.Teams.Teaminfo[1].Name); - Button[2].Text[0].Text := UTF8String(PartySession.Teams.Teaminfo[2].Name); - Button[3].Text[0].Text := Language.Translate('SONG_MENU_CANCEL'); - - // set right interaction - if (not Button[0].Visible) then - begin - if (not Button[1].Visible) then - begin - if (not Button[2].Visible) then - Interaction := 4 - else - Interaction := 2; - end - else - Interaction := 1; - end; - - end; - end; -end; - -procedure TScreenSongMenu.HandleReturn; -begin - case CurMenu of - SM_Main: - begin - case Interaction of - 0: // button 1 - begin - ScreenSong.StartSong; - Visible := false; - end; - - 1: // button 2 - begin - // select new players then sing: - ScreenSong.SelectPlayers; - Visible := false; - end; - - 2: // button 3 - begin - // show add to playlist menu - MenuShow(SM_Playlist_Add); - end; - - 3: // selectslide 3 - begin - //Dummy - end; - - 4: // button 4 - begin - ScreenSong.OpenEditor; - Visible := false; - end; - end; - end; - - SM_PlayList: - begin - Visible := false; - case Interaction of - 0: // button 1 - begin - ScreenSong.StartSong; - Visible := false; - end; - - 1: // button 2 - begin - // select new players then sing: - ScreenSong.SelectPlayers; - Visible := false; - end; - - 2: // button 3 - begin - // show add to playlist menu - MenuShow(SM_Playlist_DelItem); - end; - - 3: // selectslide 3 - begin - // dummy - end; - - 4: // button 4 - begin - ScreenSong.OpenEditor; - Visible := false; - end; - end; - end; - - SM_Playlist_Add: - begin - case Interaction of - 0: // button 1 - begin - MenuShow(SM_Playlist_New); - end; - - 3: // selectslide 3 - begin - // dummy - end; - - 4: // button 4 - begin - PlaylistMan.AddItem(ScreenSong.Interaction, SelectValue); - Visible := false; - end; - end; - end; - - SM_Playlist_New: - begin - case Interaction of - 0: // button 1 - begin - // nothing, button for entering name - end; - - 2: // button 3 - begin - // create playlist and add song - PlaylistMan.AddItem( - ScreenSong.Interaction, - PlaylistMan.AddPlaylist(Button[0].Text[0].Text)); - Visible := false; - end; - - 3: // selectslide 3 - begin - // cancel -> go back to add screen - MenuShow(SM_Playlist_Add); - end; - - 4: // button 4 - begin - Visible := false; - end; - end; - end; - - SM_Playlist_DelItem: - begin - Visible := false; - case Interaction of - 0: // button 1 - begin - // delete - PlayListMan.DelItem(PlayListMan.GetIndexbySongID(ScreenSong.Interaction)); - Visible := false; - end; - - 4: // button 4 - begin - MenuShow(SM_Playlist); - end; - end; - end; - - SM_Playlist_Load: - begin - case Interaction of - 0: // button 1 (Delete playlist) - begin - MenuShow(SM_Playlist_Del); - end; - 4: // button 4 - begin - // load playlist - PlaylistMan.SetPlayList(SelectValue); - Visible := false; - end; - end; - end; - - SM_Playlist_Del: - begin - Visible := false; - case Interaction of - 0: // button 1 - begin - // delete - PlayListMan.DelPlaylist(PlaylistMan.CurPlayList); - Visible := false; - end; - - 4: // button 4 - begin - MenuShow(SM_Playlist_Load); - end; - end; - end; - - SM_Party_Main: - begin - case Interaction of - 0: // button 1 - begin - // start singing - ScreenSong.StartSong; - Visible := false; - end; - - 4: // button 4 - begin - // joker - MenuShow(SM_Party_Joker); - end; - end; - end; - - SM_Party_Joker: - begin - Visible := false; - case Interaction of - 0: // button 1 - begin - // joker team 1 - ScreenSong.DoJoker(0); - end; - - 1: // button 2 - begin - // joker team 2 - ScreenSong.DoJoker(1); - end; - - 2: // button 3 - begin - // joker team 3 - ScreenSong.DoJoker(2); - end; - - 4: // button 4 - begin - // cancel... (go back to old menu) - MenuShow(SM_Party_Main); - end; - end; - end; - end; -end; - -end. diff --git a/src/screens/UScreenStatDetail.pas b/src/screens/UScreenStatDetail.pas deleted file mode 100644 index 1638cd85..00000000 --- a/src/screens/UScreenStatDetail.pas +++ /dev/null @@ -1,303 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenStatDetail; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - SysUtils, - UDisplay, - UMusic, - UIni, - UDataBase, - UThemes; - -type - TScreenStatDetail = class(TMenu) - public - Typ: TStatType; - Page: cardinal; - Count: byte; - Reversed: boolean; - - TotEntrys: cardinal; - TotPages: cardinal; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - - procedure SetTitle; - Procedure SetPage(NewPage: cardinal); - end; - -implementation - -uses - Math, - Classes, - UGraphic, - ULanguage, - ULog, - UUnicodeUtils; - -function TScreenStatDetail.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenStatMain); - end; - SDLK_RETURN: - begin - if Interaction = 0 then - begin - //Next Page - SetPage(Page+1); - end; - - if Interaction = 1 then - begin - //Previous Page - if (Page > 0) then - SetPage(Page-1); - end; - - if Interaction = 2 then - begin - //Reverse Order - Reversed := not Reversed; - SetPage(Page); - end; - - if Interaction = 3 then - begin - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenStatMain); - end; - end; - SDLK_LEFT: - begin - InteractPrev; - end; - SDLK_RIGHT: - begin - InteractNext; - end; - SDLK_UP: - begin - InteractPrev; - end; - SDLK_DOWN: - begin - InteractNext; - end; - end; - end; -end; - -constructor TScreenStatDetail.Create; -var - I: integer; -begin - inherited Create; - - for I := 0 to High(Theme.StatDetail.TextList) do - AddText(Theme.StatDetail.TextList[I]); - - Count := Length(Theme.StatDetail.TextList); - - AddText(Theme.StatDetail.TextDescription); - AddText(Theme.StatDetail.TextPage); - - LoadFromTheme(Theme.StatDetail); - - AddButton(Theme.StatDetail.ButtonNext); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Language.Translate('STAT_NEXT')); - - AddButton(Theme.StatDetail.ButtonPrev); - if (Length(Button[1].Text)=0) then - AddButtonText(14, 20, Language.Translate('STAT_PREV')); - - AddButton(Theme.StatDetail.ButtonReverse); - if (Length(Button[2].Text)=0) then - AddButtonText(14, 20, Language.Translate('STAT_REVERSE')); - - AddButton(Theme.StatDetail.ButtonExit); - if (Length(Button[3].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[7]); - - Interaction := 0; - Typ := TStatType(0); -end; - -procedure TScreenStatDetail.OnShow; -begin - inherited; - - //Set Tot Entrys and PAges - TotEntrys := DataBase.GetTotalEntrys(Typ); - TotPages := Ceil(TotEntrys / Count); - - //Show correct Title - SetTitle; - - //Show First Page - Reversed := false; - SetPage(0); -end; - -procedure TScreenStatDetail.SetTitle; -begin - if Reversed then - Text[Count].Text := Theme.StatDetail.DescriptionR[Ord(Typ)] - else - Text[Count].Text := Theme.StatDetail.Description[Ord(Typ)]; -end; - -procedure TScreenStatDetail.SetPage(NewPage: cardinal); -var - StatList: TList; - I: integer; - FormatStr: string; - PerPage: byte; -begin - // fetch statistics - StatList := Database.GetStats(Typ, Count, NewPage, Reversed); - if ((StatList <> nil) and (StatList.Count > 0)) then - begin - Page := NewPage; - - // reset texts - for I := 0 to Count-1 do - Text[I].Text := ''; - - FormatStr := Theme.StatDetail.FormatStr[Ord(Typ)]; - - //refresh Texts - for I := 0 to StatList.Count-1 do - begin - try - case Typ of - stBestScores: begin //Best Scores - with TStatResultBestScores(StatList[I]) do - begin - //Set Texts - if (Score > 0) then - begin - Text[I].Text := Format(FormatStr, - [Singer, Score, Theme.ILevel[Difficulty], SongArtist, SongTitle, Date]); - end; - end; - end; - - stBestSingers: begin //Best Singers - with TStatResultBestSingers(StatList[I]) do - begin - //Set Texts - if (AverageScore > 0) then - Text[I].Text := Format(FormatStr, [Player, AverageScore]); - end; - end; - - stMostSungSong: begin //Popular Songs - with TStatResultMostSungSong(StatList[I]) do - begin - //Set Texts - if (Artist <> '') then - Text[I].Text := Format(FormatStr, [Artist, Title, TimesSung]); - end; - end; - - stMostPopBand: begin //Popular Bands - with TStatResultMostPopBand(StatList[I]) do - begin - //Set Texts - if (ArtistName <> '') then - Text[I].Text := Format(FormatStr, [ArtistName, TimesSungtot]); - end; - end; - end; - except - on E: EConvertError do - Log.LogError('Error Parsing FormatString in UScreenStatDetail: ' + E.Message); - end; - end; - - if (Page + 1 = TotPages) and (TotEntrys mod Count <> 0) then - PerPage := (TotEntrys mod Count) - else - PerPage := Count; - - try - Text[Count+1].Text := Format(Theme.StatDetail.PageStr, - [Page + 1, TotPages, PerPage, TotEntrys]); - except - on E: EConvertError do - Log.LogError('Error Parsing FormatString in UScreenStatDetail: ' + E.Message); - end; - - //Show correct Title - SetTitle; - end; - - Database.FreeStats(StatList); -end; - -procedure TScreenStatDetail.SetAnimationProgress(Progress: real); -var - I: integer; -begin - for I := 0 to High(Button) do - Button[I].Texture.ScaleW := Progress; -end; - -end. diff --git a/src/screens/UScreenStatMain.pas b/src/screens/UScreenStatMain.pas deleted file mode 100644 index 204f40cd..00000000 --- a/src/screens/UScreenStatMain.pas +++ /dev/null @@ -1,323 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenStatMain; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - SysUtils, - UDisplay, - UMusic, - UIni, - UThemes; - -type - TScreenStatMain = class(TMenu) - private - //Some Stat Value that don't need to be calculated 2 times - SongsWithVid: cardinal; - function FormatOverviewIntro(FormatStr: UTF8String): UTF8String; - function FormatSongOverview(FormatStr: UTF8String): UTF8String; - function FormatPlayerOverview(FormatStr: UTF8String): UTF8String; - public - TextOverview: integer; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - procedure OnShow; override; - procedure SetAnimationProgress(Progress: real); override; - - procedure SetOverview; - end; - -implementation - -uses - UGraphic, - UDataBase, - USongs, - USong, - ULanguage, - UCommon, - Classes, - ULog, - UUnicodeUtils; - -function TScreenStatMain.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin // Key Down - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Ini.Save; - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end; - SDLK_RETURN: - begin - //Exit Button Pressed - if Interaction = 4 then - begin - AudioPlayback.PlaySound(SoundLib.Back); - FadeTo(@ScreenMain); - end - else //One of the Stats Buttons Pressed - begin - AudioPlayback.PlaySound(SoundLib.Back); - ScreenStatDetail.Typ := TStatType(Interaction); - FadeTo(@ScreenStatDetail); - end; - end; - SDLK_LEFT: - begin - InteractPrev; - end; - SDLK_RIGHT: - begin - InteractNext; - end; - SDLK_UP: - begin - InteractPrev; - end; - SDLK_DOWN: - begin - InteractNext; - end; - end; - end; -end; - -constructor TScreenStatMain.Create; -var - I: integer; -begin - inherited Create; - - TextOverview := AddText(Theme.StatMain.TextOverview); - - LoadFromTheme(Theme.StatMain); - - AddButton(Theme.StatMain.ButtonScores); - if (Length(Button[0].Text)=0) then - AddButtonText(14, 20, Theme.StatDetail.Description[0]); - - AddButton(Theme.StatMain.ButtonSingers); - if (Length(Button[1].Text)=0) then - AddButtonText(14, 20, Theme.StatDetail.Description[1]); - - AddButton(Theme.StatMain.ButtonSongs); - if (Length(Button[2].Text)=0) then - AddButtonText(14, 20, Theme.StatDetail.Description[2]); - - AddButton(Theme.StatMain.ButtonBands); - if (Length(Button[3].Text)=0) then - AddButtonText(14, 20, Theme.StatDetail.Description[3]); - - AddButton(Theme.StatMain.ButtonExit); - if (Length(Button[4].Text)=0) then - AddButtonText(14, 20, Theme.Options.Description[4]); - - Interaction := 0; - - //Set Songs with Vid - SongsWithVid := 0; - for I := 0 to Songs.SongList.Count -1 do - if (TSong(Songs.SongList[I]).Video.IsSet) then - Inc(SongsWithVid); -end; - -procedure TScreenStatMain.OnShow; -begin - inherited; - - //Set Overview Text: - SetOverview; -end; - -function TScreenStatMain.FormatOverviewIntro(FormatStr: UTF8String): UTF8String; -var - Year, Month, Day: word; -begin - {Format: - %0:d Ultrastar Version - %1:d Day of Reset - %2:d Month of Reset - %3:d Year of Reset} - - Result := ''; - - try - DecodeDate(Database.GetStatReset(), Year, Month, Day); - Result := Format(FormatStr, [Language.Translate('US_VERSION'), Day, Month, Year]); - except - on E: EConvertError do - Log.LogError('Error Parsing FormatString "STAT_OVERVIEW_INTRO": ' + E.Message); - end; -end; - -function TScreenStatMain.FormatSongOverview(FormatStr: UTF8String): UTF8String; -var - CntSongs, CntSungSongs, CntVidSongs: integer; - MostPopSongArtist, MostPopSongTitle: UTF8String; - StatList: TList; - MostSungSong: TStatResultMostSungSong; -begin - {Format: - %0:d Count Songs - %1:d Count of Sung Songs - %2:d Count of UnSung Songs - %3:d Count of Songs with Video - %4:s Name of the most popular Song} - - CntSongs := Songs.SongList.Count; - CntSungSongs := Database.GetTotalEntrys(stMostSungSong); - CntVidSongs := SongsWithVid; - - StatList := Database.GetStats(stMostSungSong, 1, 0, false); - if ((StatList <> nil) and (StatList.Count > 0)) then - begin - MostSungSong := StatList[0]; - MostPopSongArtist := MostSungSong.Artist; - MostPopSongTitle := MostSungSong.Title; - end - else - begin - MostPopSongArtist := '-'; - MostPopSongTitle := '-'; - end; - Database.FreeStats(StatList); - - Result := ''; - - try - Result := Format(FormatStr, [ - CntSongs, CntSungSongs, CntSongs-CntSungSongs, CntVidSongs, - MostPopSongArtist, MostPopSongTitle]); - except - on E: EConvertError do - Log.LogError('Error Parsing FormatString "STAT_OVERVIEW_SONG": ' + E.Message); - end; -end; - -function TScreenStatMain.FormatPlayerOverview(FormatStr: UTF8String): UTF8String; -var - CntPlayers: integer; - BestScoreStat: TStatResultBestScores; - BestSingerStat: TStatResultBestSingers; - BestPlayer, BestScorePlayer: UTF8String; - BestPlayerScore, BestScore: integer; - SingerStats, ScoreStats: TList; -begin - {Format: - %0:d Count Players - %1:s Best Player - %2:d Best Players Score - %3:s Best Score Player - %4:d Best Score} - - CntPlayers := Database.GetTotalEntrys(stBestSingers); - - SingerStats := Database.GetStats(stBestSingers, 1, 0, false); - if ((SingerStats <> nil) and (SingerStats.Count > 0)) then - begin - BestSingerStat := SingerStats[0]; - BestPlayer := BestSingerStat.Player; - BestPlayerScore := BestSingerStat.AverageScore; - end - else - begin - BestPlayer := '-'; - BestPlayerScore := 0; - end; - Database.FreeStats(SingerStats); - - ScoreStats := Database.GetStats(stBestScores, 1, 0, false); - if ((ScoreStats <> nil) and (ScoreStats.Count > 0)) then - begin - BestScoreStat := ScoreStats[0]; - BestScorePlayer := BestScoreStat.Singer; - BestScore := BestScoreStat.Score; - end - else - begin - BestScorePlayer := '-'; - BestScore := 0; - end; - Database.FreeStats(ScoreStats); - - Result := ''; - - try - Result := Format(Formatstr, [ - CntPlayers, BestPlayer, BestPlayerScore, - BestScorePlayer, BestScore]); - except - on E: EConvertError do - Log.LogError('Error Parsing FormatString "STAT_OVERVIEW_PLAYER": ' + E.Message); - end; -end; - -procedure TScreenStatMain.SetOverview; -var - Overview: UTF8String; -begin - // Format overview - Overview := FormatOverviewIntro(Language.Translate('STAT_OVERVIEW_INTRO')) + '\n \n' + - FormatSongOverview(Language.Translate('STAT_OVERVIEW_SONG')) + '\n \n' + - FormatPlayerOverview(Language.Translate('STAT_OVERVIEW_PLAYER')); - Text[0].Text := Overview; -end; - -procedure TScreenStatMain.SetAnimationProgress(Progress: real); -var - I: integer; -begin - for I := 0 to high(Button) do - Button[I].Texture.ScaleW := Progress; -end; - -end. diff --git a/src/screens/UScreenTop5.pas b/src/screens/UScreenTop5.pas deleted file mode 100644 index 2ddff713..00000000 --- a/src/screens/UScreenTop5.pas +++ /dev/null @@ -1,307 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenTop5; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - SysUtils, - SDL, - UDisplay, - UMenu, - UMusic, - USongs, - UThemes; - -type - TScreenTop5 = class(TMenu) - public - TextLevel: integer; - TextArtistTitle: integer; - DifficultyShow: integer; - - StaticNumber: array[1..5] of integer; - TextNumber: array[1..5] of integer; - TextName: array[1..5] of integer; - TextScore: array[1..5] of integer; - TextDate: array[1..5] of integer; - - Fadeout: boolean; - - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function ParseMouse(MouseButton: integer; BtnDown: boolean; X, Y: integer): boolean; override; - procedure OnShow; override; - procedure DrawScores(difficulty: integer); - function Draw: boolean; override; - end; - -implementation - -uses - UDataBase, - UGraphic, - UMain, - UIni, - UNote, - UUnicodeUtils; - -function TScreenTop5.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if PressedDown then - begin - // check normal keys - case UCS4UpperCase(CharCode) of - Ord('Q'): - begin - Result := false; - Exit; - end; - end; - - // check special keys - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE, - SDLK_RETURN: - begin - if (not Fadeout) then - begin - FadeTo(@ScreenSong); - Fadeout := true; - end; - end; - SDLK_RIGHT: - begin - inc(DifficultyShow); - if (DifficultyShow>2) then - DifficultyShow:=0; - DrawScores(DifficultyShow); - end; - SDLK_LEFT: - begin - dec(DifficultyShow); - if (DifficultyShow<0) then - DifficultyShow:=2; - DrawScores(DifficultyShow); - end; - SDLK_UP: - begin - inc(DifficultyShow); - if (DifficultyShow>2) then - DifficultyShow:=0; - DrawScores(DifficultyShow); - end; - SDLK_DOWN: - begin - dec(DifficultyShow); - if (DifficultyShow<0) then - DifficultyShow:=2; - DrawScores(DifficultyShow); - end; - SDLK_SYSREQ: - begin - Display.SaveScreenShot; - end; - end; - end; -end; - -function TScreenTop5.ParseMouse(MouseButton: integer; - BtnDown: boolean; - X, Y: integer): boolean; -begin - Result := true; - if (MouseButton = SDL_BUTTON_LEFT) and BtnDown then - //left-click anywhere sends return - ParseInput(SDLK_RETURN, 0, true); -end; - -constructor TScreenTop5.Create; -var - I: integer; -begin - inherited Create; - - LoadFromTheme(Theme.Top5); - - TextLevel := AddText(Theme.Top5.TextLevel); - TextArtistTitle := AddText(Theme.Top5.TextArtistTitle); - - for I := 0 to 4 do - begin - StaticNumber[I+1] := AddStatic(Theme.Top5.StaticNumber[I]); - TextNumber[I+1] := AddText (Theme.Top5.TextNumber[I]); - TextName[I+1] := AddText (Theme.Top5.TextName[I]); - TextScore[I+1] := AddText (Theme.Top5.TextScore[I]); - TextDate[I+1] := AddText (Theme.Top5.TextDate[I]); - end; - -end; - -procedure TScreenTop5.OnShow; -var - I: integer; - PMax: integer; - sung: boolean; //score added? otherwise in wasn't sung! -begin - inherited; - - sung := false; - Fadeout := false; - DifficultyShow := Ini.Difficulty; - - //ReadScore(CurrentSong); - - PMax := Ini.Players; - if PMax = 4 then - PMax := 5; - for I := 0 to PMax do - begin - if (Round(Player[I].ScoreTotalInt) > 0) and (ScreenSing.SungToEnd) then - begin - DataBase.AddScore(CurrentSong, Ini.Difficulty, Ini.Name[I], Round(Player[I].ScoreTotalInt)); - sung:=true; - end; - end; - - if sung then - DataBase.WriteScore(CurrentSong); - DataBase.ReadScore(CurrentSong); - - Text[TextArtistTitle].Text := CurrentSong.Artist + ' - ' + CurrentSong.Title; - - for I := 1 to Length(CurrentSong.Score[Ini.Difficulty]) do - begin - Static[StaticNumber[I]].Visible := true; - Text[TextNumber[I]].Visible := true; - Text[TextName[I]].Visible := true; - Text[TextScore[I]].Visible := true; - Text[TextDate[I]].Visible := true; - - Text[TextName[I]].Text := CurrentSong.Score[Ini.Difficulty, I-1].Name; - Text[TextScore[I]].Text := IntToStr(CurrentSong.Score[Ini.Difficulty, I-1].Score); - Text[TextDate[I]].Text := CurrentSong.Score[Ini.Difficulty, I-1].Date; - end; - - for I := Length(CurrentSong.Score[Ini.Difficulty]) + 1 to 5 do - begin - Static[StaticNumber[I]].Visible := false; - Text[TextNumber[I]].Visible := false; - Text[TextName[I]].Visible := false; - Text[TextScore[I]].Visible := false; - Text[TextDate[I]].Visible := false; - end; - - Text[TextLevel].Text := IDifficulty[Ini.Difficulty]; -end; - -procedure TScreenTop5.DrawScores(difficulty: integer); -var - I: integer; -begin - for I := 1 to Length(CurrentSong.Score[difficulty]) do - begin - Static[StaticNumber[I]].Visible := true; - Text[TextNumber[I]].Visible := true; - Text[TextName[I]].Visible := true; - Text[TextScore[I]].Visible := true; - Text[TextDate[I]].Visible := true; - - Text[TextName[I]].Text := CurrentSong.Score[difficulty, I-1].Name; - Text[TextScore[I]].Text := IntToStr(CurrentSong.Score[difficulty, I-1].Score); - Text[TextDate[I]].Text := CurrentSong.Score[difficulty, I-1].Date; - end; - - for I := Length(CurrentSong.Score[difficulty]) + 1 to 5 do - begin - Static[StaticNumber[I]].Visible := false; - Text[TextNumber[I]].Visible := false; - Text[TextName[I]].Visible := false; - Text[TextScore[I]].Visible := false; - Text[TextDate[I]].Visible := false; - end; - - Text[TextLevel].Text := IDifficulty[difficulty]; -end; - -function TScreenTop5.Draw: boolean; -//var -{ - Min: real; - Max: real; - Factor: real; - Factor2: real; - - Item: integer; - P: integer; - C: integer; -} -begin - // Singstar - let it be...... with 6 statics -(* - if PlayersPlay = 6 then - begin - for Item := 4 to 6 do - begin - if ScreenAct = 1 then P := Item-4; - if ScreenAct = 2 then P := Item-1; - - FillPlayer(Item, P); -{ - if ScreenAct = 1 then - begin - LoadColor( - Static[StaticBoxLightest[Item]].Texture.ColR, - Static[StaticBoxLightest[Item]].Texture.ColG, - Static[StaticBoxLightest[Item]].Texture.ColB, - 'P1Dark'); - end; - - if ScreenAct = 2 then - begin - LoadColor( - Static[StaticBoxLightest[Item]].Texture.ColR, - Static[StaticBoxLightest[Item]].Texture.ColG, - Static[StaticBoxLightest[Item]].Texture.ColB, - 'P4Dark'); - end; -} - end; - end; -*) - - Result := inherited Draw; -end; - -end. diff --git a/src/screens/UScreenWelcome.pas b/src/screens/UScreenWelcome.pas deleted file mode 100644 index 4b463613..00000000 --- a/src/screens/UScreenWelcome.pas +++ /dev/null @@ -1,164 +0,0 @@ -{* UltraStar Deluxe - Karaoke Game - * - * UltraStar Deluxe is the legal property of its developers, whose names - * are too numerous to list here. Please refer to the COPYRIGHT - * file distributed with this source distribution. - * - * This program is free software; you can redistribute it and/or - * modify it under the terms of the GNU General Public License - * as published by the Free Software Foundation; either version 2 - * of the License, or (at your option) any later version. - * - * This program is distributed in the hope that it will be useful, - * but WITHOUT ANY WARRANTY; without even the implied warranty of - * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - * GNU General Public License for more details. - * - * You should have received a copy of the GNU General Public License - * along with this program; see the file COPYING. If not, write to - * the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, - * Boston, MA 02110-1301, USA. - * - * $URL$ - * $Id$ - *} - -unit UScreenWelcome; - -interface - -{$IFDEF FPC} - {$MODE Delphi} -{$ENDIF} - -{$I switches.inc} - -uses - UMenu, - SDL, - SysUtils, - UThemes; - -type - TScreenWelcome = class(TMenu) - public - Animation: real; - Fadeout: boolean; - constructor Create; override; - function ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; override; - function Draw: boolean; override; - procedure OnShow; override; - end; - -implementation - -uses - UGraphic, - UTime, - USkins, - UTexture; - -function TScreenWelcome.ParseInput(PressedKey: cardinal; CharCode: UCS4Char; PressedDown: boolean): boolean; -begin - Result := true; - if (PressedDown) then - begin - case PressedKey of - SDLK_ESCAPE, - SDLK_BACKSPACE : - begin - Result := false; - end; - SDLK_RETURN: - begin - FadeTo(@ScreenMain); - Fadeout := true; - end; - end; - end; -end; - -constructor TScreenWelcome.Create; -begin - inherited Create; - AddStatic(-10, -10, 0, 0, 1, 1, 1, Skin.GetTextureFileName('ButtonAlt'), TEXTURE_TYPE_TRANSPARENT); - AddStatic(-500, 440, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 472, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 504, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 536, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - AddStatic(-500, 568, 200, 5, 0, 0, 0, Skin.GetTextureFileName('Rectangle'), TEXTURE_TYPE_COLORIZED); - Animation := 0; - Fadeout := false; -end; - -procedure TScreenWelcome.OnShow; -begin - inherited; - - CountSkipTimeSet; -end; - -function TScreenWelcome.Draw: boolean; -var - Min: real; - Max: real; - Factor: real; - Count: integer; -begin - // star animation - Animation := Animation + TimeSkip*1000; - - // draw nothing - Min := 0; Max := 1000; - if (Animation >= Min) and (Animation < Max) then - begin - end; - - // popup - Min := 1000; Max := 1120; - if (Animation >= Min) and (Animation < Max) then - begin - Factor := (Animation - Min) / (Max - Min); - Static[0].Texture.X := 600; - Static[0].Texture.Y := 600 - Factor * 230; - Static[0].Texture.W := 200; - Static[0].Texture.H := Factor * 230; - end; - - // bounce - Min := 1120; Max := 1200; - if (Animation >= Min) and (Animation < Max) then - begin - Factor := (Animation - Min) / (Max - Min); - Static[0].Texture.Y := 370 + Factor * 50; - Static[0].Texture.H := 230 - Factor * 50; - end; - - // run - Min := 1500; Max := 3500; - if (Animation >= Min) and (Animation < Max) then - begin - Factor := (Animation - Min) / (Max - Min); - - Static[0].Texture.X := 600 - Factor * 1400; - Static[0].Texture.H := 180; - - for Count := 1 to 5 do - begin - Static[Count].Texture.X := 770 - Factor * 1400; - Static[Count].Texture.W := 150 + Factor * 200; - Static[Count].Texture.Alpha := Factor * 0.5; - end; - end; - - Min := 3500; - if (Animation >= Min) and (not Fadeout) then - begin - FadeTo(@ScreenMain); - Fadeout := true; - end; - - Result := inherited Draw; -end; - -end. -- cgit v1.2.3