diff options
Diffstat (limited to 'src/lib')
68 files changed, 0 insertions, 76296 deletions
diff --git a/src/lib/FreeImage/FreeBitmap.pas b/src/lib/FreeImage/FreeBitmap.pas deleted file mode 100644 index d32fb5cb..00000000 --- a/src/lib/FreeImage/FreeBitmap.pas +++ /dev/null @@ -1,1742 +0,0 @@ -unit FreeBitmap; - -// ========================================================== -// -// Delphi wrapper for FreeImage 3 -// -// Design and implementation by -// - Anatoliy Pulyaevskiy (xvel84@rambler.ru) -// -// Contributors: -// - Enzo Costantini (enzocostantini@libero.it) -// -// 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! -// -// ========================================================== -// -// From begining all code of this file is based on C++ wrapper to -// FreeImage - FreeImagePlus. -// -// ========================================================== - -{$IFDEF FPC} - {$MODE Delphi} - {$H+} // use long strings -{$ENDIF} - -interface - -uses - SysUtils, Classes, Windows, FreeImage; - -type - { TFreeObject } - - TFreeObject = class(TObject) - public - function IsValid: Boolean; virtual; - end; - - { TFreeTag } - - TFreeTag = class(TFreeObject) - private - // fields - FTag: PFITAG; - - // getters & setters - function GetCount: Cardinal; - function GetDescription: string; - function GetID: Word; - function GetKey: string; - function GetLength: Cardinal; - function GetTagType: FREE_IMAGE_MDTYPE; - function GetValue: Pointer; - procedure SetCount(const Value: Cardinal); - procedure SetDescription(const Value: string); - procedure SetID(const Value: Word); - procedure SetKey(const Value: string); - procedure SetLength(const Value: Cardinal); - procedure SetTagType(const Value: FREE_IMAGE_MDTYPE); - procedure SetValue(const Value: Pointer); - public - // construction & destruction - constructor Create(ATag: PFITAG = nil); virtual; - destructor Destroy; override; - - // methods - function Clone: TFreeTag; - function IsValid: Boolean; override; - function ToString(Model: FREE_IMAGE_MDMODEL; Make: PChar = nil): string; - - // properties - property Key: string read GetKey write SetKey; - property Description: string read GetDescription write SetDescription; - property ID: Word read GetID write SetID; - property TagType: FREE_IMAGE_MDTYPE read GetTagType write SetTagType; - property Count: Cardinal read GetCount write SetCount; - property Length: Cardinal read GetLength write SetLength; - property Value: Pointer read GetValue write SetValue; - property Tag: PFITAG read FTag; - end; - - { forward declarations } - - TFreeBitmap = class; - TFreeMemoryIO = class; - - { TFreeBitmap } - - TFreeBitmapChangingEvent = procedure(Sender: TFreeBitmap; var OldDib, NewDib: PFIBITMAP; var Handled: Boolean) of object; - - TFreeBitmap = class(TFreeObject) - private - // fields - FDib: PFIBITMAP; - FOnChange: TNotifyEvent; - FOnChanging: TFreeBitmapChangingEvent; - - procedure SetDib(Value: PFIBITMAP); - protected - function DoChanging(var OldDib, NewDib: PFIBITMAP): Boolean; dynamic; - function Replace(NewDib: PFIBITMAP): Boolean; dynamic; - public - constructor Create(ImageType: FREE_IMAGE_TYPE = FIT_BITMAP; Width: Integer = 0; Height: Integer = 0; Bpp: Integer = 0); - destructor Destroy; override; - function SetSize(ImageType: FREE_IMAGE_TYPE; Width, Height, Bpp: Integer; RedMask: Cardinal = 0; GreenMask: Cardinal = 0; BlueMask: Cardinal = 0): Boolean; - procedure Change; dynamic; - procedure Assign(Source: TFreeBitmap); - function CopySubImage(Left, Top, Right, Bottom: Integer; Dest: TFreeBitmap): Boolean; - function PasteSubImage(Src: TFreeBitmap; Left, Top: Integer; Alpha: Integer = 256): Boolean; - procedure Clear; virtual; - function Load(const FileName: string; Flag: Integer = 0): Boolean; - function LoadU(const FileName: WideString; Flag: Integer = 0): Boolean; - function LoadFromHandle(IO: PFreeImageIO; Handle: fi_handle; Flag: Integer = 0): Boolean; - function LoadFromMemory(MemIO: TFreeMemoryIO; Flag: Integer = 0): Boolean; - function LoadFromStream(Stream: TStream; Flag: Integer = 0): Boolean; - // save functions - function CanSave(fif: FREE_IMAGE_FORMAT): Boolean; - function Save(const FileName: string; Flag: Integer = 0): Boolean; - function SaveU(const FileName: WideString; Flag: Integer = 0): Boolean; - function SaveToHandle(fif: FREE_IMAGE_FORMAT; IO: PFreeImageIO; Handle: fi_handle; Flag: Integer = 0): Boolean; - function SaveToMemory(fif: FREE_IMAGE_FORMAT; MemIO: TFreeMemoryIO; Flag: Integer = 0): Boolean; - function SaveToStream(fif: FREE_IMAGE_FORMAT; Stream: TStream; Flag: Integer = 0): Boolean; - // image information - function GetImageType: FREE_IMAGE_TYPE; - function GetWidth: Integer; - function GetHeight: Integer; - function GetScanWidth: Integer; - function IsValid: Boolean; override; - function GetInfo: PBitmapInfo; - function GetInfoHeader: PBitmapInfoHeader; - function GetImageSize: Cardinal; - function GetBitsPerPixel: Integer; - function GetLine: Integer; - function GetHorizontalResolution: Double; - function GetVerticalResolution: Double; - procedure SetHorizontalResolution(Value: Double); - procedure SetVerticalResolution(Value: Double); - // palette operations - function GetPalette: PRGBQUAD; - function GetPaletteSize: Integer; - function GetColorsUsed: Integer; - function GetColorType: FREE_IMAGE_COLOR_TYPE; - function IsGrayScale: Boolean; - // pixels access - function AccessPixels: PByte; - function GetScanLine(ScanLine: Integer): PByte; - function GetPixelIndex(X, Y: Cardinal; var Value: PByte): Boolean; - function GetPixelColor(X, Y: Cardinal; Value: PRGBQUAD): Boolean; - function SetPixelIndex(X, Y: Cardinal; Value: PByte): Boolean; - function SetPixelColor(X, Y: Cardinal; Value: PRGBQUAD): Boolean; - // convertion - function ConvertToStandardType(ScaleLinear: Boolean): Boolean; - function ConvertToType(ImageType: FREE_IMAGE_TYPE; ScaleLinear: Boolean): Boolean; - function Threshold(T: Byte): Boolean; - function ConvertTo4Bits: Boolean; - function ConvertTo8Bits: Boolean; - function ConvertTo16Bits555: Boolean; - function ConvertTo16Bits565: Boolean; - function ConvertTo24Bits: Boolean; - function ConvertTo32Bits: Boolean; - function ConvertToGrayscale: Boolean; - function ColorQuantize(Algorithm: FREE_IMAGE_QUANTIZE): Boolean; - function Dither(Algorithm: FREE_IMAGE_DITHER): Boolean; - function ConvertToRGBF: Boolean; - function ToneMapping(TMO: FREE_IMAGE_TMO; FirstParam, SecondParam: Double): Boolean; - // transparency - function IsTransparent: Boolean; - function GetTransparencyCount: Cardinal; - function GetTransparencyTable: PByte; - procedure SetTransparencyTable(Table: PByte; Count: Integer); - function HasFileBkColor: Boolean; - function GetFileBkColor(var BkColor: PRGBQuad): Boolean; - function SetFileBkColor(BkColor: PRGBQuad): Boolean; - // channel processing routines - function GetChannel(Bitmap: TFreeBitmap; Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; - function SetChannel(Bitmap: TFreeBitmap; Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; - function SplitChannels(RedChannel, GreenChannel, BlueChannel: TFreeBitmap): Boolean; - function CombineChannels(Red, Green, Blue: TFreeBitmap): Boolean; - // rotation and flipping - function RotateEx(Angle, XShift, YShift, XOrigin, YOrigin: Double; UseMask: Boolean): Boolean; - function Rotate(Angle: Double): Boolean; - function FlipHorizontal: Boolean; - function FlipVertical: Boolean; - // color manipulation routines - function Invert: Boolean; - function AdjustCurve(Lut: PByte; Channel: FREE_IMAGE_COLOR_CHANNEL): Boolean; - function AdjustGamma(Gamma: Double): Boolean; - function AdjustBrightness(Percentage: Double): Boolean; - function AdjustContrast(Percentage: Double): Boolean; - function GetHistogram(Histo: PDWORD; Channel: FREE_IMAGE_COLOR_CHANNEL = FICC_BLACK): Boolean; - // upsampling / downsampling - procedure MakeThumbnail(const Width, Height: Integer; DestBitmap: TFreeBitmap); - function Rescale(NewWidth, NewHeight: Integer; Filter: FREE_IMAGE_FILTER; Dest: TFreeBitmap = nil): Boolean; - // metadata routines - function FindFirstMetadata(Model: FREE_IMAGE_MDMODEL; var Tag: TFreeTag): PFIMETADATA; - function FindNextMetadata(MDHandle: PFIMETADATA; var Tag: TFreeTag): Boolean; - procedure FindCloseMetadata(MDHandle: PFIMETADATA); - function SetMetadata(Model: FREE_IMAGE_MDMODEL; const Key: string; Tag: TFreeTag): Boolean; - function GetMetadata(Model: FREE_IMAGE_MDMODEL; const Key: string; var Tag: TFreeTag): Boolean; - function GetMetadataCount(Model: FREE_IMAGE_MDMODEL): Cardinal; - - // properties - property Dib: PFIBITMAP read FDib write SetDib; - property OnChange: TNotifyEvent read FOnChange write FOnChange; - property OnChanging: TFreeBitmapChangingEvent read FOnChanging write FOnChanging; - end; - - { TFreeWinBitmap } - - - { TFreeMemoryIO } - - TFreeMemoryIO = class(TFreeObject) - private - FHMem: PFIMEMORY; - public - // construction and destruction - constructor Create(Data: PByte = nil; SizeInBytes: DWORD = 0); - destructor Destroy; override; - - function GetFileType: FREE_IMAGE_FORMAT; - function Read(fif: FREE_IMAGE_FORMAT; Flag: Integer = 0): PFIBITMAP; - function Write(fif: FREE_IMAGE_FORMAT; dib: PFIBITMAP; Flag: Integer = 0): Boolean; - function Tell: Longint; - function Seek(Offset: Longint; Origin: Word): Boolean; - function Acquire(var Data: PByte; var SizeInBytes: DWORD): Boolean; - // overriden methods - function IsValid: Boolean; override; - end; - - { TFreeMultiBitmap } - - TFreeMultiBitmap = class(TFreeObject) - private - FMPage: PFIMULTIBITMAP; - FMemoryCache: Boolean; - public - // constructor and destructor - constructor Create(KeepCacheInMemory: Boolean = False); - destructor Destroy; override; - - // methods - function Open(const FileName: string; CreateNew, ReadOnly: Boolean; Flags: Integer = 0): Boolean; - function Close(Flags: Integer = 0): Boolean; - function GetPageCount: Integer; - procedure AppendPage(Bitmap: TFreeBitmap); - procedure InsertPage(Page: Integer; Bitmap: TFreeBitmap); - procedure DeletePage(Page: Integer); - function MovePage(Target, Source: Integer): Boolean; - procedure LockPage(Page: Integer; DestBitmap: TFreeBitmap); - procedure UnlockPage(Bitmap: TFreeBitmap; Changed: Boolean); - function GetLockedPageNumbers(var Pages: Integer; var Count: Integer): Boolean; - // overriden methods - function IsValid: Boolean; override; - - // properties - // change of this property influences only on the next opening of a file - property MemoryCache: Boolean read FMemoryCache write FMemoryCache; - end; - -implementation - -const - ThumbSize = 150; - -// marker used for clipboard copy / paste - -procedure SetFreeImageMarker(bmih: PBitmapInfoHeader; dib: PFIBITMAP); -begin - // Windows constants goes from 0L to 5L - // Add $FF to avoid conflicts - bmih.biCompression := $FF + FreeImage_GetImageType(dib); -end; - -function GetFreeImageMarker(bmih: PBitmapInfoHeader): FREE_IMAGE_TYPE; -begin - Result := FREE_IMAGE_TYPE(bmih.biCompression - $FF); -end; - -{ TFreePersistent } - -function TFreeObject.IsValid: Boolean; -begin - Result := False -end; - -{ TFreeBitmap } - -function TFreeBitmap.AccessPixels: PByte; -begin - Result := FreeImage_GetBits(FDib) -end; - -function TFreeBitmap.AdjustBrightness(Percentage: Double): Boolean; -begin - if FDib <> 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 <wrf@ecse.rpi.edu> -// 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, // <!ELEMENT> - deAttList : (ElemDef : TElemDef); // <!ATTLIST> - deEntity : (EntityDef : TEntityDef); // <!ENTITY> - deNotation : (NotationDef : TNotationDef); // <!NOTATION> - dePI : (Target : PChar; // <?PI ?> - Content : PChar; - AttrList : TAttrList); - deError : (Pos : PChar); // Error - // deComment : ((No additional fields here)); // <!-- Comment --> - END; - - TXmlParser = CLASS // --- Internal Properties and Methods - PROTECTED - FBuffer : PChar; // NIL if there is no buffer available - FBufferSize : INTEGER; // 0 if the buffer is not owned by the Document instance - FSource : STRING; // Name of Source of document. Filename for Documents loaded with LoadFromFile - - FXmlVersion : STRING; // XML version from Document header. Default is '1.0' - FEncoding : STRING; // Encoding from Document header. Default is 'UTF-8' - FStandalone : BOOLEAN; // Standalone declaration from Document header. Default is 'yes' - FRootName : STRING; // Name of the Root Element (= DTD name) - FDtdcFinal : PChar; // Pointer to the '>' character terminating the DTD declaration - - FNormalize : BOOLEAN; // If true: Pack Whitespace and don't return empty contents - EntityStack : TEntityStack; // Entity Stack for Parameter and General Entities - FCurEncoding : STRING; // Current Encoding during parsing (always uppercase) - - PROCEDURE AnalyzeProlog; // Analyze XML Prolog or Text Declaration - PROCEDURE AnalyzeComment (Start : PChar; VAR Final : PChar); // Analyze Comments - PROCEDURE AnalyzePI (Start : PChar; VAR Final : PChar); // Analyze Processing Instructions (PI) - PROCEDURE AnalyzeDtdc; // Analyze Document Type Declaration - PROCEDURE AnalyzeDtdElements (Start : PChar; VAR Final : PChar); // Analyze DTD declarations - PROCEDURE AnalyzeTag; // Analyze Start/End/Empty-Element Tags - PROCEDURE AnalyzeCData; // Analyze CDATA Sections - PROCEDURE AnalyzeText (VAR IsDone : BOOLEAN); // Analyze Text Content between Tags - PROCEDURE AnalyzeElementDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); - PROCEDURE AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); - - PROCEDURE PushPE (VAR Start : PChar); - PROCEDURE ReplaceCharacterEntities (VAR Str : STRING); - PROCEDURE ReplaceParameterEntities (VAR Str : STRING); - PROCEDURE ReplaceGeneralEntities (VAR Str : STRING); - - FUNCTION GetDocBuffer : PChar; // Returns FBuffer or a pointer to a NUL char if Buffer is empty - - PUBLIC // --- Document Properties - PROPERTY XmlVersion : STRING READ FXmlVersion; // XML version from the Document Prolog - PROPERTY Encoding : STRING READ FEncoding; // Document Encoding from Prolog - PROPERTY Standalone : BOOLEAN READ FStandalone; // Standalone Declaration from Prolog - PROPERTY RootName : STRING READ FRootName; // Name of the Root Element - PROPERTY Normalize : BOOLEAN READ FNormalize WRITE FNormalize; // True if Content is to be normalized - PROPERTY Source : STRING READ FSource; // Name of Document Source (Filename) - PROPERTY DocBuffer : PChar READ GetDocBuffer; // Returns document buffer - PUBLIC // --- DTD Objects - Elements : TElemList; // Elements: List of TElemDef (contains Attribute Definitions) - Entities : TNvpList; // General Entities: List of TEntityDef - ParEntities : TNvpList; // Parameter Entities: List of TEntityDef - Notations : TNvpList; // Notations: List of TNotationDef - PUBLIC - CONSTRUCTOR Create; - DESTRUCTOR Destroy; OVERRIDE; - - // --- Document Handling - FUNCTION LoadFromFile (Filename : STRING; - FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; - // Loads Document from given file - FUNCTION LoadFromBuffer (Buffer : PChar) : BOOLEAN; // Loads Document from another buffer - PROCEDURE SetBuffer (Buffer : PChar); // References another buffer - PROCEDURE Clear; // Clear Document - - PUBLIC - // --- Scanning through the document - CurPartType : TPartType; // Current Type - CurName : STRING; // Current Name - CurContent : STRING; // Current Normalized Content - CurStart : PChar; // Current First character - CurFinal : PChar; // Current Last character - CurAttr : TAttrList; // Current Attribute List - PROPERTY CurEncoding : STRING READ FCurEncoding; // Current Encoding - PROCEDURE StartScan; - FUNCTION Scan : BOOLEAN; - - // --- Events / Callbacks - FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : STRING) : TXmlParser; VIRTUAL; - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; VIRTUAL; - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); VIRTUAL; - END; - - TValueType = // --- Attribute Value Type - (vtNormal, // Normal specified Attribute - vtImplied, // #IMPLIED attribute value - vtFixed, // #FIXED attribute value - vtDefault); // Attribute value from default value in !ATTLIST declaration - - TAttrDefault = // --- Attribute Default Type - (adDefault, // Normal default value - adRequired, // #REQUIRED attribute - adImplied, // #IMPLIED attribute - adFixed); // #FIXED attribute - - TAttrType = // --- Type of attribute - (atUnknown, // Unknown type - atCData, // Character data only - atID, // ID - atIdRef, // ID Reference - atIdRefs, // Several ID References, separated by Whitespace - atEntity, // Name of an unparsed Entity - atEntities, // Several unparsed Entity names, separated by Whitespace - atNmToken, // Name Token - atNmTokens, // Several Name Tokens, separated by Whitespace - atNotation, // A selection of Notation names (Unparsed Entity) - atEnumeration); // Enumeration - - TElemType = // --- Element content type - (etEmpty, // Element is always empty - etAny, // Element can have any mixture of PCDATA and any elements - etChildren, // Element must contain only elements - etMixed); // Mixed PCDATA and elements - - (*$IFDEF HAS_CONTNRS_UNIT *) - TObjectList = Contnrs.TObjectList; // Re-Export this identifier - (*$ELSE *) - TObjectList = CLASS (TList) - DESTRUCTOR Destroy; OVERRIDE; - PROCEDURE Delete (Index : INTEGER); - PROCEDURE Clear; OVERRIDE; - END; - (*$ENDIF *) - - TNvpNode = CLASS // Name-Value Pair Node - Name : STRING; - Value : STRING; - CONSTRUCTOR Create (TheName : STRING = ''; TheValue : STRING = ''); - END; - - TNvpList = CLASS (TObjectList) // Name-Value Pair List - PROCEDURE Add (Node : TNvpNode); - FUNCTION Node (Name : STRING) : TNvpNode; OVERLOAD; - FUNCTION Node (Index : INTEGER) : TNvpNode; OVERLOAD; - FUNCTION Value (Name : STRING) : STRING; OVERLOAD; - FUNCTION Value (Index : INTEGER) : STRING; OVERLOAD; - FUNCTION Name (Index : INTEGER) : STRING; - END; - - TAttr = CLASS (TNvpNode) // Attribute of a Start-Tag or Empty-Element-Tag - ValueType : TValueType; - AttrType : TAttrType; - END; - - TAttrList = CLASS (TNvpList) // List of Attributes - PROCEDURE Analyze (Start : PChar; VAR Final : PChar); - END; - - TEntityStack = CLASS (TObjectList) // Stack where current position is stored before parsing entities - PROTECTED - Owner : TXmlParser; - PUBLIC - CONSTRUCTOR Create (TheOwner : TXmlParser); - PROCEDURE Push (LastPos : PChar); OVERLOAD; - PROCEDURE Push (Instance : TObject; LastPos : PChar); OVERLOAD; - FUNCTION Pop : PChar; // Returns next char or NIL if EOF is reached. Frees Instance. - END; - - TAttrDef = CLASS (TNvpNode) // Represents a <!ATTLIST Definition. "Value" is the default value - TypeDef : STRING; // Type definition from the DTD - Notations : STRING; // Notation List, separated by pipe symbols '|' - AttrType : TAttrType; // Attribute Type - DefaultType : TAttrDefault; // Default Type - END; - - TElemDef = CLASS (TNvpList) // Represents a <!ELEMENT Definition. Is a list of TAttrDef-Nodes - Name : STRING; // Element name - ElemType : TElemType; // Element type - Definition : STRING; // Element definition from DTD - END; - - TElemList = CLASS (TObjectList) // List of TElemDef nodes - FUNCTION Node (Name : STRING) : TElemDef; - PROCEDURE Add (Node : TElemDef); - END; - - TEntityDef = CLASS (TNvpNode) // Represents a <!ENTITY Definition. - SystemId : STRING; - PublicId : STRING; - NotationName : STRING; - END; - - TNotationDef = CLASS (TNvpNode) // Represents a <!NOTATION Definition. Value is the System ID - PublicId : STRING; - END; - - TCharset = SET OF CHAR; - - -CONST - CWhitespace = [#32, #9, #13, #10]; // Whitespace characters (XmlSpec 2.3) - CLetter = [#$41..#$5A, #$61..#$7A, #$C0..#$D6, #$D8..#$F6, #$F8..#$FF]; - CDigit = [#$30..#$39]; - CNameChar = CLetter + CDigit + ['.', '-', '_', ':', #$B7]; - CNameStart = CLetter + ['_', ':']; - CQuoteChar = ['"', '''']; - CPubidChar = [#32, ^M, ^J, #9, 'a'..'z', 'A'..'Z', '0'..'9', - '-', '''', '(', ')', '+', ',', '.', '/', ':', - '=', '?', ';', '!', '*', '#', '@', '$', '_', '%']; - - CDStart = '<![CDATA['; - CDEnd = ']]>'; - - // --- Name Constants for the above enumeration types - CPartType_Name : ARRAY [TPartType] OF STRING = - ('', 'XML Prolog', 'Comment', 'PI', - 'DTD Declaration', 'Start Tag', 'Empty Tag', 'End Tag', - 'Text', 'CDATA'); - CValueType_Name : ARRAY [TValueType] OF STRING = ('Normal', 'Implied', 'Fixed', 'Default'); - CAttrDefault_Name : ARRAY [TAttrDefault] OF STRING = ('Default', 'Required', 'Implied', 'Fixed'); - CElemType_Name : ARRAY [TElemType] OF STRING = ('Empty', 'Any', 'Childs only', 'Mixed'); - CAttrType_Name : ARRAY [TAttrType] OF STRING = ('Unknown', 'CDATA', - 'ID', 'IDREF', 'IDREFS', - 'ENTITY', 'ENTITIES', - 'NMTOKEN', 'NMTOKENS', - 'Notation', 'Enumeration'); - -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; // Convert WS to spaces #x20 -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); // SetString by Start/Final of buffer -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; // Convert buffer part to Pascal string -FUNCTION TrimWs (Source : STRING) : STRING; // Trim Whitespace - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; // Convert Win-1252 to UTF-8 -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; // Convert UTF-8 to Win-1252 - - -(* -=============================================================================================== -TCustomXmlScanner event based component wrapper for TXmlParser -=============================================================================================== -*) - -TYPE - TCustomXmlScanner = CLASS; - TXmlPrologEvent = PROCEDURE (Sender : TObject; XmlVersion, Encoding: STRING; Standalone : BOOLEAN) OF OBJECT; - TCommentEvent = PROCEDURE (Sender : TObject; Comment : STRING) OF OBJECT; - TPIEvent = PROCEDURE (Sender : TObject; Target, Content: STRING; Attributes : TAttrList) OF OBJECT; - TDtdEvent = PROCEDURE (Sender : TObject; RootElementName : STRING) OF OBJECT; - TStartTagEvent = PROCEDURE (Sender : TObject; TagName : STRING; Attributes : TAttrList) OF OBJECT; - TEndTagEvent = PROCEDURE (Sender : TObject; TagName : STRING) OF OBJECT; - TContentEvent = PROCEDURE (Sender : TObject; Content : STRING) OF OBJECT; - TElementEvent = PROCEDURE (Sender : TObject; ElemDef : TElemDef) OF OBJECT; - TEntityEvent = PROCEDURE (Sender : TObject; EntityDef : TEntityDef) OF OBJECT; - TNotationEvent = PROCEDURE (Sender : TObject; NotationDef : TNotationDef) OF OBJECT; - TErrorEvent = PROCEDURE (Sender : TObject; ErrorPos : PChar) OF OBJECT; - TExternalEvent = PROCEDURE (Sender : TObject; SystemId, PublicId, NotationId : STRING; - VAR Result : TXmlParser) OF OBJECT; - TEncodingEvent = FUNCTION (Sender : TObject; CurrentEncoding, Source : STRING) : STRING OF OBJECT; - - - TCustomXmlScanner = CLASS (TComponent) - PROTECTED - FXmlParser : TXmlParser; - FOnXmlProlog : TXmlPrologEvent; - FOnComment : TCommentEvent; - FOnPI : TPIEvent; - FOnDtdRead : TDtdEvent; - FOnStartTag : TStartTagEvent; - FOnEmptyTag : TStartTagEvent; - FOnEndTag : TEndTagEvent; - FOnContent : TContentEvent; - FOnCData : TContentEvent; - FOnElement : TElementEvent; - FOnAttList : TElementEvent; - FOnEntity : TEntityEvent; - FOnNotation : TNotationEvent; - FOnDtdError : TErrorEvent; - FOnLoadExternal : TExternalEvent; - FOnTranslateEncoding : TEncodingEvent; - FStopParser : BOOLEAN; - FUNCTION GetNormalize : BOOLEAN; - PROCEDURE SetNormalize (Value : BOOLEAN); - - PROCEDURE WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); VIRTUAL; - PROCEDURE WhenComment (Comment : STRING); VIRTUAL; - PROCEDURE WhenPI (Target, Content: STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenDtdRead (RootElementName : STRING); VIRTUAL; - PROCEDURE WhenStartTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenEmptyTag (TagName : STRING; Attributes : TAttrList); VIRTUAL; - PROCEDURE WhenEndTag (TagName : STRING); VIRTUAL; - PROCEDURE WhenContent (Content : STRING); VIRTUAL; - PROCEDURE WhenCData (Content : STRING); VIRTUAL; - PROCEDURE WhenElement (ElemDef : TElemDef); VIRTUAL; - PROCEDURE WhenAttList (ElemDef : TElemDef); VIRTUAL; - PROCEDURE WhenEntity (EntityDef : TEntityDef); VIRTUAL; - PROCEDURE WhenNotation (NotationDef : TNotationDef); VIRTUAL; - PROCEDURE WhenDtdError (ErrorPos : PChar); VIRTUAL; - - PUBLIC - CONSTRUCTOR Create (AOwner: TComponent); OVERRIDE; - DESTRUCTOR Destroy; OVERRIDE; - - PROCEDURE LoadFromFile (Filename : TFilename); // Load XML Document from file - PROCEDURE LoadFromBuffer (Buffer : PChar); // Load XML Document from buffer - PROCEDURE SetBuffer (Buffer : PChar); // Refer to Buffer - FUNCTION GetFilename : TFilename; - - PROCEDURE Execute; // Perform scanning - - PROTECTED - PROPERTY XmlParser : TXmlParser READ FXmlParser; - PROPERTY StopParser : BOOLEAN READ FStopParser WRITE FStopParser; - PROPERTY Filename : TFilename READ GetFilename WRITE LoadFromFile; - PROPERTY Normalize : BOOLEAN READ GetNormalize WRITE SetNormalize; - PROPERTY OnXmlProlog : TXmlPrologEvent READ FOnXmlProlog WRITE FOnXmlProlog; - PROPERTY OnComment : TCommentEvent READ FOnComment WRITE FOnComment; - PROPERTY OnPI : TPIEvent READ FOnPI WRITE FOnPI; - PROPERTY OnDtdRead : TDtdEvent READ FOnDtdRead WRITE FOnDtdRead; - PROPERTY OnStartTag : TStartTagEvent READ FOnStartTag WRITE FOnStartTag; - PROPERTY OnEmptyTag : TStartTagEvent READ FOnEmptyTag WRITE FOnEmptyTag; - PROPERTY OnEndTag : TEndTagEvent READ FOnEndTag WRITE FOnEndTag; - PROPERTY OnContent : TContentEvent READ FOnContent WRITE FOnContent; - PROPERTY OnCData : TContentEvent READ FOnCData WRITE FOnCData; - PROPERTY OnElement : TElementEvent READ FOnElement WRITE FOnElement; - PROPERTY OnAttList : TElementEvent READ FOnAttList WRITE FOnAttList; - PROPERTY OnEntity : TEntityEvent READ FOnEntity WRITE FOnEntity; - PROPERTY OnNotation : TNotationEvent READ FOnNotation WRITE FOnNotation; - PROPERTY OnDtdError : TErrorEvent READ FOnDtdError WRITE FOnDtdError; - PROPERTY OnLoadExternal : TExternalEvent READ FOnLoadExternal WRITE FOnLoadExternal; - PROPERTY OnTranslateEncoding : TEncodingEvent READ FOnTranslateEncoding WRITE FOnTranslateEncoding; - END; - -(* -=============================================================================================== -IMPLEMENTATION -=============================================================================================== -*) - -IMPLEMENTATION - - -(* -=============================================================================================== -Unicode and UTF-8 stuff -=============================================================================================== -*) - -CONST - // --- Character Translation Table for Unicode <-> Win-1252 - WIN1252_UNICODE : ARRAY [$00..$FF] OF WORD = ( - $0000, $0001, $0002, $0003, $0004, $0005, $0006, $0007, $0008, $0009, - $000A, $000B, $000C, $000D, $000E, $000F, $0010, $0011, $0012, $0013, - $0014, $0015, $0016, $0017, $0018, $0019, $001A, $001B, $001C, $001D, - $001E, $001F, $0020, $0021, $0022, $0023, $0024, $0025, $0026, $0027, - $0028, $0029, $002A, $002B, $002C, $002D, $002E, $002F, $0030, $0031, - $0032, $0033, $0034, $0035, $0036, $0037, $0038, $0039, $003A, $003B, - $003C, $003D, $003E, $003F, $0040, $0041, $0042, $0043, $0044, $0045, - $0046, $0047, $0048, $0049, $004A, $004B, $004C, $004D, $004E, $004F, - $0050, $0051, $0052, $0053, $0054, $0055, $0056, $0057, $0058, $0059, - $005A, $005B, $005C, $005D, $005E, $005F, $0060, $0061, $0062, $0063, - $0064, $0065, $0066, $0067, $0068, $0069, $006A, $006B, $006C, $006D, - $006E, $006F, $0070, $0071, $0072, $0073, $0074, $0075, $0076, $0077, - $0078, $0079, $007A, $007B, $007C, $007D, $007E, $007F, - - $20AC, $0081, $201A, $0192, $201E, $2026, $2020, $2021, $02C6, $2030, - $0160, $2039, $0152, $008D, $017D, $008F, $0090, $2018, $2019, $201C, - $201D, $2022, $2013, $2014, $02DC, $2122, $0161, $203A, $0153, $009D, - $017E, $0178, $00A0, $00A1, $00A2, $00A3, $00A4, $00A5, $00A6, $00A7, - $00A8, $00A9, $00AA, $00AB, $00AC, $00AD, $00AE, $00AF, $00B0, $00B1, - $00B2, $00B3, $00B4, $00B5, $00B6, $00B7, $00B8, $00B9, $00BA, $00BB, - $00BC, $00BD, $00BE, $00BF, $00C0, $00C1, $00C2, $00C3, $00C4, $00C5, - $00C6, $00C7, $00C8, $00C9, $00CA, $00CB, $00CC, $00CD, $00CE, $00CF, - $00D0, $00D1, $00D2, $00D3, $00D4, $00D5, $00D6, $00D7, $00D8, $00D9, - $00DA, $00DB, $00DC, $00DD, $00DE, $00DF, $00E0, $00E1, $00E2, $00E3, - $00E4, $00E5, $00E6, $00E7, $00E8, $00E9, $00EA, $00EB, $00EC, $00ED, - $00EE, $00EF, $00F0, $00F1, $00F2, $00F3, $00F4, $00F5, $00F6, $00F7, - $00F8, $00F9, $00FA, $00FB, $00FC, $00FD, $00FE, $00FF); - -(* UTF-8 (somewhat simplified) - ----- - Character Range Byte sequence - --------------- -------------------------- (x=Bits from original character) - $0000..$007F 0xxxxxxx - $0080..$07FF 110xxxxx 10xxxxxx - $8000..$FFFF 1110xxxx 10xxxxxx 10xxxxxx - - Example - -------- - Transforming the Unicode character U+00E4 LATIN SMALL LETTER A WITH DIAERESIS ("ä"): - - ISO-8859-1, Decimal 228 - Win1252, Hex $E4 - ANSI Bin 1110 0100 - abcd efgh - - UTF-8 Binary 1100xxab 10cdefgh - Binary 11000011 10100100 - Hex $C3 $A4 - Decimal 195 164 - ANSI Ã ¤ *) - - -FUNCTION AnsiToUtf8 (Source : ANSISTRING) : STRING; - (* Converts the given Windows ANSI (Win1252) String to UTF-8. *) -VAR - I : INTEGER; // Loop counter - U : WORD; // Current Unicode value - Len : INTEGER; // Current real length of "Result" string -BEGIN - SetLength (Result, Length (Source) * 3); // Worst case - Len := 0; - FOR I := 1 TO Length (Source) DO BEGIN - U := WIN1252_UNICODE [ORD (Source [I])]; - CASE U OF - $0000..$007F : BEGIN - INC (Len); - Result [Len] := CHR (U); - END; - $0080..$07FF : BEGIN - INC (Len); - Result [Len] := CHR ($C0 OR (U SHR 6)); - INC (Len); - Result [Len] := CHR ($80 OR (U AND $3F)); - END; - $0800..$FFFF : BEGIN - INC (Len); - Result [Len] := CHR ($E0 OR (U SHR 12)); - INC (Len); - Result [Len] := CHR ($80 OR ((U SHR 6) AND $3F)); - INC (Len); - Result [Len] := CHR ($80 OR (U AND $3F)); - END; - END; - END; - SetLength (Result, Len); -END; - - -FUNCTION Utf8ToAnsi (Source : STRING; UnknownChar : CHAR = '¿') : ANSISTRING; - (* Converts the given UTF-8 String to Windows ANSI (Win-1252). - If a character can not be converted, the "UnknownChar" is inserted. *) -VAR - SourceLen : INTEGER; // Length of Source string - I, K : INTEGER; - A : BYTE; // Current ANSI character value - U : WORD; - Ch : CHAR; // Dest char - Len : INTEGER; // Current real length of "Result" string -BEGIN - SourceLen := Length (Source); - SetLength (Result, SourceLen); // Enough room to live - Len := 0; - I := 1; - WHILE I <= SourceLen DO BEGIN - A := ORD (Source [I]); - IF A < $80 THEN BEGIN // Range $0000..$007F - INC (Len); - Result [Len] := Source [I]; - INC (I); - END - ELSE BEGIN // Determine U, Inc I - IF (A AND $E0 = $C0) AND (I < SourceLen) THEN BEGIN // Range $0080..$07FF - U := (WORD (A AND $1F) SHL 6) OR (ORD (Source [I+1]) AND $3F); - INC (I, 2); - END - ELSE IF (A AND $F0 = $E0) AND (I < SourceLen-1) THEN BEGIN // Range $0800..$FFFF - U := (WORD (A AND $0F) SHL 12) OR - (WORD (ORD (Source [I+1]) AND $3F) SHL 6) OR - ( ORD (Source [I+2]) AND $3F); - INC (I, 3); - END - ELSE BEGIN // Unknown/unsupported - INC (I); - FOR K := 7 DOWNTO 0 DO - IF A AND (1 SHL K) = 0 THEN BEGIN - INC (I, (A SHR (K+1))-1); - BREAK; - END; - U := WIN1252_UNICODE [ORD (UnknownChar)]; - END; - Ch := UnknownChar; // Retrieve ANSI char - FOR A := $00 TO $FF DO - IF WIN1252_UNICODE [A] = U THEN BEGIN - Ch := CHR (A); - BREAK; - END; - INC (Len); - Result [Len] := Ch; - END; - END; - SetLength (Result, Len); -END; - - -(* -=============================================================================================== -"Special" Helper Functions - -Don't ask me why. But including these functions makes the parser *DRAMATICALLY* faster -on my K6-233 machine. You can test it yourself just by commenting them out. -They do exactly the same as the Assembler routines defined in SysUtils. -(This is where you can see how great the Delphi compiler really is. The compiled code is -faster than hand-coded assembler!) -=============================================================================================== ---> Just move this line below the StrScan function --> *) - - -FUNCTION StrPos (CONST Str, SearchStr : PChar) : PChar; - // Same functionality as SysUtils.StrPos -VAR - First : CHAR; - Len : INTEGER; -BEGIN - First := SearchStr^; - Len := StrLen (SearchStr); - Result := Str; - REPEAT - IF Result^ = First THEN - IF StrLComp (Result, SearchStr, Len) = 0 THEN BREAK; - IF Result^ = #0 THEN BEGIN - Result := NIL; - BREAK; - END; - INC (Result); - UNTIL FALSE; -END; - - -FUNCTION StrScan (CONST Start : PChar; CONST Ch : CHAR) : PChar; - // Same functionality as SysUtils.StrScan -BEGIN - Result := Start; - WHILE Result^ <> Ch DO BEGIN - IF Result^ = #0 THEN BEGIN - Result := NIL; - EXIT; - END; - INC (Result); - END; -END; - - -(* -=============================================================================================== -Helper Functions -=============================================================================================== -*) - -FUNCTION DelChars (Source : STRING; CharsToDelete : TCharset) : STRING; - // Delete all "CharsToDelete" from the string -VAR - I : INTEGER; -BEGIN - Result := Source; - FOR I := Length (Result) DOWNTO 1 DO - IF Result [I] IN CharsToDelete THEN - Delete (Result, I, 1); -END; - - -FUNCTION TrimWs (Source : STRING) : STRING; - // Trimms off Whitespace characters from both ends of the string -VAR - I : INTEGER; -BEGIN - // --- Trim Left - I := 1; - WHILE (I <= Length (Source)) AND (Source [I] IN CWhitespace) DO - INC (I); - Result := Copy (Source, I, MaxInt); - - // --- Trim Right - I := Length (Result); - WHILE (I > 1) AND (Result [I] IN CWhitespace) DO - DEC (I); - Delete (Result, I+1, Length (Result)-I); -END; - - -FUNCTION ConvertWs (Source: STRING; PackWs: BOOLEAN) : STRING; - // Converts all Whitespace characters to the Space #x20 character - // If "PackWs" is true, contiguous Whitespace characters are packed to one -VAR - I : INTEGER; -BEGIN - Result := Source; - FOR I := Length (Result) DOWNTO 1 DO - IF (Result [I] IN CWhitespace) THEN - IF PackWs AND (I > 1) AND (Result [I-1] IN CWhitespace) - THEN Delete (Result, I, 1) - ELSE Result [I] := #32; -END; - - -PROCEDURE SetStringSF (VAR S : STRING; BufferStart, BufferFinal : PChar); -BEGIN - SetString (S, BufferStart, BufferFinal-BufferStart+1); -END; - - -FUNCTION StrLPas (Start : PChar; Len : INTEGER) : STRING; -BEGIN - SetString (Result, Start, Len); -END; - - -FUNCTION StrSFPas (Start, Finish : PChar) : STRING; -BEGIN - SetString (Result, Start, Finish-Start+1); -END; - - -FUNCTION StrScanE (CONST Source : PChar; CONST CharToScanFor : CHAR) : PChar; - // If "CharToScanFor" is not found, StrScanE returns the last char of the - // buffer instead of NIL -BEGIN - Result := StrScan (Source, CharToScanFor); - IF Result = NIL THEN - Result := StrEnd (Source)-1; -END; - - -PROCEDURE ExtractName (Start : PChar; Terminators : TCharset; VAR Final : PChar); - (* Extracts the complete Name beginning at "Start". - It is assumed that the name is contained in Markup, so the '>' character is - always a Termination. - Start: IN Pointer to first char of name. Is always considered to be valid - Terminators: IN Characters which terminate the name - Final: OUT Pointer to last char of name *) -BEGIN - Final := Start+1; - Include (Terminators, #0); - Include (Terminators, '>'); - WHILE NOT (Final^ IN Terminators) DO - INC (Final); - DEC (Final); -END; - - -PROCEDURE ExtractQuote (Start : PChar; VAR Content : STRING; VAR Final : PChar); - (* Extract a string which is contained in single or double Quotes. - Start: IN Pointer to opening quote - Content: OUT The quoted string - Final: OUT Pointer to closing quote *) -BEGIN - Final := StrScan (Start+1, Start^); - IF Final = NIL THEN BEGIN - Final := StrEnd (Start+1)-1; - SetString (Content, Start+1, Final-Start); - END - ELSE - SetString (Content, Start+1, Final-1-Start); -END; - - -(* -=============================================================================================== -TEntityStackNode -This Node is pushed to the "Entity Stack" whenever the parser parses entity replacement text. -The "Instance" field holds the Instance pointer of an External Entity buffer. When it is -popped, the Instance is freed. -The "Encoding" field holds the name of the Encoding. External Parsed Entities may have -another encoding as the document entity (XmlSpec 4.3.3). So when there is an "<?xml" PI -found in the stream (= Text Declaration at the beginning of external parsed entities), the -Encoding found there is used for the External Entity (is assigned to TXmlParser.CurEncoding) -Default Encoding is for the Document Entity is UTF-8. It is assumed that External Entities -have the same Encoding as the Document Entity, unless they carry a Text Declaration. -=============================================================================================== -*) - -TYPE - TEntityStackNode = CLASS - Instance : TObject; - Encoding : STRING; - LastPos : PChar; - END; - -(* -=============================================================================================== -TEntityStack -For nesting of Entities. -When there is an entity reference found in the data stream, the corresponding entity -definition is searched and the current position is pushed to this stack. -From then on, the program scans the entitiy replacement text as if it were normal content. -When the parser reaches the end of an entity, the current position is popped off the -stack again. -=============================================================================================== -*) - -CONSTRUCTOR TEntityStack.Create (TheOwner : TXmlParser); -BEGIN - INHERITED Create; - Owner := TheOwner; -END; - - -PROCEDURE TEntityStack.Push (LastPos : PChar); -BEGIN - Push (NIL, LastPos); -END; - - -PROCEDURE TEntityStack.Push (Instance : TObject; LastPos : PChar); -VAR - ESN : TEntityStackNode; -BEGIN - ESN := TEntityStackNode.Create; - ESN.Instance := Instance; - ESN.Encoding := Owner.FCurEncoding; // Save current Encoding - ESN.LastPos := LastPos; - Add (ESN); -END; - - -FUNCTION TEntityStack.Pop : PChar; -VAR - ESN : TEntityStackNode; -BEGIN - IF Count > 0 THEN BEGIN - ESN := TEntityStackNode (Items [Count-1]); - Result := ESN.LastPos; - IF ESN.Instance <> NIL THEN - ESN.Instance.Free; - IF ESN.Encoding <> '' THEN - Owner.FCurEncoding := ESN.Encoding; // Restore current Encoding - Delete (Count-1); - END - ELSE - Result := NIL; -END; - - -(* -=============================================================================================== -TExternalID ------------ -XmlSpec 4.2.2: ExternalID ::= 'SYSTEM' S SystemLiteral | - 'PUBLIC' S PubidLiteral S SystemLiteral -XmlSpec 4.7: PublicID ::= 'PUBLIC' S PubidLiteral -SystemLiteral and PubidLiteral are quoted -=============================================================================================== -*) - -TYPE - TExternalID = CLASS - PublicId : STRING; - SystemId : STRING; - Final : PChar; - CONSTRUCTOR Create (Start : PChar); - END; - -CONSTRUCTOR TExternalID.Create (Start : PChar); -BEGIN - INHERITED Create; - Final := Start; - IF StrLComp (Start, 'SYSTEM', 6) = 0 THEN BEGIN - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, SystemID, Final); - END - ELSE IF StrLComp (Start, 'PUBLIC', 6) = 0 THEN BEGIN - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, PublicID, Final); - INC (Final); - WHILE NOT (Final^ IN (CQuoteChar + [#0, '>', '['])) DO INC (Final); - IF NOT (Final^ IN CQuoteChar) THEN EXIT; - ExtractQuote (Final, SystemID, Final); - END; -END; - - -(* -=============================================================================================== -TXmlParser -=============================================================================================== -*) - -CONSTRUCTOR TXmlParser.Create; -BEGIN - INHERITED Create; - FBuffer := NIL; - FBufferSize := 0; - Elements := TElemList.Create; - Entities := TNvpList.Create; - ParEntities := TNvpList.Create; - Notations := TNvpList.Create; - CurAttr := TAttrList.Create; - EntityStack := TEntityStack.Create (Self); - Clear; -END; - - -DESTRUCTOR TXmlParser.Destroy; -BEGIN - Clear; - Elements.Free; - Entities.Free; - ParEntities.Free; - Notations.Free; - CurAttr.Free; - EntityStack.Free; - INHERITED Destroy; -END; - - -PROCEDURE TXmlParser.Clear; - // Free Buffer and clear all object attributes -BEGIN - IF (FBufferSize > 0) AND (FBuffer <> NIL) THEN - FreeMem (FBuffer); - FBuffer := NIL; - FBufferSize := 0; - FSource := ''; - FXmlVersion := ''; - FEncoding := ''; - FStandalone := FALSE; - FRootName := ''; - FDtdcFinal := NIL; - FNormalize := TRUE; - Elements.Clear; - Entities.Clear; - ParEntities.Clear; - Notations.Clear; - CurAttr.Clear; - EntityStack.Clear; -END; - - -FUNCTION TXmlParser.LoadFromFile (Filename : STRING; FileMode : INTEGER = fmOpenRead OR fmShareDenyNone) : BOOLEAN; - // Loads Document from given file - // Returns TRUE if successful -VAR - f : FILE; - ReadIn : INTEGER; - OldFileMode : INTEGER; -BEGIN - Result := FALSE; - Clear; - - // --- Open File - OldFileMode := SYSTEM.FileMode; - TRY - SYSTEM.FileMode := FileMode; - TRY - AssignFile (f, Filename); - Reset (f, 1); - EXCEPT - EXIT; - END; - - TRY - // --- Allocate Memory - TRY - FBufferSize := Filesize (f) + 1; - GetMem (FBuffer, FBufferSize); - EXCEPT - Clear; - EXIT; - END; - - // --- Read File - TRY - BlockRead (f, FBuffer^, FBufferSize, ReadIn); - (FBuffer+ReadIn)^ := #0; // NULL termination - EXCEPT - Clear; - EXIT; - END; - FINALLY - CloseFile (f); - END; - - FSource := Filename; - Result := TRUE; - - FINALLY - SYSTEM.FileMode := OldFileMode; - END; -END; - - -FUNCTION TXmlParser.LoadFromBuffer (Buffer : PChar) : BOOLEAN; - // Loads Document from another buffer - // Returns TRUE if successful - // The "Source" property becomes '<MEM>' if successful -BEGIN - Result := FALSE; - Clear; - FBufferSize := StrLen (Buffer) + 1; - TRY - GetMem (FBuffer, FBufferSize); - EXCEPT - Clear; - EXIT; - END; - StrCopy (FBuffer, Buffer); - FSource := '<MEM>'; - Result := TRUE; -END; - - -PROCEDURE TXmlParser.SetBuffer (Buffer : PChar); // References another buffer -BEGIN - Clear; - FBuffer := Buffer; - FBufferSize := 0; - FSource := '<REFERENCE>'; -END; - - -//----------------------------------------------------------------------------------------------- -// Scanning through the document -//----------------------------------------------------------------------------------------------- - -PROCEDURE TXmlParser.StartScan; -BEGIN - CurPartType := ptNone; - CurName := ''; - CurContent := ''; - CurStart := NIL; - CurFinal := NIL; - CurAttr.Clear; - EntityStack.Clear; -END; - - -FUNCTION TXmlParser.Scan : BOOLEAN; - // Scans the next Part - // Returns TRUE if a part could be found, FALSE if there is no part any more - // - // "IsDone" can be set to FALSE by AnalyzeText in order to go to the next part - // if there is no Content due to normalization -VAR - IsDone : BOOLEAN; -BEGIN - REPEAT - IsDone := TRUE; - - // --- Start of next Part - IF CurStart = NIL - THEN CurStart := DocBuffer - ELSE CurStart := CurFinal+1; - CurFinal := CurStart; - - // --- End of Document of Pop off a new part from the Entity stack? - IF CurStart^ = #0 THEN - CurStart := EntityStack.Pop; - - // --- No Document or End Of Document: Terminate Scan - IF (CurStart = NIL) OR (CurStart^ = #0) THEN BEGIN - CurStart := StrEnd (DocBuffer); - CurFinal := CurStart-1; - EntityStack.Clear; - Result := FALSE; - EXIT; - END; - - IF (StrLComp (CurStart, '<?xml', 5) = 0) AND - ((CurStart+5)^ IN CWhitespace) THEN AnalyzeProlog // XML Declaration, Text Declaration - ELSE IF StrLComp (CurStart, '<?', 2) = 0 THEN AnalyzePI (CurStart, CurFinal) // PI - ELSE IF StrLComp (CurStart, '<!--', 4) = 0 THEN AnalyzeComment (CurStart, CurFinal) // Comment - ELSE IF StrLComp (CurStart, '<!DOCTYPE', 9) = 0 THEN AnalyzeDtdc // DTDc - ELSE IF StrLComp (CurStart, CDStart, Length (CDStart)) = 0 THEN AnalyzeCdata // CDATA Section - ELSE IF StrLComp (CurStart, '<', 1) = 0 THEN AnalyzeTag // Start-Tag, End-Tag, Empty-Element-Tag - ELSE AnalyzeText (IsDone); // Text Content - UNTIL IsDone; - Result := TRUE; -END; - - -PROCEDURE TXmlParser.AnalyzeProlog; - // Analyze XML Prolog or Text Declaration -VAR - F : PChar; -BEGIN - CurAttr.Analyze (CurStart+5, F); - IF EntityStack.Count = 0 THEN BEGIN - FXmlVersion := CurAttr.Value ('version'); - FEncoding := CurAttr.Value ('encoding'); - FStandalone := CurAttr.Value ('standalone') = 'yes'; - END; - CurFinal := StrPos (F, '?>'); - IF CurFinal <> NIL - THEN INC (CurFinal) - ELSE CurFinal := StrEnd (CurStart)-1; - FCurEncoding := AnsiUpperCase (CurAttr.Value ('encoding')); - IF FCurEncoding = '' THEN - FCurEncoding := 'UTF-8'; // Default XML Encoding is UTF-8 - CurPartType := ptXmlProlog; - CurName := ''; - CurContent := ''; -END; - - -PROCEDURE TXmlParser.AnalyzeComment (Start : PChar; VAR Final : PChar); - // Analyze Comments -BEGIN - Final := StrPos (Start+4, '-->'); - IF Final = NIL - THEN Final := StrEnd (Start)-1 - ELSE INC (Final, 2); - CurPartType := ptComment; -END; - - -PROCEDURE TXmlParser.AnalyzePI (Start : PChar; VAR Final : PChar); - // Analyze Processing Instructions (PI) - // This is also called for Character -VAR - F : PChar; -BEGIN - CurPartType := ptPI; - Final := StrPos (Start+2, '?>'); - IF Final = NIL - THEN Final := StrEnd (Start)-1 - ELSE INC (Final); - ExtractName (Start+2, CWhitespace + ['?', '>'], F); - SetStringSF (CurName, Start+2, F); - SetStringSF (CurContent, F+1, Final-2); - CurAttr.Analyze (F+1, F); -END; - - -PROCEDURE TXmlParser.AnalyzeDtdc; - (* Analyze Document Type Declaration - doctypedecl ::= '<!DOCTYPE' S Name (S ExternalID)? S? ('[' (markupdecl | PEReference | S)* ']' S?)? '>' - markupdecl ::= elementdecl | AttlistDecl | EntityDecl | NotationDecl | PI | Comment - PEReference ::= '%' Name ';' - - elementdecl ::= '<!ELEMENT' S Name S contentspec S? '>' - AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>' - EntityDecl ::= '<!ENTITY' S Name S EntityDef S? '>' | - '<!ENTITY' S '%' S Name S PEDef S? '>' - NotationDecl ::= '<!NOTATION' S Name S (ExternalID | PublicID) S? '>' - PI ::= '<?' PITarget (S (Char* - (Char* '?>' Char* )))? '?>' - Comment ::= '<!--' ((Char - '-') | ('-' (Char - '-')))* '-->' *) -TYPE - TPhase = (phName, phDtd, phInternal, phFinishing); -VAR - Phase : TPhase; - F : PChar; - ExternalID : TExternalID; - ExternalDTD : TXmlParser; - DER : TDtdElementRec; -BEGIN - DER.Start := CurStart; - EntityStack.Clear; // Clear stack for Parameter Entities - CurPartType := ptDtdc; - - // --- Don't read DTDc twice - IF FDtdcFinal <> NIL THEN BEGIN - CurFinal := FDtdcFinal; - EXIT; - END; - - // --- Scan DTDc - CurFinal := CurStart + 9; // First char after '<!DOCTYPE' - Phase := phName; - REPEAT - CASE CurFinal^ OF - '%' : BEGIN - PushPE (CurFinal); - CONTINUE; - END; - #0 : IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurFinal := EntityStack.Pop; - CONTINUE; - END; - '[' : BEGIN - Phase := phInternal; - AnalyzeDtdElements (CurFinal+1, CurFinal); - CONTINUE; - END; - ']' : Phase := phFinishing; - '>' : BREAK; - ELSE IF NOT (CurFinal^ IN CWhitespace) THEN BEGIN - CASE Phase OF - phName : IF (CurFinal^ IN CNameStart) THEN BEGIN - ExtractName (CurFinal, CWhitespace + ['[', '>'], F); - SetStringSF (FRootName, CurFinal, F); - CurFinal := F; - Phase := phDtd; - END; - phDtd : IF (StrLComp (CurFinal, 'SYSTEM', 6) = 0) OR - (StrLComp (CurFinal, 'PUBLIC', 6) = 0) THEN BEGIN - ExternalID := TExternalID.Create (CurFinal); - ExternalDTD := LoadExternalEntity (ExternalId.SystemId, ExternalID.PublicId, ''); - F := StrPos (ExternalDtd.DocBuffer, '<!'); - IF F <> NIL THEN - AnalyzeDtdElements (F, F); - ExternalDTD.Free; - CurFinal := ExternalID.Final; - ExternalID.Free; - END; - ELSE BEGIN - DER.ElementType := deError; - DER.Pos := CurFinal; - DER.Final := CurFinal; - DtdElementFound (DER); - END; - END; - - END; - END; - INC (CurFinal); - UNTIL FALSE; - - CurPartType := ptDtdc; - CurName := ''; - CurContent := ''; - - // It is an error in the document if "EntityStack" is not empty now - IF EntityStack.Count > 0 THEN BEGIN - DER.ElementType := deError; - DER.Final := CurFinal; - DER.Pos := CurFinal; - DtdElementFound (DER); - END; - - EntityStack.Clear; // Clear stack for General Entities - FDtdcFinal := CurFinal; -END; - - -PROCEDURE TXmlParser.AnalyzeDtdElements (Start : PChar; VAR Final : PChar); - // Analyze the "Elements" of a DTD contained in the external or - // internal DTD subset. -VAR - DER : TDtdElementRec; -BEGIN - Final := Start; - REPEAT - CASE Final^ OF - '%' : BEGIN - PushPE (Final); - CONTINUE; - END; - #0 : IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurFinal := EntityStack.Pop; - CONTINUE; - END; - ']', - '>' : BREAK; - '<' : IF StrLComp (Final, '<!ELEMENT', 9) = 0 THEN AnalyzeElementDecl (Final, Final) - ELSE IF StrLComp (Final, '<!ATTLIST', 9) = 0 THEN AnalyzeAttListDecl (Final, Final) - ELSE IF StrLComp (Final, '<!ENTITY', 8) = 0 THEN AnalyzeEntityDecl (Final, Final) - ELSE IF StrLComp (Final, '<!NOTATION', 10) = 0 THEN AnalyzeNotationDecl (Final, Final) - ELSE IF StrLComp (Final, '<?', 2) = 0 THEN BEGIN // PI in DTD - DER.ElementType := dePI; - DER.Start := Final; - AnalyzePI (Final, Final); - DER.Target := PChar (CurName); - DER.Content := PChar (CurContent); - DER.AttrList := CurAttr; - DER.Final := Final; - DtdElementFound (DER); - END - ELSE IF StrLComp (Final, '<!--', 4) = 0 THEN BEGIN // Comment in DTD - DER.ElementType := deComment; - DER.Start := Final; - AnalyzeComment (Final, Final); - DER.Final := Final; - DtdElementFound (DER); - END - ELSE BEGIN - DER.ElementType := deError; - DER.Start := Final; - DER.Pos := Final; - DER.Final := Final; - DtdElementFound (DER); - END; - - END; - INC (Final); - UNTIL FALSE; -END; - - -PROCEDURE TXmlParser.AnalyzeTag; - // Analyze Tags -VAR - S, F : PChar; - Attr : TAttr; - ElemDef : TElemDef; - AttrDef : TAttrDef; - I : INTEGER; -BEGIN - CurPartType := ptStartTag; - S := CurStart+1; - IF S^ = '/' THEN BEGIN - CurPartType := ptEndTag; - INC (S); - END; - ExtractName (S, CWhitespace + ['/'], F); - SetStringSF (CurName, S, F); - CurAttr.Analyze (F+1, CurFinal); - IF CurFinal^ = '/' THEN BEGIN - CurPartType := ptEmptyTag; - END; - CurFinal := StrScanE (CurFinal, '>'); - - // --- Set Default Attribute values for nonexistent attributes - IF (CurPartType = ptStartTag) OR (CurPartType = ptEmptyTag) THEN BEGIN - ElemDef := Elements.Node (CurName); - IF ElemDef <> NIL THEN BEGIN - FOR I := 0 TO ElemDef.Count-1 DO BEGIN - AttrDef := TAttrDef (ElemDef [I]); - Attr := TAttr (CurAttr.Node (AttrDef.Name)); - IF (Attr = NIL) AND (AttrDef.Value <> '') THEN BEGIN - Attr := TAttr.Create (AttrDef.Name, AttrDef.Value); - Attr.ValueType := vtDefault; - CurAttr.Add (Attr); - END; - IF Attr <> NIL THEN BEGIN - CASE AttrDef.DefaultType OF - adDefault : ; - adRequired : ; // -!- It is an error in the document if "Attr.Value" is an empty string - adImplied : Attr.ValueType := vtImplied; - adFixed : BEGIN - Attr.ValueType := vtFixed; - Attr.Value := AttrDef.Value; - END; - END; - Attr.AttrType := AttrDef.AttrType; - END; - END; - END; - - // --- Normalize Attribute Values. XmlSpec: - // - a character reference is processed by appending the referenced character to the attribute value - // - an entity reference is processed by recursively processing the replacement text of the entity - // - a whitespace character (#x20, #xD, #xA, #x9) is processed by appending #x20 to the normalized value, - // except that only a single #x20 is appended for a "#xD#xA" sequence that is part of an external - // parsed entity or the literal entity value of an internal parsed entity - // - other characters are processed by appending them to the normalized value - // If the declared value is not CDATA, then the XML processor must further process the - // normalized attribute value by discarding any leading and trailing space (#x20) characters, - // and by replacing sequences of space (#x20) characters by a single space (#x20) character. - // All attributes for which no declaration has been read should be treated by a - // non-validating parser as if declared CDATA. - // !!! The XML 1.0 SE specification is somewhat different here - // This code does not conform exactly to this specification - FOR I := 0 TO CurAttr.Count-1 DO - WITH TAttr (CurAttr [I]) DO BEGIN - ReplaceGeneralEntities (Value); - ReplaceCharacterEntities (Value); - IF (AttrType <> atCData) AND (AttrType <> atUnknown) - THEN Value := TranslateEncoding (TrimWs (ConvertWs (Value, TRUE))) - ELSE Value := TranslateEncoding (ConvertWs (Value, FALSE)); - END; - END; -END; - - -PROCEDURE TXmlParser.AnalyzeCData; - // Analyze CDATA Sections -BEGIN - CurPartType := ptCData; - CurFinal := StrPos (CurStart, CDEnd); - IF CurFinal = NIL THEN BEGIN - CurFinal := StrEnd (CurStart)-1; - CurContent := TranslateEncoding (StrPas (CurStart+Length (CDStart))); - END - ELSE BEGIN - SetStringSF (CurContent, CurStart+Length (CDStart), CurFinal-1); - INC (CurFinal, Length (CDEnd)-1); - CurContent := TranslateEncoding (CurContent); - END; -END; - - -PROCEDURE TXmlParser.AnalyzeText (VAR IsDone : BOOLEAN); - (* Analyzes Text Content between Tags. CurFinal will point to the last content character. - Content ends at a '<' character or at the end of the document. - Entity References and Character Entity references are resolved. - If PackSpaces is TRUE, contiguous Whitespace Characters will be compressed to - one Space #x20 character, Whitespace at the beginning and end of content will - be trimmed off and content which is or becomes empty is not returned to - the application (in this case, "IsDone" is set to FALSE which causes the - Scan method to proceed directly to the next part. *) - - PROCEDURE ProcessEntity; - (* Is called if there is an ampsersand '&' character found in the document. - IN "CurFinal" points to the ampersand - OUT "CurFinal" points to the first character after the semi-colon ';' *) - VAR - P : PChar; - Name : STRING; - EntityDef : TEntityDef; - ExternalEntity : TXmlParser; - BEGIN - P := StrScan (CurFinal , ';'); - IF P <> NIL THEN BEGIN - SetStringSF (Name, CurFinal+1, P-1); - - // Is it a Character Entity? - IF (CurFinal+1)^ = '#' THEN BEGIN - IF UpCase ((CurFinal+2)^) = 'X' // !!! Can't use "CHR" for Unicode characters > 255: - THEN CurContent := CurContent + CHR (StrToIntDef ('$'+Copy (Name, 3, MaxInt), 32)) - ELSE CurContent := CurContent + CHR (StrToIntDef (Copy (Name, 2, MaxInt), 32)); - CurFinal := P+1; - EXIT; - END - - // Is it a Predefined Entity? - ELSE IF Name = 'lt' THEN BEGIN CurContent := CurContent + '<'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'gt' THEN BEGIN CurContent := CurContent + '>'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'amp' THEN BEGIN CurContent := CurContent + '&'; CurFinal := P+1; EXIT; END - ELSE IF Name = 'apos' THEN BEGIN CurContent := CurContent + ''''; CurFinal := P+1; EXIT; END - ELSE IF Name = 'quot' THEN BEGIN CurContent := CurContent + '"'; CurFinal := P+1; EXIT; END; - - // Replace with Entity from DTD - EntityDef := TEntityDef (Entities.Node (Name)); - IF EntityDef <> NIL THEN BEGIN - IF EntityDef.Value <> '' THEN BEGIN - EntityStack.Push (P+1); - CurFinal := PChar (EntityDef.Value); - END - ELSE BEGIN - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); - EntityStack.Push (ExternalEntity, P+1); - CurFinal := ExternalEntity.DocBuffer; - END; - END - ELSE BEGIN - CurContent := CurContent + Name; - CurFinal := P+1; - END; - END - ELSE BEGIN - INC (CurFinal); - END; - END; - -VAR - C : INTEGER; -BEGIN - CurFinal := CurStart; - CurPartType := ptContent; - CurContent := ''; - C := 0; - REPEAT - CASE CurFinal^ OF - '&' : BEGIN - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - C := 0; - ProcessEntity; - CONTINUE; - END; - #0 : BEGIN - IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - C := 0; - CurFinal := EntityStack.Pop; - CONTINUE; - END; - END; - '<' : BREAK; - ELSE INC (C); - END; - INC (CurFinal); - UNTIL FALSE; - CurContent := CurContent + TranslateEncoding (StrLPas (CurFinal-C, C)); - DEC (CurFinal); - - IF FNormalize THEN BEGIN - CurContent := ConvertWs (TrimWs (CurContent), TRUE); - IsDone := CurContent <> ''; // IsDone will only get FALSE if PackSpaces is TRUE - END; -END; - - -PROCEDURE TXmlParser.AnalyzeElementDecl (Start : PChar; VAR Final : PChar); - (* Parse <!ELEMENT declaration starting at "Start" - Final must point to the terminating '>' character - XmlSpec 3.2: - elementdecl ::= '<!ELEMENT' S Name S contentspec S? '>' - contentspec ::= 'EMPTY' | 'ANY' | Mixed | children - Mixed ::= '(' S? '#PCDATA' (S? '|' S? Name)* S? ')*' | - '(' S? '#PCDATA' S? ')' - children ::= (choice | seq) ('?' | '*' | '+')? - choice ::= '(' S? cp ( S? '|' S? cp )* S? ')' - cp ::= (Name | choice | seq) ('?' | '*' | '+')? - seq ::= '(' S? cp ( S? ',' S? cp )* S? ')' - - More simply: - contentspec ::= EMPTY - ANY - '(#PCDATA)' - '(#PCDATA | A | B)*' - '(A, B, C)' - '(A | B | C)' - '(A?, B*, C+), - '(A, (B | C | D)* )' *) -VAR - Element : TElemDef; - Elem2 : TElemDef; - F : PChar; - DER : TDtdElementRec; -BEGIN - Element := TElemDef.Create; - Final := Start + 9; - DER.Start := Start; - REPEAT - IF Final^ = '>' THEN BREAK; - IF (Final^ IN CNameStart) AND (Element.Name = '') THEN BEGIN - ExtractName (Final, CWhitespace, F); - SetStringSF (Element.Name, Final, F); - Final := F; - F := StrScan (Final+1, '>'); - IF F = NIL THEN BEGIN - Element.Definition := STRING (Final); - Final := StrEnd (Final); - BREAK; - END - ELSE BEGIN - SetStringSF (Element.Definition, Final+1, F-1); - Final := F; - BREAK; - END; - END; - INC (Final); - UNTIL FALSE; - Element.Definition := DelChars (Element.Definition, CWhitespace); - ReplaceParameterEntities (Element.Definition); - IF Element.Definition = 'EMPTY' THEN Element.ElemType := etEmpty - ELSE IF Element.Definition = 'ANY' THEN Element.ElemType := etAny - ELSE IF Copy (Element.Definition, 1, 8) = '(#PCDATA' THEN Element.ElemType := etMixed - ELSE IF Copy (Element.Definition, 1, 1) = '(' THEN Element.ElemType := etChildren - ELSE Element.ElemType := etAny; - - Elem2 := Elements.Node (Element.Name); - IF Elem2 <> NIL THEN - Elements.Delete (Elements.IndexOf (Elem2)); - Elements.Add (Element); - Final := StrScanE (Final, '>'); - DER.ElementType := deElement; - DER.ElemDef := Element; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeAttListDecl (Start : PChar; VAR Final : PChar); - (* Parse <!ATTLIST declaration starting at "Start" - Final must point to the terminating '>' character - XmlSpec 3.3: - AttlistDecl ::= '<!ATTLIST' S Name AttDef* S? '>' - AttDef ::= S Name S AttType S DefaultDecl - AttType ::= StringType | TokenizedType | EnumeratedType - StringType ::= 'CDATA' - TokenizedType ::= 'ID' | 'IDREF' | 'IDREFS' | 'ENTITY' | 'ENTITIES' | 'NMTOKEN' | 'NMTOKENS' - EnumeratedType ::= NotationType | Enumeration - NotationType ::= 'NOTATION' S '(' S? Name (S? '|' S? Name)* S? ')' - Enumeration ::= '(' S? Nmtoken (S? '|' S? Nmtoken)* S? ')' - DefaultDecl ::= '#REQUIRED' | '#IMPLIED' | (('#FIXED' S)? AttValue) - AttValue ::= '"' ([^<&"] | Reference)* '"' | "'" ([^<&'] | Reference)* "'" - Examples: - <!ATTLIST address - A1 CDATA "Default" - A2 ID #REQUIRED - A3 IDREF #IMPLIED - A4 IDREFS #IMPLIED - A5 ENTITY #FIXED "&at;ü" - A6 ENTITIES #REQUIRED - A7 NOTATION (WMF | DXF) "WMF" - A8 (A | B | C) #REQUIRED> *) -TYPE - TPhase = (phElementName, phName, phType, phNotationContent, phDefault); -VAR - Phase : TPhase; - F : PChar; - ElementName : STRING; - ElemDef : TElemDef; - AttrDef : TAttrDef; - AttrDef2 : TAttrDef; - Strg : STRING; - DER : TDtdElementRec; -BEGIN - Final := Start + 9; // The character after <!ATTLIST - Phase := phElementName; - DER.Start := Start; - AttrDef := NIL; - ElemDef := NIL; - REPEAT - IF NOT (Final^ IN CWhitespace) THEN - CASE Final^ OF - '%' : BEGIN - PushPE (Final); - CONTINUE; - END; - #0 : IF EntityStack.Count = 0 THEN - BREAK - ELSE BEGIN - Final := EntityStack.Pop; - CONTINUE; - END; - '>' : BREAK; - ELSE CASE Phase OF - phElementName : BEGIN - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); - SetStringSF (ElementName, Final, F); - Final := F; - ElemDef := Elements.Node (ElementName); - IF ElemDef = NIL THEN BEGIN - ElemDef := TElemDef.Create; - ElemDef.Name := ElementName; - ElemDef.Definition := 'ANY'; - ElemDef.ElemType := etAny; - Elements.Add (ElemDef); - END; - Phase := phName; - END; - phName : BEGIN - AttrDef := TAttrDef.Create; - ExtractName (Final, CWhitespace + CQuoteChar + ['#'], F); - SetStringSF (AttrDef.Name, Final, F); - Final := F; - AttrDef2 := TAttrDef (ElemDef.Node (AttrDef.Name)); - IF AttrDef2 <> NIL THEN - ElemDef.Delete (ElemDef.IndexOf (AttrDef2)); - ElemDef.Add (AttrDef); - Phase := phType; - END; - phType : BEGIN - IF Final^ = '(' THEN BEGIN - F := StrScan (Final+1, ')'); - IF F <> NIL - THEN SetStringSF (AttrDef.TypeDef, Final+1, F-1) - ELSE AttrDef.TypeDef := STRING (Final+1); - AttrDef.TypeDef := DelChars (AttrDef.TypeDef, CWhitespace); - AttrDef.AttrType := atEnumeration; - ReplaceParameterEntities (AttrDef.TypeDef); - ReplaceCharacterEntities (AttrDef.TypeDef); - Phase := phDefault; - END - ELSE IF StrLComp (Final, 'NOTATION', 8) = 0 THEN BEGIN - INC (Final, 8); - AttrDef.AttrType := atNotation; - Phase := phNotationContent; - END - ELSE BEGIN - ExtractName (Final, CWhitespace+CQuoteChar+['#'], F); - SetStringSF (AttrDef.TypeDef, Final, F); - IF AttrDef.TypeDef = 'CDATA' THEN AttrDef.AttrType := atCData - ELSE IF AttrDef.TypeDef = 'ID' THEN AttrDef.AttrType := atId - ELSE IF AttrDef.TypeDef = 'IDREF' THEN AttrDef.AttrType := atIdRef - ELSE IF AttrDef.TypeDef = 'IDREFS' THEN AttrDef.AttrType := atIdRefs - ELSE IF AttrDef.TypeDef = 'ENTITY' THEN AttrDef.AttrType := atEntity - ELSE IF AttrDef.TypeDef = 'ENTITIES' THEN AttrDef.AttrType := atEntities - ELSE IF AttrDef.TypeDef = 'NMTOKEN' THEN AttrDef.AttrType := atNmToken - ELSE IF AttrDef.TypeDef = 'NMTOKENS' THEN AttrDef.AttrType := atNmTokens; - Phase := phDefault; - END - END; - phNotationContent : BEGIN - F := StrScan (Final, ')'); - IF F <> NIL THEN - SetStringSF (AttrDef.Notations, Final+1, F-1) - ELSE BEGIN - AttrDef.Notations := STRING (Final+1); - Final := StrEnd (Final); - END; - ReplaceParameterEntities (AttrDef.Notations); - AttrDef.Notations := DelChars (AttrDef.Notations, CWhitespace); - Phase := phDefault; - END; - phDefault : BEGIN - IF Final^ = '#' THEN BEGIN - ExtractName (Final, CWhiteSpace + CQuoteChar, F); - SetStringSF (Strg, Final, F); - Final := F; - ReplaceParameterEntities (Strg); - IF Strg = '#REQUIRED' THEN BEGIN AttrDef.DefaultType := adRequired; Phase := phName; END - ELSE IF Strg = '#IMPLIED' THEN BEGIN AttrDef.DefaultType := adImplied; Phase := phName; END - ELSE IF Strg = '#FIXED' THEN AttrDef.DefaultType := adFixed; - END - ELSE IF (Final^ IN CQuoteChar) THEN BEGIN - ExtractQuote (Final, AttrDef.Value, Final); - ReplaceParameterEntities (AttrDef.Value); - ReplaceCharacterEntities (AttrDef.Value); - Phase := phName; - END; - IF Phase = phName THEN BEGIN - AttrDef := NIL; - END; - END; - - END; - END; - INC (Final); - UNTIL FALSE; - - Final := StrScan (Final, '>'); - - DER.ElementType := deAttList; - DER.ElemDef := ElemDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeEntityDecl (Start : PChar; VAR Final : PChar); - (* Parse <!ENTITY declaration starting at "Start" - Final must point to the terminating '>' character - XmlSpec 4.2: - EntityDecl ::= '<!ENTITY' S Name S EntityDef S? '>' | - '<!ENTITY' S '%' S Name S PEDef S? '>' - EntityDef ::= EntityValue | (ExternalID NDataDecl?) - PEDef ::= EntityValue | ExternalID - NDataDecl ::= S 'NDATA' S Name - EntityValue ::= '"' ([^%&"] | PEReference | EntityRef | CharRef)* '"' | - "'" ([^%&'] | PEReference | EntityRef | CharRef)* "'" - PEReference ::= '%' Name ';' - - Examples - <!ENTITY test1 "Stefan Heymann"> <!-- Internal, general, parsed --> - <!ENTITY test2 SYSTEM "ent2.xml"> <!-- External, general, parsed --> - <!ENTITY test2 SYSTEM "ent3.gif" NDATA gif> <!-- External, general, unparsed --> - <!ENTITY % test3 "<!ELEMENT q ANY>"> <!-- Internal, parameter --> - <!ENTITY % test6 SYSTEM "ent6.xml"> <!-- External, parameter --> - <!ENTITY test4 "&test1; ist lieb"> <!-- IGP, Replacement text <> literal value --> - <!ENTITY test5 "<p>Dies ist ein Test-Absatz</p>"> <!-- IGP, See XmlSpec 2.4 --> - *) -TYPE - TPhase = (phName, phContent, phNData, phNotationName, phFinalGT); -VAR - Phase : TPhase; - IsParamEntity : BOOLEAN; - F : PChar; - ExternalID : TExternalID; - EntityDef : TEntityDef; - EntityDef2 : TEntityDef; - DER : TDtdElementRec; -BEGIN - Final := Start + 8; // First char after <!ENTITY - DER.Start := Start; - Phase := phName; - IsParamEntity := FALSE; - EntityDef := TEntityDef.Create; - REPEAT - IF NOT (Final^ IN CWhitespace) THEN - CASE Final^ OF - '%' : IsParamEntity := TRUE; - '>' : BREAK; - ELSE CASE Phase OF - phName : IF Final^ IN CNameStart THEN BEGIN - ExtractName (Final, CWhitespace + CQuoteChar, F); - SetStringSF (EntityDef.Name, Final, F); - Final := F; - Phase := phContent; - END; - phContent : IF Final^ IN CQuoteChar THEN BEGIN - ExtractQuote (Final, EntityDef.Value, Final); - Phase := phFinalGT; - END - ELSE IF (StrLComp (Final, 'SYSTEM', 6) = 0) OR - (StrLComp (Final, 'PUBLIC', 6) = 0) THEN BEGIN - ExternalID := TExternalID.Create (Final); - EntityDef.SystemId := ExternalID.SystemId; - EntityDef.PublicId := ExternalID.PublicId; - Final := ExternalID.Final; - Phase := phNData; - ExternalID.Free; - END; - phNData : IF StrLComp (Final, 'NDATA', 5) = 0 THEN BEGIN - INC (Final, 4); - Phase := phNotationName; - END; - phNotationName : IF Final^ IN CNameStart THEN BEGIN - ExtractName (Final, CWhitespace + ['>'], F); - SetStringSF (EntityDef.NotationName, Final, F); - Final := F; - Phase := phFinalGT; - END; - phFinalGT : ; // -!- There is an error in the document if this branch is called - END; - END; - INC (Final); - UNTIL FALSE; - IF IsParamEntity THEN BEGIN - EntityDef2 := TEntityDef (ParEntities.Node (EntityDef.Name)); - IF EntityDef2 <> NIL THEN - ParEntities.Delete (ParEntities.IndexOf (EntityDef2)); - ParEntities.Add (EntityDef); - ReplaceCharacterEntities (EntityDef.Value); - END - ELSE BEGIN - EntityDef2 := TEntityDef (Entities.Node (EntityDef.Name)); - IF EntityDef2 <> NIL THEN - Entities.Delete (Entities.IndexOf (EntityDef2)); - Entities.Add (EntityDef); - ReplaceParameterEntities (EntityDef.Value); // Create replacement texts (see XmlSpec 4.5) - ReplaceCharacterEntities (EntityDef.Value); - END; - Final := StrScanE (Final, '>'); - - DER.ElementType := deEntity; - DER.EntityDef := EntityDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.AnalyzeNotationDecl (Start : PChar; VAR Final : PChar); - // Parse <!NOTATION declaration starting at "Start" - // Final must point to the terminating '>' character - // XmlSpec 4.7: NotationDecl ::= '<!NOTATION' S Name S (ExternalID | PublicID) S? '>' -TYPE - TPhase = (phName, phExtId, phEnd); -VAR - ExternalID : TExternalID; - Phase : TPhase; - F : PChar; - NotationDef : TNotationDef; - DER : TDtdElementRec; -BEGIN - Final := Start + 10; // Character after <!NOTATION - DER.Start := Start; - Phase := phName; - NotationDef := TNotationDef.Create; - REPEAT - IF NOT (Final^ IN CWhitespace) THEN - CASE Final^ OF - '>', - #0 : BREAK; - ELSE CASE Phase OF - phName : BEGIN - ExtractName (Final, CWhitespace + ['>'], F); - SetStringSF (NotationDef.Name, Final, F); - Final := F; - Phase := phExtId; - END; - phExtId : BEGIN - ExternalID := TExternalID.Create (Final); - NotationDef.Value := ExternalID.SystemId; - NotationDef.PublicId := ExternalID.PublicId; - Final := ExternalId.Final; - ExternalId.Free; - Phase := phEnd; - END; - phEnd : ; // -!- There is an error in the document if this branch is called - END; - END; - INC (Final); - UNTIL FALSE; - Notations.Add (NotationDef); - Final := StrScanE (Final, '>'); - - DER.ElementType := deNotation; - DER.NotationDef := NotationDef; - DER.Final := Final; - DtdElementFound (DER); -END; - - -PROCEDURE TXmlParser.PushPE (VAR Start : PChar); - (* If there is a parameter entity reference found in the data stream, - the current position will be pushed to the entity stack. - Start: IN Pointer to the '%' character starting the PE reference - OUT Pointer to first character of PE replacement text *) -VAR - P : PChar; - EntityDef : TEntityDef; -BEGIN - P := StrScan (Start, ';'); - IF P <> NIL THEN BEGIN - EntityDef := TEntityDef (ParEntities.Node (StrSFPas (Start+1, P-1))); - IF EntityDef <> NIL THEN BEGIN - EntityStack.Push (P+1); - Start := PChar (EntityDef.Value); - END - ELSE - Start := P+1; - END; -END; - - -PROCEDURE TXmlParser.ReplaceCharacterEntities (VAR Str : STRING); - // Replaces all Character Entity References in the String -VAR - Start : INTEGER; - PAmp : PChar; - PSemi : PChar; - PosAmp : INTEGER; - Len : INTEGER; // Length of Entity Reference -BEGIN - IF Str = '' THEN EXIT; - Start := 1; - REPEAT - PAmp := StrPos (PChar (Str) + Start-1, '&#'); - IF PAmp = NIL THEN BREAK; - PSemi := StrScan (PAmp+2, ';'); - IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PChar (Str) + 1; - Len := PSemi-PAmp+1; - IF CompareText (Str [PosAmp+2], 'x') = 0 // !!! Can't use "CHR" for Unicode characters > 255 - THEN Str [PosAmp] := CHR (StrToIntDef ('$'+Copy (Str, PosAmp+3, Len-4), 0)) - ELSE Str [PosAmp] := CHR (StrToIntDef (Copy (Str, PosAmp+2, Len-3), 32)); - Delete (Str, PosAmp+1, Len-1); - Start := PosAmp + 1; - UNTIL FALSE; -END; - - -PROCEDURE TXmlParser.ReplaceParameterEntities (VAR Str : STRING); - // Recursively replaces all Parameter Entity References in the String - PROCEDURE ReplaceEntities (VAR Str : STRING); - VAR - Start : INTEGER; - PAmp : PChar; - PSemi : PChar; - PosAmp : INTEGER; - Len : INTEGER; - Entity : TEntityDef; - Repl : STRING; // Replacement - BEGIN - IF Str = '' THEN EXIT; - Start := 1; - REPEAT - PAmp := StrPos (PChar (Str)+Start-1, '%'); - IF PAmp = NIL THEN BREAK; - PSemi := StrScan (PAmp+2, ';'); - IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PChar (Str) + 1; - Len := PSemi-PAmp+1; - Entity := TEntityDef (ParEntities.Node (Copy (Str, PosAmp+1, Len-2))); - IF Entity <> NIL THEN BEGIN - Repl := Entity.Value; - ReplaceEntities (Repl); // Recursion - END - ELSE - Repl := Copy (Str, PosAmp, Len); - Delete (Str, PosAmp, Len); - Insert (Repl, Str, PosAmp); - Start := PosAmp + Length (Repl); - UNTIL FALSE; - END; -BEGIN - ReplaceEntities (Str); -END; - - -PROCEDURE TXmlParser.ReplaceGeneralEntities (VAR Str : STRING); - // Recursively replaces General Entity References in the String - PROCEDURE ReplaceEntities (VAR Str : STRING); - VAR - Start : INTEGER; - PAmp : PChar; - PSemi : PChar; - PosAmp : INTEGER; - Len : INTEGER; - EntityDef : TEntityDef; - EntName : STRING; - Repl : STRING; // Replacement - ExternalEntity : TXmlParser; - BEGIN - IF Str = '' THEN EXIT; - Start := 1; - REPEAT - PAmp := StrPos (PChar (Str)+Start-1, '&'); - IF PAmp = NIL THEN BREAK; - PSemi := StrScan (PAmp+2, ';'); - IF PSemi = NIL THEN BREAK; - PosAmp := PAmp - PChar (Str) + 1; - Len := PSemi-PAmp+1; - EntName := Copy (Str, PosAmp+1, Len-2); - IF EntName = 'lt' THEN Repl := '<' - ELSE IF EntName = 'gt' THEN Repl := '>' - ELSE IF EntName = 'amp' THEN Repl := '&' - ELSE IF EntName = 'apos' THEN Repl := '''' - ELSE IF EntName = 'quot' THEN Repl := '"' - ELSE BEGIN - EntityDef := TEntityDef (Entities.Node (EntName)); - IF EntityDef <> NIL THEN BEGIN - IF EntityDef.Value <> '' THEN // Internal Entity - Repl := EntityDef.Value - ELSE BEGIN // External Entity - ExternalEntity := LoadExternalEntity (EntityDef.SystemId, EntityDef.PublicId, EntityDef.NotationName); - Repl := StrPas (ExternalEntity.DocBuffer); // !!! What if it contains a Text Declaration? - ExternalEntity.Free; - END; - ReplaceEntities (Repl); // Recursion - END - ELSE - Repl := Copy (Str, PosAmp, Len); - END; - Delete (Str, PosAmp, Len); - Insert (Repl, Str, PosAmp); - Start := PosAmp + Length (Repl); - UNTIL FALSE; - END; -BEGIN - ReplaceEntities (Str); -END; - - -FUNCTION TXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser; - // This will be called whenever there is a Parsed External Entity or - // the DTD External Subset to be parsed. - // It has to create a TXmlParser instance and load the desired Entity. - // This instance of LoadExternalEntity assumes that "SystemId" is a valid - // file name (relative to the Document source) and loads this file using - // the LoadFromFile method. -VAR - Filename : STRING; -BEGIN - // --- Convert System ID to complete filename - Filename := StringReplace (SystemId, '/', '\', [rfReplaceAll]); - IF Copy (FSource, 1, 1) <> '<' THEN - IF (Copy (Filename, 1, 2) = '\\') OR (Copy (Filename, 2, 1) = ':') THEN - // Already has an absolute Path - ELSE BEGIN - Filename := ExtractFilePath (FSource) + Filename; - END; - - // --- Load the File - Result := TXmlParser.Create; - Result.LoadFromFile (Filename); -END; - - -FUNCTION TXmlParser.TranslateEncoding (CONST Source : STRING) : STRING; - // The member variable "CurEncoding" always holds the name of the current - // encoding, e.g. 'UTF-8' or 'ISO-8859-1'. - // This virtual method "TranslateEncoding" is responsible for translating - // the content passed in the "Source" parameter to the Encoding which - // is expected by the application. - // This instance of "TranlateEncoding" assumes that the Application expects - // Windows ANSI (Win1252) strings. It is able to transform UTF-8 or ISO-8859-1 - // encodings. - // If you want your application to understand or create other encodings, you - // override this function. -BEGIN - IF CurEncoding = 'UTF-8' - THEN Result := Utf8ToAnsi (Source) - ELSE Result := Source; -END; - - -PROCEDURE TXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); - // This method is called for every element which is found in the DTD - // declaration. The variant record TDtdElementRec is passed which - // holds informations about the element. - // You can override this function to handle DTD declarations. - // Note that when you parse the same Document instance a second time, - // the DTD will not get parsed again. -BEGIN -END; - - -FUNCTION TXmlParser.GetDocBuffer: PChar; - // Returns FBuffer or a pointer to a NUL char if Buffer is empty -BEGIN - IF FBuffer = NIL - THEN Result := #0 - ELSE Result := FBuffer; -END; - - -(*$IFNDEF HAS_CONTNRS_UNIT -=============================================================================================== -TObjectList -=============================================================================================== -*) - -DESTRUCTOR TObjectList.Destroy; -BEGIN - Clear; - SetCapacity(0); - INHERITED Destroy; -END; - - -PROCEDURE TObjectList.Delete (Index : INTEGER); -BEGIN - IF (Index < 0) OR (Index >= Count) THEN EXIT; - TObject (Items [Index]).Free; - INHERITED Delete (Index); -END; - - -PROCEDURE TObjectList.Clear; -BEGIN - WHILE Count > 0 DO - Delete (Count-1); -END; - -(*$ENDIF *) - -(* -=============================================================================================== -TNvpNode --------- -Node base class for the TNvpList -=============================================================================================== -*) - -CONSTRUCTOR TNvpNode.Create (TheName, TheValue : STRING); -BEGIN - INHERITED Create; - Name := TheName; - Value := TheValue; -END; - - -(* -=============================================================================================== -TNvpList --------- -A generic List of Name-Value Pairs, based on the TObjectList introduced in Delphi 5 -=============================================================================================== -*) - -PROCEDURE TNvpList.Add (Node : TNvpNode); -VAR - I : INTEGER; -BEGIN - FOR I := Count-1 DOWNTO 0 DO - IF Node.Name > TNvpNode (Items [I]).Name THEN BEGIN - Insert (I+1, Node); - EXIT; - END; - Insert (0, Node); -END; - - - -FUNCTION TNvpList.Node (Name : STRING) : TNvpNode; - // Binary search for Node -VAR - L, H : INTEGER; // Low, High Limit - T, C : INTEGER; // Test Index, Comparison result - Last : INTEGER; // Last Test Index -BEGIN - IF Count=0 THEN BEGIN - Result := NIL; - EXIT; - END; - - L := 0; - H := Count; - Last := -1; - REPEAT - T := (L+H) DIV 2; - IF T=Last THEN BREAK; - Result := TNvpNode (Items [T]); - C := CompareStr (Result.Name, Name); - IF C = 0 THEN EXIT - ELSE IF C < 0 THEN L := T - ELSE H := T; - Last := T; - UNTIL FALSE; - Result := NIL; -END; - - -FUNCTION TNvpList.Node (Index : INTEGER) : TNvpNode; -BEGIN - IF (Index < 0) OR (Index >= Count) - THEN Result := NIL - ELSE Result := TNvpNode (Items [Index]); -END; - - -FUNCTION TNvpList.Value (Name : STRING) : STRING; -VAR - Nvp : TNvpNode; -BEGIN - Nvp := TNvpNode (Node (Name)); - IF Nvp <> NIL - THEN Result := Nvp.Value - ELSE Result := ''; -END; - - -FUNCTION TNvpList.Value (Index : INTEGER) : STRING; -BEGIN - IF (Index < 0) OR (Index >= Count) - THEN Result := '' - ELSE Result := TNvpNode (Items [Index]).Value; -END; - - -FUNCTION TNvpList.Name (Index : INTEGER) : STRING; -BEGIN - IF (Index < 0) OR (Index >= Count) - THEN Result := '' - ELSE Result := TNvpNode (Items [Index]).Name; -END; - - -(* -=============================================================================================== -TAttrList -List of Attributes. The "Analyze" method extracts the Attributes from the given Buffer. -Is used for extraction of Attributes in Start-Tags, Empty-Element Tags and the "pseudo" -attributes in XML Prologs, Text Declarations and PIs. -=============================================================================================== -*) - -PROCEDURE TAttrList.Analyze (Start : PChar; VAR Final : PChar); - // Analyze the Buffer for Attribute=Name pairs. - // Terminates when there is a character which is not IN CNameStart - // (e.g. '?>' or '>' or '/>') -TYPE - TPhase = (phName, phEq, phValue); -VAR - Phase : TPhase; - F : PChar; - Name : STRING; - Value : STRING; - Attr : TAttr; -BEGIN - Clear; - Phase := phName; - Final := Start; - REPEAT - IF (Final^ = #0) OR (Final^ = '>') THEN BREAK; - IF NOT (Final^ IN CWhitespace) THEN - CASE Phase OF - phName : BEGIN - IF NOT (Final^ IN CNameStart) THEN EXIT; - ExtractName (Final, CWhitespace + ['=', '/'], F); - SetStringSF (Name, Final, F); - Final := F; - Phase := phEq; - END; - phEq : BEGIN - IF Final^ = '=' THEN - Phase := phValue - END; - phValue : BEGIN - IF Final^ IN CQuoteChar THEN BEGIN - ExtractQuote (Final, Value, F); - Attr := TAttr.Create; - Attr.Name := Name; - Attr.Value := Value; - Attr.ValueType := vtNormal; - Add (Attr); - Final := F; - Phase := phName; - END; - END; - END; - INC (Final); - UNTIL FALSE; -END; - - -(* -=============================================================================================== -TElemList -List of TElemDef nodes. -=============================================================================================== -*) - -FUNCTION TElemList.Node (Name : STRING) : TElemDef; - // Binary search for the Node with the given Name -VAR - L, H : INTEGER; // Low, High Limit - T, C : INTEGER; // Test Index, Comparison result - Last : INTEGER; // Last Test Index -BEGIN - IF Count=0 THEN BEGIN - Result := NIL; - EXIT; - END; - - L := 0; - H := Count; - Last := -1; - REPEAT - T := (L+H) DIV 2; - IF T=Last THEN BREAK; - Result := TElemDef (Items [T]); - C := CompareStr (Result.Name, Name); - IF C = 0 THEN EXIT - ELSE IF C < 0 THEN L := T - ELSE H := T; - Last := T; - UNTIL FALSE; - Result := NIL; -END; - - -PROCEDURE TElemList.Add (Node : TElemDef); -VAR - I : INTEGER; -BEGIN - FOR I := Count-1 DOWNTO 0 DO - IF Node.Name > TElemDef (Items [I]).Name THEN BEGIN - Insert (I+1, Node); - EXIT; - END; - Insert (0, Node); -END; - - -(* -=============================================================================================== -TScannerXmlParser -A TXmlParser descendant for the TCustomXmlScanner component -=============================================================================================== -*) - -TYPE - TScannerXmlParser = CLASS (TXmlParser) - Scanner : TCustomXmlScanner; - CONSTRUCTOR Create (TheScanner : TCustomXmlScanner); - FUNCTION LoadExternalEntity (SystemId, PublicId, - Notation : STRING) : TXmlParser; OVERRIDE; - FUNCTION TranslateEncoding (CONST Source : STRING) : STRING; OVERRIDE; - PROCEDURE DtdElementFound (DtdElementRec : TDtdElementRec); OVERRIDE; - END; - -CONSTRUCTOR TScannerXmlParser.Create (TheScanner : TCustomXmlScanner); -BEGIN - INHERITED Create; - Scanner := TheScanner; -END; - - -FUNCTION TScannerXmlParser.LoadExternalEntity (SystemId, PublicId, Notation : STRING) : TXmlParser; -BEGIN - IF Assigned (Scanner.FOnLoadExternal) - THEN Scanner.FOnLoadExternal (Scanner, SystemId, PublicId, Notation, Result) - ELSE Result := INHERITED LoadExternalEntity (SystemId, PublicId, Notation); -END; - - -FUNCTION TScannerXmlParser.TranslateEncoding (CONST Source : STRING) : STRING; -BEGIN - IF Assigned (Scanner.FOnTranslateEncoding) - THEN Result := Scanner.FOnTranslateEncoding (Scanner, CurEncoding, Source) - ELSE Result := INHERITED TranslateEncoding (Source); -END; - - -PROCEDURE TScannerXmlParser.DtdElementFound (DtdElementRec : TDtdElementRec); -BEGIN - WITH DtdElementRec DO - CASE ElementType OF - deElement : Scanner.WhenElement (ElemDef); - deAttList : Scanner.WhenAttList (ElemDef); - deEntity : Scanner.WhenEntity (EntityDef); - deNotation : Scanner.WhenNotation (NotationDef); - dePI : Scanner.WhenPI (STRING (Target), STRING (Content), AttrList); - deComment : Scanner.WhenComment (StrSFPas (Start, Final)); - deError : Scanner.WhenDtdError (Pos); - END; -END; - - -(* -=============================================================================================== -TCustomXmlScanner -=============================================================================================== -*) - -CONSTRUCTOR TCustomXmlScanner.Create (AOwner: TComponent); -BEGIN - INHERITED; - FXmlParser := TScannerXmlParser.Create (Self); -END; - - -DESTRUCTOR TCustomXmlScanner.Destroy; -BEGIN - FXmlParser.Free; - INHERITED; -END; - - -PROCEDURE TCustomXmlScanner.LoadFromFile (Filename : TFilename); - // Load XML Document from file -BEGIN - FXmlParser.LoadFromFile (Filename); -END; - - -PROCEDURE TCustomXmlScanner.LoadFromBuffer (Buffer : PChar); - // Load XML Document from buffer -BEGIN - FXmlParser.LoadFromBuffer (Buffer); -END; - - -PROCEDURE TCustomXmlScanner.SetBuffer (Buffer : PChar); - // Refer to Buffer -BEGIN - FXmlParser.SetBuffer (Buffer); -END; - - -FUNCTION TCustomXmlScanner.GetFilename : TFilename; -BEGIN - Result := FXmlParser.Source; -END; - - -FUNCTION TCustomXmlScanner.GetNormalize : BOOLEAN; -BEGIN - Result := FXmlParser.Normalize; -END; - - -PROCEDURE TCustomXmlScanner.SetNormalize (Value : BOOLEAN); -BEGIN - FXmlParser.Normalize := Value; -END; - - -PROCEDURE TCustomXmlScanner.WhenXmlProlog(XmlVersion, Encoding: STRING; Standalone : BOOLEAN); - // Is called when the parser has parsed the <? xml ?> declaration of the prolog -BEGIN - IF Assigned (FOnXmlProlog) THEN FOnXmlProlog (Self, XmlVersion, Encoding, Standalone); -END; - - -PROCEDURE TCustomXmlScanner.WhenComment (Comment : STRING); - // Is called when the parser has parsed a <!-- comment --> -BEGIN - IF Assigned (FOnComment) THEN FOnComment (Self, Comment); -END; - - -PROCEDURE TCustomXmlScanner.WhenPI (Target, Content: STRING; Attributes : TAttrList); - // Is called when the parser has parsed a <?processing instruction ?> -BEGIN - IF Assigned (FOnPI) THEN FOnPI (Self, Target, Content, Attributes); -END; - - -PROCEDURE TCustomXmlScanner.WhenDtdRead (RootElementName : STRING); - // Is called when the parser has completely parsed the DTD -BEGIN - IF Assigned (FOnDtdRead) THEN FOnDtdRead (Self, RootElementName); -END; - - -PROCEDURE TCustomXmlScanner.WhenStartTag (TagName : STRING; Attributes : TAttrList); - // Is called when the parser has parsed a start tag like <p> -BEGIN - IF Assigned (FOnStartTag) THEN FOnStartTag (Self, TagName, Attributes); -END; - - -PROCEDURE TCustomXmlScanner.WhenEmptyTag (TagName : STRING; Attributes : TAttrList); - // Is called when the parser has parsed an Empty Element Tag like <br/> -BEGIN - IF Assigned (FOnEmptyTag) THEN FOnEmptyTag (Self, TagName, Attributes); -END; - - -PROCEDURE TCustomXmlScanner.WhenEndTag (TagName : STRING); - // Is called when the parser has parsed an End Tag like </p> -BEGIN - IF Assigned (FOnEndTag) THEN FOnEndTag (Self, TagName); -END; - - -PROCEDURE TCustomXmlScanner.WhenContent (Content : STRING); - // Is called when the parser has parsed an element's text content -BEGIN - IF Assigned (FOnContent) THEN FOnContent (Self, Content); -END; - - -PROCEDURE TCustomXmlScanner.WhenCData (Content : STRING); - // Is called when the parser has parsed a CDATA section -BEGIN - IF Assigned (FOnCData) THEN FOnCData (Self, Content); -END; - - -PROCEDURE TCustomXmlScanner.WhenElement (ElemDef : TElemDef); - // Is called when the parser has parsed an <!ELEMENT> definition - // inside the DTD -BEGIN - IF Assigned (FOnElement) THEN FOnElement (Self, ElemDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenAttList (ElemDef : TElemDef); - // Is called when the parser has parsed an <!ATTLIST> definition - // inside the DTD -BEGIN - IF Assigned (FOnAttList) THEN FOnAttList (Self, ElemDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenEntity (EntityDef : TEntityDef); - // Is called when the parser has parsed an <!ENTITY> definition - // inside the DTD -BEGIN - IF Assigned (FOnEntity) THEN FOnEntity (Self, EntityDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenNotation (NotationDef : TNotationDef); - // Is called when the parser has parsed a <!NOTATION> definition - // inside the DTD -BEGIN - IF Assigned (FOnNotation) THEN FOnNotation (Self, NotationDef); -END; - - -PROCEDURE TCustomXmlScanner.WhenDtdError (ErrorPos : PChar); - // Is called when the parser has found an Error in the DTD -BEGIN - IF Assigned (FOnDtdError) THEN FOnDtdError (Self, ErrorPos); -END; - - -PROCEDURE TCustomXmlScanner.Execute; - // Perform scanning - // Scanning is done synchronously, i.e. you can expect events to be triggered - // in the order of the XML data stream. Execute will finish when the whole XML - // document has been scanned or when the StopParser property has been set to TRUE. -BEGIN - FStopParser := FALSE; - FXmlParser.StartScan; - WHILE FXmlParser.Scan AND (NOT FStopParser) DO - CASE FXmlParser.CurPartType OF - ptNone : ; - ptXmlProlog : WhenXmlProlog (FXmlParser.XmlVersion, FXmlParser.Encoding, FXmlParser.Standalone); - ptComment : WhenComment (StrSFPas (FXmlParser.CurStart, FXmlParser.CurFinal)); - ptPI : WhenPI (FXmlParser.CurName, FXmlParser.CurContent, FXmlParser.CurAttr); - ptDtdc : WhenDtdRead (FXmlParser.RootName); - ptStartTag : WhenStartTag (FXmlParser.CurName, FXmlParser.CurAttr); - ptEmptyTag : WhenEmptyTag (FXmlParser.CurName, FXmlParser.CurAttr); - ptEndTag : WhenEndTag (FXmlParser.CurName); - ptContent : WhenContent (FXmlParser.CurContent); - ptCData : WhenCData (FXmlParser.CurContent); - END; -END; - - -END. diff --git a/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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2000 - 2001 Dominique Louis. } -{ } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Logging functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2001 - DL : Initial creation } -{ 25/10/2001 - DRE : Added $M+ directive to allow published } -{ in classes. Added a compile directive } -{ around fmShareExclusive as this does not } -{ exist in Free Pascal } -{ } -{******************************************************************************} -{ - $Log: logger.pas,v $ - Revision 1.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 <robert_marquardt@gmx.de) } -{ } -{ Copyright (C) 2000, 2001 Robert Marquardt. } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators (Project JEDI) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/NPL/NPL-1_1Final.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{******************************************************************} -{ - $Log: moduleloader.pas,v $ - Revision 1.4 2004/02/20 17:19:10 savage - Added Calling convention to Win32 functions just in case. - - Revision 1.3 2004/02/14 22:36:29 savage - Fixed inconsistencies of using LoadLibrary and LoadModule. - Now all units make use of LoadModule rather than LoadLibrary and other dynamic proc procedures. - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - - Revision 1.1 2004/02/14 00:04:50 savage - dllfuncs conflicts with FreePascal so it has been renamed back to the moduleloader.pas - - Revision 1.1 2004/02/05 00:08:19 savage - Module 1.0 release - - -} - -interface - -{$i jedi-sdl.inc} -{$WEAKPACKAGEUNIT ON} - -// each OS gets its own IFDEFed complete code block to make reading easier - -{$IFDEF WIN32} -uses - Windows; - -type - // Handle to a loaded DLL - TModuleHandle = HINST; - -const - // Value designating an unassigned TModuleHandle od a failed loading - INVALID_MODULEHANDLE_VALUE = TModuleHandle(0); - -function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; stdcall; -function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; stdcall; -procedure UnloadModule(var Module: TModuleHandle); stdcall; -function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; stdcall; -function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; stdcall; -function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; stdcall; -function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; stdcall; - -implementation - -// load the DLL file FileName -// the rules for FileName are those of LoadLibrary -// Returns: True = success, False = failure to load -// Assigns: the handle of the loaded DLL to Module -// Warning: if Module has any other value than INVALID_MODULEHANDLE_VALUE -// on entry the function will do nothing but returning success. - -function LoadModule(var Module: TModuleHandle; FileName: PChar): Boolean; -begin - if Module = INVALID_MODULEHANDLE_VALUE then - Module := LoadLibrary( FileName ); - Result := Module <> INVALID_MODULEHANDLE_VALUE; -end; - -// load the DLL file FileName -// LoadLibraryEx is used to get better control of the loading -// for the allowed values for flags see LoadLibraryEx documentation. - -function LoadModuleEx(var Module: TModuleHandle; FileName: PChar; Flags: Cardinal): Boolean; -begin - if Module = INVALID_MODULEHANDLE_VALUE then - Module := LoadLibraryEx( FileName, 0, Flags); - Result := Module <> INVALID_MODULEHANDLE_VALUE; -end; - -// unload a DLL loaded with LoadModule or LoadModuleEx -// The procedure will not try to unload a handle with -// value INVALID_MODULEHANDLE_VALUE and assigns this value -// to Module after unload. - -procedure UnloadModule(var Module: TModuleHandle); -begin - if Module <> INVALID_MODULEHANDLE_VALUE then - FreeLibrary(Module); - Module := INVALID_MODULEHANDLE_VALUE; -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the DLL Module -// nil is returned if the symbol is not available - -function GetModuleSymbol(Module: TModuleHandle; SymbolName: PChar): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := GetProcAddress(Module, SymbolName ); -end; - -// returns the pointer to the symbol named SymbolName -// if it is exported from the DLL Module -// nil is returned if the symbol is not available. -// as an extra the boolean variable Accu is updated -// by anding in the success of the function. -// This is very handy for rendering a global result -// when accessing a long list of symbols. - -function GetModuleSymbolEx(Module: TModuleHandle; SymbolName: PChar; var Accu: Boolean): Pointer; -begin - Result := nil; - if Module <> INVALID_MODULEHANDLE_VALUE then - Result := GetProcAddress(Module, SymbolName ); - Accu := Accu and (Result <> nil); -end; - -// get the value of variables exported from a DLL Module -// Delphi cannot access variables in a DLL directly, so -// this function allows to copy the data from the DLL. -// Beware! You are accessing the DLL memory image directly. -// Be sure to access a variable not a function and be sure -// to read the correct amount of data. - -function ReadModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Sym^, Buffer, Size); -end; - -// set the value of variables exported from a DLL Module -// Delphi cannot access variables in a DLL directly, so -// this function allows to copy the data to the DLL! -// BEWARE! You are accessing the DLL memory image directly. -// Be sure to access a variable not a function and be sure -// to write the correct amount of data. -// The changes are not persistent. They get lost when the -// DLL is unloaded. - -function WriteModuleData(Module: TModuleHandle; SymbolName: PChar; var Buffer; Size: Cardinal): Boolean; -var - Sym: Pointer; -begin - Result := True; - Sym := GetModuleSymbolEx(Module, SymbolName, Result); - if Result then - Move(Buffer, Sym^, Size); -end; - -{$ENDIF} - -{$IFDEF Unix} -uses -{$ifdef 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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: registryuserpreferences.pas,v $ - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - {$IFDEF REG} - Registry, - {$ELSE} - IniFiles, - {$ENDIF} - Classes, - userpreferences; - -type - TRegistryUserPreferences = class( TUserPreferences ) - private - - protected - function GetSection( const Index : Integer ) : string; virtual; abstract; - function GetIdentifier( const Index : Integer ) : string; virtual; abstract; - function GetDefaultBoolean( const Index : Integer ) : Boolean; override; - function GetBoolean( const Index : Integer ) : Boolean; override; - procedure SetBoolean( const Index : Integer; const Value : Boolean ); override; - function GetDefaultDateTime( const Index : Integer ) : TDateTime; override; - function GetDateTime( const Index : Integer ) : TDateTime; override; - procedure SetDateTime( const Index : Integer; const Value : TDateTime ); override; - function GetDefaultInteger( const Index : Integer ) : Integer; override; - function GetInteger( const Index : Integer ) : Integer; override; - procedure SetInteger( const Index : Integer; const Value : Integer ); override; - function GetDefaultFloat( const Index : Integer ) : single; override; - function GetFloat( const Index : Integer ) : single; override; - procedure SetFloat( const Index : Integer; const Value : single ); override; - function GetDefaultString( const Index : Integer ) : string; override; - function GetString( const Index : Integer ) : string; override; - procedure SetString( const Index : Integer; const Value : string ); override; - public - Registry : {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}; - constructor Create( const FileName : string = '' ); reintroduce; - destructor Destroy; override; - procedure Update; override; - end; - -implementation - -uses - SysUtils; - -{ TRegistryUserPreferences } -constructor TRegistryUserPreferences.Create( const FileName : string ); -var - defFileName : string; -begin - inherited Create; - - if FileName <> '' then - defFileName := FileName - else - defFileName := ChangeFileExt( ParamStr( 0 ), '.ini' ); - - Registry := {$IFDEF REG}TRegIniFile{$ELSE}TIniFile{$ENDIF}.Create( defFileName ); -end; - -destructor TRegistryUserPreferences.Destroy; -begin - Update; - Registry.Free; - Registry := nil; - inherited; -end; - -function TRegistryUserPreferences.GetBoolean( const Index : Integer ) : Boolean; -begin - Result := Registry.ReadBool( GetSection( Index ), GetIdentifier( Index ), GetDefaultBoolean( Index ) ); -end; - -function TRegistryUserPreferences.GetDateTime( const Index : Integer ): TDateTime; -begin - Result := Registry.ReadDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultDateTime( Index ){$ENDIF} ); -end; - -function TRegistryUserPreferences.GetDefaultBoolean( const Index : Integer ) : Boolean; -begin - result := false; -end; - -function TRegistryUserPreferences.GetDefaultDateTime( const Index: Integer ) : TDateTime; -begin - result := Now; -end; - -function TRegistryUserPreferences.GetDefaultFloat( const Index: Integer ) : single; -begin - result := 0.0; -end; - -function TRegistryUserPreferences.GetDefaultInteger(const Index : Integer ) : Integer; -begin - result := 0; -end; - -function TRegistryUserPreferences.GetDefaultString( const Index : Integer ) : string; -begin - result := ''; -end; - -function TRegistryUserPreferences.GetFloat( const Index : Integer ): single; -begin - Result := Registry.ReadFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ), GetDefaultFloat( Index ){$ENDIF} ); -end; - -function TRegistryUserPreferences.GetInteger( const Index : Integer ) : Integer; -begin - Result := Registry.ReadInteger( GetSection( Index ), GetIdentifier( Index ), GetDefaultInteger( Index ) ); -end; - -function TRegistryUserPreferences.GetString( const Index : Integer ): string; -begin - Result := Registry.ReadString( GetSection( Index ), GetIdentifier( Index ), GetDefaultString( Index ) ); -end; - -procedure TRegistryUserPreferences.SetBoolean( const Index : Integer; const Value : Boolean ); -begin - Registry.WriteBool( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetDateTime( const Index: Integer; const Value: TDateTime ); -begin - Registry.WriteDateTime( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetFloat(const Index: Integer; const Value: single); -begin - Registry.WriteFloat( GetSection( Index ){$IFNDEF REG}, GetIdentifier( Index ){$ENDIF}, Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetInteger( const Index, Value : Integer ); -begin - Registry.WriteInteger( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.SetString( const Index : Integer; const Value : string ); -begin - Registry.WriteString( GetSection( Index ), GetIdentifier( Index ), Value ); - inherited; -end; - -procedure TRegistryUserPreferences.Update; -begin - {$IFDEF REG} - Registry.CloseKey; - {$ELSE} - Registry.UpdateFile; - {$ENDIF} -end; - -end. diff --git a/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 <slouken@devolution.com> are } -{ Copyright (C) 1997-2004 Sam Lantinga } -{ 5635-34 Springhouse Dr. } -{ Pleasanton, CA 94588 (USA) } -{ } -{ All Rights Reserved. } -{ } -{ The original files are : SDL.h } -{ SDL_main.h } -{ SDL_types.h } -{ SDL_rwops.h } -{ SDL_timer.h } -{ SDL_audio.h } -{ SDL_cdrom.h } -{ SDL_joystick.h } -{ SDL_mouse.h } -{ SDL_keyboard.h } -{ SDL_events.h } -{ SDL_video.h } -{ SDL_byteorder.h } -{ SDL_version.h } -{ SDL_active.h } -{ SDL_thread.h } -{ SDL_mutex .h } -{ SDL_getenv.h } -{ SDL_loadso.h } -{ } -{ The initial developer of this Pascal code was : } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2000 - 2004 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Tom Jones <tigertomjones@gmx.de> His Project inspired this conversion } -{ Matthias Thoma <ma.thoma@gmx.de> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ May 08 2001 - DL : Added Keyboard State Array ( See demos for how to } -{ use ) } -{ PKeyStateArr = ^TKeyStateArr; } -{ TKeyStateArr = array[0..65000] of UInt8; } -{ As most games will need it. } -{ } -{ April 02 2001 - DL : Added SDL_getenv.h definitions and tested version } -{ 1.2.0 compatability. } -{ } -{ March 13 2001 - MT : Added Linux compatibility. } -{ } -{ March 10 2001 - MT : Added externalsyms for DEFINES } -{ Changed the license header } -{ } -{ March 09 2001 - MT : Added Kylix Ifdefs/Deleted the uses mmsystem } -{ } -{ March 01 2001 - DL : Update conversion of version 1.1.8 } -{ } -{ July 22 2001 - DL : Added TUInt8Array and PUIntArray after suggestions } -{ from Matthias Thoma and Eric Grange. } -{ } -{ October 12 2001 - DL : Various changes as suggested by Matthias Thoma and } -{ David Acklam } -{ } -{ October 24 2001 - DL : Added FreePascal support as per suggestions from } -{ Dean Ellis. } -{ } -{ October 27 2001 - DL : Added SDL_BUTTON macro } -{ } -{ November 08 2001 - DL : Bug fix as pointed out by Puthoon. } -{ } -{ November 29 2001 - DL : Bug fix of SDL_SetGammaRamp as pointed out by Simon} -{ Rushton. } -{ } -{ November 30 2001 - DL : SDL_NOFRAME added as pointed out by Simon Rushton. } -{ } -{ December 11 2001 - DL : Added $WEAKPACKAGEUNIT ON to facilitate useage in } -{ Components } -{ } -{ January 05 2002 - DL : Added SDL_Swap32 function as suggested by Matthias } -{ Thoma and also made sure the _getenv from } -{ MSVCRT.DLL uses the right calling convention } -{ } -{ January 25 2002 - DL : Updated conversion of SDL_AddTimer & } -{ SDL_RemoveTimer as per suggestions from Matthias } -{ Thoma. } -{ } -{ January 27 2002 - DL : Commented out exported function putenv and getenv } -{ So that developers get used to using SDL_putenv } -{ SDL_getenv, as they are more portable } -{ } -{ March 05 2002 - DL : Added FreeAnNil procedure for Delphi 4 users. } -{ } -{ October 23 2002 - DL : Added Delphi 3 Define of Win32. } -{ If you intend to you Delphi 3... } -{ ( which is officially unsupported ) make sure you } -{ remove references to $EXTERNALSYM in this and other} -{ SDL files. } -{ } -{ November 29 2002 - DL : Fixed bug in Declaration of SDL_GetRGBA that was } -{ pointed out by Todd Lang } -{ } -{ April 03 2003 - DL : Added jedi-sdl.inc include file to support more } -{ Pascal compilers. Initial support is now included } -{ for GnuPascal, VirtualPascal, TMT and obviously } -{ continue support for Delphi Kylix and FreePascal. } -{ } -{ April 08 2003 - MK : Aka Mr Kroket - Added Better FPC support } -{ } -{ April 24 2003 - DL : under instruction from Alexey Barkovoy, I have added} -{ better TMT Pascal support and under instruction } -{ from Prof. Abimbola Olowofoyeku (The African Chief),} -{ I have added better Gnu Pascal support } -{ } -{ April 30 2003 - DL : under instruction from David Mears AKA } -{ Jason Siletto, I have added FPC Linux support. } -{ This was compiled with fpc 1.1, so remember to set } -{ include file path. ie. -Fi/usr/share/fpcsrc/rtl/* } -{ } -{ - $Log: sdl.pas,v $ - Revision 1.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<<n) - // array to hold joystick ID values - //static UInt SYS_JoystickID[MAX_JOYSTICKS]; - //static JOYCAPS SYS_Joystick[MAX_JOYSTICKS]; - - { Get the current state of a POV hat on a joystick - The return value is one of the following positions: } - SDL_HAT_CENTERED = $00; -{$EXTERNALSYM SDL_HAT_CENTERED} - SDL_HAT_UP = $01; -{$EXTERNALSYM SDL_HAT_UP} - SDL_HAT_RIGHT = $02; -{$EXTERNALSYM SDL_HAT_RIGHT} - SDL_HAT_DOWN = $04; -{$EXTERNALSYM SDL_HAT_DOWN} - SDL_HAT_LEFT = $08; -{$EXTERNALSYM SDL_HAT_LEFT} - SDL_HAT_RIGHTUP = SDL_HAT_RIGHT or SDL_HAT_UP; -{$EXTERNALSYM SDL_HAT_RIGHTUP} - SDL_HAT_RIGHTDOWN = SDL_HAT_RIGHT or SDL_HAT_DOWN; -{$EXTERNALSYM SDL_HAT_RIGHTDOWN} - SDL_HAT_LEFTUP = SDL_HAT_LEFT or SDL_HAT_UP; -{$EXTERNALSYM SDL_HAT_LEFTUP} - SDL_HAT_LEFTDOWN = SDL_HAT_LEFT or SDL_HAT_DOWN; -{$EXTERNALSYM SDL_HAT_LEFTDOWN} - - // SDL_events.h constants - SDL_NOEVENT = 0; // Unused (do not remove) -{$EXTERNALSYM SDL_NOEVENT} - SDL_ACTIVEEVENT = 1; // Application loses/gains visibility -{$EXTERNALSYM SDL_ACTIVEEVENT} - SDL_KEYDOWN = 2; // Keys pressed -{$EXTERNALSYM SDL_KEYDOWN} - SDL_KEYUP = 3; // Keys released -{$EXTERNALSYM SDL_KEYUP} - SDL_MOUSEMOTION = 4; // Mouse moved -{$EXTERNALSYM SDL_MOUSEMOTION} - SDL_MOUSEBUTTONDOWN = 5; // Mouse button pressed -{$EXTERNALSYM SDL_MOUSEBUTTONDOWN} - SDL_MOUSEBUTTONUP = 6; // Mouse button released -{$EXTERNALSYM SDL_MOUSEBUTTONUP} - SDL_JOYAXISMOTION = 7; // Joystick axis motion -{$EXTERNALSYM SDL_JOYAXISMOTION} - SDL_JOYBALLMOTION = 8; // Joystick trackball motion -{$EXTERNALSYM SDL_JOYBALLMOTION} - SDL_JOYHATMOTION = 9; // Joystick hat position change -{$EXTERNALSYM SDL_JOYHATMOTION} - SDL_JOYBUTTONDOWN = 10; // Joystick button pressed -{$EXTERNALSYM SDL_JOYBUTTONDOWN} - SDL_JOYBUTTONUP = 11; // Joystick button released -{$EXTERNALSYM SDL_JOYBUTTONUP} - SDL_QUITEV = 12; // User-requested quit ( Changed due to procedure conflict ) -{$EXTERNALSYM SDL_QUIT} - SDL_SYSWMEVENT = 13; // System specific event -{$EXTERNALSYM SDL_SYSWMEVENT} - SDL_EVENT_RESERVEDA = 14; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVEDA} - SDL_EVENT_RESERVED = 15; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED} - SDL_VIDEORESIZE = 16; // User resized video mode -{$EXTERNALSYM SDL_VIDEORESIZE} - SDL_VIDEOEXPOSE = 17; // Screen needs to be redrawn -{$EXTERNALSYM SDL_VIDEOEXPOSE} - SDL_EVENT_RESERVED2 = 18; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED2} - SDL_EVENT_RESERVED3 = 19; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED3} - SDL_EVENT_RESERVED4 = 20; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED4} - SDL_EVENT_RESERVED5 = 21; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED5} - SDL_EVENT_RESERVED6 = 22; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED6} - SDL_EVENT_RESERVED7 = 23; // Reserved for future use.. -{$EXTERNALSYM SDL_EVENT_RESERVED7} - // Events SDL_USEREVENT through SDL_MAXEVENTS-1 are for your use - SDL_USEREVENT = 24; -{$EXTERNALSYM SDL_USEREVENT} - // This last event is only for bounding internal arrays - // It is the number of bits in the event mask datatype -- UInt32 - SDL_NUMEVENTS = 32; -{$EXTERNALSYM SDL_NUMEVENTS} - - SDL_ALLEVENTS = $FFFFFFFF; -{$EXTERNALSYM SDL_ALLEVENTS} - - SDL_ACTIVEEVENTMASK = 1 shl SDL_ACTIVEEVENT; -{$EXTERNALSYM SDL_ACTIVEEVENTMASK} - SDL_KEYDOWNMASK = 1 shl SDL_KEYDOWN; -{$EXTERNALSYM SDL_KEYDOWNMASK} - SDL_KEYUPMASK = 1 shl SDL_KEYUP; -{$EXTERNALSYM SDL_KEYUPMASK} - SDL_MOUSEMOTIONMASK = 1 shl SDL_MOUSEMOTION; -{$EXTERNALSYM SDL_MOUSEMOTIONMASK} - SDL_MOUSEBUTTONDOWNMASK = 1 shl SDL_MOUSEBUTTONDOWN; -{$EXTERNALSYM SDL_MOUSEBUTTONDOWNMASK} - SDL_MOUSEBUTTONUPMASK = 1 shl SDL_MOUSEBUTTONUP; -{$EXTERNALSYM SDL_MOUSEBUTTONUPMASK} - SDL_MOUSEEVENTMASK = 1 shl SDL_MOUSEMOTION or - 1 shl SDL_MOUSEBUTTONDOWN or - 1 shl SDL_MOUSEBUTTONUP; -{$EXTERNALSYM SDL_MOUSEEVENTMASK} - SDL_JOYAXISMOTIONMASK = 1 shl SDL_JOYAXISMOTION; -{$EXTERNALSYM SDL_JOYAXISMOTIONMASK} - SDL_JOYBALLMOTIONMASK = 1 shl SDL_JOYBALLMOTION; -{$EXTERNALSYM SDL_JOYBALLMOTIONMASK} - SDL_JOYHATMOTIONMASK = 1 shl SDL_JOYHATMOTION; -{$EXTERNALSYM SDL_JOYHATMOTIONMASK} - SDL_JOYBUTTONDOWNMASK = 1 shl SDL_JOYBUTTONDOWN; -{$EXTERNALSYM SDL_JOYBUTTONDOWNMASK} - SDL_JOYBUTTONUPMASK = 1 shl SDL_JOYBUTTONUP; -{$EXTERNALSYM SDL_JOYBUTTONUPMASK} - SDL_JOYEVENTMASK = 1 shl SDL_JOYAXISMOTION or - 1 shl SDL_JOYBALLMOTION or - 1 shl SDL_JOYHATMOTION or - 1 shl SDL_JOYBUTTONDOWN or - 1 shl SDL_JOYBUTTONUP; -{$EXTERNALSYM SDL_JOYEVENTMASK} - SDL_VIDEORESIZEMASK = 1 shl SDL_VIDEORESIZE; -{$EXTERNALSYM SDL_VIDEORESIZEMASK} - SDL_QUITMASK = 1 shl SDL_QUITEV; -{$EXTERNALSYM SDL_QUITMASK} - SDL_SYSWMEVENTMASK = 1 shl SDL_SYSWMEVENT; -{$EXTERNALSYM SDL_SYSWMEVENTMASK} - - { This function allows you to set the state of processing certain events. - If 'state' is set to SDL_IGNORE, that event will be automatically dropped - from the event queue and will not event be filtered. - If 'state' is set to SDL_ENABLE, that event will be processed normally. - If 'state' is set to SDL_QUERY, SDL_EventState() will return the - current processing state of the specified event. } - - SDL_QUERY = -1; -{$EXTERNALSYM SDL_QUERY} - SDL_IGNORE = 0; -{$EXTERNALSYM SDL_IGNORE} - SDL_DISABLE = 0; -{$EXTERNALSYM SDL_DISABLE} - SDL_ENABLE = 1; -{$EXTERNALSYM SDL_ENABLE} - - //SDL_keyboard.h constants - // This is the mask which refers to all hotkey bindings - SDL_ALL_HOTKEYS = $FFFFFFFF; -{$EXTERNALSYM SDL_ALL_HOTKEYS} - -{ Enable/Disable keyboard repeat. Keyboard repeat defaults to off. - 'delay' is the initial delay in ms between the time when a key is - pressed, and keyboard repeat begins. - 'interval' is the time in ms between keyboard repeat events. } - - SDL_DEFAULT_REPEAT_DELAY = 500; -{$EXTERNALSYM SDL_DEFAULT_REPEAT_DELAY} - SDL_DEFAULT_REPEAT_INTERVAL = 30; -{$EXTERNALSYM SDL_DEFAULT_REPEAT_INTERVAL} - - // The keyboard syms have been cleverly chosen to map to ASCII - SDLK_UNKNOWN = 0; -{$EXTERNALSYM SDLK_UNKNOWN} - SDLK_FIRST = 0; -{$EXTERNALSYM SDLK_FIRST} - SDLK_BACKSPACE = 8; -{$EXTERNALSYM SDLK_BACKSPACE} - SDLK_TAB = 9; -{$EXTERNALSYM SDLK_TAB} - SDLK_CLEAR = 12; -{$EXTERNALSYM SDLK_CLEAR} - SDLK_RETURN = 13; -{$EXTERNALSYM SDLK_RETURN} - SDLK_PAUSE = 19; -{$EXTERNALSYM SDLK_PAUSE} - SDLK_ESCAPE = 27; -{$EXTERNALSYM SDLK_ESCAPE} - SDLK_SPACE = 32; -{$EXTERNALSYM SDLK_SPACE} - SDLK_EXCLAIM = 33; -{$EXTERNALSYM SDLK_EXCLAIM} - SDLK_QUOTEDBL = 34; -{$EXTERNALSYM SDLK_QUOTEDBL} - SDLK_HASH = 35; -{$EXTERNALSYM SDLK_HASH} - SDLK_DOLLAR = 36; -{$EXTERNALSYM SDLK_DOLLAR} - SDLK_AMPERSAND = 38; -{$EXTERNALSYM SDLK_AMPERSAND} - SDLK_QUOTE = 39; -{$EXTERNALSYM SDLK_QUOTE} - SDLK_LEFTPAREN = 40; -{$EXTERNALSYM SDLK_LEFTPAREN} - SDLK_RIGHTPAREN = 41; -{$EXTERNALSYM SDLK_RIGHTPAREN} - SDLK_ASTERISK = 42; -{$EXTERNALSYM SDLK_ASTERISK} - SDLK_PLUS = 43; -{$EXTERNALSYM SDLK_PLUS} - SDLK_COMMA = 44; -{$EXTERNALSYM SDLK_COMMA} - SDLK_MINUS = 45; -{$EXTERNALSYM SDLK_MINUS} - SDLK_PERIOD = 46; -{$EXTERNALSYM SDLK_PERIOD} - SDLK_SLASH = 47; -{$EXTERNALSYM SDLK_SLASH} - SDLK_0 = 48; -{$EXTERNALSYM SDLK_0} - SDLK_1 = 49; -{$EXTERNALSYM SDLK_1} - SDLK_2 = 50; -{$EXTERNALSYM SDLK_2} - SDLK_3 = 51; -{$EXTERNALSYM SDLK_3} - SDLK_4 = 52; -{$EXTERNALSYM SDLK_4} - SDLK_5 = 53; -{$EXTERNALSYM SDLK_5} - SDLK_6 = 54; -{$EXTERNALSYM SDLK_6} - SDLK_7 = 55; -{$EXTERNALSYM SDLK_7} - SDLK_8 = 56; -{$EXTERNALSYM SDLK_8} - SDLK_9 = 57; -{$EXTERNALSYM SDLK_9} - SDLK_COLON = 58; -{$EXTERNALSYM SDLK_COLON} - SDLK_SEMICOLON = 59; -{$EXTERNALSYM SDLK_SEMICOLON} - SDLK_LESS = 60; -{$EXTERNALSYM SDLK_LESS} - SDLK_EQUALS = 61; -{$EXTERNALSYM SDLK_EQUALS} - SDLK_GREATER = 62; -{$EXTERNALSYM SDLK_GREATER} - SDLK_QUESTION = 63; -{$EXTERNALSYM SDLK_QUESTION} - SDLK_AT = 64; -{$EXTERNALSYM SDLK_AT} - - { Skip uppercase letters } - - SDLK_LEFTBRACKET = 91; -{$EXTERNALSYM SDLK_LEFTBRACKET} - SDLK_BACKSLASH = 92; -{$EXTERNALSYM SDLK_BACKSLASH} - SDLK_RIGHTBRACKET = 93; -{$EXTERNALSYM SDLK_RIGHTBRACKET} - SDLK_CARET = 94; -{$EXTERNALSYM SDLK_CARET} - SDLK_UNDERSCORE = 95; -{$EXTERNALSYM SDLK_UNDERSCORE} - SDLK_BACKQUOTE = 96; -{$EXTERNALSYM SDLK_BACKQUOTE} - SDLK_a = 97; -{$EXTERNALSYM SDLK_a} - SDLK_b = 98; -{$EXTERNALSYM SDLK_b} - SDLK_c = 99; -{$EXTERNALSYM SDLK_c} - SDLK_d = 100; -{$EXTERNALSYM SDLK_d} - SDLK_e = 101; -{$EXTERNALSYM SDLK_e} - SDLK_f = 102; -{$EXTERNALSYM SDLK_f} - SDLK_g = 103; -{$EXTERNALSYM SDLK_g} - SDLK_h = 104; -{$EXTERNALSYM SDLK_h} - SDLK_i = 105; -{$EXTERNALSYM SDLK_i} - SDLK_j = 106; -{$EXTERNALSYM SDLK_j} - SDLK_k = 107; -{$EXTERNALSYM SDLK_k} - SDLK_l = 108; -{$EXTERNALSYM SDLK_l} - SDLK_m = 109; -{$EXTERNALSYM SDLK_m} - SDLK_n = 110; -{$EXTERNALSYM SDLK_n} - SDLK_o = 111; -{$EXTERNALSYM SDLK_o} - SDLK_p = 112; -{$EXTERNALSYM SDLK_p} - SDLK_q = 113; -{$EXTERNALSYM SDLK_q} - SDLK_r = 114; -{$EXTERNALSYM SDLK_r} - SDLK_s = 115; -{$EXTERNALSYM SDLK_s} - SDLK_t = 116; -{$EXTERNALSYM SDLK_t} - SDLK_u = 117; -{$EXTERNALSYM SDLK_u} - SDLK_v = 118; -{$EXTERNALSYM SDLK_v} - SDLK_w = 119; -{$EXTERNALSYM SDLK_w} - SDLK_x = 120; -{$EXTERNALSYM SDLK_x} - SDLK_y = 121; -{$EXTERNALSYM SDLK_y} - SDLK_z = 122; -{$EXTERNALSYM SDLK_z} - SDLK_DELETE = 127; -{$EXTERNALSYM SDLK_DELETE} - // End of ASCII mapped keysyms - - // International keyboard syms - SDLK_WORLD_0 = 160; // 0xA0 -{$EXTERNALSYM SDLK_WORLD_0} - SDLK_WORLD_1 = 161; -{$EXTERNALSYM SDLK_WORLD_1} - SDLK_WORLD_2 = 162; -{$EXTERNALSYM SDLK_WORLD_2} - SDLK_WORLD_3 = 163; -{$EXTERNALSYM SDLK_WORLD_3} - SDLK_WORLD_4 = 164; -{$EXTERNALSYM SDLK_WORLD_4} - SDLK_WORLD_5 = 165; -{$EXTERNALSYM SDLK_WORLD_5} - SDLK_WORLD_6 = 166; -{$EXTERNALSYM SDLK_WORLD_6} - SDLK_WORLD_7 = 167; -{$EXTERNALSYM SDLK_WORLD_7} - SDLK_WORLD_8 = 168; -{$EXTERNALSYM SDLK_WORLD_8} - SDLK_WORLD_9 = 169; -{$EXTERNALSYM SDLK_WORLD_9} - SDLK_WORLD_10 = 170; -{$EXTERNALSYM SDLK_WORLD_10} - SDLK_WORLD_11 = 171; -{$EXTERNALSYM SDLK_WORLD_11} - SDLK_WORLD_12 = 172; -{$EXTERNALSYM SDLK_WORLD_12} - SDLK_WORLD_13 = 173; -{$EXTERNALSYM SDLK_WORLD_13} - SDLK_WORLD_14 = 174; -{$EXTERNALSYM SDLK_WORLD_14} - SDLK_WORLD_15 = 175; -{$EXTERNALSYM SDLK_WORLD_15} - SDLK_WORLD_16 = 176; -{$EXTERNALSYM SDLK_WORLD_16} - SDLK_WORLD_17 = 177; -{$EXTERNALSYM SDLK_WORLD_17} - SDLK_WORLD_18 = 178; -{$EXTERNALSYM SDLK_WORLD_18} - SDLK_WORLD_19 = 179; -{$EXTERNALSYM SDLK_WORLD_19} - SDLK_WORLD_20 = 180; -{$EXTERNALSYM SDLK_WORLD_20} - SDLK_WORLD_21 = 181; -{$EXTERNALSYM SDLK_WORLD_21} - SDLK_WORLD_22 = 182; -{$EXTERNALSYM SDLK_WORLD_22} - SDLK_WORLD_23 = 183; -{$EXTERNALSYM SDLK_WORLD_23} - SDLK_WORLD_24 = 184; -{$EXTERNALSYM SDLK_WORLD_24} - SDLK_WORLD_25 = 185; -{$EXTERNALSYM SDLK_WORLD_25} - SDLK_WORLD_26 = 186; -{$EXTERNALSYM SDLK_WORLD_26} - SDLK_WORLD_27 = 187; -{$EXTERNALSYM SDLK_WORLD_27} - SDLK_WORLD_28 = 188; -{$EXTERNALSYM SDLK_WORLD_28} - SDLK_WORLD_29 = 189; -{$EXTERNALSYM SDLK_WORLD_29} - SDLK_WORLD_30 = 190; -{$EXTERNALSYM SDLK_WORLD_30} - SDLK_WORLD_31 = 191; -{$EXTERNALSYM SDLK_WORLD_31} - SDLK_WORLD_32 = 192; -{$EXTERNALSYM SDLK_WORLD_32} - SDLK_WORLD_33 = 193; -{$EXTERNALSYM SDLK_WORLD_33} - SDLK_WORLD_34 = 194; -{$EXTERNALSYM SDLK_WORLD_34} - SDLK_WORLD_35 = 195; -{$EXTERNALSYM SDLK_WORLD_35} - SDLK_WORLD_36 = 196; -{$EXTERNALSYM SDLK_WORLD_36} - SDLK_WORLD_37 = 197; -{$EXTERNALSYM SDLK_WORLD_37} - SDLK_WORLD_38 = 198; -{$EXTERNALSYM SDLK_WORLD_38} - SDLK_WORLD_39 = 199; -{$EXTERNALSYM SDLK_WORLD_39} - SDLK_WORLD_40 = 200; -{$EXTERNALSYM SDLK_WORLD_40} - SDLK_WORLD_41 = 201; -{$EXTERNALSYM SDLK_WORLD_41} - SDLK_WORLD_42 = 202; -{$EXTERNALSYM SDLK_WORLD_42} - SDLK_WORLD_43 = 203; -{$EXTERNALSYM SDLK_WORLD_43} - SDLK_WORLD_44 = 204; -{$EXTERNALSYM SDLK_WORLD_44} - SDLK_WORLD_45 = 205; -{$EXTERNALSYM SDLK_WORLD_45} - SDLK_WORLD_46 = 206; -{$EXTERNALSYM SDLK_WORLD_46} - SDLK_WORLD_47 = 207; -{$EXTERNALSYM SDLK_WORLD_47} - SDLK_WORLD_48 = 208; -{$EXTERNALSYM SDLK_WORLD_48} - SDLK_WORLD_49 = 209; -{$EXTERNALSYM SDLK_WORLD_49} - SDLK_WORLD_50 = 210; -{$EXTERNALSYM SDLK_WORLD_50} - SDLK_WORLD_51 = 211; -{$EXTERNALSYM SDLK_WORLD_51} - SDLK_WORLD_52 = 212; -{$EXTERNALSYM SDLK_WORLD_52} - SDLK_WORLD_53 = 213; -{$EXTERNALSYM SDLK_WORLD_53} - SDLK_WORLD_54 = 214; -{$EXTERNALSYM SDLK_WORLD_54} - SDLK_WORLD_55 = 215; -{$EXTERNALSYM SDLK_WORLD_55} - SDLK_WORLD_56 = 216; -{$EXTERNALSYM SDLK_WORLD_56} - SDLK_WORLD_57 = 217; -{$EXTERNALSYM SDLK_WORLD_57} - SDLK_WORLD_58 = 218; -{$EXTERNALSYM SDLK_WORLD_58} - SDLK_WORLD_59 = 219; -{$EXTERNALSYM SDLK_WORLD_59} - SDLK_WORLD_60 = 220; -{$EXTERNALSYM SDLK_WORLD_60} - SDLK_WORLD_61 = 221; -{$EXTERNALSYM SDLK_WORLD_61} - SDLK_WORLD_62 = 222; -{$EXTERNALSYM SDLK_WORLD_62} - SDLK_WORLD_63 = 223; -{$EXTERNALSYM SDLK_WORLD_63} - SDLK_WORLD_64 = 224; -{$EXTERNALSYM SDLK_WORLD_64} - SDLK_WORLD_65 = 225; -{$EXTERNALSYM SDLK_WORLD_65} - SDLK_WORLD_66 = 226; -{$EXTERNALSYM SDLK_WORLD_66} - SDLK_WORLD_67 = 227; -{$EXTERNALSYM SDLK_WORLD_67} - SDLK_WORLD_68 = 228; -{$EXTERNALSYM SDLK_WORLD_68} - SDLK_WORLD_69 = 229; -{$EXTERNALSYM SDLK_WORLD_69} - SDLK_WORLD_70 = 230; -{$EXTERNALSYM SDLK_WORLD_70} - SDLK_WORLD_71 = 231; -{$EXTERNALSYM SDLK_WORLD_71} - SDLK_WORLD_72 = 232; -{$EXTERNALSYM SDLK_WORLD_72} - SDLK_WORLD_73 = 233; -{$EXTERNALSYM SDLK_WORLD_73} - SDLK_WORLD_74 = 234; -{$EXTERNALSYM SDLK_WORLD_74} - SDLK_WORLD_75 = 235; -{$EXTERNALSYM SDLK_WORLD_75} - SDLK_WORLD_76 = 236; -{$EXTERNALSYM SDLK_WORLD_76} - SDLK_WORLD_77 = 237; -{$EXTERNALSYM SDLK_WORLD_77} - SDLK_WORLD_78 = 238; -{$EXTERNALSYM SDLK_WORLD_78} - SDLK_WORLD_79 = 239; -{$EXTERNALSYM SDLK_WORLD_79} - SDLK_WORLD_80 = 240; -{$EXTERNALSYM SDLK_WORLD_80} - SDLK_WORLD_81 = 241; -{$EXTERNALSYM SDLK_WORLD_81} - SDLK_WORLD_82 = 242; -{$EXTERNALSYM SDLK_WORLD_82} - SDLK_WORLD_83 = 243; -{$EXTERNALSYM SDLK_WORLD_83} - SDLK_WORLD_84 = 244; -{$EXTERNALSYM SDLK_WORLD_84} - SDLK_WORLD_85 = 245; -{$EXTERNALSYM SDLK_WORLD_85} - SDLK_WORLD_86 = 246; -{$EXTERNALSYM SDLK_WORLD_86} - SDLK_WORLD_87 = 247; -{$EXTERNALSYM SDLK_WORLD_87} - SDLK_WORLD_88 = 248; -{$EXTERNALSYM SDLK_WORLD_88} - SDLK_WORLD_89 = 249; -{$EXTERNALSYM SDLK_WORLD_89} - SDLK_WORLD_90 = 250; -{$EXTERNALSYM SDLK_WORLD_90} - SDLK_WORLD_91 = 251; -{$EXTERNALSYM SDLK_WORLD_91} - SDLK_WORLD_92 = 252; -{$EXTERNALSYM SDLK_WORLD_92} - SDLK_WORLD_93 = 253; -{$EXTERNALSYM SDLK_WORLD_93} - SDLK_WORLD_94 = 254; -{$EXTERNALSYM SDLK_WORLD_94} - SDLK_WORLD_95 = 255; // 0xFF -{$EXTERNALSYM SDLK_WORLD_95} - - // Numeric keypad - SDLK_KP0 = 256; -{$EXTERNALSYM SDLK_KP0} - SDLK_KP1 = 257; -{$EXTERNALSYM SDLK_KP1} - SDLK_KP2 = 258; -{$EXTERNALSYM SDLK_KP2} - SDLK_KP3 = 259; -{$EXTERNALSYM SDLK_KP3} - SDLK_KP4 = 260; -{$EXTERNALSYM SDLK_KP4} - SDLK_KP5 = 261; -{$EXTERNALSYM SDLK_KP5} - SDLK_KP6 = 262; -{$EXTERNALSYM SDLK_KP6} - SDLK_KP7 = 263; -{$EXTERNALSYM SDLK_KP7} - SDLK_KP8 = 264; -{$EXTERNALSYM SDLK_KP8} - SDLK_KP9 = 265; -{$EXTERNALSYM SDLK_KP9} - SDLK_KP_PERIOD = 266; -{$EXTERNALSYM SDLK_KP_PERIOD} - SDLK_KP_DIVIDE = 267; -{$EXTERNALSYM SDLK_KP_DIVIDE} - SDLK_KP_MULTIPLY = 268; -{$EXTERNALSYM SDLK_KP_MULTIPLY} - SDLK_KP_MINUS = 269; -{$EXTERNALSYM SDLK_KP_MINUS} - SDLK_KP_PLUS = 270; -{$EXTERNALSYM SDLK_KP_PLUS} - SDLK_KP_ENTER = 271; -{$EXTERNALSYM SDLK_KP_ENTER} - SDLK_KP_EQUALS = 272; -{$EXTERNALSYM SDLK_KP_EQUALS} - - // Arrows + Home/End pad - SDLK_UP = 273; -{$EXTERNALSYM SDLK_UP} - SDLK_DOWN = 274; -{$EXTERNALSYM SDLK_DOWN} - SDLK_RIGHT = 275; -{$EXTERNALSYM SDLK_RIGHT} - SDLK_LEFT = 276; -{$EXTERNALSYM SDLK_LEFT} - SDLK_INSERT = 277; -{$EXTERNALSYM SDLK_INSERT} - SDLK_HOME = 278; -{$EXTERNALSYM SDLK_HOME} - SDLK_END = 279; -{$EXTERNALSYM SDLK_END} - SDLK_PAGEUP = 280; -{$EXTERNALSYM SDLK_PAGEUP} - SDLK_PAGEDOWN = 281; -{$EXTERNALSYM SDLK_PAGEDOWN} - - // Function keys - SDLK_F1 = 282; -{$EXTERNALSYM SDLK_F1} - SDLK_F2 = 283; -{$EXTERNALSYM SDLK_F2} - SDLK_F3 = 284; -{$EXTERNALSYM SDLK_F3} - SDLK_F4 = 285; -{$EXTERNALSYM SDLK_F4} - SDLK_F5 = 286; -{$EXTERNALSYM SDLK_F5} - SDLK_F6 = 287; -{$EXTERNALSYM SDLK_F6} - SDLK_F7 = 288; -{$EXTERNALSYM SDLK_F7} - SDLK_F8 = 289; -{$EXTERNALSYM SDLK_F8} - SDLK_F9 = 290; -{$EXTERNALSYM SDLK_F9} - SDLK_F10 = 291; -{$EXTERNALSYM SDLK_F10} - SDLK_F11 = 292; -{$EXTERNALSYM SDLK_F11} - SDLK_F12 = 293; -{$EXTERNALSYM SDLK_F12} - SDLK_F13 = 294; -{$EXTERNALSYM SDLK_F13} - SDLK_F14 = 295; -{$EXTERNALSYM SDLK_F14} - SDLK_F15 = 296; -{$EXTERNALSYM SDLK_F15} - - // Key state modifier keys - SDLK_NUMLOCK = 300; -{$EXTERNALSYM SDLK_NUMLOCK} - SDLK_CAPSLOCK = 301; -{$EXTERNALSYM SDLK_CAPSLOCK} - SDLK_SCROLLOCK = 302; -{$EXTERNALSYM SDLK_SCROLLOCK} - SDLK_RSHIFT = 303; -{$EXTERNALSYM SDLK_RSHIFT} - SDLK_LSHIFT = 304; -{$EXTERNALSYM SDLK_LSHIFT} - SDLK_RCTRL = 305; -{$EXTERNALSYM SDLK_RCTRL} - SDLK_LCTRL = 306; -{$EXTERNALSYM SDLK_LCTRL} - SDLK_RALT = 307; -{$EXTERNALSYM SDLK_RALT} - SDLK_LALT = 308; -{$EXTERNALSYM SDLK_LALT} - SDLK_RMETA = 309; -{$EXTERNALSYM SDLK_RMETA} - SDLK_LMETA = 310; -{$EXTERNALSYM SDLK_LMETA} - SDLK_LSUPER = 311; // Left "Windows" key -{$EXTERNALSYM SDLK_LSUPER} - SDLK_RSUPER = 312; // Right "Windows" key -{$EXTERNALSYM SDLK_RSUPER} - SDLK_MODE = 313; // "Alt Gr" key -{$EXTERNALSYM SDLK_MODE} - SDLK_COMPOSE = 314; // Multi-key compose key -{$EXTERNALSYM SDLK_COMPOSE} - - // Miscellaneous function keys - SDLK_HELP = 315; -{$EXTERNALSYM SDLK_HELP} - SDLK_PRINT = 316; -{$EXTERNALSYM SDLK_PRINT} - SDLK_SYSREQ = 317; -{$EXTERNALSYM SDLK_SYSREQ} - SDLK_BREAK = 318; -{$EXTERNALSYM SDLK_BREAK} - SDLK_MENU = 319; -{$EXTERNALSYM SDLK_MENU} - SDLK_POWER = 320; // Power Macintosh power key -{$EXTERNALSYM SDLK_POWER} - SDLK_EURO = 321; // Some european keyboards -{$EXTERNALSYM SDLK_EURO} - -{$IFDEF GP2X} -SDLK_GP2X_UP = 0; -{$EXTERNALSYM SDLK_GP2X_UP} -SDLK_GP2X_UPLEFT = 1; -{$EXTERNALSYM SDLK_GP2X_UPLEFT} -SDLK_GP2X_LEFT = 2; -{$EXTERNALSYM SDLK_GP2X_LEFT} -SDLK_GP2X_DOWNLEFT = 3; -{$EXTERNALSYM SDLK_GP2X_DOWNLEFT} -SDLK_GP2X_DOWN = 4; -{$EXTERNALSYM SDLK_GP2X_DOWN} -SDLK_GP2X_DOWNRIGHT = 5; -{$EXTERNALSYM SDLK_GP2X_DOWNRIGHT} -SDLK_GP2X_RIGHT = 6; -{$EXTERNALSYM SDLK_GP2X_RIGHT} -SDLK_GP2X_UPRIGHT = 7; -{$EXTERNALSYM SDLK_GP2X_UPRIGHT} -SDLK_GP2X_START = 8; -{$EXTERNALSYM SDLK_GP2X_START} -SDLK_GP2X_SELECT = 9; -{$EXTERNALSYM SDLK_GP2X_SELECT} -SDLK_GP2X_L = 10; -{$EXTERNALSYM SDLK_GP2X_L} -SDLK_GP2X_R = 11; -{$EXTERNALSYM SDLK_GP2X_R} -SDLK_GP2X_A = 12; -{$EXTERNALSYM SDLK_GP2X_A} -SDLK_GP2X_B = 13; -{$EXTERNALSYM SDLK_GP2X_B} -SDLK_GP2X_Y = 14; -{$EXTERNALSYM SDLK_GP2X_Y} -SDLK_GP2X_X = 15; -{$EXTERNALSYM SDLK_GP2X_X} -SDLK_GP2X_VOLUP = 16; -{$EXTERNALSYM SDLK_GP2X_VOLUP} -SDLK_GP2X_VOLDOWN = 17; -{$EXTERNALSYM SDLK_GP2X_VOLDOWN} -SDLK_GP2X_CLICK = 18; -{$EXTERNALSYM SDLK_GP2X_CLICK} -{$ENDIF} - - // Enumeration of valid key mods (possibly OR'd together) - KMOD_NONE = $0000; -{$EXTERNALSYM KMOD_NONE} - KMOD_LSHIFT = $0001; -{$EXTERNALSYM KMOD_LSHIFT} - KMOD_RSHIFT = $0002; -{$EXTERNALSYM KMOD_RSHIFT} - KMOD_LCTRL = $0040; -{$EXTERNALSYM KMOD_LCTRL} - KMOD_RCTRL = $0080; -{$EXTERNALSYM KMOD_RCTRL} - KMOD_LALT = $0100; -{$EXTERNALSYM KMOD_LALT} - KMOD_RALT = $0200; -{$EXTERNALSYM KMOD_RALT} - KMOD_LMETA = $0400; -{$EXTERNALSYM KMOD_LMETA} - KMOD_RMETA = $0800; -{$EXTERNALSYM KMOD_RMETA} - KMOD_NUM = $1000; -{$EXTERNALSYM KMOD_NUM} - KMOD_CAPS = $2000; -{$EXTERNALSYM KMOD_CAPS} - KMOD_MODE = 44000; -{$EXTERNALSYM KMOD_MODE} - KMOD_RESERVED = $8000; -{$EXTERNALSYM KMOD_RESERVED} - - KMOD_CTRL = (KMOD_LCTRL or KMOD_RCTRL); -{$EXTERNALSYM KMOD_CTRL} - KMOD_SHIFT = (KMOD_LSHIFT or KMOD_RSHIFT); -{$EXTERNALSYM KMOD_SHIFT} - KMOD_ALT = (KMOD_LALT or KMOD_RALT); -{$EXTERNALSYM KMOD_ALT} - KMOD_META = (KMOD_LMETA or KMOD_RMETA); -{$EXTERNALSYM KMOD_META} - - //SDL_video.h constants - // Transparency definitions: These define alpha as the opacity of a surface */ - SDL_ALPHA_OPAQUE = 255; -{$EXTERNALSYM SDL_ALPHA_OPAQUE} - SDL_ALPHA_TRANSPARENT = 0; -{$EXTERNALSYM SDL_ALPHA_TRANSPARENT} - - // These are the currently supported flags for the SDL_surface - // Available for SDL_CreateRGBSurface() or SDL_SetVideoMode() - SDL_SWSURFACE = $00000000; // Surface is in system memory -{$EXTERNALSYM SDL_SWSURFACE} - SDL_HWSURFACE = $00000001; // Surface is in video memory -{$EXTERNALSYM SDL_HWSURFACE} - SDL_ASYNCBLIT = $00000004; // Use asynchronous blits if possible -{$EXTERNALSYM SDL_ASYNCBLIT} - // Available for SDL_SetVideoMode() - SDL_ANYFORMAT = $10000000; // Allow any video depth/pixel-format -{$EXTERNALSYM SDL_ANYFORMAT} - SDL_HWPALETTE = $20000000; // Surface has exclusive palette -{$EXTERNALSYM SDL_HWPALETTE} - SDL_DOUBLEBUF = $40000000; // Set up double-buffered video mode -{$EXTERNALSYM SDL_DOUBLEBUF} - SDL_FULLSCREEN = $80000000; // Surface is a full screen display -{$EXTERNALSYM SDL_FULLSCREEN} - SDL_OPENGL = $00000002; // Create an OpenGL rendering context -{$EXTERNALSYM SDL_OPENGL} - SDL_OPENGLBLIT = $00000002; // Create an OpenGL rendering context -{$EXTERNALSYM SDL_OPENGLBLIT} - SDL_RESIZABLE = $00000010; // This video mode may be resized -{$EXTERNALSYM SDL_RESIZABLE} - SDL_NOFRAME = $00000020; // No window caption or edge frame -{$EXTERNALSYM SDL_NOFRAME} - // Used internally (read-only) - SDL_HWACCEL = $00000100; // Blit uses hardware acceleration -{$EXTERNALSYM SDL_HWACCEL} - SDL_SRCCOLORKEY = $00001000; // Blit uses a source color key -{$EXTERNALSYM SDL_SRCCOLORKEY} - SDL_RLEACCELOK = $00002000; // Private flag -{$EXTERNALSYM SDL_RLEACCELOK} - SDL_RLEACCEL = $00004000; // Colorkey blit is RLE accelerated -{$EXTERNALSYM SDL_RLEACCEL} - SDL_SRCALPHA = $00010000; // Blit uses source alpha blending -{$EXTERNALSYM SDL_SRCALPHA} - SDL_SRCCLIPPING = $00100000; // Blit uses source clipping -{$EXTERNALSYM SDL_SRCCLIPPING} - SDL_PREALLOC = $01000000; // Surface uses preallocated memory -{$EXTERNALSYM SDL_PREALLOC} - - { The most common video overlay formats. - For an explanation of these pixel formats, see: - http://www.webartz.com/fourcc/indexyuv.htm - - For information on the relationship between color spaces, see: - http://www.neuro.sfc.keio.ac.jp/~aly/polygon/info/color-space-faq.html } - - SDL_YV12_OVERLAY = $32315659; // Planar mode: Y + V + U (3 planes) -{$EXTERNALSYM SDL_YV12_OVERLAY} - SDL_IYUV_OVERLAY = $56555949; // Planar mode: Y + U + V (3 planes) -{$EXTERNALSYM SDL_IYUV_OVERLAY} - SDL_YUY2_OVERLAY = $32595559; // Packed mode: Y0+U0+Y1+V0 (1 plane) -{$EXTERNALSYM SDL_YUY2_OVERLAY} - SDL_UYVY_OVERLAY = $59565955; // Packed mode: U0+Y0+V0+Y1 (1 plane) -{$EXTERNALSYM SDL_UYVY_OVERLAY} - SDL_YVYU_OVERLAY = $55595659; // Packed mode: Y0+V0+Y1+U0 (1 plane) -{$EXTERNALSYM SDL_YVYU_OVERLAY} - - // flags for SDL_SetPalette() - SDL_LOGPAL = $01; -{$EXTERNALSYM SDL_LOGPAL} - SDL_PHYSPAL = $02; -{$EXTERNALSYM SDL_PHYSPAL} - - //SDL_mouse.h constants - { Used as a mask when testing buttons in buttonstate - Button 1: Left mouse button - Button 2: Middle mouse button - Button 3: Right mouse button - Button 4: Mouse Wheel Up (may also be a real button) - Button 5: Mouse Wheel Down (may also be a real button) - Button 6: Mouse X1 (may also be a real button) - Button 7: Mouse X2 (may also be a real button) - } - SDL_BUTTON_LEFT = 1; -{$EXTERNALSYM SDL_BUTTON_LEFT} - SDL_BUTTON_MIDDLE = 2; -{$EXTERNALSYM SDL_BUTTON_MIDDLE} - SDL_BUTTON_RIGHT = 3; -{$EXTERNALSYM SDL_BUTTON_RIGHT} - SDL_BUTTON_WHEELUP = 4; -{$EXTERNALSYM SDL_BUTTON_WHEELUP} - SDL_BUTTON_WHEELDOWN = 5; -{$EXTERNALSYM SDL_BUTTON_WHEELDOWN} - SDL_BUTTON_X1 = 6; -{$EXTERNALSYM SDL_BUTTON_X1} - SDL_BUTTON_X2 = 7; -{$EXTERNALSYM SDL_BUTTON_X2} - - SDL_BUTTON_LMASK = SDL_PRESSED shl (SDL_BUTTON_LEFT - 1); -{$EXTERNALSYM SDL_BUTTON_LMASK} - SDL_BUTTON_MMASK = SDL_PRESSED shl (SDL_BUTTON_MIDDLE - 1); -{$EXTERNALSYM SDL_BUTTON_MMASK} - SDL_BUTTON_RMASK = SDL_PRESSED shl (SDL_BUTTON_RIGHT - 1); -{$EXTERNALSYM SDL_BUTTON_RMASK} - SDL_BUTTON_X1MASK = SDL_PRESSED shl (SDL_BUTTON_X1 - 1); -{$EXTERNALSYM SDL_BUTTON_X1MASK} - SDL_BUTTON_X2MASK = SDL_PRESSED shl (SDL_BUTTON_X2 - 1); -{$EXTERNALSYM SDL_BUTTON_X2MASK} - - // SDL_active.h constants - // The available application states - SDL_APPMOUSEFOCUS = $01; // The app has mouse coverage -{$EXTERNALSYM SDL_APPMOUSEFOCUS} - SDL_APPINPUTFOCUS = $02; // The app has input focus -{$EXTERNALSYM SDL_APPINPUTFOCUS} - SDL_APPACTIVE = $04; // The application is active -{$EXTERNALSYM SDL_APPACTIVE} - - // SDL_mutex.h constants - // Synchronization functions which can time out return this value - // they time out. - - SDL_MUTEX_TIMEDOUT = 1; -{$EXTERNALSYM SDL_MUTEX_TIMEDOUT} - - // This is the timeout value which corresponds to never time out - SDL_MUTEX_MAXWAIT = not Cardinal(0); -{$EXTERNALSYM SDL_MUTEX_MAXWAIT} - - {TSDL_GrabMode = ( - SDL_GRAB_QUERY, - SDL_GRAB_OFF, - SDL_GRAB_ON, - SDL_GRAB_FULLSCREEN ); // Used internally} - SDL_GRAB_QUERY = -1; - SDL_GRAB_OFF = 0; - SDL_GRAB_ON = 1; - //SDL_GRAB_FULLSCREEN // Used internally - -type - THandle = Cardinal; - //SDL_types.h types - // Basic data types - - SDL_Bool = (SDL_FALSE, SDL_TRUE); - TSDL_Bool = SDL_Bool; - - PUInt8Array = ^TUInt8Array; - PUInt8 = ^UInt8; - PPUInt8 = ^PUInt8; - UInt8 = Byte; -{$EXTERNALSYM UInt8} - TUInt8Array = array [0..MAXINT shr 1] of UInt8; - - PUInt16 = ^UInt16; - UInt16 = word; -{$EXTERNALSYM UInt16} - - PSInt8 = ^SInt8; - SInt8 = Shortint; -{$EXTERNALSYM SInt8} - - PSInt16 = ^SInt16; - SInt16 = smallint; -{$EXTERNALSYM SInt16} - - PUInt32 = ^UInt32; - UInt32 = Cardinal; -{$EXTERNALSYM UInt32} - - SInt32 = Integer; -{$EXTERNALSYM SInt32} - - PInt = ^Integer; - - PShortInt = ^ShortInt; - - PUInt64 = ^UInt64; - UInt64 = record - hi: UInt32; - lo: UInt32; - end; -{$EXTERNALSYM UInt64} - - PSInt64 = ^SInt64; - SInt64 = record - hi: UInt32; - lo: UInt32; - end; -{$EXTERNALSYM SInt64} - - TSDL_GrabMode = Integer; - - // SDL_error.h types - TSDL_errorcode = ( - SDL_ENOMEM, - SDL_EFREAD, - SDL_EFWRITE, - SDL_EFSEEK, - SDL_LASTERROR); - - SDL_errorcode = TSDL_errorcode; -{$EXTERNALSYM SDL_errorcode} - - TArg = record - case Byte of - 0: (value_ptr: Pointer); - (* #if 0 means: never - 1 : ( value_c : Byte ); - *) - 2: (value_i: Integer); - 3: (value_f: double); - 4: (buf: array[0..ERR_MAX_STRLEN - 1] of Byte); - end; - - PSDL_error = ^TSDL_error; - TSDL_error = record - { This is a numeric value corresponding to the current error } - error: Integer; - - { This is a key used to index into a language hashtable containing - internationalized versions of the SDL error messages. If the key - is not in the hashtable, or no hashtable is available, the key is - used directly as an error message format string. } - key: array[0..ERR_MAX_STRLEN - 1] of Byte; - - { These are the arguments for the error functions } - argc: Integer; - args: array[0..ERR_MAX_ARGS - 1] of TArg; - end; - - // SDL_rwops.h types - // This is the read/write operation structure -- very basic - // some helper types to handle the unions - // "packed" is only guessed - - TStdio = record - autoclose: Integer; - // FILE * is only defined in Kylix so we use a simple Pointer - fp: Pointer; - end; - - TMem = record - base: PUInt8; - here: PUInt8; - stop: PUInt8; - end; - - TUnknown = record - data1: Pointer; - end; - - // first declare the pointer type - PSDL_RWops = ^TSDL_RWops; - // now the pointer to function types - {$IFNDEF __GPC__} - TSeek = function( context: PSDL_RWops; offset: Integer; whence: Integer ): Integer; cdecl; - TRead = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; maxnum : Integer ): Integer; cdecl; - TWrite = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; num: Integer ): Integer; cdecl; - TClose = function( context: PSDL_RWops ): Integer; cdecl; - {$ELSE} - TSeek = function( context: PSDL_RWops; offset: Integer; whence: Integer ): Integer; - TRead = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; maxnum : Integer ): Integer; - TWrite = function( context: PSDL_RWops; Ptr: Pointer; size: Integer; num: Integer ): Integer; - TClose = function( context: PSDL_RWops ): Integer; - {$ENDIF} - // the variant record itself - TSDL_RWops = record - seek: TSeek; - read: TRead; - write: TWrite; - close: TClose; - // a keyword as name is not allowed - type_: UInt32; - // be warned! structure alignment may arise at this point - case Integer of - 0: (stdio: TStdio); - 1: (mem: TMem); - 2: (unknown: TUnknown); - end; - - SDL_RWops = TSDL_RWops; -{$EXTERNALSYM SDL_RWops} - - - // SDL_timer.h types - // Function prototype for the timer callback function - {$IFNDEF __GPC__} - TSDL_TimerCallback = function( interval: UInt32 ): UInt32; cdecl; - {$ELSE} - TSDL_TimerCallback = function( interval: UInt32 ): UInt32; - {$ENDIF} - - { New timer API, supports multiple timers - Written by Stephane Peter <megastep@lokigames.com> } - - { Function prototype for the new timer callback function. - The callback function is passed the current timer interval and returns - the next timer interval. If the returned value is the same as the one - passed in, the periodic alarm continues, otherwise a new alarm is - scheduled. If the callback returns 0, the periodic alarm is cancelled. } - {$IFNDEF __GPC__} - TSDL_NewTimerCallback = function( interval: UInt32; param: Pointer ): UInt32; cdecl; - {$ELSE} - TSDL_NewTimerCallback = function( interval: UInt32; param: Pointer ): UInt32; - {$ENDIF} - - // Definition of the timer ID type - PSDL_TimerID = ^TSDL_TimerID; - TSDL_TimerID = record - interval: UInt32; - callback: TSDL_NewTimerCallback; - param: Pointer; - last_alarm: UInt32; - next: PSDL_TimerID; - end; - - {$IFNDEF __GPC__} - TSDL_AudioSpecCallback = procedure( userdata: Pointer; stream: PUInt8; len: Integer ); cdecl; - {$ELSE} - TSDL_AudioSpecCallback = procedure( userdata: Pointer; stream: PUInt8; len: Integer ); - {$ENDIF} - - // SDL_audio.h types - // The calculated values in this structure are calculated by SDL_OpenAudio() - PSDL_AudioSpec = ^TSDL_AudioSpec; - TSDL_AudioSpec = record - freq: Integer; // DSP frequency -- samples per second - format: UInt16; // Audio data format - channels: UInt8; // Number of channels: 1 mono, 2 stereo - silence: UInt8; // Audio buffer silence value (calculated) - samples: UInt16; // Audio buffer size in samples - padding: UInt16; // Necessary for some compile environments - size: UInt32; // Audio buffer size in bytes (calculated) - { This function is called when the audio device needs more data. - 'stream' is a pointer to the audio data buffer - 'len' is the length of that buffer in bytes. - Once the callback returns, the buffer will no longer be valid. - Stereo samples are stored in a LRLRLR ordering.} - callback: TSDL_AudioSpecCallback; - userdata: Pointer; - end; - - // A structure to hold a set of audio conversion filters and buffers - PSDL_AudioCVT = ^TSDL_AudioCVT; - - PSDL_AudioCVTFilter = ^TSDL_AudioCVTFilter; - TSDL_AudioCVTFilter = record - cvt: PSDL_AudioCVT; - format: UInt16; - end; - - PSDL_AudioCVTFilterArray = ^TSDL_AudioCVTFilterArray; - TSDL_AudioCVTFilterArray = array[0..9] of PSDL_AudioCVTFilter; - - TSDL_AudioCVT = record - needed: Integer; // Set to 1 if conversion possible - src_format: UInt16; // Source audio format - dst_format: UInt16; // Target audio format - rate_incr: double; // Rate conversion increment - buf: PUInt8; // Buffer to hold entire audio data - len: Integer; // Length of original audio buffer - len_cvt: Integer; // Length of converted audio buffer - len_mult: Integer; // buffer must be len*len_mult big - len_ratio: double; // Given len, final size is len*len_ratio - filters: TSDL_AudioCVTFilterArray; - filter_index: Integer; // Current audio conversion function - end; - - TSDL_Audiostatus = ( - SDL_AUDIO_STOPPED, - SDL_AUDIO_PLAYING, - SDL_AUDIO_PAUSED - ); - - // SDL_cdrom.h types - TSDL_CDStatus = ( - CD_ERROR, - CD_TRAYEMPTY, - CD_STOPPED, - CD_PLAYING, - CD_PAUSED ); - - PSDL_CDTrack = ^TSDL_CDTrack; - TSDL_CDTrack = record - id: UInt8; // Track number - type_: UInt8; // Data or audio track - unused: UInt16; - length: UInt32; // Length, in frames, of this track - offset: UInt32; // Offset, in frames, from start of disk - end; - - // This structure is only current as of the last call to SDL_CDStatus() - PSDL_CD = ^TSDL_CD; - TSDL_CD = record - id: Integer; // Private drive identifier - status: TSDL_CDStatus; // Current drive status - - // The rest of this structure is only valid if there's a CD in drive - numtracks: Integer; // Number of tracks on disk - cur_track: Integer; // Current track position - cur_frame: Integer; // Current frame offset within current track - track: array[0..SDL_MAX_TRACKS] of TSDL_CDTrack; - end; - - //SDL_joystick.h types - PTransAxis = ^TTransAxis; - TTransAxis = record - offset: Integer; - scale: single; - end; - - // The private structure used to keep track of a joystick - PJoystick_hwdata = ^TJoystick_hwdata; - TJoystick_hwdata = record - // joystick ID - id: Integer; - // values used to translate device-specific coordinates into SDL-standard ranges - transaxis: array[0..5] of TTransAxis; - end; - - PBallDelta = ^TBallDelta; - TBallDelta = record - dx: Integer; - dy: Integer; - end; // Current ball motion deltas - - // The SDL joystick structure - PSDL_Joystick = ^TSDL_Joystick; - TSDL_Joystick = record - index: UInt8; // Device index - name: PChar; // Joystick name - system dependent - - naxes: Integer; // Number of axis controls on the joystick - axes: PUInt16; // Current axis states - - nhats: Integer; // Number of hats on the joystick - hats: PUInt8; // Current hat states - - nballs: Integer; // Number of trackballs on the joystick - balls: PBallDelta; // Current ball motion deltas - - nbuttons: Integer; // Number of buttons on the joystick - buttons: PUInt8; // Current button states - - hwdata: PJoystick_hwdata; // Driver dependent information - - ref_count: Integer; // Reference count for multiple opens - end; - - // SDL_verion.h types - PSDL_version = ^TSDL_version; - TSDL_version = record - major: UInt8; - minor: UInt8; - patch: UInt8; - end; - - // SDL_keyboard.h types - TSDLKey = LongWord; - - TSDLMod = LongWord; - - PSDL_KeySym = ^TSDL_KeySym; - TSDL_KeySym = record - scancode: UInt8; // hardware specific scancode - sym: TSDLKey; // SDL virtual keysym - modifier: TSDLMod; // current key modifiers - unicode: UInt16; // translated character - end; - - // SDL_events.h types - {Checks the event queue for messages and optionally returns them. - If 'action' is SDL_ADDEVENT, up to 'numevents' events will be added to - the back of the event queue. - If 'action' is SDL_PEEKEVENT, up to 'numevents' events at the front - of the event queue, matching 'mask', will be returned and will not - be removed from the queue. - If 'action' is SDL_GETEVENT, up to 'numevents' events at the front - of the event queue, matching 'mask', will be returned and will be - removed from the queue. - This function returns the number of events actually stored, or -1 - if there was an error. This function is thread-safe. } - - TSDL_EventAction = (SDL_ADDEVENT, SDL_PEEKEVENT, SDL_GETEVENT); - - // Application visibility event structure - TSDL_ActiveEvent = record - type_: UInt8; // SDL_ACTIVEEVENT - gain: UInt8; // Whether given states were gained or lost (1/0) - state: UInt8; // A mask of the focus states - end; - - // Keyboard event structure - TSDL_KeyboardEvent = record - type_: UInt8; // SDL_KEYDOWN or SDL_KEYUP - which: UInt8; // The keyboard device index - state: UInt8; // SDL_PRESSED or SDL_RELEASED - keysym: TSDL_KeySym; - end; - - // Mouse motion event structure - TSDL_MouseMotionEvent = record - type_: UInt8; // SDL_MOUSEMOTION - which: UInt8; // The mouse device index - state: UInt8; // The current button state - x, y: UInt16; // The X/Y coordinates of the mouse - xrel: SInt16; // The relative motion in the X direction - yrel: SInt16; // The relative motion in the Y direction - end; - - // Mouse button event structure - TSDL_MouseButtonEvent = record - type_: UInt8; // SDL_MOUSEBUTTONDOWN or SDL_MOUSEBUTTONUP - which: UInt8; // The mouse device index - button: UInt8; // The mouse button index - state: UInt8; // SDL_PRESSED or SDL_RELEASED - x: UInt16; // The X coordinates of the mouse at press time - y: UInt16; // The Y coordinates of the mouse at press time - end; - - // Joystick axis motion event structure - TSDL_JoyAxisEvent = record - type_: UInt8; // SDL_JOYAXISMOTION - which: UInt8; // The joystick device index - axis: UInt8; // The joystick axis index - value: SInt16; // The axis value (range: -32768 to 32767) - end; - - // Joystick trackball motion event structure - TSDL_JoyBallEvent = record - type_: UInt8; // SDL_JOYAVBALLMOTION - which: UInt8; // The joystick device index - ball: UInt8; // The joystick trackball index - xrel: SInt16; // The relative motion in the X direction - yrel: SInt16; // The relative motion in the Y direction - end; - - // Joystick hat position change event structure - TSDL_JoyHatEvent = record - type_: UInt8; // SDL_JOYHATMOTION */ - which: UInt8; // The joystick device index */ - hat: UInt8; // The joystick hat index */ - value: UInt8; { The hat position value: - 8 1 2 - 7 0 3 - 6 5 4 - - Note that zero means the POV is centered. } - - end; - - // Joystick button event structure - TSDL_JoyButtonEvent = record - type_: UInt8; // SDL_JOYBUTTONDOWN or SDL_JOYBUTTONUP - which: UInt8; // The joystick device index - button: UInt8; // The joystick button index - state: UInt8; // SDL_PRESSED or SDL_RELEASED - end; - - { The "window resized" event - When you get this event, you are responsible for setting a new video - mode with the new width and height. } - TSDL_ResizeEvent = record - type_: UInt8; // SDL_VIDEORESIZE - w: Integer; // New width - h: Integer; // New height - end; - - // The "quit requested" event - PSDL_QuitEvent = ^TSDL_QuitEvent; - TSDL_QuitEvent = record - type_: UInt8; - end; - - // A user-defined event type - PSDL_UserEvent = ^TSDL_UserEvent; - TSDL_UserEvent = record - type_: UInt8; // SDL_USEREVENT through SDL_NUMEVENTS-1 - code: Integer; // User defined event code */ - data1: Pointer; // User defined data pointer */ - data2: Pointer; // User defined data pointer */ - end; - - // The "screen redraw" event - PSDL_ExposeEvent = ^TSDL_ExposeEvent; - TSDL_ExposeEvent = record - type_ : Uint8; // SDL_VIDEOEXPOSE - end; - - {$IFDEF Unix} - //These are the various supported subsystems under UNIX - TSDL_SysWm = ( SDL_SYSWM_X11 ) ; - {$ENDIF} - -// The windows custom event structure -{$IFDEF 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] ) ... <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 <slouken@devolution.com> are } -{ Copyright (C) 1997-2004 Sam Lantinga } -{ 5635-34 Springhouse Dr. } -{ Pleasanton, CA 94588 (USA) } -{ } -{ All Rights Reserved. } -{ } -{ The original files are : SDL_cpuinfo.h } -{ } -{ The initial developer of this Pascal code was : } -{ Dominqiue Louis <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2004 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ - $Log: sdl_cpuinfo.pas,v $ - Revision 1.2 2004/02/18 22:52:53 savage - Forgot to add jedi-sdl.inc file. It's there now. - - Revision 1.1 2004/02/18 22:35:54 savage - Brought sdl.pas up to 1.2.7 compatability - Thus... - Added SDL_GL_STEREO, - SDL_GL_MULTISAMPLEBUFFERS, - SDL_GL_MULTISAMPLESAMPLES - - Add DLL/Shared object functions - function SDL_LoadObject( const sofile : PChar ) : Pointer; - - function SDL_LoadFunction( handle : Pointer; const name : PChar ) : Pointer; - - procedure SDL_UnloadObject( handle : Pointer ); - - Added function to create RWops from const memory: SDL_RWFromConstMem() - function SDL_RWFromConstMem(const mem: Pointer; size: Integer) : PSDL_RWops; - - Ported SDL_cpuinfo.h so Now you can test for Specific CPU types. - - -} -{******************************************************************************} - -interface - -{$I jedi-sdl.inc} - -uses - sdl; - -{* This function returns true if the CPU has the RDTSC instruction - *} -function SDL_HasRDTSC : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasRDTSC'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasRDTSC} - -{* This function returns true if the CPU has MMX features - *} -function SDL_HasMMX : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMX'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasMMX} - -{* This function returns true if the CPU has MMX Ext. features - *} -function SDL_HasMMXExt : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasMMXExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasMMXExt} - -{* This function returns true if the CPU has 3DNow features - *} -function SDL_Has3DNow : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNow'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_Has3DNow} - -{* This function returns true if the CPU has 3DNow! Ext. features - *} -function SDL_Has3DNowExt : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_Has3DNowExt'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_Has3DNowExt} - -{* This function returns true if the CPU has SSE features - *} -function SDL_HasSSE : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasSSE} - -{* This function returns true if the CPU has SSE2 features - *} -function SDL_HasSSE2 : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasSSE2'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasSSE2} - -{* This function returns true if the CPU has AltiVec features - *} -function SDL_HasAltiVec : SDL_Bool; -cdecl; external {$IFDEF __GPC__}name 'SDL_HasAltiVec'{$ELSE} SDLLibName{$ENDIF __GPC__}; -{$EXTERNALSYM SDL_HasAltiVec} - -implementation - -end. -
\ No newline at end of file diff --git a/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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: sdlgameinterface.pas,v $ - Revision 1.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 <tigertomjones@gmx.de> } -{ } -{ Portions created by Tom Jones are } -{ Copyright (C) 2000 - 2001 Tom Jones. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ Róbert Kisnémeth <mikrobi@freemail.hu> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Helper functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2000 - TJ : Initial creation } -{ } -{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } -{ } -{ Sept 14 2001 - RK : Added flipping routines. } -{ } -{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } -{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } -{ Added PSDLRect() } -{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} -{ Also removed by poor attempt or a dialog box } -{ } -{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } -{ SubSurface, MonoSurface & TexturedSurface } -{ } -{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } -{ types rather that Windows types. This makes it more} -{ portable to Linix. } -{ } -{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } -{ } -{ Oct 27 2001 - JF : Added ScrollY function } -{ } -{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } -{ } -{ Mar 28 2002 - JF : Added SDL_RotateSurface } -{ } -{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } -{ } -{ May 27 2002 - YS : GradientFillRect function } -{ } -{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } -{ & SDL_50Scanline2xBlit } -{ } -{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } -{ } -{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } -{ } -{ November 9 2002 - JF : Added Jason's boolean Surface functions } -{ } -{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } -{ } -{******************************************************************************} -{ - $Log: sdli386utils.pas,v $ - Revision 1.5 2004/06/02 19:38:53 savage - Changes to SDL_GradientFillRect as suggested by - Ángel Eduardo García Hernández. Many thanks. - - Revision 1.4 2004/05/29 23:11:53 savage - Changes to SDL_ScaleSurfaceRect as suggested by - Ángel Eduardo García Hernández to fix a colour issue with the function. Many thanks. - - Revision 1.3 2004/02/20 22:04:11 savage - Added Changes as mentioned by Rodrigo "Rui" R. (1/2 RRC2Soft) to facilitate FPC compilation and it also works in Delphi. Also syncronized the funcitons so that they are identical to sdlutils.pas, when no assembly version is available. - - Revision 1.2 2004/02/14 00:23:39 savage - As UNIX is defined in jedi-sdl.inc this will be used to check linux compatability as well. Units have been changed to reflect this change. - - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -interface - -{$i jedi-sdl.inc} - -uses -{$IFDEF UNIX} - Types, - Xlib, -{$ENDIF} - SysUtils, - sdl; - -type - TGradientStyle = ( gsHorizontal, gsVertical ); - - // Pixel procedures -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : Boolean; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; - -procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); - -// Line procedures -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal );overload; - -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ; DashLength, DashSpace : byte ); overload; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); - -// Surface procedures -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); - -// Flip procedures -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); - -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; overload; - -function SDLRect( aRect : TRect ) : TSDL_Rect; overload; - -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; - -// Fill Rect routine -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); - -// NOTE for All SDL_2xblit... function : the dest surface must be 2x of the source surface! -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : -PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : -boolean; - -// Jason's boolean Surface functions -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); - -function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; - -implementation - -uses - Math; - -function SDL_PixelTest( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcSurface2 : - PSDL_Surface; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1, Mod2 : cardinal; - Addr1, Addr2 : cardinal; - BPP : cardinal; - Pitch1, Pitch2 : cardinal; - TransparentColor1, TransparentColor2 : cardinal; - tx, ty : cardinal; - StartTick : cardinal; - Color1, Color2 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - if SrcRect2 = nil then - begin - with Src_Rect2 do - begin - x := 0; - y := 0; - w := SrcSurface2.w; - h := SrcSurface2.h; - end; - end - else - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := cardinal( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - with SrcSurface2^ do - begin - TransparentColor2 := format.colorkey; - Pitch2 := Pitch; - Addr2 := cardinal( Pixels ); - inc( Addr2, Pitch2 * UInt32( Src_Rect2.y ) ); - end; - Mod1 := Pitch1 - ( ScanWidth * BPP ); - Mod2 := Pitch2 - ( ScanWidth * BPP ); - inc( Addr1, BPP * Scan1Start ); - inc( Addr2, BPP * Scan2Start ); - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - inc( Addr2, Pitch2 * UInt32( Top1 - Top2 ) ); - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) and ( PByte( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - inc( Addr2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) and ( PWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - inc( Addr2, 2 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - Color2 := PLongWord( Addr2 )^ and $00FFFFFF; - if ( Color1 <> TransparentColor1 ) and ( Color2 <> TransparentColor2 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - inc( Addr2, 3 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) and ( PLongWord( Addr2 )^ <> - TransparentColor2 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - inc( Addr2, 4 ); - end; - inc( Addr1, Mod1 ); - inc( Addr2, Mod2 ); - end; - end; -end; - -function SDL_GetPixel( SrcSurface : PSDL_Surface; x : cardinal; y : cardinal ) : Uint32; -var - bpp : UInt32; - p : PInteger; -begin - bpp := SrcSurface.format.BytesPerPixel; - // Here p is the address to the pixel we want to retrieve - p := Pointer( Uint32( SrcSurface.pixels ) + UInt32( y ) * SrcSurface.pitch + UInt32( x ) * - bpp ); - case bpp of - 1 : result := PUint8( p )^; - 2 : result := PUint16( p )^; - 3 : - if ( SDL_BYTEORDER = SDL_BIG_ENDIAN ) then - result := PUInt8Array( p )[ 0 ] shl 16 or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] - else - result := PUInt8Array( p )[ 0 ] or PUInt8Array( p )[ 1 ] shl 8 or - PUInt8Array( p )[ 2 ] shl 16; - 4 : result := PUint32( p )^; - else - result := 0; // shouldn't happen, but avoids warnings - end; -end; - -procedure SDL_PutPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - Addr, Pitch, BPP : cardinal; -begin - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - BPP := SrcSurface.format.BytesPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - mov ecx, Color - cmp BPP, 1 - jne @Not1BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov [eax], cl - jmp @Quit - @Not1BPP: - cmp BPP, 2 - jne @Not2BPP - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov [eax], cx - jmp @Quit - @Not2BPP: - cmp BPP, 3 - jne @Not3BPP - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov edx, [eax] - and edx, $ff000000 - or edx, ecx - mov [eax], edx - jmp @Quit - @Not3BPP: - mul BPP // EAX := x * BPP - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * BPP - mov [eax], ecx - @Quit: - end; -end; - -procedure SDL_AddPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - SrcColor, FinalColor : cardinal; - Addr, Pitch, Bits : cardinal; -begin - if Color = 0 then - exit; - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - Bits := SrcSurface.format.BitsPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - cmp Bits, 8 - jne @Not8bit - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov cl, [eax] - movzx ecx, cl - mov SrcColor, ecx - mov edx, Color - and ecx, 3 - and edx, 3 - add ecx, edx - cmp ecx, 3 - jbe @Skip1_8bit - mov ecx, 3 - @Skip1_8bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $1c - and edx, $1c - add ecx, edx - cmp ecx, $1c - jbe @Skip2_8bit - mov ecx, $1c - @Skip2_8bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $e0 - and edx, $e0 - add ecx, edx - cmp ecx, $e0 - jbe @Skip3_8bit - mov ecx, $e0 - @Skip3_8bit: - or ecx, FinalColor - mov [eax], cl - jmp @Quit - @Not8bit: - cmp Bits, 15 - jne @Not15bit - shl eax, 1 - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - and ecx, $00007fff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - add ecx, edx - cmp ecx, $1f - jbe @Skip1_15bit - mov ecx, $1f - @Skip1_15bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $03e0 - and edx, $03e0 - add ecx, edx - cmp ecx, $03e0 - jbe @Skip2_15bit - mov ecx, $03e0 - @Skip2_15bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $7c00 - and edx, $7c00 - add ecx, edx - cmp ecx, $7c00 - jbe @Skip3_15bit - mov ecx, $7c00 - @Skip3_15bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not15Bit: - cmp Bits, 16 - jne @Not16bit - shl eax, 1 - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - and ecx, $0000ffff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - add ecx, edx - cmp ecx, $1f - jbe @Skip1_16bit - mov ecx, $1f - @Skip1_16bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $07e0 - and edx, $07e0 - add ecx, edx - cmp ecx, $07e0 - jbe @Skip2_16bit - mov ecx, $07e0 - @Skip2_16bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $f800 - and edx, $f800 - add ecx, edx - cmp ecx, $f800 - jbe @Skip3_16bit - mov ecx, $f800 - @Skip3_16bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not16Bit: - cmp Bits, 24 - jne @Not24bit - mov ecx, 0 - add ecx, eax - shl ecx, 1 - add ecx, eax - mov eax, ecx - jmp @32bit - @Not24bit: - shl eax, 2 - @32bit: - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x * 2 - mov ecx, [eax] - mov FinalColor, ecx - and FinalColor, $ff000000 - and ecx, $00ffffff - mov SrcColor, ecx - mov edx, Color - and ecx, $000000ff - and edx, $000000ff - add ecx, edx - cmp ecx, $000000ff - jbe @Skip1_32bit - mov ecx, $000000ff - @Skip1_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $0000ff00 - and edx, $0000ff00 - add ecx, edx - cmp ecx, $0000ff00 - jbe @Skip2_32bit - mov ecx, $0000ff00 - @Skip2_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $00ff0000 - and edx, $00ff0000 - add ecx, edx - cmp ecx, $00ff0000 - jbe @Skip3_32bit - mov ecx, $00ff0000 - @Skip3_32bit: - or ecx, FinalColor - mov [eax], ecx - @Quit: - end; -end; - -procedure SDL_SubPixel( SrcSurface : PSDL_Surface; x : integer; y : integer; Color : - cardinal ); -var - SrcColor, FinalColor : cardinal; - Addr, Pitch, Bits : cardinal; -begin - if Color = 0 then - exit; - Addr := cardinal( SrcSurface.Pixels ); - Pitch := SrcSurface.Pitch; - Bits := SrcSurface.format.BitsPerPixel; - asm - mov eax, y - mul Pitch // EAX := y * Pitch - add Addr, eax // Addr:= Addr + (y * Pitch) - mov eax, x - cmp Bits, 8 - jne @Not8bit - add eax, Addr // Now: EAX:= Addr + (y * Pitch) + x - mov cl, [eax] - movzx ecx, cl - mov SrcColor, ecx - mov edx, Color - and ecx, 3 - and edx, 3 - sub ecx, edx - jns @Skip1_8bit - mov ecx, 0 - @Skip1_8bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $1c - and edx, $1c - sub ecx, edx - jns @Skip2_8bit - mov ecx, 0 - @Skip2_8bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $e0 - and edx, $e0 - sub ecx, edx - jns @Skip3_8bit - mov ecx, 0 - @Skip3_8bit: - or ecx, FinalColor - mov [eax], cl - jmp @Quit - @Not8bit: - cmp Bits, 15 - jne @Not15bit - shl eax, 1 - add eax, Addr - mov ecx, [eax] - and ecx, $00007fff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - sub ecx, edx - jns @Skip1_15bit - mov ecx, 0 - @Skip1_15bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $03e0 - and edx, $03e0 - sub ecx, edx - jns @Skip2_15bit - mov ecx, 0 - @Skip2_15bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $7c00 - and edx, $7c00 - sub ecx, edx - jns @Skip3_15bit - mov ecx, 0 - @Skip3_15bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not15Bit: - cmp Bits, 16 - jne @Not16bit - shl eax, 1 - add eax, Addr - mov ecx, [eax] - and ecx, $0000ffff - mov SrcColor, ecx - mov edx, Color - and ecx, $1f - and edx, $1f - sub ecx, edx - jns @Skip1_16bit - mov ecx, 0 - @Skip1_16bit: - mov FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $07e0 - and edx, $07e0 - sub ecx, edx - jns @Skip2_16bit - mov ecx, 0 - @Skip2_16bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $f800 - and edx, $f800 - sub ecx, edx - jns @Skip3_16bit - mov ecx, 0 - @Skip3_16bit: - or ecx, FinalColor - mov [eax], cx - jmp @Quit - @Not16Bit: - cmp Bits, 24 - jne @Not24bit - mov ecx, 0 - add ecx, eax - shl ecx, 1 - add ecx, eax - mov eax, ecx - jmp @32bit - @Not24bit: - shl eax, 2 - @32bit: - add eax, Addr - mov ecx, [eax] - mov FinalColor, ecx - and FinalColor, $ff000000 - and ecx, $00ffffff - mov SrcColor, ecx - mov edx, Color - and ecx, $000000ff - and edx, $000000ff - sub ecx, edx - jns @Skip1_32bit - mov ecx, 0 - @Skip1_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $0000ff00 - and edx, $0000ff00 - sub ecx, edx - jns @Skip2_32bit - mov ecx, 0 - @Skip2_32bit: - or FinalColor, ecx - mov ecx, SrcColor - mov edx, Color - and ecx, $00ff0000 - and edx, $00ff0000 - sub ecx, edx - jns @Skip3_32bit - mov ecx, 0 - @Skip3_32bit: - or ecx, FinalColor - mov [eax], ecx - @Quit: - end; -end; - -// Draw a line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_PutPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// Draw a dashed line between x1,y1 and x2,y2 to the given surface -// NOTE: The surface must be locked before calling this! -procedure SDL_DrawLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ; DashLength, DashSpace : byte ); overload; -var - dx, dy, sdx, sdy, x, y, px, py, counter : integer; drawdash : boolean; -begin - counter := 0; - drawdash := true; //begin line drawing with dash - - //Avoid invalid user-passed dash parameters - if (DashLength < 1) - then DashLength := 1; - if (DashSpace < 1) - then DashSpace := 0; - - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc(counter); - if (counter > DashLength-1) and (DashSpace > 0) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc(counter); - if counter > DashSpace-1 then - begin - drawdash := true; - counter := 0; - end; - end; - - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - - //Alternate drawing dashes, or leaving spaces - if drawdash then - begin - SDL_PutPixel( DstSurface, px, py, Color ); - inc(counter); - if (counter > DashLength-1) and (DashSpace > 0) then - begin - drawdash := false; - counter := 0; - end; - end - else //space - begin - inc(counter); - if counter > DashSpace-1 then - begin - drawdash := true; - counter := 0; - end; - end; - - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_AddLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_AddPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -procedure SDL_SubLine( DstSurface : PSDL_Surface; x1, y1, x2, y2 : integer; Color : - cardinal ); -var - dx, dy, sdx, sdy, x, y, px, py : integer; -begin - dx := x2 - x1; - dy := y2 - y1; - if dx < 0 then - sdx := -1 - else - sdx := 1; - if dy < 0 then - sdy := -1 - else - sdy := 1; - dx := sdx * dx + 1; - dy := sdy * dy + 1; - x := 0; - y := 0; - px := x1; - py := y1; - if dx >= dy then - begin - for x := 0 to dx - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - y := y + dy; - if y >= dx then - begin - y := y - dx; - py := py + sdy; - end; - px := px + sdx; - end; - end - else - begin - for y := 0 to dy - 1 do - begin - SDL_SubPixel( DstSurface, px, py, Color ); - x := x + dx; - if x >= dy then - begin - x := x - dy; - px := px + sdx; - end; - py := py + sdy; - end; - end; -end; - -// This procedure works on 8, 15, 16, 24 and 32 bits color depth surfaces. -// In 8 bit color depth mode the procedure works with the default packed -// palette (RRRGGGBB). It handles all clipping. -procedure SDL_AddSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - // TransparentColor := format.ColorKey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - mov esp, eax // ESP - source color - mov bl, [edi] // BL := destination color - mov dl, bl // DL := destination color - and ax, $03 // Adding BLUE - and bl, $03 - add al, bl - cmp al, $03 - jbe @Skip1 - mov al, $03 - @Skip1: - mov cl, al - mov eax, esp // Adding GREEN - mov bl, dl - and al, $1c - and bl, $1c - add al, bl - cmp al, $1c - jbe @Skip2 - mov al, $1c - @Skip2: - or cl, al - mov eax, esp // Adding RED - mov bl, dl - and ax, $e0 - and bx, $e0 - add ax, bx - cmp ax, $e0 - jbe @Skip3 - mov al, $e0 - @Skip3: - or cl, al - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $001F // Adding BLUE - and bx, $001F - add ax, bx - cmp ax, $001F - jbe @Skip1 - mov ax, $001F - @Skip1: - mov cx, ax - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $3E0 - and bx, $3E0 - add ax, bx - cmp ax, $3E0 - jbe @Skip2 - mov ax, $3E0 - @Skip2: - or cx, ax - mov eax, esp // Adding RED - mov bx, dx - and ax, $7C00 - and bx, $7C00 - add ax, bx - cmp ax, $7C00 - jbe @Skip3 - mov ax, $7C00 - @Skip3: - or cx, ax - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $1F // Adding BLUE - and bx, $1F - add ax, bx - cmp ax, $1F - jbe @Skip1 - mov ax, $1F - @Skip1: - mov cx, ax - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $7E0 - and bx, $7E0 - add ax, bx - cmp ax, $7E0 - jbe @Skip2 - mov ax, $7E0 - @Skip2: - or cx, ax - mov eax, esp // Adding RED - mov bx, dx - and eax, $F800 - and ebx, $F800 - add eax, ebx - cmp eax, $F800 - jbe @Skip3 - mov ax, $F800 - @Skip3: - or cx, ax - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - add bx, ax - cmp bx, $00ff - jb @Skip - mov bl, $ff - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - add bx, ax - cmp bx, $00ff - jb @Skip - mov bl, $ff - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; - -procedure SDL_SubSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 then skip everything - mov esp, eax // ESP - source color - mov bl, [edi] // BL := destination color - mov dl, bl // DL := destination color - and al, $03 // Subtract BLUE - and bl, $03 - sub bl, al - jns @Skip1 - mov bl, 0 - @Skip1: - mov cl, bl - mov eax, esp // Subtract GREEN - mov bl, dl - and al, $1c - and bl, $1c - sub bl, al - jns @Skip2 - mov bl, 0 - @Skip2: - or cl, bl - mov eax, esp // Subtract RED - mov bl, dl - and ax, $e0 - and bx, $e0 - sub bx, ax - jns @Skip3 - mov bl, 0 - @Skip3: - or cl, bl - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $001F // Subtract BLUE - and bx, $001F - sub bx, ax - jns @Skip1 - mov bx, 0 - @Skip1: - mov cx, bx - mov eax, esp // Subtract GREEN - mov bx, dx - and ax, $3E0 - and bx, $3E0 - sub bx, ax - jns @Skip2 - mov bx, 0 - @Skip2: - or cx, bx - mov eax, esp // Subtract RED - mov bx, dx - and ax, $7C00 - and bx, $7C00 - sub bx, ax - jns @Skip3 - mov bx, 0 - @Skip3: - or cx, bx - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - mov esp, eax // ESP - source color - mov bx, [edi] // BX := destination color - mov dx, bx // DX := destination color - and ax, $1F // Subtracting BLUE - and bx, $1F - sub bx, ax - jns @Skip1 - mov bx, 0 - @Skip1: - mov cx, bx - mov eax, esp // Adding GREEN - mov bx, dx - and ax, $7E0 - and bx, $7E0 - sub bx, ax - jns @Skip2 - mov bx, 0 - @Skip2: - or cx, bx - mov eax, esp // Adding RED - mov bx, dx - and eax, $F800 - and ebx, $F800 - sub ebx, eax - jns @Skip3 - mov bx, 0 - @Skip3: - or cx, bx - mov [edi], cx - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - sub bx, ax - jns @Skip - mov bl, 0 - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov bl, [edi] // BX := destination color - mov al, [esi] // AX := source color - cmp al, 0 - je @Skip // if AL=0 then skip COMPONENT - mov ah, 0 // AX := COLOR COMPONENT - mov bh, 0 - sub bx, ax - jns @Skip - mov bl, 0 - @Skip: - mov [edi], bl - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; - -procedure SDL_MonoSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Color : cardinal ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - SrcTransparentColor : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - SrcTransparentColor := format.colorkey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - case bits of - 8 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - movzx eax, al - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov [edi], cl - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 15, 16 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - movzx eax, ax - cmp eax, SrcTransparentColor - je @SkipColor // if AX=Transparent color then skip everything - mov [edi], cx - @SkipColor: - inc esi - inc esi - inc edi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 24 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - and ecx, $00ffffff - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // EAX := source color - and eax, $00ffffff - cmp eax, SrcTransparentColor - je @SkipColor // if EAX=Transparent color then skip everything - mov ebx, [edi] - and ebx, $ff000000 - or ebx, ecx - mov [edi], ecx - @SkipColor: - add esi, 3 - add edi, 3 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp, _esp - mov edi, _edi - mov esi, _esi - mov ebx, _ebx - end; - 32 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - mov ecx, Color - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // EAX := source color - cmp eax, SrcTransparentColor - je @SkipColor // if EAX=Transparent color then skip everything - mov [edi], ecx - @SkipColor: - add esi, 4 - add edi, 4 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp, _esp - mov edi, _edi - mov esi, _esi - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); -end; -// TextureRect.w and TextureRect.h are not used. -// The TextureSurface's size MUST larger than the drawing rectangle!!! - -procedure SDL_TexturedSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DstSurface : PSDL_Surface; DestRect : PSDL_Rect; Texture : PSDL_Surface; - TextureRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TextAddr : cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod, TextMod : cardinal; - SrcTransparentColor : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DstSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DstSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DstSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - SrcTransparentColor := format.colorkey; - end; - with DstSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := DstSurface.Format.BitsPerPixel; - end; - with Texture^ do - begin - TextAddr := cardinal( Pixels ) + UInt32( TextureRect.y ) * Pitch + - UInt32( TextureRect.x ) * Format.BytesPerPixel; - TextMod := Pitch - Src.w * Format.BytesPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DstSurface ); - SDL_LockSurface( Texture ); - case bits of - 8 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ebx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - movzx eax, al - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov al, [ebx] - mov [edi], al - @SkipColor: - inc esi - inc edi - inc ebx - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ebx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx, _ebx - end; - 15, 16 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ecx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AL := source color - movzx eax, ax - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov ax, [ecx] - mov [edi], ax - @SkipColor: - inc esi - inc esi - inc edi - inc edi - inc ecx - inc ecx - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ecx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - 24 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov _ebx, ebx - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ebx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // AL := source color - and eax, $00ffffff - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov eax, [ebx] - and eax, $00ffffff - mov ecx, [edi] - and ecx, $ff000000 - or ecx, eax - mov [edi], eax - @SkipColor: - add esi, 3 - add edi, 3 - add ebx, 3 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ebx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx, _ebx - end; - 32 : - asm - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ecx, TextAddr - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov eax, [esi] // AL := source color - cmp eax, SrcTransparentColor - je @SkipColor // if AL=Transparent color then skip everything - mov eax, [ecx] - mov [edi], eax - @SkipColor: - add esi, 4 - add edi, 4 - add ecx, 4 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - add ecx, TextMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DstSurface ); - SDL_UnlockSurface( Texture ); -end; - -procedure SDL_ZoomSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; DstRect : PSDL_Rect ); -var - xc, yc : cardinal; - rx, wx, ry, wy, ry16 : cardinal; - color : cardinal; - modx, mody : cardinal; -begin - // Warning! No checks for surface pointers!!! - if srcrect = nil then - srcrect := @SrcSurface.clip_rect; - if dstrect = nil then - dstrect := @DstSurface.clip_rect; - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - modx := trunc( ( srcrect.w / dstrect.w ) * 65536 ); - mody := trunc( ( srcrect.h / dstrect.h ) * 65536 ); - //rx := srcrect.x * 65536; - ry := srcrect.y * 65536; - wy := dstrect.y; - for yc := 0 to dstrect.h - 1 do - begin - rx := srcrect.x * 65536; - wx := dstrect.x; - ry16 := ry shr 16; - for xc := 0 to dstrect.w - 1 do - begin - color := SDL_GetPixel( SrcSurface, rx shr 16, ry16 ); - SDL_PutPixel( DstSurface, wx, wy, color ); - rx := rx + modx; - inc( wx ); - end; - ry := ry + mody; - inc( wy ); - end; - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; -// Re-map a rectangular area into an area defined by four vertices -// Converted from C to Pascal by KiCHY - -procedure SDL_WarpSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; DstSurface : PSDL_Surface; UL, UR, LR, LL : PPoint ); -const - SHIFTS = 15; // Extend ints to limit round-off error (try 2 - 20) - THRESH = 1 shl SHIFTS; // Threshold for pixel size value - procedure CopySourceToDest( UL, UR, LR, LL : TPoint; x1, y1, x2, y2 : cardinal ); - var - tm, lm, rm, bm, m : TPoint; - mx, my : cardinal; - cr : cardinal; - begin - // Does the destination area specify a single pixel? - if ( ( abs( ul.x - ur.x ) < THRESH ) and - ( abs( ul.x - lr.x ) < THRESH ) and - ( abs( ul.x - ll.x ) < THRESH ) and - ( abs( ul.y - ur.y ) < THRESH ) and - ( abs( ul.y - lr.y ) < THRESH ) and - ( abs( ul.y - ll.y ) < THRESH ) ) then - begin // Yes - cr := SDL_GetPixel( SrcSurface, ( x1 shr SHIFTS ), ( y1 shr SHIFTS ) ); - SDL_PutPixel( DstSurface, ( ul.x shr SHIFTS ), ( ul.y shr SHIFTS ), cr ); - end - else - begin // No - // Quarter the source and the destination, and then recurse - tm.x := ( ul.x + ur.x ) shr 1; - tm.y := ( ul.y + ur.y ) shr 1; - bm.x := ( ll.x + lr.x ) shr 1; - bm.y := ( ll.y + lr.y ) shr 1; - lm.x := ( ul.x + ll.x ) shr 1; - lm.y := ( ul.y + ll.y ) shr 1; - rm.x := ( ur.x + lr.x ) shr 1; - rm.y := ( ur.y + lr.y ) shr 1; - m.x := ( tm.x + bm.x ) shr 1; - m.y := ( tm.y + bm.y ) shr 1; - mx := ( x1 + x2 ) shr 1; - my := ( y1 + y2 ) shr 1; - CopySourceToDest( ul, tm, m, lm, x1, y1, mx, my ); - CopySourceToDest( tm, ur, rm, m, mx, y1, x2, my ); - CopySourceToDest( m, rm, lr, bm, mx, my, x2, y2 ); - CopySourceToDest( lm, m, bm, ll, x1, my, mx, y2 ); - end; - end; -var - _UL, _UR, _LR, _LL : TPoint; - Rect_x, Rect_y, Rect_w, Rect_h : integer; -begin - if SDL_MustLock( SrcSurface ) then - SDL_LockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_LockSurface( DstSurface ); - if SrcRect = nil then - begin - Rect_x := 0; - Rect_y := 0; - Rect_w := ( SrcSurface.w - 1 ) shl SHIFTS; - Rect_h := ( SrcSurface.h - 1 ) shl SHIFTS; - end - else - begin - Rect_x := SrcRect.x; - Rect_y := SrcRect.y; - Rect_w := ( SrcRect.w - 1 ) shl SHIFTS; - Rect_h := ( SrcRect.h - 1 ) shl SHIFTS; - end; - // Shift all values to help reduce round-off error. - _ul.x := ul.x shl SHIFTS; - _ul.y := ul.y shl SHIFTS; - _ur.x := ur.x shl SHIFTS; - _ur.y := ur.y shl SHIFTS; - _lr.x := lr.x shl SHIFTS; - _lr.y := lr.y shl SHIFTS; - _ll.x := ll.x shl SHIFTS; - _ll.y := ll.y shl SHIFTS; - CopySourceToDest( _ul, _ur, _lr, _ll, Rect_x, Rect_y, Rect_w, Rect_h ); - if SDL_MustLock( SrcSurface ) then - SDL_UnlockSurface( SrcSurface ); - if SDL_MustLock( DstSurface ) then - SDL_UnlockSurface( DstSurface ); -end; - -// flips a rectangle vertically on given surface -procedure SDL_FlipRectV( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -var - TmpRect : TSDL_Rect; - Locked : boolean; - y, FlipLength, RowLength : integer; - Row1, Row2 : Pointer; - OneRow : TByteArray; // Optimize it if you wish -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin // if Rect=nil then we flip the whole surface - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.h shr 1 - 1; - RowLength := Rect^.w * DstSurface^.format.BytesPerPixel; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - Row1 := pointer( cardinal( DstSurface^.Pixels ) + UInt32( Rect^.y ) * - DstSurface^.Pitch ); - Row2 := pointer( cardinal( DstSurface^.Pixels ) + ( UInt32( Rect^.y ) + Rect^.h - 1 ) - * DstSurface^.Pitch ); - for y := 0 to FlipLength do - begin - Move( Row1^, OneRow, RowLength ); - Move( Row2^, Row1^, RowLength ); - Move( OneRow, Row2^, RowLength ); - inc( cardinal( Row1 ), DstSurface^.Pitch ); - dec( cardinal( Row2 ), DstSurface^.Pitch ); - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// flips a rectangle horizontally on given surface -procedure SDL_FlipRectH( DstSurface : PSDL_Surface; Rect : PSDL_Rect ); -type - T24bit = packed array[ 0..2 ] of byte; - T24bitArray = packed array[ 0..8191 ] of T24bit; - P24bitArray = ^T24bitArray; - TLongWordArray = array[ 0..8191 ] of LongWord; - PLongWordArray = ^TLongWordArray; -var - TmpRect : TSDL_Rect; - Row8bit : PByteArray; - Row16bit : PWordArray; - Row24bit : P24bitArray; - Row32bit : PLongWordArray; - y, x, RightSide, FlipLength : integer; - Pixel : cardinal; - Pixel24 : T24bit; - Locked : boolean; -begin - if DstSurface <> nil then - begin - if Rect = nil then - begin - TmpRect := SDLRect( 0, 0, DstSurface.w, DstSurface.h ); - Rect := @TmpRect; - end; - FlipLength := Rect^.w shr 1 - 1; - if SDL_MustLock( DstSurface ) then - begin - Locked := true; - SDL_LockSurface( DstSurface ); - end - else - Locked := false; - case DstSurface^.format.BytesPerPixel of - 1 : - begin - Row8Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row8Bit^[ x ]; - Row8Bit^[ x ] := Row8Bit^[ RightSide ]; - Row8Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row8Bit ), DstSurface^.pitch ); - end; - end; - 2 : - begin - Row16Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row16Bit^[ x ]; - Row16Bit^[ x ] := Row16Bit^[ RightSide ]; - Row16Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row16Bit ), DstSurface^.pitch ); - end; - end; - 3 : - begin - Row24Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel24 := Row24Bit^[ x ]; - Row24Bit^[ x ] := Row24Bit^[ RightSide ]; - Row24Bit^[ RightSide ] := Pixel24; - dec( RightSide ); - end; - inc( cardinal( Row24Bit ), DstSurface^.pitch ); - end; - end; - 4 : - begin - Row32Bit := pointer( cardinal( DstSurface^.pixels ) + UInt32( Rect^.y ) * - DstSurface^.pitch ); - for y := 1 to Rect^.h do - begin - RightSide := Rect^.w - 1; - for x := 0 to FlipLength do - begin - Pixel := Row32Bit^[ x ]; - Row32Bit^[ x ] := Row32Bit^[ RightSide ]; - Row32Bit^[ RightSide ] := Pixel; - dec( RightSide ); - end; - inc( cardinal( Row32Bit ), DstSurface^.pitch ); - end; - end; - end; - if Locked then - SDL_UnlockSurface( DstSurface ); - end; -end; - -// Use with caution! The procedure allocates memory for TSDL_Rect and return with its pointer. -// But you MUST free it after you don't need it anymore!!! -function PSDLRect( aLeft, aTop, aWidth, aHeight : integer ) : PSDL_Rect; -var - Rect : PSDL_Rect; -begin - New( Rect ); - with Rect^ do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; - Result := Rect; -end; - -function SDLRect( aLeft, aTop, aWidth, aHeight : integer ) : TSDL_Rect; -begin - with result do - begin - x := aLeft; - y := aTop; - w := aWidth; - h := aHeight; - end; -end; - -function SDLRect( aRect : TRect ) : TSDL_Rect; -begin - with aRect do - result := SDLRect( Left, Top, Right - Left, Bottom - Top ); -end; - -procedure SDL_Stretch8( Surface, Dst_Surface : PSDL_Surface; x1, x2, y1, y2, yr, yw, - depth : integer ); -var - dx, dy, e, d, dx2 : integer; - src_pitch, dst_pitch : uint16; - src_pixels, dst_pixels : PUint8; -begin - if ( yw >= dst_surface^.h ) then - exit; - dx := ( x2 - x1 ); - dy := ( y2 - y1 ); - dy := dy shl 1; - e := dy - dx; - dx2 := dx shl 1; - src_pitch := Surface^.pitch; - dst_pitch := dst_surface^.pitch; - src_pixels := PUint8( integer( Surface^.pixels ) + yr * src_pitch + y1 * depth ); - dst_pixels := PUint8( integer( dst_surface^.pixels ) + yw * dst_pitch + x1 * - depth ); - for d := 0 to dx - 1 do - begin - move( src_pixels^, dst_pixels^, depth ); - while ( e >= 0 ) do - begin - inc( src_pixels, depth ); - e := e - dx2; - end; - inc( dst_pixels, depth ); - e := e + dy; - end; -end; - -function sign( x : integer ) : integer; -begin - if x > 0 then - result := 1 - else - result := -1; -end; - -// Stretches a part of a surface -function SDL_ScaleSurfaceRect( SrcSurface : PSDL_Surface; SrcX1, SrcY1, SrcW, SrcH, - Width, Height : integer ) : PSDL_Surface; -var - dst_surface : PSDL_Surface; - dx, dy, e, d, dx2, srcx2, srcy2 : integer; - destx1, desty1 : integer; -begin - srcx2 := srcx1 + SrcW; - srcy2 := srcy1 + SrcH; - result := nil; - destx1 := 0; - desty1 := 0; - dx := abs( integer( Height - desty1 ) ); - dy := abs( integer( SrcY2 - SrcY1 ) ); - e := ( dy shl 1 ) - dx; - dx2 := dx shl 1; - dy := dy shl 1; - dst_surface := SDL_CreateRGBSurface( SDL_HWPALETTE, width - destx1, Height - - desty1, - SrcSurface^.Format^.BitsPerPixel, - SrcSurface^.Format^.RMask, - SrcSurface^.Format^.GMask, - SrcSurface^.Format^.BMask, - SrcSurface^.Format^.AMask ); - if ( dst_surface^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( dst_surface, @SrcSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - SDL_SetColorKey( dst_surface, sdl_srccolorkey, SrcSurface^.format^.colorkey ); - if ( SDL_MustLock( dst_surface ) ) then - if ( SDL_LockSurface( dst_surface ) < 0 ) then - exit; - for d := 0 to dx - 1 do - begin - SDL_Stretch8( SrcSurface, dst_surface, destx1, Width, SrcX1, SrcX2, SrcY1, desty1, - SrcSurface^.format^.BytesPerPixel ); - while e >= 0 do - begin - inc( SrcY1 ); - e := e - dx2; - end; - inc( desty1 ); - e := e + dy; - end; - if SDL_MUSTLOCK( dst_surface ) then - SDL_UnlockSurface( dst_surface ); - result := dst_surface; -end; - -procedure SDL_ScrollY( DstSurface : PSDL_Surface; DifY : integer ); -var - r1, r2 : TSDL_Rect; - //buffer: PSDL_Surface; - YPos : Integer; -begin - if ( DstSurface <> nil ) and ( DifY <> 0 ) then - begin - //if DifY > 0 then // going up - //begin - ypos := 0; - r1.x := 0; - r2.x := 0; - r1.w := DstSurface.w; - r2.w := DstSurface.w; - r1.h := DifY; - r2.h := DifY; - while ypos < DstSurface.h do - begin - r1.y := ypos; - r2.y := ypos + DifY; - SDL_BlitSurface( DstSurface, @r2, DstSurface, @r1 ); - ypos := ypos + DifY; - end; - //end - //else - //begin // Going Down - //end; - end; -end; - -procedure SDL_ScrollX( DstSurface : PSDL_Surface; DifX : integer ); -var - r1, r2 : TSDL_Rect; - buffer : PSDL_Surface; -begin - if ( DstSurface <> nil ) and ( DifX <> 0 ) then - begin - buffer := SDL_CreateRGBSurface( SDL_HWSURFACE, ( DstSurface^.w - DifX ) * 2, - DstSurface^.h * 2, - DstSurface^.Format^.BitsPerPixel, - DstSurface^.Format^.RMask, - DstSurface^.Format^.GMask, - DstSurface^.Format^.BMask, - DstSurface^.Format^.AMask ); - if buffer <> nil then - begin - if ( buffer^.format^.BytesPerPixel = 1 ) then - SDL_SetColors( buffer, @DstSurface^.format^.palette^.colors^[ 0 ], 0, 256 ); - r1 := SDLRect( DifX, 0, buffer^.w, buffer^.h ); - r2 := SDLRect( 0, 0, buffer^.w, buffer^.h ); - SDL_BlitSurface( DstSurface, @r1, buffer, @r2 ); - SDL_BlitSurface( buffer, @r2, DstSurface, @r2 ); - SDL_FreeSurface( buffer ); - end; - end; -end; - -procedure SDL_RotateRad( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Single ); -var - aSin, aCos : Single; - MX, MY, DX, DY, NX, NY, SX, SY, OX, OY, Width, Height, TX, TY, RX, RY, ROX, ROY : Integer; - Colour, TempTransparentColour : UInt32; - MAXX, MAXY : Integer; -begin - // Rotate the surface to the target surface. - TempTransparentColour := SrcSurface.format.colorkey; - if srcRect.w > srcRect.h then - begin - Width := srcRect.w; - Height := srcRect.w; - end - else - begin - Width := srcRect.h; - Height := srcRect.h; - end; - - maxx := DstSurface.w; - maxy := DstSurface.h; - aCos := cos( Angle ); - aSin := sin( Angle ); - - Width := round( abs( srcrect.h * acos ) + abs( srcrect.w * asin ) ); - Height := round( abs( srcrect.h * asin ) + abs( srcrect.w * acos ) ); - - OX := Width div 2; - OY := Height div 2; ; - MX := ( srcRect.x + ( srcRect.x + srcRect.w ) ) div 2; - MY := ( srcRect.y + ( srcRect.y + srcRect.h ) ) div 2; - ROX := ( -( srcRect.w div 2 ) ) + Offsetx; - ROY := ( -( srcRect.h div 2 ) ) + OffsetY; - Tx := ox + round( ROX * aSin - ROY * aCos ); - Ty := oy + round( ROY * aSin + ROX * aCos ); - SX := 0; - for DX := DestX - TX to DestX - TX + ( width ) do - begin - Inc( SX ); - SY := 0; - for DY := DestY - TY to DestY - TY + ( Height ) do - begin - RX := SX - OX; - RY := SY - OY; - NX := round( mx + RX * aSin + RY * aCos ); // - NY := round( my + RY * aSin - RX * aCos ); // - // Used for testing only - //SDL_PutPixel(DstSurface.SDLSurfacePointer,DX,DY,0); - if ( ( DX > 0 ) and ( DX < MAXX ) ) and ( ( DY > 0 ) and ( DY < MAXY ) ) then - begin - if ( NX >= srcRect.x ) and ( NX <= srcRect.x + srcRect.w ) then - begin - if ( NY >= srcRect.y ) and ( NY <= srcRect.y + srcRect.h ) then - begin - Colour := SDL_GetPixel( SrcSurface, NX, NY ); - if Colour <> TempTransparentColour then - begin - SDL_PutPixel( DstSurface, DX, DY, Colour ); - end; - end; - end; - end; - inc( SY ); - end; - end; -end; - -procedure SDL_RotateDeg( DstSurface, SrcSurface : PSDL_Surface; SrcRect : - PSDL_Rect; DestX, DestY, OffsetX, OffsetY : Integer; Angle : Integer ); -begin - SDL_RotateRad( DstSurface, SrcSurface, SrcRect, DestX, DestY, OffsetX, OffsetY, DegToRad( Angle ) ); -end; - -function ValidateSurfaceRect( DstSurface : PSDL_Surface; dstrect : PSDL_Rect ) : TSDL_Rect; -var - RealRect : TSDL_Rect; - OutOfRange : Boolean; -begin - OutOfRange := false; - if dstrect = nil then - begin - RealRect.x := 0; - RealRect.y := 0; - RealRect.w := DstSurface.w; - RealRect.h := DstSurface.h; - end - else - begin - if dstrect.x < DstSurface.w then - begin - RealRect.x := dstrect.x; - end - else if dstrect.x < 0 then - begin - realrect.x := 0; - end - else - begin - OutOfRange := True; - end; - if dstrect.y < DstSurface.h then - begin - RealRect.y := dstrect.y; - end - else if dstrect.y < 0 then - begin - realrect.y := 0; - end - else - begin - OutOfRange := True; - end; - if OutOfRange = False then - begin - if realrect.x + dstrect.w <= DstSurface.w then - begin - RealRect.w := dstrect.w; - end - else - begin - RealRect.w := dstrect.w - realrect.x; - end; - if realrect.y + dstrect.h <= DstSurface.h then - begin - RealRect.h := dstrect.h; - end - else - begin - RealRect.h := dstrect.h - realrect.y; - end; - end; - end; - if OutOfRange = False then - begin - result := realrect; - end - else - begin - realrect.w := 0; - realrect.h := 0; - realrect.x := 0; - realrect.y := 0; - result := realrect; - end; -end; - -procedure SDL_FillRectAdd( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 + Color and $E0; - G := SrcColor and $1C + Color and $1C; - B := SrcColor and $03 + Color and $03; - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 + Color and $7C00; - G := SrcColor and $03E0 + Color and $03E0; - B := SrcColor and $001F + Color and $001F; - if R > $7C00 then - R := $7C00; - if G > $03E0 then - G := $03E0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 + Color and $F800; - G := SrcColor and $07C0 + Color and $07C0; - B := SrcColor and $001F + Color and $001F; - if R > $F800 then - R := $F800; - if G > $07C0 then - G := $07C0; - if B > $001F then - B := $001F; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 + Color and $00FF0000; - G := SrcColor and $0000FF00 + Color and $0000FF00; - B := SrcColor and $000000FF + Color and $000000FF; - if R > $FF0000 then - R := $FF0000; - if G > $00FF00 then - G := $00FF00; - if B > $0000FF then - B := $0000FF; - PUInt32( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_FillRectSub( DstSurface : PSDL_Surface; dstrect : PSDL_Rect; color : UInt32 ); -var - RealRect : TSDL_Rect; - Addr : pointer; - ModX, BPP : cardinal; - x, y, R, G, B, SrcColor : cardinal; -begin - RealRect := ValidateSurfaceRect( DstSurface, DstRect ); - if ( RealRect.w > 0 ) and ( RealRect.h > 0 ) then - begin - SDL_LockSurface( DstSurface ); - BPP := DstSurface.format.BytesPerPixel; - with DstSurface^ do - begin - Addr := pointer( UInt32( pixels ) + UInt32( RealRect.y ) * pitch + UInt32( RealRect.x ) * BPP ); - ModX := Pitch - UInt32( RealRect.w ) * BPP; - end; - case DstSurface.format.BitsPerPixel of - 8 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $E0 - Color and $E0; - G := SrcColor and $1C - Color and $1C; - B := SrcColor and $03 - Color and $03; - if R > $E0 then - R := 0; - if G > $1C then - G := 0; - if B > $03 then - B := 0; - PUInt8( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 15 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $7C00 - Color and $7C00; - G := SrcColor and $03E0 - Color and $03E0; - B := SrcColor and $001F - Color and $001F; - if R > $7C00 then - R := 0; - if G > $03E0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 16 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $F800 - Color and $F800; - G := SrcColor and $07C0 - Color and $07C0; - B := SrcColor and $001F - Color and $001F; - if R > $F800 then - R := 0; - if G > $07C0 then - G := 0; - if B > $001F then - B := 0; - PUInt16( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 24 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := SrcColor and $FF000000 or R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - 32 : - begin - for y := 0 to RealRect.h - 1 do - begin - for x := 0 to RealRect.w - 1 do - begin - SrcColor := PUInt32( Addr )^; - R := SrcColor and $00FF0000 - Color and $00FF0000; - G := SrcColor and $0000FF00 - Color and $0000FF00; - B := SrcColor and $000000FF - Color and $000000FF; - if R > $FF0000 then - R := 0; - if G > $00FF00 then - G := 0; - if B > $0000FF then - B := 0; - PUInt32( Addr )^ := R or G or B; - inc( UInt32( Addr ), BPP ); - end; - inc( UInt32( Addr ), ModX ); - end; - end; - end; - SDL_UnlockSurface( DstSurface ); - end; -end; - -procedure SDL_GradientFillRect( DstSurface : PSDL_Surface; const Rect : PSDL_Rect; const StartColor, EndColor : TSDL_Color; const Style : TGradientStyle ); -var - FBC : array[ 0..255 ] of Cardinal; - // temp vars - i, YR, YG, YB, SR, SG, SB, DR, DG, DB : Integer; - - TempStepV, TempStepH : Single; - TempLeft, TempTop, TempHeight, TempWidth : integer; - TempRect : TSDL_Rect; - -begin - // calc FBC - YR := StartColor.r; - YG := StartColor.g; - YB := StartColor.b; - SR := YR; - SG := YG; - SB := YB; - DR := EndColor.r - SR; - DG := EndColor.g - SG; - DB := EndColor.b - SB; - - for i := 0 to 255 do - begin - FBC[ i ] := SDL_MapRGB( DstSurface.format, YR, YG, YB ); - YR := SR + round( DR / 255 * i ); - YG := SG + round( DG / 255 * i ); - YB := SB + round( DB / 255 * i ); - end; - - // if aStyle = 1 then begin - TempStepH := Rect.w / 255; - TempStepV := Rect.h / 255; - TempHeight := Trunc( TempStepV + 1 ); - TempWidth := Trunc( TempStepH + 1 ); - TempTop := 0; - TempLeft := 0; - TempRect.x := Rect.x; - TempRect.y := Rect.y; - TempRect.h := Rect.h; - TempRect.w := Rect.w; - - case Style of - gsHorizontal : - begin - TempRect.h := TempHeight; - for i := 0 to 255 do - begin - TempRect.y := Rect.y + TempTop; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempTop := Trunc( TempStepV * i ); - end; - end; - gsVertical : - begin - TempRect.w := TempWidth; - for i := 0 to 255 do - begin - TempRect.x := Rect.x + TempLeft; - SDL_FillRect( DstSurface, @TempRect, FBC[ i ] ); - TempLeft := Trunc( TempStepH * i ); - end; - end; - end; -end; - -procedure SDL_2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BytesPerPixel of - 1 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; - mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 2 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 3 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx], eax - and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 4 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; - mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BytesPerPixel of - 1 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 2 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], eax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 3 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 4 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -procedure SDL_50Scanline2xBlit( Src, Dest : PSDL_Surface ); -var - ReadAddr, WriteAddr, ReadRow, WriteRow : UInt32; - SrcPitch, DestPitch, x, y, w, h : UInt32; -begin - if ( Src = nil ) or ( Dest = nil ) then - exit; - if ( Src.w shl 1 ) < Dest.w then - exit; - if ( Src.h shl 1 ) < Dest.h then - exit; - - if SDL_MustLock( Src ) then - SDL_LockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_LockSurface( Dest ); - - ReadRow := UInt32( Src.Pixels ); - WriteRow := UInt32( Dest.Pixels ); - - SrcPitch := Src.pitch; - DestPitch := Dest.pitch; - - w := Src.w; - h := Src.h; - - case Src.format.BitsPerPixel of - 8 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov al, [ecx] // PUInt8(WriteAddr)^ := PUInt8(ReadAddr)^; - mov [edx], al - mov [edx + 1], al // PUInt8(WriteAddr + 1)^ := PUInt8(ReadAddr)^; - shr al, 1 - and al, $6d - mov [edx + ebx], al // PUInt8(WriteAddr + DestPitch)^ := PUInt8(ReadAddr)^; - mov [edx + ebx + 1], al // PUInt8(WriteAddr + DestPitch + 1)^ := PUInt8(ReadAddr)^; - - inc ecx // inc(ReadAddr); - add edx, 2 // inc(WriteAddr, 2); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 15 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - shr ax, 1 - and ax, $3def - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 16 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov ax, [ecx] // PUInt16(WriteAddr)^ := PUInt16(ReadAddr)^; - mov [edx], ax - mov [edx + 2], ax // PUInt16(WriteAddr + 2)^ := PUInt16(ReadAddr)^; - shr ax, 1 - and ax, $7bef - mov [edx + ebx], ax // PUInt16(WriteAddr + DestPitch)^ := PUInt16(ReadAddr)^; - mov [edx + ebx + 2], ax // PUInt16(WriteAddr + DestPitch + 2)^ := PUInt16(ReadAddr)^; - - add ecx, 2 // inc(ReadAddr, 2); - add edx, 4 // inc(WriteAddr, 4); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 24 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // (PUInt32(WriteAddr)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - and eax, $00ffffff - and dword ptr [edx], $ff000000 - or [edx], eax - and dword ptr [edx + 3], $00ffffff // (PUInt32(WriteAddr + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + 3], eax - shr eax, 1 - and eax, $007f7f7f - and dword ptr [edx + ebx], $00ffffff // (PUInt32(WriteAddr + DestPitch)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx], eax - and dword ptr [edx + ebx + 3], $00ffffff // (PUInt32(WriteAddr + DestPitch + 3)^ and $ff000000) or (PUInt32(ReadAddr)^ and $00ffffff); - or [edx + ebx + 3], eax - - add ecx, 3 // inc(ReadAddr, 3); - add edx, 6 // inc(WriteAddr, 6); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - 32 : - asm - push ebx - mov eax, h // for y := 1 to Src.h do - mov y, eax - @LoopY: - mov eax, ReadRow // ReadAddr := ReadRow; - mov ReadAddr, eax - - mov eax, WriteRow // WriteAddr := WriteRow; - mov WriteAddr, eax - - mov eax, w // for x := 1 to Src.w do - mov x, eax - - mov ecx, ReadAddr - mov edx, WriteAddr - mov ebx, DestPitch - - @LoopX: - mov eax, [ecx] // PUInt32(WriteAddr)^ := PUInt32(ReadAddr)^; - mov [edx], eax - mov [edx + 4], eax // PUInt32(WriteAddr + 4)^ := PUInt32(ReadAddr)^; - shr eax, 1 - and eax, $7f7f7f7f - mov [edx + ebx], eax // PUInt32(WriteAddr + DestPitch)^ := PUInt32(ReadAddr)^; - mov [edx + ebx + 4], eax // PUInt32(WriteAddr + DestPitch + 4)^ := PUInt32(ReadAddr)^; - - add ecx, 4 // inc(ReadAddr, 4); - add edx, 8 // inc(WriteAddr, 8); - - dec x - jnz @LoopX - - mov eax, SrcPitch // inc(UInt32(ReadRow), SrcPitch); - add ReadRow, eax - - mov eax, DestPitch // inc(UInt32(WriteRow), DestPitch * 2); - add WriteRow, eax - add WriteRow, eax - - dec y - jnz @LoopY - pop ebx - end; - end; - - if SDL_MustLock( Src ) then - SDL_UnlockSurface( Src ); - if SDL_MustLock( Dest ) then - SDL_UnlockSurface( Dest ); -end; - -function SDL_PixelTestSurfaceVsRect( SrcSurface1 : PSDL_Surface; SrcRect1 : PSDL_Rect; SrcRect2 : PSDL_Rect; Left1, Top1, Left2, Top2 : integer ) : -boolean; -var - Src_Rect1, Src_Rect2 : TSDL_Rect; - right1, bottom1 : integer; - right2, bottom2 : integer; - Scan1Start, Scan2Start, ScanWidth, ScanHeight : cardinal; - Mod1: cardinal; - Addr1 : cardinal; - BPP : cardinal; - Pitch1 : cardinal; - TransparentColor1 : cardinal; - tx, ty : cardinal; - StartTick : cardinal; - Color1 : cardinal; -begin - Result := false; - if SrcRect1 = nil then - begin - with Src_Rect1 do - begin - x := 0; - y := 0; - w := SrcSurface1.w; - h := SrcSurface1.h; - end; - end - else - Src_Rect1 := SrcRect1^; - - Src_Rect2 := SrcRect2^; - with Src_Rect1 do - begin - Right1 := Left1 + w; - Bottom1 := Top1 + h; - end; - with Src_Rect2 do - begin - Right2 := Left2 + w; - Bottom2 := Top2 + h; - end; - if ( Left1 >= Right2 ) or ( Right1 <= Left2 ) or ( Top1 >= Bottom2 ) or ( -Bottom1 <= - Top2 ) then - exit; - if Left1 <= Left2 then - begin - // 1. left, 2. right - Scan1Start := Src_Rect1.x + Left2 - Left1; - Scan2Start := Src_Rect2.x; - ScanWidth := Right1 - Left2; - with Src_Rect2 do - if ScanWidth > w then - ScanWidth := w; - end - else - begin - // 1. right, 2. left - Scan1Start := Src_Rect1.x; - Scan2Start := Src_Rect2.x + Left1 - Left2; - ScanWidth := Right2 - Left1; - with Src_Rect1 do - if ScanWidth > w then - ScanWidth := w; - end; - with SrcSurface1^ do - begin - Pitch1 := Pitch; - Addr1 := cardinal( Pixels ); - inc( Addr1, Pitch1 * UInt32( Src_Rect1.y ) ); - with format^ do - begin - BPP := BytesPerPixel; - TransparentColor1 := colorkey; - end; - end; - - Mod1 := Pitch1 - ( ScanWidth * BPP ); - - inc( Addr1, BPP * Scan1Start ); - - if Top1 <= Top2 then - begin - // 1. up, 2. down - ScanHeight := Bottom1 - Top2; - if ScanHeight > Src_Rect2.h then - ScanHeight := Src_Rect2.h; - inc( Addr1, Pitch1 * UInt32( Top2 - Top1 ) ); - end - else - begin - // 1. down, 2. up - ScanHeight := Bottom2 - Top1; - if ScanHeight > Src_Rect1.h then - ScanHeight := Src_Rect1.h; - - end; - case BPP of - 1 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PByte( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1 ); - - end; - inc( Addr1, Mod1 ); - - end; - 2 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 2 ); - - end; - inc( Addr1, Mod1 ); - - end; - 3 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - Color1 := PLongWord( Addr1 )^ and $00FFFFFF; - - if ( Color1 <> TransparentColor1 ) - then - begin - Result := true; - exit; - end; - inc( Addr1, 3 ); - - end; - inc( Addr1, Mod1 ); - - end; - 4 : - for ty := 1 to ScanHeight do - begin - for tx := 1 to ScanWidth do - begin - if ( PLongWord( Addr1 )^ <> TransparentColor1 ) then - begin - Result := true; - exit; - end; - inc( Addr1, 4 ); - - end; - inc( Addr1, Mod1 ); - - end; - end; -end; - -procedure SDL_ORSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TransparentColor : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - cmp al, byte ptr TransparentColor - je @SkipColor - or al, [edi] - mov [edi], al - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - or ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - or ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov al, [esi] // AL := source color - or al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov al, [esi] // AL := source color - or al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -procedure SDL_ANDSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr, TransparentColor : cardinal; - // TransparentColor: cardinal; - _ebx, _esi, _edi, _esp : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov al, [esi] // AL := source color - cmp al, 0 - je @SkipColor // if AL=0 or AL=transparent color then skip everything - cmp al, byte ptr TransparentColor - je @SkipColor - and al, [edi] - mov [edi], al - @SkipColor: - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 15 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - and ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 16 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - @Loopx: - mov ax, [esi] // AX := source color - cmp ax, 0 - je @SkipColor // if AX=0 then skip everything - cmp ax, word ptr TransparentColor - je @SkipColor - and ax, [edi] - mov [edi], ax - @SkipColor: - add esi, 2 - add edi, 2 - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 24 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - mov WorkX, ax // WorkX := Src.w - add WorkX, ax // WorkX := Src.w * 2 - add WorkX, ax // WorkX := Src.w * 3 - @Loopx: - mov al, [esi] // AL := source color - and al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - 32 : - asm - mov _ebx, ebx - mov _esi, esi - mov _edi, edi - mov _esp, esp - mov esi, SrcAddr // ESI - Source Offset - mov edi, DestAddr // EDI - Destination Offset - mov ax, Src.h // WorkY := Src.h - mov WorkY, ax - @LoopY: - mov ax, Src.w - shl ax, 2 - mov WorkX, ax // WorkX := Src.w * 4 - @Loopx: - mov al, [esi] // AL := source color - and al, [edi] - mov [edi], al - inc esi - inc edi - dec WorkX - jnz @LoopX - add esi, SrcMod - add edi, DestMod - dec WorkY - jnz @LoopY - mov esp,_esp - mov edi,_edi - mov esi,_esi - mov ebx,_ebx - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_GTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 > Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; - if Pixel2 and $1C > Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; - if Pixel2 and $03 > Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 > Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; - if Pixel2 and $03E0 > Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; - if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 > Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; - if Pixel2 and $07E0 > Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; - if Pixel2 and $001F > Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 > Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 > Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF > Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - - -procedure SDL_LTSurface( SrcSurface : PSDL_Surface; SrcRect : PSDL_Rect; - DestSurface : PSDL_Surface; DestRect : PSDL_Rect ); -var - R, G, B, Pixel1, Pixel2, TransparentColor : cardinal; - Src, Dest : TSDL_Rect; - Diff : integer; - SrcAddr, DestAddr : cardinal; - WorkX, WorkY : word; - SrcMod, DestMod : cardinal; - Bits : cardinal; -begin - if ( SrcSurface = nil ) or ( DestSurface = nil ) then - exit; // Remove this to make it faster - if ( SrcSurface.Format.BitsPerPixel <> DestSurface.Format.BitsPerPixel ) then - exit; // Remove this to make it faster - if SrcRect = nil then - begin - with Src do - begin - x := 0; - y := 0; - w := SrcSurface.w; - h := SrcSurface.h; - end; - end - else - Src := SrcRect^; - if DestRect = nil then - begin - Dest.x := 0; - Dest.y := 0; - end - else - Dest := DestRect^; - Dest.w := Src.w; - Dest.h := Src.h; - with DestSurface.Clip_Rect do - begin - // Source's right side is greater than the dest.cliprect - if Dest.x + Src.w > x + w then - begin - smallint( Src.w ) := x + w - Dest.x; - smallint( Dest.w ) := x + w - Dest.x; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's bottom side is greater than the dest.clip - if Dest.y + Src.h > y + h then - begin - smallint( Src.h ) := y + h - Dest.y; - smallint( Dest.h ) := y + h - Dest.y; - if smallint( Dest.h ) < 1 then - exit; - end; - // Source's left side is less than the dest.clip - if Dest.x < x then - begin - Diff := x - Dest.x; - Src.x := Src.x + Diff; - smallint( Src.w ) := smallint( Src.w ) - Diff; - Dest.x := x; - smallint( Dest.w ) := smallint( Dest.w ) - Diff; - if smallint( Dest.w ) < 1 then - exit; - end; - // Source's Top side is less than the dest.clip - if Dest.y < y then - begin - Diff := y - Dest.y; - Src.y := Src.y + Diff; - smallint( Src.h ) := smallint( Src.h ) - Diff; - Dest.y := y; - smallint( Dest.h ) := smallint( Dest.h ) - Diff; - if smallint( Dest.h ) < 1 then - exit; - end; - end; - with SrcSurface^ do - begin - SrcAddr := cardinal( Pixels ) + UInt32( Src.y ) * Pitch + UInt32( Src.x ) * - Format.BytesPerPixel; - SrcMod := Pitch - Src.w * Format.BytesPerPixel; - TransparentColor := Format.colorkey; - end; - with DestSurface^ do - begin - DestAddr := cardinal( Pixels ) + UInt32( Dest.y ) * Pitch + UInt32( Dest.x ) * - Format.BytesPerPixel; - DestMod := Pitch - Dest.w * Format.BytesPerPixel; - Bits := Format.BitsPerPixel; - end; - SDL_LockSurface( SrcSurface ); - SDL_LockSurface( DestSurface ); - WorkY := Src.h; - case bits of - 8 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt8( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt8( DestAddr )^; - if Pixel2 > 0 then - begin - if Pixel2 and $E0 < Pixel1 and $E0 then R := Pixel2 and $E0 else R := Pixel1 and $E0; - if Pixel2 and $1C < Pixel1 and $1C then G := Pixel2 and $1C else G := Pixel1 and $1C; - if Pixel2 and $03 < Pixel1 and $03 then B := Pixel2 and $03 else B := Pixel1 and $03; - - if R > $E0 then - R := $E0; - if G > $1C then - G := $1C; - if B > $03 then - B := $03; - PUInt8( DestAddr )^ := R or G or B; - end - else - PUInt8( DestAddr )^ := Pixel1; - end; - inc( SrcAddr ); - inc( DestAddr ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 15 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $7C00 < Pixel1 and $7C00 then R := Pixel2 and $7C00 else R := Pixel1 and $7C00; - if Pixel2 and $03E0 < Pixel1 and $03E0 then G := Pixel2 and $03E0 else G := Pixel1 and $03E0; - if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 16 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt16( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt16( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $F800 < Pixel1 and $F800 then R := Pixel2 and $F800 else R := Pixel1 and $F800; - if Pixel2 and $07E0 < Pixel1 and $07E0 then G := Pixel2 and $07E0 else G := Pixel1 and $07E0; - if Pixel2 and $001F < Pixel1 and $001F then B := Pixel2 and $001F else B := Pixel1 and $001F; - - PUInt16( DestAddr )^ := R or G or B; - end - else - PUInt16( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 2 ); - inc( DestAddr, 2 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 24 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^ and $00FFFFFF; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^ and $00FFFFFF; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or ( R or G or B ); - end - else - PUInt32( DestAddr )^ := PUInt32( DestAddr )^ and $FF000000 or Pixel1; - end; - inc( SrcAddr, 3 ); - inc( DestAddr, 3 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - 32 : - begin - repeat - WorkX := Src.w; - repeat - Pixel1 := PUInt32( SrcAddr )^; - if ( Pixel1 <> TransparentColor ) and ( Pixel1 <> 0 ) then - begin - Pixel2 := PUInt32( DestAddr )^; - if Pixel2 > 0 then - begin - - if Pixel2 and $FF0000 < Pixel1 and $FF0000 then R := Pixel2 and $FF0000 else R := Pixel1 and $FF0000; - if Pixel2 and $00FF00 < Pixel1 and $00FF00 then G := Pixel2 and $00FF00 else G := Pixel1 and $00FF00; - if Pixel2 and $0000FF < Pixel1 and $0000FF then B := Pixel2 and $0000FF else B := Pixel1 and $0000FF; - - PUInt32( DestAddr )^ := R or G or B; - end - else - PUInt32( DestAddr )^ := Pixel1; - end; - inc( SrcAddr, 4 ); - inc( DestAddr, 4 ); - dec( WorkX ); - until WorkX = 0; - inc( SrcAddr, SrcMod ); - inc( DestAddr, DestMod ); - dec( WorkY ); - until WorkY = 0; - end; - end; - SDL_UnlockSurface( SrcSurface ); - SDL_UnlockSurface( DestSurface ); -end; - -function SDL_ClipLine(var x1,y1,x2,y2: Integer; ClipRect: PSDL_Rect) : boolean; -var tflag, flag1, flag2: word; - txy, xedge, yedge: Integer; - slope: single; - - function ClipCode(x,y: Integer): word; - begin - Result := 0; - if x < ClipRect.x then Result := 1; - if x >= ClipRect.w + ClipRect.x then Result := Result or 2; - if y < ClipRect.y then Result := Result or 4; - if y >= ClipRect.h + ClipRect.y then Result := Result or 8; - end; - -begin - flag1 := ClipCode(x1,y1); - flag2 := ClipCode(x2,y2); - result := true; - - while true do - begin - if (flag1 or flag2) = 0 then Exit; // all in - - if (flag1 and flag2) <> 0 then - begin - result := false; - Exit; // all out - end; - - if flag2 = 0 then - begin - txy := x1; x1 := x2; x2 := txy; - txy := y1; y1 := y2; y2 := txy; - tflag := flag1; flag1 := flag2; flag2 := tflag; - end; - - if (flag2 and 3) <> 0 then - begin - if (flag2 and 1) <> 0 then - xedge := ClipRect.x - else - xedge := ClipRect.w + ClipRect.x -1; // back 1 pixel otherwise we end up in a loop - - slope := (y2 - y1) / (x2 - x1); - y2 := y1 + Round(slope * (xedge - x1)); - x2 := xedge; - end - else - begin - if (flag2 and 4) <> 0 then - yedge := ClipRect.y - else - yedge := ClipRect.h + ClipRect.y -1; // up 1 pixel otherwise we end up in a loop - - slope := (x2 - x1) / (y2 - y1); - x2 := x1 + Round(slope * (yedge - y1)); - y2 := yedge; - end; - - flag2 := ClipCode(x2, y2); - end; -end; - -end. - - diff --git a/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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2003 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ SDL Mouse, Keyboard and Joystick wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ March 12 2003 - DL : Initial creation } -{ } -{ February 02 2004 - DL : Added Custom Cursor Support to the Mouse class } -{ - $Log: sdlinput.pas,v $ - Revision 1.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" <mrkroket@hotmail.com> } -{ } -{******************************************************************} -{ - $Log: sdlstreams.pas,v $ - Revision 1.1 2004/02/05 00:08:20 savage - Module 1.0 release - - -} - -{$i jedi-sdl.inc} - -interface - -uses - Classes, - SysUtils, - sdl, - sdlutils; - -{$IFDEF FPC} -type - EinvalidContainer=class(Exception); - {$ENDIF} - -function LoadSDLBMPFromStream( Stream : TStream ) : PSDL_Surface; -procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); -function SDL_Swap16( D : UInt16 ) : Uint16; -function SDL_Swap32( D : UInt32 ) : Uint32; -function SDLStreamSetup( stream : TStream ) : PSDL_RWops; -// this only closes the SDL_RWops part of the stream, not the stream itself -procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); - -implementation - -function SDL_Swap16( D : UInt16 ) : Uint16; -begin - Result := ( D shl 8 ) or ( D shr 8 ); -end; - -function SDL_Swap32( D : UInt32 ) : Uint32; -begin - Result := ( ( D shl 24 ) or ( ( D shl 8 ) and $00FF0000 ) or ( ( D shr 8 ) and $0000FF00 ) or ( D shr 24 ) ); -end; - -(*function SDL_Swap64(D : UInt64) : Uint64; -var hi,lo : Uint32; -begin - // Separate into high and low 32-bit resultues and swap them - lo := Uint32(D and $0FFFFFFFF); // bloody pascal is too tight in it's type checking! - D := D shr 32; - hi = Uint32((D and $FFFFFFFF)); - result = SDL_Swap32(lo); - result := result shl 32; - result := result or SDL_Swap32(hi); -end; -*) - -function SdlStreamSeek( context : PSDL_RWops; offset : Integer; whence : Integer ) : integer; cdecl; -var - stream : TStream; - origin : Word; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamSeek on nil' ); - case whence of - 0 : origin := soFromBeginning; // Offset is from the beginning of the resource. Seek moves to the position Offset. Offset must be >= 0. - 1 : origin := soFromCurrent; // Offset is from the current position in the resource. Seek moves to Position + Offset. - 2 : origin := soFromEnd; - else - origin := soFromBeginning; // just in case - end; - Result := stream.Seek( offset, origin ); -end; - -function SDLStreamWrite( context : PSDL_RWops; Ptr : Pointer; - size : Integer; num : Integer ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamWrite on nil' ); - try - Result := stream.Write( Ptr^, Size * num ) div size; - except - Result := -1; - end; -end; - -function SdlStreamRead( context : PSDL_RWops; Ptr : Pointer; size : Integer; maxnum - : Integer ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamRead on nil' ); - try - Result := stream.read( Ptr^, Size * maxnum ) div size; - except - Result := -1; - end; -end; - -function SDLStreamClose( context : PSDL_RWops ) : Integer; cdecl; -var - stream : TStream; -begin - stream := TStream( context.unknown ); - if ( stream = nil ) then - raise EInvalidContainer.Create( 'SDLStreamClose on nil' ); - stream.Free; - Result := 1; -end; - -function SDLStreamSetup( stream : TStream ) : PSDL_RWops; -begin - result := SDL_AllocRW; - if ( result = nil ) then - raise EInvalidContainer.Create( 'could not create SDLStream on nil' ); - result.unknown := TUnknown( stream ); - result.seek := SDLStreamSeek; - result.read := SDLStreamRead; - result.write := SDLStreamWrite; - result.close := SDLStreamClose; - Result.type_ := 2; // TUnknown -end; - -// this only closes the SDL part of the stream, not the context - -procedure SDLStreamCloseRWops( SDL_RWops : PSDL_RWops ); -begin - SDL_FreeRW( SDL_RWops ); -end; - -function LoadSDLBMPFromStream( stream : TStream ) : PSDL_Surface; -var - SDL_RWops : PSDL_RWops; -begin - SDL_RWops := SDLStreamSetup( stream ); - result := SDL_LoadBMP_RW( SDL_RWops, 0 ); - SDLStreamCloseRWops( SDL_RWops ); -end; - -procedure SaveSDLBMPToStream( SDL_Surface : PSDL_Surface; stream : TStream ); -var - SDL_RWops : PSDL_RWops; -begin - SDL_RWops := SDLStreamSetup( stream ); - SDL_SaveBMP_RW( SDL_Surface, SDL_RWops, 0 ); - SDLStreamCloseRWops( SDL_RWops ); -end; - -end. - diff --git a/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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2004 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ SDL Window Wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: sdlticks.pas,v $ - Revision 1.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 <tigertomjones@gmx.de> } -{ } -{ Portions created by Tom Jones are } -{ Copyright (C) 2000 - 2001 Tom Jones. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ Róbert Kisnémeth <mikrobi@freemail.hu> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ Helper functions... } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ 2000 - TJ : Initial creation } -{ } -{ July 13 2001 - DL : Added PutPixel and GetPixel routines. } -{ } -{ Sept 14 2001 - RK : Added flipping routines. } -{ } -{ Sept 19 2001 - RK : Added PutPixel & line drawing & blitting with ADD } -{ effect. Fixed a bug in SDL_PutPixel & SDL_GetPixel } -{ Added PSDLRect() } -{ Sept 22 2001 - DL : Removed need for Windows.pas by defining types here} -{ Also removed by poor attempt or a dialog box } -{ } -{ Sept 25 2001 - RK : Added PixelTest, NewPutPixel, SubPixel, SubLine, } -{ SubSurface, MonoSurface & TexturedSurface } -{ } -{ Sept 26 2001 - DL : Made change so that it refers to native Pascal } -{ types rather that Windows types. This makes it more} -{ portable to Linix. } -{ } -{ Sept 27 2001 - RK : SDLUtils now can be compiled with FreePascal } -{ } -{ Oct 27 2001 - JF : Added ScrollY function } -{ } -{ Jan 21 2002 - RK : Added SDL_ZoomSurface and SDL_WarpSurface } -{ } -{ Mar 28 2002 - JF : Added SDL_RotateSurface } -{ } -{ May 13 2002 - RK : Improved SDL_FillRectAdd & SDL_FillRectSub } -{ } -{ May 27 2002 - YS : GradientFillRect function } -{ } -{ May 30 2002 - RK : Added SDL_2xBlit, SDL_Scanline2xBlit } -{ & SDL_50Scanline2xBlit } -{ } -{ June 12 2002 - RK : Added SDL_PixelTestSurfaceVsRect } -{ } -{ June 12 2002 - JF : Updated SDL_PixelTestSurfaceVsRect } -{ } -{ November 9 2002 - JF : Added Jason's boolean Surface functions } -{ } -{ December 10 2002 - DE : Added Dean's SDL_ClipLine function } -{ } -{ April 26 2003 - SS : Incorporated JF's changes to SDL_ClipLine } -{ Fixed SDL_ClipLine bug for non-zero cliprect x, y } -{ Added overloaded SDL_DrawLine for dashed lines } -{ } -{******************************************************************************} -{ - $Log: sdlutils.pas,v $ - Revision 1.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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominique Louis are } -{ Copyright (C) 2004 - 2100 Dominique Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ SDL Window Wrapper } -{ } -{ } -{ Requires } -{ -------- } -{ SDL.dll on Windows platforms } -{ libSDL-1.1.so.0 on Linux platform } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ January 31 2003 - DL : Initial creation } -{ } -{ - $Log: sdlwindow.pas,v $ - Revision 1.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 <Dominique@SavageSoftware.com.au> } -{ } -{ Portions created by Dominqiue Louis are } -{ Copyright (C) 2000 - 2001 Dominqiue Louis. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ } -{ } -{ } -{ } -{ } -{ } -{ } -{ Requires } -{ -------- } -{ The SDL Runtime libraris on Win32 : SDL.dll on Linux : libSDL.so } -{ They are available from... } -{ http://www.libsdl.org . } -{ } -{ Programming Notes } -{ ----------------- } -{ } -{ } -{ } -{ } -{ Revision History } -{ ---------------- } -{ September 23 2004 - DL : Initial Creation } -{ - $Log: userpreferences.pas,v $ - Revision 1.1 2004/09/30 22:35:47 savage - Changes, enhancements and additions as required to get SoAoS working. - - -} -{******************************************************************************} - -interface - -uses - Classes; - -type - TUserPreferences = class - private - FAutoSave: Boolean; - procedure CheckAutoSave; - protected - function GetDefaultBoolean( const Index : Integer ) : Boolean; virtual; abstract; - function GetBoolean( const Index : Integer ) : Boolean; virtual; abstract; - procedure SetBoolean( const Index : Integer; const Value : Boolean ); virtual; - function GetDefaultDateTime( const Index : Integer ) : TDateTime; virtual; abstract; - function GetDateTime( const Index : Integer ) : TDateTime; virtual; abstract; - procedure SetDateTime( const Index : Integer; const Value : TDateTime ); virtual; - function GetDefaultInteger( const Index : Integer ) : Integer; virtual; abstract; - function GetInteger( const Index : Integer ) : Integer; virtual; abstract; - procedure SetInteger( const Index : Integer; const Value : Integer ); virtual; - function GetDefaultFloat( const Index : Integer ) : single; virtual; abstract; - function GetFloat( const Index : Integer ) : single; virtual; abstract; - procedure SetFloat( const Index : Integer; const Value : single ); virtual; - function GetDefaultString( const Index : Integer ) : string; virtual; abstract; - function GetString( const Index : Integer ) : string; virtual; abstract; - procedure SetString( const Index : Integer; const Value : string ); virtual; - function GetDefaultBinaryStream( const Index : Integer ) : TStream; virtual; abstract; - function GetBinaryStream( const Index : Integer ) : TStream; virtual; abstract; - procedure SetBinaryStream( const Index : Integer; const Value : TStream ); virtual; - public - procedure Update; virtual; abstract; - constructor Create; virtual; - destructor Destroy; override; - property AutoSave : Boolean read FAutoSave write FAutoSave; - end; - -implementation - -{ TUserPreferences } -procedure TUserPreferences.CheckAutoSave; -begin - if FAutoSave then - Update; -end; - -constructor TUserPreferences.Create; -begin - inherited; - FAutoSave := false; -end; - -destructor TUserPreferences.Destroy; -begin - - inherited; -end; - -procedure TUserPreferences.SetBinaryStream( const Index : Integer; const Value : TStream ); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetBoolean(const Index: Integer; const Value: Boolean); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetDateTime(const Index: Integer; const Value: TDateTime); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetFloat(const Index: Integer; const Value: single); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetInteger(const Index, Value: Integer); -begin - CheckAutoSave; -end; - -procedure TUserPreferences.SetString(const Index: Integer; const Value: string); -begin - CheckAutoSave; -end; - -end. 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 <slouken@devolution.com> 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 <ma.thoma@gmx.de> } -{ } -{ Portions created by Matthias Thoma are } -{ Copyright (C) 2000 - 2001 Matthias Thoma. } -{ } -{ } -{ Contributor(s) } -{ -------------- } -{ Dominique Louis <Dominique@SavageSoftware.com.au> } -{ } -{ Obtained through: } -{ Joint Endeavour of Delphi Innovators ( Project JEDI ) } -{ } -{ You may retrieve the latest version of this file at the Project } -{ JEDI home page, located at http://delphi-jedi.org } -{ } -{ The contents of this file are used with permission, subject to } -{ the Mozilla Public License Version 1.1 (the "License"); you may } -{ not use this file except in compliance with the License. You may } -{ obtain a copy of the License at } -{ http://www.mozilla.org/MPL/MPL-1.1.html } -{ } -{ Software distributed under the License is distributed on an } -{ "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either express or } -{ implied. See the License for the specific language governing } -{ rights and limitations under the License. } -{ } -{ Description } -{ ----------- } -{ 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.<br> - * 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, <value> 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, <value> 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 - * <width>x<height> 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 - * <frame_rate_num>/<frame_rate_den>, 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 <michaelni@gmx.at> - * - * 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 <michaelni@gmx.at> - * - * 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 <michaelni@gmx.at> - * - * 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 <michaelni@gmx.at> - * - * 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<b - *) -function av_cmp_q(a: TAVRational; b: TAVRational): cint; {$IFDEF HasInline}inline;{$ENDIF} - -(** - * Converts rational to double. - * @param a rational to convert - * @return (double) a - *) -function av_q2d(a: TAVRational): cdouble; {$IFDEF HasInline}inline;{$ENDIF} - -(** - * Reduces a fraction. - * This is useful for framerate calculations. - * @param dst_num destination numerator - * @param dst_den destination denominator - * @param num source numerator - * @param den source denominator - * @param max the maximum allowed for dst_num & dst_den - * @return 1 if exact, 0 otherwise - *) -function av_reduce(dst_num: PCint; dst_den: PCint; num: cint64; den: cint64; max: cint64): cint; - cdecl; external av__util; - -(** - * Multiplies two rationals. - * @param b first rational - * @param c second rational - * @return b*c - *) -function av_mul_q(b: TAVRational; c: TAVRational): TAVRational; - cdecl; external av__util; {av_const} - -(** - * Divides one rational by another. - * @param b first rational - * @param c second rational - * @return b/c - *) -function av_div_q(b: TAVRational; c: TAVRational): TAVRational; - cdecl; external av__util; {av_const} - -(** - * Adds two rationals. - * @param b first rational - * @param c second rational - * @return b+c - *) -function av_add_q(b: TAVRational; c: TAVRational): TAVRational; - cdecl; external av__util; {av_const} - -(** - * Subtracts one rational from another. - * @param b first rational - * @param c second rational - * @return b-c - *) -function av_sub_q(b: TAVRational; c: TAVRational): TAVRational; - cdecl; external av__util; {av_const} - -(** - * Converts a double precision floating point number to a rational. - * @param d double to convert - * @param max the maximum allowed numerator and denominator - * @return (AVRational) d - *) -function av_d2q(d: cdouble; max: cint): TAVRational; - cdecl; external av__util; {av_const} - -{$IF LIBAVUTIL_VERSION >= 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 <michaelni@gmx.at> - * - * 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 - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Library *) - (* *) - (* <Description> *) - (* 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). *) - (* *) - (* <Note> *) - (* Library objects are normally created by @FT_Init_FreeType, and *) - (* destroyed with @FT_Done_FreeType. *) - (* *) - FT_Library = Pointer; - - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_FACE_FLAG_XXX *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Values> *) - (* 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; - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Encoding *) - (* *) - (* <Description> *) - (* An enumeration used to specify encodings supported by charmaps. *) - (* Used in the @FT_Select_Charmap API function. *) - (* *) - (* <Note> *) - (* 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. *) - (* *) - (* <Values> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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'); - - - (*************************************************************************) - (* *) - (* <Constant> *) - (* FT_STYLE_FLAG_XXX *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Values> *) - (* 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; - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Render_Mode *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Values> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_GlyphSlot *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Also> *) - (* @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} - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Glyph_Metrics *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Fields> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Bitmap_Size *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Fields> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Face *) - (* *) - (* <Description> *) - (* A handle to a given typographic face object. A face object models *) - (* a given typeface, in a given style. *) - (* *) - (* <Note> *) - (* 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). *) - (* *) - (* <Also> *) - (* The @FT_FaceRec details the publicly accessible fields of a given *) - (* face object. *) - (* *) - FT_Face = ^FT_FaceRec; - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_CharMap *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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. *) - (* *) - (* <Also> *) - (* 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; - - - - - - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_SubGlyph *) - (* *) - (* <Description> *) - (* The subglyph structure is an internal object used to describe *) - (* subglyphs (for example, in the case of composites). *) - (* *) - (* <Note> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_GlyphSlotRec *) - (* *) - (* <Description> *) - (* FreeType root glyph slot class structure. A glyph slot is a *) - (* container where individual glyphs can be loaded, be they *) - (* vectorial or bitmap/graymaps. *) - (* *) - (* <Fields> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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' . *) - (* *) - (* <Note> *) - (* 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 *) - (* <compute kern between current and previous glyph and add it to *) - (* `origin_x'> *) - (* *) - (* <load glyph with `FT_Load_Glyph'> *) - (* *) - (* 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; *) - (* *) - (* <save glyph image, or render glyph, or ...> *) - (* *) - (* 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; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_Size_Metrics *) - (* *) - (* <Description> *) - (* The size metrics structure returned scaled important distances for *) - (* a given size object. *) - (* *) - (* <Fields> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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; - - (*************************************************************************) - (* *) - (* <Type> *) - (* FT_Size *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <Note> *) - (* 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. *) - (* *) - (* <Also> *) - (* The @FT_SizeRec structure details the publicly accessible fields *) - (* of a given face object. *) - (* *) - FT_Size = ^FT_SizeRec; - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_SizeRec *) - (* *) - (* <Description> *) - (* FreeType root size class structure. A size object models the *) - (* resolution and pointsize dependent data of a given face. *) - (* *) - (* <Fields> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_FaceRec *) - (* *) - (* <Description> *) - (* FreeType root face class structure. A face object models the *) - (* resolution and point-size independent data found in a font file. *) - (* *) - (* <Fields> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Struct> *) - (* FT_CharMapRec *) - (* *) - (* <Description> *) - (* The base charmap structure. *) - (* *) - (* <Fields> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Init_FreeType *) - (* *) - (* <Description> *) - (* Initializes a new FreeType library object. The set of modules *) - (* that are registered by this function is determined at build time. *) - (* *) - (* <Output> *) - (* alibrary :: A handle to a new library object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Init_FreeType(out alibrary : FT_Library ) : FT_Error; - cdecl; external ft_lib name 'FT_Init_FreeType'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Done_FreeType *) - (* *) - (* <Description> *) - (* Destroys a given FreeType library object and all of its childs, *) - (* including resources, drivers, faces, sizes, etc. *) - (* *) - (* <Input> *) - (* library :: A handle to the target library object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Done_FreeType(alibrary : FT_Library ) : FT_Error; - cdecl; external ft_lib name 'FT_Done_FreeType'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Attach_File *) - (* *) - (* <Description> *) - (* `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. *) - (* *) - (* <InOut> *) - (* face :: The target face object. *) - (* *) - (* <Input> *) - (* filepathname :: An 8-bit pathname naming the `metrics' file. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_New_Memory_Face *) - (* *) - (* <Description> *) - (* Creates a new face object from a given resource and typeface index *) - (* using a font file already loaded into memory. *) - (* *) - (* <InOut> *) - (* library :: A handle to the library resource. *) - (* *) - (* <Input> *) - (* 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. *) - (* *) - (* <Output> *) - (* aface :: A handle to a new face object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_New_Face *) - (* *) - (* <Description> *) - (* Creates a new face object from a given resource and typeface index *) - (* using a pathname to the font file. *) - (* *) - (* <InOut> *) - (* library :: A handle to the library resource. *) - (* *) - (* <Input> *) - (* pathname :: A path to the font file. *) - (* *) - (* face_index :: The index of the face within the resource. The *) - (* first face has index 0. *) - (* *) - (* <Output> *) - (* aface :: A handle to a new face object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Done_Face *) - (* *) - (* <Description> *) - (* Discards a given face object, as well as all of its child slots *) - (* and sizes. *) - (* *) - (* <Input> *) - (* face :: A handle to a target face object. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - function FT_Done_Face(face : FT_Face ) : FT_Error; - cdecl; external ft_lib name 'FT_Done_Face'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Select_Charmap *) - (* *) - (* <Description> *) - (* Selects a given charmap by its encoding tag (as listed in *) - (* `freetype.h'). *) - (* *) - (* <InOut> *) - (* face :: A handle to the source face object. *) - (* *) - (* <Input> *) - (* encoding :: A handle to the selected charmap. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Get_Char_Index *) - (* *) - (* <Description> *) - (* Returns the glyph index of a given character code. This function *) - (* uses a charmap object to do the translation. *) - (* *) - (* <Input> *) - (* face :: A handle to the source face object. *) - (* *) - (* charcode :: The character code. *) - (* *) - (* <Return> *) - (* The glyph index. 0 means `undefined character code'. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Load_Glyph *) - (* *) - (* <Description> *) - (* A function used to load a single glyph within a given glyph slot, *) - (* for a given size. *) - (* *) - (* <InOut> *) - (* face :: A handle to the target face object where the glyph *) - (* will be loaded. *) - (* *) - (* <Input> *) - (* 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). *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Render_Glyph *) - (* *) - (* <Description> *) - (* Converts a given glyph image to a bitmap. It does so by *) - (* inspecting the glyph image format, find the relevant renderer, and *) - (* invoke it. *) - (* *) - (* <InOut> *) - (* slot :: A handle to the glyph slot containing the image to *) - (* convert. *) - (* *) - (* <Input> *) - (* 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. *) - (* *) - (* <Return> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Enum> *) - (* FT_Kerning_Mode *) - (* *) - (* <Description> *) - (* An enumeration used to specify which kerning values to return in *) - (* @FT_Get_Kerning. *) - (* *) - (* <Values> *) - (* 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; - - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Get_Kerning *) - (* *) - (* <Description> *) - (* Returns the kerning vector between two glyphs of a same face. *) - (* *) - (* <Input> *) - (* 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. *) - (* *) - (* <Output> *) - (* akerning :: The kerning vector. This is in font units for *) - (* scalable formats, and in pixels for fixed-sizes *) - (* formats. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Set_Char_Size *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <InOut> *) - (* face :: A handle to a target face object. *) - (* *) - (* <Input> *) - (* 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. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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'; - - (*************************************************************************) - (* *) - (* <Function> *) - (* FT_Set_Pixel_Sizes *) - (* *) - (* <Description> *) - (* 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. *) - (* *) - (* <InOut> *) - (* face :: A handle to the target face object. *) - (* *) - (* <Input> *) - (* pixel_width :: The character width, in integer pixels. *) - (* *) - (* pixel_height :: The character height, in integer pixels. *) - (* *) - (* <Return> *) - (* FreeType error code. 0 means success. *) - (* *) - (* <Note> *) - (* 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_<chunk> 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 <dchurcher@cix.compulink.co.uk>, - 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 <dchurcher@cix.compulink.co.uk>, - 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 <dchurcher@cix.compulink.co.uk>, - 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. -<pre> - set PA_RECOMMENDED_OUTPUT_DEVICE=1 -</pre> - 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 <erikd@mega-nerd.com> -** -** 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. |