- Updated Vampyre Imaging Lib

- Added font rendering
- Added height display in flat mode
This commit is contained in:
Andreas Schneider 2009-12-05 17:26:22 +01:00
parent a5128b0d05
commit be3f8c05df
40 changed files with 34488 additions and 32762 deletions

View File

@ -56,7 +56,7 @@
<MinVersion Major="4" Minor="5" Release="1" Valid="True"/>
</Item5>
</RequiredPackages>
<Units Count="35">
<Units Count="36">
<Unit0>
<Filename Value="CentrED.lpr"/>
<IsPartOfProject Value="True"/>
@ -273,6 +273,11 @@
<IsPartOfProject Value="True"/>
<UnitName Value="UTiledata"/>
</Unit34>
<Unit35>
<Filename Value="UGLFont.pas"/>
<IsPartOfProject Value="True"/>
<UnitName Value="UGLFont"/>
</Unit35>
</Units>
</ProjectOptions>
<CompilerOptions>

View File

@ -40,7 +40,7 @@ uses
UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo,
UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets,
UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow,
Logging, UMap, UWorldItem, UStatics, UTiledata;
Logging, UMap, UWorldItem, UStatics, UTiledata, UGLFont;
{$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF}

BIN
Client/GLFont/DejaVu.fnt Normal file

Binary file not shown.

BIN
Client/GLFont/DejaVu.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 5.0 KiB

View File

@ -1,3 +1,5 @@
Overlay/LeftTopArrow.tga
Overlay/TopArrow.tga
Overlay/VirtualLayer.tga
GLFont/DejaVu.png
GLFont/DejaVu.fnt

205
Client/UGLFont.pas Normal file
View File

@ -0,0 +1,205 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
unit UGLFont;
{$mode objfpc}{$H+}
interface
uses
Classes, SysUtils, Math, ImagingClasses, ImagingTypes, ImagingOpenGL, GL;
type
TFontInfo = packed record
Character: Char;
LeftOffset: SmallInt;
CharWidth: Word;
Width: Word;
Height: Word;
X1: Single;
Y1: Single;
X2: Single;
Y2: Single;
end;
{ TGLFont }
TGLFont = class
constructor Create;
destructor Destroy; override;
protected
FFontImage: TSingleImage;
FFontTexture: TGLuint;
FSpaceWidth: Word;
FFontInfo: array of TFontInfo;
function FindCharInfo(AChar: Char): Integer;
public
function GetTextHeight(AText: String): Integer;
function GetTextWidth(AText: String): Integer;
procedure DrawText(AX, AY: Integer; AText: String);
procedure LoadImage(AImage: TStream);
procedure LoadFontInfo(AFontInfo: TStream);
procedure UpdateTexture;
end;
implementation
uses
Logging;
{ TGLFont }
constructor TGLFont.Create;
begin
FFontTexture := 0;
end;
destructor TGLFont.Destroy;
begin
FreeAndNil(FFontImage);
if FFontTexture <> 0 then
glDeleteTextures(1, @FFontTexture);
inherited Destroy;
end;
function TGLFont.FindCharInfo(AChar: Char): Integer;
var
i: Integer;
begin
Result := -1;
i := 0;
while (i < Length(FFontInfo)) and (Result = -1) do
begin
if FFontInfo[i].Character = AChar then
Result := i
else
Inc(i);
end;
end;
function TGLFont.GetTextHeight(AText: String): Integer;
var
i, charInfo: Integer;
begin
Result := 0;
for i := 1 to Length(AText) do
begin
if AText[i] <> ' ' then
begin
charInfo := FindCharInfo(AText[i]);
if charInfo > -1 then
Result := Max(Result, FFontInfo[charInfo].Height);
end;
end;
end;
function TGLFont.GetTextWidth(AText: String): Integer;
var
i, charInfo: Integer;
begin
Result := 0;
for i := 1 to Length(AText) do
begin
if AText[i] = ' ' then
Inc(Result, FSpaceWidth)
else
begin
charInfo := FindCharInfo(AText[i]);
if charInfo > -1 then
Result := Result + FFontInfo[charInfo].LeftOffset +
FFontInfo[charInfo].CharWidth;
end;
end;
end;
procedure TGLFont.DrawText(AX, AY: Integer; AText: String);
var
i, charInfo: Integer;
curX: Integer;
x1, y1, x2, y2: Single;
begin
if FFontTexture = 0 then UpdateTexture;
glBindTexture(GL_TEXTURE_2D, FFontTexture);
curX := AX;
for i := 1 to Length(AText) do
begin
if AText[i] = ' ' then
Inc(curX, FSpaceWidth)
else
begin
charInfo := FindCharInfo(AText[i]);
if charInfo > -1 then
begin
x1 := FFontInfo[charInfo].X1;
y1 := FFontInfo[charInfo].Y1;
x2 := FFontInfo[charInfo].X2;
y2 := FFontInfo[charInfo].Y2;
Inc(curX, FFontInfo[charInfo].LeftOffset);
glBegin(GL_QUADS);
glTexCoord2f(x1, y1); glVertex2i(curX, AY);
glTexCoord2f(x2, y1); glVertex2i(curX + FFontInfo[charInfo].Width, AY);
glTexCoord2f(x2, y2); glVertex2i(curX + FFontInfo[charInfo].Width,
AY + FFontInfo[charInfo].Height);
glTexCoord2f(x1, y2); glVertex2i(curX, AY + FFontInfo[charInfo].Height);
glEnd;
Inc(curX, FFontInfo[charInfo].CharWidth);
end;
end;
end;
end;
procedure TGLFont.LoadImage(AImage: TStream);
begin
FFontImage := TSingleImage.CreateFromStream(AImage);
end;
procedure TGLFont.LoadFontInfo(AFontInfo: TStream);
begin
AFontInfo.Read(FSpaceWidth, SizeOf(FSpaceWidth));
SetLength(FFontInfo, (AFontInfo.Size - AFontInfo.Position) div
SizeOf(TFontInfo));
AFontInfo.Read(FFontInfo[0], Length(FFontInfo) * SizeOf(TFontInfo));
end;
procedure TGLFont.UpdateTexture;
begin
Logger.Send('UpdateTexture');
if FFontTexture <> 0 then glDeleteTextures(1, @FFontTexture);
FFontTexture := CreateGLTextureFromImage(FFontImage.ImageDataPointer^, 0, 0,
True, ifUnknown);
glBindTexture(GL_TEXTURE_2D, FFontTexture);
glTexEnvi(GL_TEXTURE_ENV, GL_TEXTURE_ENV_MODE, GL_MODULATE);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MAG_FILTER, GL_LINEAR);
glTexParameteri(GL_TEXTURE_2D, GL_TEXTURE_MIN_FILTER, GL_LINEAR_MIPMAP_LINEAR);
end;
end.

View File

@ -30,11 +30,11 @@ unit ULandscape;
interface
uses
SysUtils, Classes, math, LCLIntf, GL, GLU, ImagingOpenGL, Imaging,
SysUtils, Classes, math, LCLIntf, GL, GLu, ImagingOpenGL, Imaging,
ImagingClasses, ImagingTypes, ImagingUtility,
UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem,
UMulBlock,
UVector, UEnhancedMemoryStream,
UVector, UEnhancedMemoryStream, UGLFont,
UCacheManager;
type
@ -196,6 +196,19 @@ type
procedure UpdateWriteMap(AStream: TEnhancedMemoryStream);
end;
{ TGLText }
TGLText = class
constructor Create(AFont: TGLFont; AText: String);
protected
FFont: TGLFont;
FText: String;
FWidth: Integer;
FHeight: Integer;
public
procedure Render(AScreenRect: TRect);
end;
TScreenState = (ssNormal, ssFiltered, ssGhost);
PBlockInfo = ^TBlockInfo;
@ -212,6 +225,7 @@ type
HueOverride: Boolean;
CheckRealQuad: Boolean;
Translucent: Boolean;
Text: TGLText;
Next: PBlockInfo;
end;
@ -1213,6 +1227,7 @@ begin
Result^.State := ssNormal;
Result^.Highlighted := False;
Result^.Translucent := False;
Result^.Text := nil;
Result^.Next := nil;
if FShortCuts[0] = nil then //First element
@ -1239,6 +1254,7 @@ begin
current^.Item.Locked := False;
current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved);
if current^.Normals <> nil then Dispose(current^.Normals);
current^.Text.Free;
Dispose(current);
current := next;
end;
@ -1266,6 +1282,7 @@ begin
if last <> nil then last^.Next := current^.Next;
if current^.Normals <> nil then Dispose(current^.Normals);
current^.Text.Free;
Dispose(current);
Dec(FCount);
@ -1356,6 +1373,7 @@ begin
Result^.State := ssNormal;
Result^.Highlighted := False;
Result^.Translucent := False;
Result^.Text := nil;
if (FShortCuts[0] = nil) or (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then
begin
@ -1490,5 +1508,27 @@ begin
Delete(TWorldItem(ATile));
end;
{ TGLText }
constructor TGLText.Create(AFont: TGLFont; AText: String);
var
i: Integer;
begin
FFont := AFont;
FText := AText;
FWidth := FFont.GetTextWidth(AText);
FHeight := FFont.GetTextHeight('A');
end;
procedure TGLText.Render(AScreenRect: TRect);
var
x, y: Integer;
i: Integer;
begin
y := AScreenRect.Top + (AScreenRect.Bottom - AScreenRect.Top - FHeight) div 2;
x := AScreenRect.Left + (AScreenRect.Right - AScreenRect.Left - FWidth) div 2;
FFont.DrawText(x, y, FText);
end;
end.

View File

@ -21,7 +21,7 @@
* CDDL HEADER END
*
*
* Portions Copyright 2007 Andreas Schneider
* Portions Copyright 2009 Andreas Schneider
*)
unit UResourceManager;
@ -69,8 +69,8 @@ end;
destructor TResourceManager.Destroy;
begin
if FFileStream <> nil then FreeAndNil(FFileStream);
if FResourceStream <> nil then FreeAndNil(FResourceStream);
FreeAndNil(FFileStream);
FreeAndNil(FResourceStream);
inherited Destroy;
end;
@ -81,8 +81,7 @@ begin
if AIndex <> FCurrentResource then
begin
FFileStream.Position := FLookupTable[AIndex];
if FResourceStream <> nil then
FResourceStream.Free;
FResourceStream.Free;
FResourceStream := TMemoryStream.Create;
FFileStream.Read(size, SizeOf(Cardinal));
FResourceStream.CopyFrom(FFileStream, size);

View File

@ -31,10 +31,10 @@ interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Menus,
ComCtrls, OpenGLContext, GL, GLU, UGameResources, ULandscape, ExtCtrls,
ComCtrls, OpenGLContext, GL, GLu, UGameResources, ULandscape, ExtCtrls,
StdCtrls, Spin, UEnums, VirtualTrees, Buttons, UMulBlock, UWorldItem, math,
LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList, fgl,
ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket;
ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket, UGLFont;
type
TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object;
@ -269,6 +269,7 @@ type
Node: PVirtualNode; Stream: TStream);
protected
{ Members }
FAppDir: String;
FX: Integer;
FY: Integer;
FDrawDistance: Integer;
@ -294,6 +295,7 @@ type
FRepaintNeeded: Boolean;
FSelection: TRect;
FUndoList: TPacketList;
FGLFont: TGLFont;
{ Methods }
procedure BuildTileList;
function ConfirmAction: Boolean;
@ -784,6 +786,8 @@ var
virtualLayerGraphic: TSingleImage;
searchRec: TSearchRec;
begin
FAppDir := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName));
FLandscape := ResMan.Landscape;
FLandscape.OnChange := @OnLandscapeChanged;
FLandscape.OnMapChanged := @OnMapChanged;
@ -812,8 +816,7 @@ begin
vstChat.NodeDataSize := SizeOf(TChatInfo);
pnlChatHeader.AnchorSide[akBottom].Control := pnlBottom;
FLocationsFile := IncludeTrailingPathDelimiter(ExtractFilePath(
Application.ExeName)) + 'Locations.dat';
FLocationsFile := FAppDir + 'Locations.dat';
vstLocations.NodeDataSize := SizeOf(TLocationInfo);
if FileExists(FLocationsFile) then vstLocations.LoadFromFile(FLocationsFile);
@ -824,11 +827,14 @@ begin
virtualLayerGraphic.Height, virtualLayerGraphic);
virtualLayerGraphic.Free;
FGLFont := TGLFont.Create;
FGLFont.LoadImage(ResourceManager.GetResource(3));
FGLFont.LoadFontInfo(ResourceManager.GetResource(4));
FVirtualTiles := TWorldItemList.Create(True);
FUndoList := TPacketList.Create(True);
FRandomPresetLocation := IncludeTrailingPathDelimiter(ExtractFilePath(
Application.ExeName)) + 'RandomPresets' + PathDelim;
FRandomPresetLocation := FAppDir + 'RandomPresets' + PathDelim;
if not DirectoryExists(FRandomPresetLocation) then
CreateDir(FRandomPresetLocation);
@ -1116,6 +1122,7 @@ begin
FreeAndNil(FVLayerMaterial);
FreeAndNil(FVirtualTiles);
FreeAndNil(FUndoList);
FreeAndNil(FGLFont);
RegisterPacketHandler($0C, nil);
end;
@ -1783,9 +1790,11 @@ procedure TfrmMain.InitSize;
begin
glViewport(0, 0, oglGameWindow.Width, oglGameWindow.Height);
glMatrixMode(GL_PROJECTION);
glPushMatrix;
glLoadIdentity;
gluOrtho2D(0, oglGameWindow.Width, oglGameWindow.Height, 0);
glMatrixMode(GL_MODELVIEW);
glPushMatrix;
glLoadIdentity;
end;
@ -1923,6 +1932,10 @@ begin
CheckRealQuad := True;
end;
end;
end else
begin
ABlockInfo^.Text.Free;
ABlockInfo^.Text := TGLText.Create(FGLFont, IntToStr(item.Z));
end;
if not ABlockInfo^.CheckRealQuad then
@ -2082,6 +2095,9 @@ begin
if highlight then
glDisable(GL_COLOR_LOGIC_OP);
if (blockInfo^.Text <> nil) then
blockInfo^.Text.Render(blockInfo^.ScreenRect);
end;
FOverlayUI.Draw(oglGameWindow);

View File

@ -1,5 +1,5 @@
{
$Id: Imaging.pas 124 2008-04-21 09:47:07Z galfar $
$Id: Imaging.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -203,9 +203,8 @@ function SplitImage(var Image: TImageData; var Chunks: TDynImageDataArray;
Pal must be allocated to have at least MaxColors entries.}
function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean;
{ Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise.
Only multiples of 90 degrees are allowed.}
function RotateImage(var Image: TImageData; Angle: LongInt): Boolean;
{ Rotates image by Angle degrees counterclockwise. All angles are allowed.}
function RotateImage(var Image: TImageData; Angle: Single): Boolean;
{ Drawing/Pixel functions }
@ -303,7 +302,7 @@ function PopOptions: Boolean;
{ Image Format Functions }
{ Returns short information about given image format.}
function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
{ Returns size in bytes of Width x Height area of pixels. Works for all formats.}
function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
@ -534,28 +533,28 @@ procedure RaiseImaging(const Msg: string; const Args: array of const);
implementation
uses
{$IFDEF LINK_BITMAP}
{$IFNDEF DONT_LINK_BITMAP}
ImagingBitmap,
{$ENDIF}
{$IFDEF LINK_JPEG}
{$IFNDEF DONT_LINK_JPEG}
ImagingJpeg,
{$ENDIF}
{$IF Defined(LINK_PNG) or Defined(LINK_MNG) or Defined(LINK_JNG)}
{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
ImagingNetworkGraphics,
{$IFEND}
{$IFDEF LINK_GIF}
{$IFNDEF DONT_LINK_GIF}
ImagingGif,
{$ENDIF}
{$IFDEF LINK_DDS}
{$IFNDEF DONT_LINK_DDS}
ImagingDds,
{$ENDIF}
{$IFDEF LINK_TARGA}
{$IFNDEF DONT_LINK_TARGA}
ImagingTarga,
{$ENDIF}
{$IFDEF LINK_PNM}
{$IFNDEF DONT_LINK_PNM}
ImagingPortableMaps,
{$ENDIF}
{$IFDEF LINK_EXTRAS}
{$IFNDEF DONT_LINK_EXTRAS}
ImagingExtras,
{$ENDIF}
ImagingFormats, ImagingUtility, ImagingIO;
@ -606,8 +605,9 @@ resourcestring
SErrorFreePalette = 'Error while freeing palette @%p';
SErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%p';
SErrorReplaceColor = 'Error while replacing colors in rectangle X:%d Y:%d W:%d H:%d of image %s';
SErrorRotateImage = 'Error while rotating image %s by %d degrees';
SErrorRotateImage = 'Error while rotating image %s by %.2n degrees';
SErrorStretchRect = 'Error while stretching rect from image %s to image %s.';
SErrorEmptyStream = 'Input stream has no data. Check Position property.';
const
// initial size of array with options information
@ -727,7 +727,7 @@ function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image:
var
FInfo: PImageFormatInfo;
begin
Assert((Width >= 0) and (Height >= 0));
Assert((Width > 0) and (Height >0));
Assert(IsImageFormatValid(Format));
Result := False;
FreeImage(Image);
@ -996,6 +996,8 @@ var
I: LongInt;
begin
Assert(Stream <> nil);
if Stream.Size - Stream.Position = 0 then
RaiseImaging(SErrorEmptyStream, []);
Result := False;
Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
if Format <> nil then
@ -1057,6 +1059,8 @@ var
Format: TImageFileFormat;
begin
Assert(Stream <> nil);
if Stream.Size - Stream.Position = 0 then
RaiseImaging(SErrorEmptyStream, []);
Result := False;
Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
if Format <> nil then
@ -1416,7 +1420,10 @@ begin
// Free old image and assign new image to it
FreeMemNil(Image.Bits);
if Image.Palette <> nil then
begin
FreeMem(WorkImage.Palette);
WorkImage.Palette := Image.Palette;
end;
Image := WorkImage;
Result := True;
except
@ -1854,33 +1861,154 @@ begin
end;
end;
function RotateImage(var Image: TImageData; Angle: LongInt): Boolean;
function RotateImage(var Image: TImageData; Angle: Single): Boolean;
var
X, Y, BytesPerPixel: LongInt;
RotImage: TImageData;
Pix, RotPix: PByte;
OldFmt: TImageFormat;
begin
Assert(Angle mod 90 = 0);
Result := False;
if TestImage(Image) then
try
if (Angle < -360) or (Angle > 360) then Angle := Angle mod 360;
if (Angle = 0) or (Abs(Angle) = 360) then
procedure XShear(var Src, Dst: TImageData; Row, Offset, Weight, Bpp: Integer);
var
I, J, XPos: Integer;
PixSrc, PixLeft, PixOldLeft: TColor32Rec;
LineDst: PByteArray;
SrcPtr: PColor32;
begin
SrcPtr := @PByteArray(Src.Bits)[Row * Src.Width * Bpp];
LineDst := @PByteArray(Dst.Bits)[Row * Dst.Width * Bpp];
PixOldLeft.Color := 0;
for I := 0 to Src.Width - 1 do
begin
Result := True;
Exit;
CopyPixel(SrcPtr, @PixSrc, Bpp);
for J := 0 to Bpp - 1 do
PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256);
XPos := I + Offset;
if (XPos >= 0) and (XPos < Dst.Width) then
begin
for J := 0 to Bpp - 1 do
PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
CopyPixel(@PixSrc, @LineDst[XPos * Bpp], Bpp);
end;
PixOldLeft := PixLeft;
Inc(PByte(SrcPtr), Bpp);
end;
Angle := Iff(Angle = -90, 270, Angle);
Angle := Iff(Angle = -270, 90, Angle);
Angle := Iff(Angle = -180, 180, Angle);
XPos := Src.Width + Offset;
if XPos < Dst.Width then
CopyPixel(@PixOldLeft, @LineDst[XPos * Bpp], Bpp);
end;
OldFmt := Image.Format;
if ImageFormatInfos[Image.Format].IsSpecial then
ConvertImage(Image, ifDefault);
procedure YShear(var Src, Dst: TImageData; Col, Offset, Weight, Bpp: Integer);
var
I, J, YPos: Integer;
PixSrc, PixLeft, PixOldLeft: TColor32Rec;
SrcPtr: PByte;
begin
SrcPtr := @PByteArray(Src.Bits)[Col * Bpp];
PixOldLeft.Color := 0;
for I := 0 to Src.Height - 1 do
begin
CopyPixel(SrcPtr, @PixSrc, Bpp);
for J := 0 to Bpp - 1 do
PixLeft.Channels[J] := MulDiv(PixSrc.Channels[J], Weight, 256);
YPos := I + Offset;
if (YPos >= 0) and (YPos < Dst.Height) then
begin
for J := 0 to Bpp - 1 do
PixSrc.Channels[J] := PixSrc.Channels[J] - (PixLeft.Channels[J] - PixOldLeft.Channels[J]);
CopyPixel(@PixSrc, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
end;
PixOldLeft := PixLeft;
Inc(SrcPtr, Src.Width * Bpp);
end;
YPos := Src.Height + Offset;
if YPos < Dst.Height then
CopyPixel(@PixOldLeft, @PByteArray(Dst.Bits)[(YPos * Dst.Width + Col) * Bpp], Bpp);
end;
procedure Rotate45(var Image: TImageData; Angle: Single);
var
TempImage1, TempImage2: TImageData;
AngleRad, AngleTan, AngleSin, AngleCos, Shear: Single;
I, DstWidth, DstHeight, SrcWidth, SrcHeight, Bpp: Integer;
SrcFmt, TempFormat: TImageFormat;
Info: TImageFormatInfo;
begin
AngleRad := Angle * Pi / 180;
AngleSin := Sin(AngleRad);
AngleCos := Cos(AngleRad);
AngleTan := Sin(AngleRad / 2) / Cos(AngleRad / 2);
SrcWidth := Image.Width;
SrcHeight := Image.Height;
SrcFmt := Image.Format;
if not (SrcFmt in [ifR8G8B8..ifX8R8G8B8, ifGray8..ifGray32, ifA16Gray16]) then
ConvertImage(Image, ifA8R8G8B8);
TempFormat := Image.Format;
GetImageFormatInfo(TempFormat, Info);
Bpp := Info.BytesPerPixel;
// 1st shear (horizontal)
DstWidth := Trunc(SrcWidth + SrcHeight * Abs(AngleTan) + 0.5);
DstHeight := SrcHeight;
NewImage(DstWidth, DstHeight, TempFormat, TempImage1);
for I := 0 to DstHeight - 1 do
begin
if AngleTan >= 0 then
Shear := (I + 0.5) * AngleTan
else
Shear := (I - DstHeight + 0.5) * AngleTan;
XShear(Image, TempImage1, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
end;
// 2nd shear (vertical)
FreeImage(Image);
DstHeight := Trunc(SrcWidth * Abs(AngleSin) + SrcHeight * AngleCos + 0.5) + 1;
NewImage(DstWidth, DstHeight, TempFormat, TempImage2);
if AngleSin >= 0 then
Shear := (SrcWidth - 1) * AngleSin
else
Shear := (SrcWidth - DstWidth) * -AngleSin;
for I := 0 to DstWidth - 1 do
begin
YShear(TempImage1, TempImage2, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
Shear := Shear - AngleSin;
end;
// 3rd shear (horizontal)
FreeImage(TempImage1);
DstWidth := Trunc(SrcHeight * Abs(AngleSin) + SrcWidth * AngleCos + 0.5) + 1;
NewImage(DstWidth, DstHeight, TempFormat, Image);
if AngleSin >= 0 then
Shear := (SrcWidth - 1) * AngleSin * -AngleTan
else
Shear := ((SrcWidth - 1) * -AngleSin + (1 - DstHeight)) * AngleTan;
for I := 0 to DstHeight - 1 do
begin
XShear(TempImage2, Image, I, Floor(Shear), Trunc(255 * (Shear - Floor(Shear)) + 1), Bpp);
Shear := Shear + AngleTan;
end;
FreeImage(TempImage2);
if Image.Format <> SrcFmt then
ConvertImage(Image, SrcFmt);
end;
procedure RotateMul90(var Image: TImageData; Angle: Integer);
var
RotImage: TImageData;
X, Y, BytesPerPixel: Integer;
RotPix, Pix: PByte;
begin
InitImage(RotImage);
BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel;
@ -1920,8 +2048,7 @@ begin
begin
for Y := 0 to RotImage.Height - 1 do
begin
Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width +
Y) * BytesPerPixel];
Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel];
for X := 0 to RotImage.Width - 1 do
begin
CopyPixel(Pix, RotPix, BytesPerPixel);
@ -1935,6 +2062,46 @@ begin
FreeMemNil(Image.Bits);
RotImage.Palette := Image.Palette;
Image := RotImage;
end;
begin
Result := False;
if TestImage(Image) then
try
while Angle >= 360 do
Angle := Angle - 360;
while Angle < 0 do
Angle := Angle + 360;
if (Angle = 0) or (Abs(Angle) = 360) then
begin
Result := True;
Exit;
end;
OldFmt := Image.Format;
if ImageFormatInfos[Image.Format].IsSpecial then
ConvertImage(Image, ifDefault);
if (Angle > 45) and (Angle <= 135) then
begin
RotateMul90(Image, 90);
Angle := Angle - 90;
end
else if (Angle > 135) and (Angle <= 225) then
begin
RotateMul90(Image, 180);
Angle := Angle - 180;
end
else if (Angle > 225) and (Angle <= 315) then
begin
RotateMul90(Image, 270);
Angle := Angle - 270;
end;
if Angle <> 0 then
Rotate45(Image, Angle);
if OldFmt <> Image.Format then
ConvertImage(Image, OldFmt);
@ -2421,7 +2588,7 @@ end;
{ Image Format Functions }
function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean;
function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
begin
FillChar(Info, SizeOf(Info), 0);
if ImageFormatInfos[Format] <> nil then
@ -2527,7 +2694,7 @@ begin
if OptionId >= Length(Options) then
SetLength(Options, OptionId + InitialOptions);
if (OptionId >= 0) and (OptionId < Length(Options)) and (Options[OptionId] = nil) then
if (OptionId >= 0) and (OptionId < Length(Options)) {and (Options[OptionId] = nil) - must be able to override existing } then
begin
Options[OptionId] := Variable;
Result := True;
@ -2539,7 +2706,7 @@ var
I: LongInt;
begin
Result := nil;
for I := 0 to ImageFileFormats.Count - 1 do
for I := ImageFileFormats.Count - 1 downto 0 do
if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(Ext) >= 0 then
begin
Result := TImageFileFormat(ImageFileFormats[I]);
@ -2552,7 +2719,7 @@ var
I: LongInt;
begin
Result := nil;
for I := 0 to ImageFileFormats.Count - 1 do
for I := ImageFileFormats.Count - 1 downto 0 do
if TImageFileFormat(ImageFileFormats[I]).TestFileName(FileName) then
begin
Result := TImageFileFormat(ImageFileFormats[I]);
@ -3289,6 +3456,19 @@ finalization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Extended RotateImage to allow arbitrary angle rotations.
- Reversed the order file formats list is searched so
if you register a new one it will be found sooner than
built in formats.
- Fixed memory leak in ResizeImage ocurring when resizing
indexed images.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Added position/size checks to LoadFromStream functions.
- Changed conditional compilation in impl. uses section to reflect changes
in LINK symbols.
-- 0.24.3 Changes/Bug Fixes ---------------------------------
- GenerateMipMaps now generates all smaller levels from
original big image (better results when using more advanced filters).

View File

@ -1,5 +1,5 @@
{
$Id: ImagingCanvases.pas 131 2008-08-14 15:14:24Z galfar $
$Id: ImagingCanvases.pas 174 2009-09-08 09:37:59Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -118,6 +118,8 @@ type
TDynFPPixelArray = array of TColorFPRec;
THistogramArray = array[Byte] of Integer;
TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
{ Base canvas class for drawing objects, applying effects, and other.
@ -128,7 +130,7 @@ type
recompute some data size related stuff).
TImagingCanvas works for all image data formats except special ones
(compressed). Because of this its methods are quite slow (they work
(compressed). Because of this its methods are quite slow (they usually work
with colors in ifA32R32G32B32F format). If you want fast drawing you
can use one of fast canvas clases. These descendants of TImagingCanvas
work only for few select formats (or only one) but they are optimized thus
@ -216,6 +218,12 @@ type
filled by using the current fill settings. Rect specifies bounding rectangle
of ellipse to be drawn.}
procedure Ellipse(const Rect: TRect);
{ Fills area of canvas with current fill color starting at point [X, Y] and
coloring its neighbors. Default flood fill mode changes color of all
neighbors with the same color as pixel [X, Y]. With BoundaryFillMode
set to True neighbors are recolored regardless of their old color,
but area which will be recolored has boundary (specified by current pen color).}
procedure FloodFill(X, Y: Integer; BoundaryFillMode: Boolean = False);
{ Draws contents of this canvas onto another canvas with pixel blending.
Blending factors are chosen using TBlendingFactor parameters.
@ -225,7 +233,7 @@ type
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
{ Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); virtual;
{ Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).}
procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer);
@ -239,7 +247,7 @@ type
{ Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; Filter: TResizeFilter = rfBilinear);
const DestRect: TRect; Filter: TResizeFilter = rfBilinear); virtual;
{ Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).}
procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
@ -286,10 +294,36 @@ type
{ Gamma correction of individual color channels. Range is (0, +inf),
1.0 means no change.}
procedure GammaCorection(Red, Green, Blue: Single);
{ Inverts colors of all image pixels, makes negative image.}
procedure InvertColors;
{ Simple single level thresholding with threshold level for each color channel.}
{ Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
procedure InvertColors; virtual;
{ Simple single level thresholding with threshold level (in range [0, 1])
for each color channel.}
procedure Threshold(Red, Green, Blue: Single);
{ Adjusts the color levels of the image by scaling the
colors falling between specified white and black points to full [0, 1] range.
The black point specifies the darkest color in the image, white point
specifies the lightest color, and mid point is gamma aplied to image.
Black and white point must be in range [0, 1].}
procedure AdjustColorLevels(BlackPoint, WhitePoint: Single; MidPoint: Single = 1.0);
{ Premultiplies color channel values by alpha. Needed for some platforms/APIs
to display images with alpha properly.}
procedure PremultiplyAlpha;
{ Reverses PremultiplyAlpha operation.}
procedure UnPremultiplyAlpha;
{ Calculates image histogram for each channel and also gray values. Each
channel has 256 values available. Channel values of data formats with higher
precision are scaled and rounded. Example: Red[126] specifies number of pixels
in image with red channel = 126.}
procedure GetHistogram(out Red, Green, Blue, Alpha, Gray: THistogramArray);
{ Fills image channel with given value leaving other channels intact.
Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
channel identifier.}
procedure FillChannel(ChannelId: Integer; NewChannelValue: Byte); overload;
{ Fills image channel with given value leaving other channels intact.
Use ChannelAlpha, ChannelRed, etc. constants from ImagingTypes as
channel identifier.}
procedure FillChannelFP(ChannelId: Integer; NewChannelValue: Single); overload;
{ Color used when drawing lines, frames, and outlines of objects.}
property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
@ -337,6 +371,7 @@ type
TFastARGB32Canvas = class(TImagingCanvas)
protected
FScanlines: PScanlineArray;
procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPixel32(X, Y: LongInt): TColor32; override;
procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override;
public
@ -344,6 +379,11 @@ type
procedure UpdateCanvasState; override;
procedure DrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); override;
procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas;
const DestRect: TRect; Filter: TResizeFilter = rfBilinear); override;
procedure InvertColors; override;
property Scanlines: PScanlineArray read FScanlines;
class function GetSupportedFormats: TImageFormats; override;
@ -600,13 +640,16 @@ procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte;
DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
var
DestPix: TColorFPRec;
SrcAlpha, DestAlpha: Single;
begin
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Blend the two pixels (Src 'over' Dest alpha composition operation)
DestPix.R := SrcPix.R * SrcPix.A + DestPix.R * DestPix.A * (1.0 - SrcPix.A);
DestPix.G := SrcPix.G * SrcPix.A + DestPix.G * DestPix.A * (1.0 - SrcPix.A);
DestPix.B := SrcPix.B * SrcPix.A + DestPix.B * DestPix.A * (1.0 - SrcPix.A);
DestPix.A := SrcPix.A + DestPix.A * (1.0 - SrcPix.A);
DestPix.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
DestAlpha := 1.0 - SrcAlpha;
DestPix.R := SrcPix.R * SrcAlpha + DestPix.R * DestAlpha;
DestPix.G := SrcPix.G * SrcAlpha + DestPix.G * DestAlpha;
DestPix.B := SrcPix.B * SrcAlpha + DestPix.B * DestAlpha;
// Write blended pixel
DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
end;
@ -691,7 +734,7 @@ begin
end;
end;
function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, Ignore: Single): TColorFPRec;
function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := Pixel.R * C + B;
@ -707,7 +750,7 @@ begin
Result.B := Power(Pixel.B, 1.0 / B);
end;
function TransformInvert(const Pixel: TColorFPRec; A, B, C: Single): TColorFPRec;
function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := 1.0 - Pixel.R;
@ -723,6 +766,49 @@ begin
Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0);
end;
function TransformLevels(const Pixel: TColorFPRec; BlackPoint, WhitePoint, Exp: Single): TColorFPRec;
begin
Result.A := Pixel.A;
if Pixel.R > BlackPoint then
Result.R := Power((Pixel.R - BlackPoint) / (WhitePoint - BlackPoint), Exp)
else
Result.R := 0.0;
if Pixel.G > BlackPoint then
Result.G := Power((Pixel.G - BlackPoint) / (WhitePoint - BlackPoint), Exp)
else
Result.G := 0.0;
if Pixel.B > BlackPoint then
Result.B := Power((Pixel.B - BlackPoint) / (WhitePoint - BlackPoint), Exp)
else
Result.B := 0.0;
end;
function TransformPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
begin
Result.A := Pixel.A;
Result.R := Result.R * Pixel.A;
Result.G := Result.G * Pixel.A;
Result.B := Result.B * Pixel.A;
end;
function TransformUnPremultiplyAlpha(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
begin
Result.A := Pixel.A;
if Pixel.A <> 0.0 then
begin
Result.R := Result.R / Pixel.A;
Result.G := Result.G / Pixel.A;
Result.B := Result.B / Pixel.A;
end
else
begin
Result.R := 0;
Result.G := 0;
Result.B := 0;
end;
end;
{ TImagingCanvas class implementation }
constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
@ -1175,6 +1261,98 @@ begin
end;
end;
procedure TImagingCanvas.FloodFill(X, Y: Integer; BoundaryFillMode: Boolean);
var
Stack: array of TPoint;
StackPos, Y1: Integer;
OldColor: TColor32;
SpanLeft, SpanRight: Boolean;
procedure Push(AX, AY: Integer);
begin
if StackPos < High(Stack) then
begin
Inc(StackPos);
Stack[StackPos].X := AX;
Stack[StackPos].Y := AY;
end
else
begin
SetLength(Stack, Length(Stack) + FPData.Width);
Push(AX, AY);
end;
end;
function Pop(out AX, AY: Integer): Boolean;
begin
if StackPos > 0 then
begin
AX := Stack[StackPos].X;
AY := Stack[StackPos].Y;
Dec(StackPos);
Result := True;
end
else
Result := False;
end;
function Compare(AX, AY: Integer): Boolean;
var
Color: TColor32;
begin
Color := GetPixel32(AX, AY);
if BoundaryFillMode then
Result := (Color <> FFillColor32) and (Color <> FPenColor32)
else
Result := Color = OldColor;
end;
begin
// Scanline Floodfill Algorithm With Stack
// http://student.kuleuven.be/~m0216922/CG/floodfill.html
if not PtInRect(FClipRect, Point(X, Y)) then Exit;
SetLength(Stack, FPData.Width * 4);
StackPos := 0;
OldColor := GetPixel32(X, Y);
Push(X, Y);
while Pop(X, Y) do
begin
Y1 := Y;
while (Y1 >= FClipRect.Top) and Compare(X, Y1) do
Dec(Y1);
Inc(Y1);
SpanLeft := False;
SpanRight := False;
while (Y1 < FClipRect.Bottom) and Compare(X, Y1) do
begin
SetPixel32(X, Y1, FFillColor32);
if not SpanLeft and (X > FClipRect.Left) and Compare(X - 1, Y1) then
begin
Push(X - 1, Y1);
SpanLeft := True;
end
else if SpanLeft and (X > FClipRect.Left) and not Compare(X - 1, Y1) then
SpanLeft := False
else if not SpanRight and (X < FClipRect.Right - 1) and Compare(X + 1, Y1)then
begin
Push(X + 1, Y1);
SpanRight := True;
end
else if SpanRight and (X < FClipRect.Right - 1) and not Compare(X + 1, Y1) then
SpanRight := False;
Inc(Y1);
end;
end;
end;
procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor,
DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
@ -1533,7 +1711,7 @@ end;
procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
begin
PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
Brightness / 100, 0.0);
Brightness / 100, 0);
end;
procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single);
@ -1551,6 +1729,98 @@ begin
PointTransform(TransformThreshold, Red, Green, Blue);
end;
procedure TImagingCanvas.AdjustColorLevels(BlackPoint, WhitePoint, MidPoint: Single);
begin
PointTransform(TransformLevels, BlackPoint, WhitePoint, 1.0 / MidPoint);
end;
procedure TImagingCanvas.PremultiplyAlpha;
begin
PointTransform(TransformPremultiplyAlpha, 0, 0, 0);
end;
procedure TImagingCanvas.UnPremultiplyAlpha;
begin
PointTransform(TransformUnPremultiplyAlpha, 0, 0, 0);
end;
procedure TImagingCanvas.GetHistogram(out Red, Green, Blue, Alpha,
Gray: THistogramArray);
var
X, Y, Bpp: Integer;
PixPointer: PByte;
Color32: TColor32Rec;
begin
FillChar(Red, SizeOf(Red), 0);
FillChar(Green, SizeOf(Green), 0);
FillChar(Blue, SizeOf(Blue), 0);
FillChar(Alpha, SizeOf(Alpha), 0);
FillChar(Gray, SizeOf(Gray), 0);
Bpp := FFormatInfo.BytesPerPixel;
for Y := FClipRect.Top to FClipRect.Bottom - 1 do
begin
PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
for X := FClipRect.Left to FClipRect.Right - 1 do
begin
Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
Inc(Red[Color32.R]);
Inc(Green[Color32.G]);
Inc(Blue[Color32.B]);
Inc(Alpha[Color32.A]);
Inc(Gray[Round(GrayConv.R * Color32.R + GrayConv.G * Color32.G + GrayConv.B * Color32.B)]);
Inc(PixPointer, Bpp);
end;
end;
end;
procedure TImagingCanvas.FillChannel(ChannelId: Integer; NewChannelValue: Byte);
var
X, Y, Bpp: Integer;
PixPointer: PByte;
Color32: TColor32Rec;
begin
Bpp := FFormatInfo.BytesPerPixel;
for Y := FClipRect.Top to FClipRect.Bottom - 1 do
begin
PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
for X := FClipRect.Left to FClipRect.Right - 1 do
begin
Color32 := FFormatInfo.GetPixel32(PixPointer, @FFormatInfo, FPData.Palette);
Color32.Channels[ChannelId] := NewChannelValue;
FFormatInfo.SetPixel32(PixPointer, @FFormatInfo, FPData.Palette, Color32);
Inc(PixPointer, Bpp);
end;
end;
end;
procedure TImagingCanvas.FillChannelFP(ChannelId: Integer; NewChannelValue: Single);
var
X, Y, Bpp: Integer;
PixPointer: PByte;
ColorFP: TColorFPRec;
begin
Bpp := FFormatInfo.BytesPerPixel;
for Y := FClipRect.Top to FClipRect.Bottom - 1 do
begin
PixPointer := @PByteArray(FPData.Bits)[Y * FPData.Width * Bpp + FClipRect.Left * Bpp];
for X := FClipRect.Left to FClipRect.Right - 1 do
begin
ColorFP := FFormatInfo.GetPixelFP(PixPointer, @FFormatInfo, FPData.Palette);
ColorFP.Channels[ChannelId] := NewChannelValue;
FFormatInfo.SetPixelFP(PixPointer, @FFormatInfo, FPData.Palette, ColorFP);
Inc(PixPointer, Bpp);
end;
end;
end;
class function TImagingCanvas.GetSupportedFormats: TImageFormats;
begin
Result := [ifIndex8..Pred(ifDXT1)];
@ -1564,6 +1834,55 @@ begin
inherited Destroy;
end;
procedure TFastARGB32Canvas.AlphaBlendPixels(SrcPix, DestPix: PColor32Rec);
var
SrcAlpha, DestAlpha, FinalAlpha: Integer;
begin
FinalAlpha := SrcPix.A + 1 + (DestPix.A * (256 - SrcPix.A)) shr 8;
if FinalAlpha = 0 then
SrcAlpha := 0
else
SrcAlpha := (SrcPix.A shl 8) div FinalAlpha;
DestAlpha := 256 - SrcAlpha;
DestPix.A := ClampToByte(FinalAlpha);
DestPix.R := (SrcPix.R * SrcAlpha + DestPix.R * DestAlpha) shr 8;
DestPix.G := (SrcPix.G * SrcAlpha + DestPix.G * DestAlpha) shr 8;
DestPix.B := (SrcPix.B * SrcAlpha + DestPix.B * DestAlpha) shr 8;
end;
procedure TFastARGB32Canvas.DrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer);
var
X, Y, SrcX, SrcY, Width, Height: Integer;
SrcPix, DestPix: PColor32Rec;
begin
if DestCanvas.ClassType <> Self.ClassType then
begin
inherited;
Exit;
end;
SrcX := SrcRect.Left;
SrcY := SrcRect.Top;
Width := SrcRect.Right - SrcRect.Left;
Height := SrcRect.Bottom - SrcRect.Top;
ClipCopyBounds(SrcX, SrcY, Width, Height, DestX, DestY,
FPData.Width, FPData.Height, DestCanvas.ClipRect);
for Y := 0 to Height - 1 do
begin
SrcPix := @FScanlines[SrcY + Y, SrcX];
DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + Y, DestX];
for X := 0 to Width - 1 do
begin
AlphaBlendPixels(SrcPix, DestPix);
Inc(SrcPix);
Inc(DestPix);
end;
end;
end;
function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32;
begin
Result := FScanlines[Y, X].Color;
@ -1578,6 +1897,189 @@ begin
end;
end;
procedure TFastARGB32Canvas.StretchDrawAlpha(const SrcRect: TRect;
DestCanvas: TImagingCanvas; const DestRect: TRect; Filter: TResizeFilter);
var
X, Y, ScaleX, ScaleY, Yp, Xp, Weight1, Weight2, Weight3, Weight4,
FracX, FracY, InvFracY, T1, T2: Integer;
SrcX, SrcY, SrcWidth, SrcHeight: Integer;
DestX, DestY, DestWidth, DestHeight: Integer;
SrcLine, SrcLine2: PColor32RecArray;
DestPix: PColor32Rec;
Accum: TColor32Rec;
begin
if (Filter = rfBicubic) or (DestCanvas.ClassType <> Self.ClassType) then
begin
inherited;
Exit;
end;
SrcX := SrcRect.Left;
SrcY := SrcRect.Top;
SrcWidth := SrcRect.Right - SrcRect.Left;
SrcHeight := SrcRect.Bottom - SrcRect.Top;
DestX := DestRect.Left;
DestY := DestRect.Top;
DestWidth := DestRect.Right - DestRect.Left;
DestHeight := DestRect.Bottom - DestRect.Top;
// Clip src and dst rects
ClipStretchBounds(SrcX, SrcY, SrcWidth, SrcHeight, DestX, DestY, DestWidth, DestHeight,
FPData.Width, FPData.Height, DestCanvas.ClipRect);
ScaleX := (SrcWidth shl 16) div DestWidth;
ScaleY := (SrcHeight shl 16) div DestHeight;
// Nearest and linear filtering using fixed point math
if Filter = rfNearest then
begin
Yp := 0;
for Y := DestY to DestY + DestHeight - 1 do
begin
Xp := 0;
SrcLine := @FScanlines[SrcY + Yp shr 16, SrcX];
DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
for X := 0 to DestWidth - 1 do
begin
AlphaBlendPixels(@SrcLine[Xp shr 16], DestPix);
Inc(DestPix);
Inc(Xp, ScaleX);
end;
Inc(Yp, ScaleY);
end;
end
else
begin
Yp := (ScaleY shr 1) - $8000;
for Y := DestY to DestY + DestHeight - 1 do
begin
DestPix := @TFastARGB32Canvas(DestCanvas).FScanlines[Y, DestX];
if Yp < 0 then
begin
T1 := 0;
FracY := 0;
InvFracY := $10000;
end
else
begin
T1 := Yp shr 16;
FracY := Yp and $FFFF;
InvFracY := (not Yp and $FFFF) + 1;
end;
T2 := Iff(T1 < SrcHeight - 1, T1 + 1, T1);
SrcLine := @Scanlines[T1 + SrcY, SrcX];
SrcLine2 := @Scanlines[T2 + SrcY, SrcX];
Xp := (ScaleX shr 1) - $8000;
for X := 0 to DestWidth - 1 do
begin
if Xp < 0 then
begin
T1 := 0;
FracX := 0;
end
else
begin
T1 := Xp shr 16;
FracX := Xp and $FFFF;
end;
T2 := Iff(T1 < SrcWidth - 1, T1 + 1, T1);
Weight2:= (Cardinal(InvFracY) * FracX) shr 16; // cast to Card, Int can overflow gere
Weight1:= InvFracY - Weight2;
Weight4:= (Cardinal(FracY) * FracX) shr 16;
Weight3:= FracY - Weight4;
Accum.B := (SrcLine[T1].B * Weight1 + SrcLine[T2].B * Weight2 +
SrcLine2[T1].B * Weight3 + SrcLine2[T2].B * Weight4 + $8000) shr 16;
Accum.G := (SrcLine[T1].G * Weight1 + SrcLine[T2].G * Weight2 +
SrcLine2[T1].G * Weight3 + SrcLine2[T2].G * Weight4 + $8000) shr 16;
Accum.R := (SrcLine[T1].R * Weight1 + SrcLine[T2].R * Weight2 +
SrcLine2[T1].R * Weight3 + SrcLine2[T2].R * Weight4 + $8000) shr 16;
Accum.A := (SrcLine[T1].A * Weight1 + SrcLine[T2].A * Weight2 +
SrcLine2[T1].A * Weight3 + SrcLine2[T2].A * Weight4 + $8000) shr 16;
AlphaBlendPixels(@Accum, DestPix);
Inc(Xp, ScaleX);
Inc(DestPix);
end;
Inc(Yp, ScaleY);
end;
end;
{
// Generate mapping tables
MapX := BuildMappingTable(DestX, DestX + DestWidth, SrcX, SrcX + SrcWidth,
FPData.Width, FilterFunction, Radius, False);
MapY := BuildMappingTable(DestY, DestY + DestHeight, SrcY, SrcY + SrcHeight,
FPData.Height, FilterFunction, Radius, False);
FindExtremes(MapX, XMinimum, XMaximum);
SetLength(LineBuffer, XMaximum - XMinimum + 1);
for J := 0 to DestHeight - 1 do
begin
ClusterY := MapY[J];
for X := XMinimum to XMaximum do
begin
AccumA := 0;
AccumR := 0;
AccumG := 0;
AccumB := 0;
for Y := 0 to Length(ClusterY) - 1 do
begin
Weight := Round(ClusterY[Y].Weight * 256);
SrcColor := FScanlines[ClusterY[Y].Pos, X];
AccumB := AccumB + SrcColor.B * Weight;
AccumG := AccumG + SrcColor.G * Weight;
AccumR := AccumR + SrcColor.R * Weight;
AccumA := AccumA + SrcColor.A * Weight;
end;
with LineBuffer[X - XMinimum] do
begin
A := AccumA;
R := AccumR;
G := AccumG;
B := AccumB;
end;
end;
DestPtr := @TFastARGB32Canvas(DestCanvas).FScanlines[DestY + J, DestX];
for I := 0 to DestWidth - 1 do
begin
ClusterX := MapX[I];
AccumA := 0;
AccumR := 0;
AccumG := 0;
AccumB := 0;
for X := 0 to Length(ClusterX) - 1 do
begin
Weight := Round(ClusterX[X].Weight * 256);
with LineBuffer[ClusterX[X].Pos - XMinimum] do
begin
AccumB := AccumB + B * Weight;
AccumG := AccumG + G * Weight;
AccumR := AccumR + R * Weight;
AccumA := AccumA + A * Weight;
end;
end;
AccumA := ClampInt(AccumA, 0, $00FF0000);
AccumR := ClampInt(AccumR, 0, $00FF0000);
AccumG := ClampInt(AccumG, 0, $00FF0000);
AccumB := ClampInt(AccumB, 0, $00FF0000);
SrcColor.Color := (Cardinal(AccumA and $00FF0000) shl 8) or
(AccumR and $00FF0000) or ((AccumG and $00FF0000) shr 8) or ((AccumB and $00FF0000) shr 16);
AlphaBlendPixels(@SrcColor, DestPtr);
Inc(DestPtr);
end;
end; }
end;
procedure TFastARGB32Canvas.UpdateCanvasState;
var
I: LongInt;
@ -1601,6 +2103,24 @@ begin
Result := [ifA8R8G8B8];
end;
procedure TFastARGB32Canvas.InvertColors;
var
X, Y: Integer;
PixPtr: PColor32Rec;
begin
for Y := FClipRect.Top to FClipRect.Bottom - 1 do
begin
PixPtr := @FScanlines[Y, FClipRect.Left];
for X := FClipRect.Left to FClipRect.Right - 1 do
begin
PixPtr.R := not PixPtr.R;
PixPtr.G := not PixPtr.G;
PixPtr.B := not PixPtr.B;
Inc(PixPtr);
end;
end;
end;
initialization
RegisterCanvas(TFastARGB32Canvas);
@ -1616,6 +2136,19 @@ finalization
- add blending (*image and object drawing)
- more objects (arc, polygon)
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added some methods to TFastARGB32Canvas (InvertColors, DrawAlpha/StretchDrawAlpha)
- Fixed DrawAlpha/StretchDrawAlpha destination alpha calculation.
- Added PremultiplyAlpha and UnPremultiplyAlpha methods.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Added FillChannel methods.
- Added FloodFill method.
- Added GetHistogram method.
- Fixed "Invalid FP operation" in AdjustColorLevels in FPC compiled exes
(thanks to Carlos González).
- Added TImagingCanvas.AdjustColorLevels method.
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed error that could cause AV in linear and nonlinear filters.
- Added blended rect filling function FillRectBlend.

View File

@ -1,5 +1,5 @@
{
$Id: ImagingClasses.pas 124 2008-04-21 09:47:07Z galfar $
$Id: ImagingClasses.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -68,7 +68,7 @@ type
constructor CreateFromImage(AImage: TBaseImage);
destructor Destroy; override;
{ Returns info about current image.}
function ToString: string;
function ToString: string; {$IF Defined(DCC) and (CompilerVersion >= 20.0)}override;{$IFEND}
{ Creates a new image data with the given size and format. Old image
data is lost. Works only for the current image of TMultiImage.}
@ -81,8 +81,8 @@ type
{ Mirrors current image. Reverses the image along its vertical axis the left
side becomes the right and vice versa.}
procedure Mirror;
{ Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise.}
procedure Rotate(Angle: LongInt);
{ Rotates image by Angle degrees counterclockwise.}
procedure Rotate(Angle: Single);
{ Copies rectangular part of SrcImage to DstImage. No blending is performed -
alpha is simply copied to destination image. Operates also with
negative X and Y coordinates.
@ -451,7 +451,7 @@ begin
DoPixelsChanged;
end;
procedure TBaseImage.Rotate(Angle: LongInt);
procedure TBaseImage.Rotate(Angle: Single);
begin
if Valid and Imaging.RotateImage(FPData^, Angle) then
DoPixelsChanged;

View File

@ -1,5 +1,5 @@
{
$Id: ImagingColors.pas 74 2007-03-12 15:04:04Z galfar $
$Id: ImagingColors.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -68,6 +68,12 @@ procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
{ Converts CMYK to RGB color.}
procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word);
{ Converts RGB color to YCoCg.}
procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
{ Converts YCoCg to RGB color.}
procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
implementation
procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte);
@ -149,11 +155,17 @@ procedure RGBToCMYK(R, G, B: Byte; var C, M, Y, K: Byte);
begin
RGBToCMY(R, G, B, C, M, Y);
K := Min(C, Min(M, Y));
if K > 0 then
if K = 255 then
begin
C := C - K;
M := M - K;
Y := Y - K;
C := 0;
M := 0;
Y := 0;
end
else
begin
C := ClampToByte(Round((C - K) / (255 - K) * 255));
M := ClampToByte(Round((M - K) / (255 - K) * 255));
Y := ClampToByte(Round((Y - K) / (255 - K) * 255));
end;
end;
@ -168,11 +180,17 @@ procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
begin
RGBToCMY16(R, G, B, C, M, Y);
K := Min(C, Min(M, Y));
if K > 0 then
if K = 65535 then
begin
C := C - K;
M := M - K;
Y := Y - K;
C := 0;
M := 0;
Y := 0;
end
else
begin
C := ClampToWord(Round((C - K) / (65535 - K) * 65535));
M := ClampToWord(Round((M - K) / (65535 - K) * 65535));
Y := ClampToWord(Round((Y - K) / (65535 - K) * 65535));
end;
end;
@ -183,12 +201,35 @@ begin
B := 65535 - (Y - MulDiv(Y, K, 65535) + K);
end;
procedure RGBToYCoCg(R, G, B: Byte; var Y, Co, Cg: Byte);
begin
// C and Delphi's SHR behaviour differs for negative numbers, use div instead.
Y := ClampToByte(( R + G shl 1 + B + 2) div 4);
Co := ClampToByte(( R shl 1 - B shl 1 + 2) div 4 + 128);
Cg := ClampToByte((-R + G shl 1 - B + 2) div 4 + 128);
end;
procedure YCoCgToRGB(Y, Co, Cg: Byte; var R, G, B: Byte);
var
CoInt, CgInt: Integer;
begin
CoInt := Co - 128;
CgInt := Cg - 128;
R := ClampToByte(Y + CoInt - CgInt);
G := ClampToByte(Y + CgInt);
B := ClampToByte(Y - CoInt - CgInt);
end;
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added RGB<>YCoCg conversion functions.
- Fixed RGB>>CMYK conversions.
-- 0.23 Changes/Bug Fixes -----------------------------------
- Added RGB<>CMY(K) converion functions for 16 bit channels
(needed by PSD loading code).

View File

@ -1,5 +1,5 @@
{
$Id: ImagingComponents.pas 132 2008-08-27 20:37:38Z galfar $
$Id: ImagingComponents.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -26,7 +26,7 @@
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html
}
{ This unit contains VCL/CLX/LCL TGraphic descendant which uses Imaging library
{ This unit contains VCL/LCL TGraphic descendant which uses Imaging library
for saving and loading.}
unit ImagingComponents;
@ -34,6 +34,17 @@ unit ImagingComponents;
interface
{$IFDEF LCL}
{$DEFINE COMPONENT_SET_LCL}
{$ENDIF}
{$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
// If no component sets should be used just include empty unit.
//DOC-IGNORE-BEGIN
implementation
//DOC-IGNORE-END
{$ELSE}
uses
SysUtils, Types, Classes,
{$IFDEF MSWINDOWS}
@ -42,10 +53,6 @@ uses
{$IFDEF COMPONENT_SET_VCL}
Graphics,
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
Qt,
QGraphics,
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
InterfaceBase,
GraphType,
@ -71,6 +78,8 @@ type
procedure ReadDataFromStream(Stream: TStream); virtual;
procedure AssignTo(Dest: TPersistent); override;
public
constructor Create; override;
{ Loads new image from the stream. It can load all image
file formats supported by Imaging (and enabled of course)
even though it is called by descendant class capable of
@ -114,8 +123,7 @@ type
{ Returns file extensions of this graphic class.}
class function GetFileExtensions: string; override;
{ Returns default MIME type of this graphic class.}
function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
//function GetDefaultMimeType: string; override;
function GetMimeType: string; override;
{$ENDIF}
{ Default (the most common) file extension of this graphic class.}
property DefaultFileExt: string read FDefaultFileExt;
@ -123,7 +131,7 @@ type
TImagingGraphicForSaveClass = class of TImagingGraphicForSave;
{$IFDEF LINK_BITMAP}
{$IFNDEF DONT_LINK_BITMAP}
{ TImagingGraphic descendant for loading/saving Windows bitmaps.
VCL/CLX/LCL all have native support for bitmaps so you might
want to disable this class (although you can save bitmaps with
@ -140,7 +148,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_JPEG}
{$IFNDEF DONT_LINK_JPEG}
{ TImagingGraphic descendant for loading/saving JPEG images.}
TImagingJpeg = class(TImagingGraphicForSave)
protected
@ -151,8 +159,7 @@ type
procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
function GetDefaultMimeType: string; override;
function GetMimeType: string; override;
{$ENDIF}
{ See ImagingJpegQuality option for details.}
property Quality: LongInt read FQuality write FQuality;
@ -161,7 +168,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_PNG}
{$IFNDEF DONT_LINK_PNG}
{ TImagingGraphic descendant for loading/saving PNG images.}
TImagingPNG = class(TImagingGraphicForSave)
protected
@ -178,7 +185,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_GIF}
{$IFNDEF DONT_LINK_GIF}
{ TImagingGraphic descendant for loading/saving GIF images.}
TImagingGIF = class(TImagingGraphicForSave)
public
@ -186,7 +193,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_TARGA}
{$IFNDEF DONT_LINK_TARGA}
{ TImagingGraphic descendant for loading/saving Targa images.}
TImagingTarga = class(TImagingGraphicForSave)
protected
@ -200,7 +207,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_DDS}
{$IFNDEF DONT_LINK_DDS}
{ Compresssion type used when saving DDS files by TImagingDds.}
TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
@ -218,7 +225,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_MNG}
{$IFNDEF DONT_LINK_MNG}
{ TImagingGraphic descendant for loading/saving MNG images.}
TImagingMNG = class(TImagingGraphicForSave)
protected
@ -233,8 +240,7 @@ type
procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here
function GetDefaultMimeType: string; override;
function GetMimeType: string; override;
{$ENDIF}
{ See ImagingMNGLossyCompression option for details.}
property LossyCompression: Boolean read FLossyCompression write FLossyCompression;
@ -251,7 +257,7 @@ type
end;
{$ENDIF}
{$IFDEF LINK_JNG}
{$IFNDEF DONT_LINK_JNG}
{ TImagingGraphic descendant for loading/saving JNG images.}
TImagingJNG = class(TImagingGraphicForSave)
protected
@ -328,29 +334,29 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T
implementation
uses
{$IF Defined(UNIX) and Defined(COMPONENT_SET_LCL)}
{$IFDEF LCLGTK2}
{$IF Defined(LCL)}
{$IF Defined(LCLGTK2)}
GLib2, GDK2, GTK2, GTKDef, GTKProc,
{$ELSE}
{$ELSEIF Defined(LCLGTK)}
GDK, GTK, GTKDef, GTKProc,
{$ENDIF}
{$IFEND}
{$IFEND}
{$IFDEF LINK_BITMAP}
{$IFNDEF DONT_LINK_BITMAP}
ImagingBitmap,
{$ENDIF}
{$IFDEF LINK_JPEG}
{$IFNDEF DONT_LINK_JPEG}
ImagingJpeg,
{$ENDIF}
{$IFDEF LINK_GIF}
{$IFNDEF DONT_LINK_GIF}
ImagingGif,
{$ENDIF}
{$IFDEF LINK_TARGA}
{$IFNDEF DONT_LINK_TARGA}
ImagingTarga,
{$ENDIF}
{$IFDEF LINK_DDS}
{$IFNDEF DONT_LINK_DDS}
ImagingDds,
{$ENDIF}
{$IF Defined(LINK_PNG) or Defined(LINK_MNG) or Defined(LINK_JNG)}
{$IF not Defined(DONT_LINK_PNG) or not Defined(DONT_LINK_MNG) or not Defined(DONT_LINK_JNG)}
ImagingNetworkGraphics,
{$IFEND}
ImagingUtility;
@ -359,9 +365,10 @@ resourcestring
SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p';
SBadFormatDisplay = 'Unsupported image format passed';
SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
SImagingGraphicName = 'Imaging Graphic AllInOne';
{ Registers types to VCL/CLX/LCL.}
{ Registers types to VCL/LCL.}
procedure RegisterTypes;
var
I: LongInt;
@ -387,87 +394,85 @@ var
begin
for I := Imaging.GetFileFormatCount - 1 downto 0 do
RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGraphic);{$ENDIF}
Classes.RegisterClass(TImagingGraphic);
{$IFDEF LINK_TARGA}
{$IFNDEF DONT_LINK_TARGA}
RegisterFileFormat(TImagingTarga);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingTarga);{$ENDIF}
Classes.RegisterClass(TImagingTarga);
{$ENDIF}
{$IFDEF LINK_DDS}
{$IFNDEF DONT_LINK_DDS}
RegisterFileFormat(TImagingDDS);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingDDS);{$ENDIF}
Classes.RegisterClass(TImagingDDS);
{$ENDIF}
{$IFDEF LINK_JNG}
{$IFNDEF DONT_LINK_JNG}
RegisterFileFormat(TImagingJNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJNG);{$ENDIF}
Classes.RegisterClass(TImagingJNG);
{$ENDIF}
{$IFDEF LINK_MNG}
{$IFNDEF DONT_LINK_MNG}
RegisterFileFormat(TImagingMNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingMNG);{$ENDIF}
Classes.RegisterClass(TImagingMNG);
{$ENDIF}
{$IFDEF LINK_GIF}
{$IFNDEF DONT_LINK_GIF}
RegisterFileFormat(TImagingGIF);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGIF);{$ENDIF}
Classes.RegisterClass(TImagingGIF);
{$ENDIF}
{$IFDEF LINK_PNG}
{$IFNDEF DONT_LINK_PNG}
{$IFDEF COMPONENT_SET_LCL}
// Unregister Lazarus´ default PNG loader which crashes on some PNG files
TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
{$ENDIF}
RegisterFileFormat(TImagingPNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingPNG);{$ENDIF}
Classes.RegisterClass(TImagingPNG);
{$ENDIF}
{$IFDEF LINK_JPEG}
{$IFNDEF DONT_LINK_JPEG}
RegisterFileFormat(TImagingJpeg);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJpeg);{$ENDIF}
Classes.RegisterClass(TImagingJpeg);
{$ENDIF}
{$IFDEF LINK_BITMAP}
{$IFNDEF DONT_LINK_BITMAP}
RegisterFileFormat(TImagingBitmap);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingBitmap);{$ENDIF}
Classes.RegisterClass(TImagingBitmap);
{$ENDIF}
end;
{ Unregisters types from VCL/CLX/LCL.}
{ Unregisters types from VCL/LCL.}
procedure UnRegisterTypes;
begin
{$IFDEF LINK_BITMAP}
{$IFNDEF DONT_LINK_BITMAP}
TPicture.UnregisterGraphicClass(TImagingBitmap);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingBitmap);{$ENDIF}
Classes.UnRegisterClass(TImagingBitmap);
{$ENDIF}
{$IFDEF LINK_JPEG}
{$IFNDEF DONT_LINK_JPEG}
TPicture.UnregisterGraphicClass(TImagingJpeg);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingJpeg);{$ENDIF}
Classes.UnRegisterClass(TImagingJpeg);
{$ENDIF}
{$IFDEF LINK_PNG}
{$IFNDEF DONT_LINK_PNG}
TPicture.UnregisterGraphicClass(TImagingPNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingPNG);{$ENDIF}
Classes.UnRegisterClass(TImagingPNG);
{$ENDIF}
{$IFDEF LINK_GIF}
{$IFNDEF DONT_LINK_GIF}
TPicture.UnregisterGraphicClass(TImagingGIF);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGIF);{$ENDIF}
Classes.UnRegisterClass(TImagingGIF);
{$ENDIF}
{$IFDEF LINK_TARGA}
{$IFNDEF DONT_LINK_TARGA}
TPicture.UnregisterGraphicClass(TImagingTarga);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingTarga);{$ENDIF}
Classes.UnRegisterClass(TImagingTarga);
{$ENDIF}
{$IFDEF LINK_DDS}
{$IFNDEF DONT_LINK_DDS}
TPicture.UnregisterGraphicClass(TImagingDDS);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingDDS);{$ENDIF}
Classes.UnRegisterClass(TImagingDDS);
{$ENDIF}
TPicture.UnregisterGraphicClass(TImagingGraphic);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGraphic);{$ENDIF}
Classes.UnRegisterClass(TImagingGraphic);
end;
function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
begin
case Format of
{$IFNDEF COMPONENT_SET_LCL}
{$IFDEF COMPONENT_SET_VCL}
ifIndex8: Result := pf8bit;
{$ENDIF}
{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))}
ifR5G6B5: Result := pf16bit;
ifR8G8B8: Result := pf24bit;
{$IFEND}
{$ENDIF}
ifA8R8G8B8,
ifX8R8G8B8: Result := pf32bit;
else
@ -479,11 +484,9 @@ function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
begin
case Format of
pf8bit: Result := ifIndex8;
{$IFNDEF COMPONENT_SET_CLX}
pf15bit: Result := ifA1R5G5B5;
pf16bit: Result := ifR5G6B5;
pf24bit: Result := ifR8G8B8;
{$ENDIF}
pf32bit: Result := ifA8R8G8B8;
else
Result := ifUnknown;
@ -499,9 +502,6 @@ var
{$IFDEF COMPONENT_SET_VCL}
LogPalette: TMaxLogPalette;
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
ColorTable: PPalette32;
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
RawImage: TRawImage;
ImgHandle, ImgMaskHandle: HBitmap;
@ -517,19 +517,16 @@ begin
if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
Imaging.ConvertImage(WorkData, ifA8R8G8B8)
else
{$IFNDEF COMPONENT_SET_LCL}
{$IFDEF COMPONENT_SET_VCL}
if Info.IsIndexed or Info.HasGrayChannel then
Imaging.ConvertImage(WorkData, ifIndex8)
else if Info.UsePixelFormat then
Imaging.ConvertImage(WorkData, ifR5G6B5)
else
{$ENDIF}
{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))}
if Info.UsePixelFormat then
Imaging.ConvertImage(WorkData, ifR5G6B5)
else
Imaging.ConvertImage(WorkData, ifR8G8B8);
Imaging.ConvertImage(WorkData, ifR8G8B8);
{$ELSE}
Imaging.ConvertImage(WorkData, ifA8R8G8B8);
{$IFEND}
{$ENDIF}
PF := DataFormatToPixelFormat(WorkData.Format);
GetImageFormatInfo(WorkData.Format, Info);
@ -565,27 +562,13 @@ begin
// Copy scanlines
for I := 0 to WorkData.Height - 1 do
Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
Bitmap.Width := WorkData.Width;
Bitmap.Height := WorkData.Height;
Bitmap.PixelFormat := PF;
if (PF = pf8bit) and (WorkData.Palette <> nil) then
begin
// Copy palette
ColorTable := Bitmap.ColorTable;
for I := 0 to Info.PaletteEntries - 1 do
with ColorTable[I] do
begin
R := WorkData.Palette[I].R;
G := WorkData.Palette[I].G;
B := WorkData.Palette[I].B;
end;
end;
// Copy scanlines
for I := 0 to WorkData.Height - 1 do
Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes);
// Delphi 2009 and newer support alpha transparency fro TBitmap
{$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
if Bitmap.PixelFormat = pf32bit then
Bitmap.AlphaFormat := afDefined;
{$IFEND}
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
// Create 32bit raw image from image data
@ -594,9 +577,9 @@ begin
begin
Width := WorkData.Width;
Height := WorkData.Height;
BitsPerPixel := Info.BytesPerPixel * 8;
BitsPerPixel := 32;
Format := ricfRGBA;
LineEnd := rileByteBoundary;
LineEnd := rileDWordBoundary;
BitOrder := riboBitsInOrder;
ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom;
@ -608,14 +591,13 @@ begin
RedShift := 16;
GreenShift := 8;
BlueShift := 0;
Depth := 24;
Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon)
end;
RawImage.Data := WorkData.Bits;
RawImage.DataSize := WorkData.Size;
// Create bitmap from raw image
{ If you get complitation error here upgrade to Lazarus 0.9.24+ }
if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle, False) then
if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then
begin
Bitmap.Handle := ImgHandle;
Bitmap.MaskHandle := ImgMaskHandle;
@ -634,9 +616,6 @@ var
Colors: Word;
LogPalette: TMaxLogPalette;
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
ColorTable: PPalette32;
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
RawImage: TRawImage;
LineLazBytes: LongInt;
@ -650,7 +629,6 @@ begin
// trough RawImage api and cannot be changed to mirror some Imaging format
// (so formats with no coresponding Imaging format cannot be saved now).
{ If you get complitation error here upgrade to Lazarus 0.9.24+ }
if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
case RawImage.Description.BitsPerPixel of
8: Format := ifIndex8;
@ -707,28 +685,9 @@ begin
for I := 0 to Data.Height - 1 do
Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
if Format = ifIndex8 then
begin
// Copy palette
ColorTable := Bitmap.ColorTable;
for I := 0 to Info.PaletteEntries - 1 do
with ColorTable[I] do
begin
Data.Palette[I].A := $FF;
Data.Palette[I].R := R;
Data.Palette[I].G := G;
Data.Palette[I].B := B;
end;
end;
// Copy scanlines
for I := 0 to Data.Height - 1 do
Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
// Get raw image from bitmap (mask handle must be 0 or expect violations)
if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then // uncommnet for Laz 0.9.25 if you get error here
//if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then
if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, nil) then
begin
LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
RawImage.Description.LineEnd);
@ -757,6 +716,7 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T
var
OldMode: Integer;
BitmapInfo: Windows.TBitmapInfo;
Bmp: TBitmap;
begin
if TestImage(ImageData) then
begin
@ -780,10 +740,22 @@ begin
end;
try
with SrcRect, ImageData do
Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
with SrcRect, ImageData do
if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left,
Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY);
Top, Right - Left, Bottom - Top, Bits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY) <> Height then
begin
// StretchDIBits may fail on some ocassions (error 487, http://support.microsoft.com/kb/269585).
// This fallback is slow but works every time. Thanks to Sergey Galezdinov for the fix.
Bmp := TBitmap.Create;
try
ConvertDataToBitmap(ImageData, Bmp);
StretchBlt(DC, DstRect.Left, DstRect.Top, DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top,
Bmp.Canvas.Handle, 0, 0, Width, Height, SRCCOPY);
finally
Bmp.Free;
end;
end;
finally
Windows.SetStretchBltMode(DC, OldMode);
end;
@ -792,50 +764,21 @@ end;
{$ENDIF}
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect);
{$IF Defined(MSWINDOWS) and not Defined(COMPONENT_SET_CLX)}
{$IF Defined(DCC) or Defined(LCLWIN32)} // Delphi or LCL Win32
begin
DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
end;
{$ELSEIF Defined(COMPONENT_SET_CLX)}
var
Bitmap: TBitmap;
//Handle: LongWord;
begin
(*
// It would be nice if this worked:
DstCanvas.Start;
Handle := QPainter_handle(DstCanvas.Handle);
{$IFDEF MSWINDOWS}
DisplayImageDataOnDC(Handle, DstRect, ImageData, SrcRect);
{$ELSE}
DisplayImageDataOnX(Handle, DstRect, ImageData, SrcRect);
{$ENDIF}
DstCanvas.Stop;
*)
Bitmap := TBitmap.Create;
try
ConvertDataToBitmap(ImageData, Bitmap);
DstCanvas.CopyRect(DstRect, Bitmap.Canvas, SrcRect);
finally
Bitmap.Free;
end;
end;
{$ELSEIF Defined(UNIX) and Defined(COMPONENT_SET_LCL)}
{$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)}
procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; ImageData: TImageData);
var
P: TPoint;
begin
// If you get compilation errors here with new Lazarus (rev 14368+)
// uncomment commented code and comment the active code below:
P := TGtkDeviceContext(Dest).Offset;
//P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X);
Inc(DstY, P.Y);
gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC,
//gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
end;
@ -890,6 +833,10 @@ begin
end;
end;
end;
{$ELSE}
begin
raise Exception.Create(SUnsupportedLCLWidgetSet);
end;
{$IFEND}
procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage);
@ -911,6 +858,12 @@ end;
{ TImagingGraphic class implementation }
constructor TImagingGraphic.Create;
begin
inherited Create;
PixelFormat := pf24Bit;
end;
procedure TImagingGraphic.LoadFromStream(Stream: TStream);
begin
ReadDataFromStream(Stream);
@ -1020,14 +973,13 @@ begin
Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
end;
function TImagingGraphicForSave.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
//function TImagingGraphicForSave.GetDefaultMimeType: string;
function TImagingGraphicForSave.GetMimeType: string;
begin
Result := 'image/' + FDefaultFileExt;
end;
{$ENDIF}
{$IFDEF LINK_BITMAP}
{$IFNDEF DONT_LINK_BITMAP}
{ TImagingBitmap class implementation }
@ -1051,7 +1003,7 @@ begin
end;
{$ENDIF}
{$IFDEF LINK_JPEG}
{$IFNDEF DONT_LINK_JPEG}
{ TImagingJpeg class implementation }
@ -1068,8 +1020,7 @@ begin
end;
{$IFDEF COMPONENT_SET_LCL}
//function TImagingJpeg.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
function TImagingJpeg.GetDefaultMimeType: string;
function TImagingJpeg.GetMimeType: string;
begin
Result := 'image/jpeg';
end;
@ -1086,7 +1037,7 @@ end;
{$ENDIF}
{$IFDEF LINK_PNG}
{$IFNDEF DONT_LINK_PNG}
{ TImagingPNG class implementation }
@ -1112,7 +1063,7 @@ begin
end;
{$ENDIF}
{$IFDEF LINK_GIF}
{$IFNDEF DONT_LINK_GIF}
{ TImagingGIF class implementation}
@ -1123,7 +1074,7 @@ end;
{$ENDIF}
{$IFDEF LINK_TARGA}
{$IFNDEF DONT_LINK_TARGA}
{ TImagingTarga class implementation }
@ -1147,7 +1098,7 @@ begin
end;
{$ENDIF}
{$IFDEF LINK_DDS}
{$IFNDEF DONT_LINK_DDS}
{ TImagingDDS class implementation }
@ -1180,7 +1131,7 @@ begin
end;
{$ENDIF}
{$IFDEF LINK_MNG}
{$IFNDEF DONT_LINK_MNG}
{ TImagingMNG class implementation }
@ -1201,8 +1152,7 @@ begin
end;
{$IFDEF COMPONENT_SET_LCL}
//function TImagingMNG.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here
function TImagingMNG.GetDefaultMimeType: string;
function TImagingMNG.GetMimeType: string;
begin
Result := 'video/mng';
end;
@ -1222,7 +1172,7 @@ begin
end;
{$ENDIF}
{$IFDEF LINK_JNG}
{$IFNDEF DONT_LINK_JNG}
{ TImagingJNG class implementation }
@ -1259,12 +1209,30 @@ initialization
finalization
UnRegisterTypes;
{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
{
File Notes:
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Setting AlphaFormat property of TBitmap in ConvertDataToBitmap
when using Delphi 2009+.
- Fixed garbled LCL TBitmaps created by ConvertDataToBitmap
in Mac OS X (Carbon).
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Added some more IFDEFs for Lazarus widget sets.
- Removed CLX code.
- GTK version of Unix DisplayImageData only used with LCL GTK so the
the rest of the unit can be used with Qt or other LCL interfaces.
- Fallback mechanism for DisplayImageDataOnDC, it may fail on occasions.
- Changed file format conditional compilation to reflect changes
in LINK symbols.
- Lazarus 0.9.26 compatibility changes.
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
with GTK2 target.

View File

@ -1,5 +1,5 @@
{
$Id: ImagingExport.pas 71 2007-03-08 00:10:10Z galfar $
$Id: ImagingExport.pas 173 2009-09-04 17:05:52Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -52,14 +52,14 @@ function ImTestImage(var Image: TImageData): Boolean; cdecl;
function ImFreeImage(var Image: TImageData): Boolean; cdecl;
{ Look at DetermineFileFormat for details. Ext should have enough space for
result file extension.}
function ImDetermineFileFormat(FileName, Ext: PChar): Boolean; cdecl;
function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean; cdecl;
{ Look at DetermineMemoryFormat for details. Ext should have enough space for
result file extension.}
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean; cdecl;
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean; cdecl;
{ Look at IsFileFormatSupported for details.}
function ImIsFileFormatSupported(FileName: PChar): Boolean; cdecl;
function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
{ Look at EnumFileFormats for details.}
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar;
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
{ Inits image list.}
@ -82,24 +82,24 @@ function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadImageFromFile for details.}
function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean; cdecl;
function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean; cdecl;
{ Look at LoadImageFromMemory for details.}
function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
{ Look at LoadMultiImageFromFile for details.}
function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList): Boolean; cdecl;
function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadMultiImageFromMemory for details.}
function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
var ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveImageToFile for details.}
function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean; cdecl;
function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean; cdecl;
{ Look at SaveImageToMemory for details.}
function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt;
function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean; cdecl;
{ Look at SaveMultiImageToFile for details.}
function ImSaveMultiImageToFile(FileName: PChar; ImageList: TImageDataList): Boolean; cdecl;
function ImSaveMultiImageToFile(FileName: PAnsiChar; ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveMultiImageToMemory for details.}
function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt;
function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean; cdecl;
{ Look at CloneImage for details.}
@ -131,7 +131,7 @@ function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
{ Look at RotateImage for details.}
function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean; cdecl;
function ImRotateImage(var Image: TImageData; Angle: Single): Boolean; cdecl;
{ Look at CopyRect for details.}
function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
@ -262,33 +262,33 @@ begin
end;
end;
function ImDetermineFileFormat(FileName, Ext: PChar): Boolean;
function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
var
S: string;
begin
try
S := Imaging.DetermineFileFormat(FileName);
Result := S <> '';
StrCopy(Ext, PChar(S));
StrCopy(Ext, PAnsiChar(AnsiString(S)));
except
Result := False;
end;
end;
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean;
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
var
S: string;
begin
try
S := Imaging.DetermineMemoryFormat(Data, Size);
Result := S <> '';
StrCopy(Ext, PChar(S));
StrCopy(Ext, PAnsiChar(AnsiString(S)));
except
Result := False;
end;
end;
function ImIsFileFormatSupported(FileName: PChar): Boolean;
function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
begin
try
Result := Imaging.IsFileFormatSupported(FileName);
@ -297,7 +297,7 @@ begin
end;
end;
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PChar;
function ImEnumFileFormats(var Index: LongInt; Name, DefaultExt, Masks: PAnsiChar;
var CanSave, IsMultiImageFormat: Boolean): Boolean;
var
StrName, StrDefaultExt, StrMasks: string;
@ -305,9 +305,9 @@ begin
try
Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
IsMultiImageFormat);
StrCopy(Name, PChar(StrName));
StrCopy(DefaultExt, PChar(StrDefaultExt));
StrCopy(Masks, PChar(StrMasks));
StrCopy(Name, PAnsiChar(AnsiString(StrName)));
StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
except
Result := False;
end;
@ -419,7 +419,7 @@ begin
end;
end;
function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean;
function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
begin
try
Result := Imaging.LoadImageFromFile(FileName, Image);
@ -437,7 +437,7 @@ begin
end;
end;
function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList):
function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
Boolean;
begin
try
@ -460,7 +460,7 @@ begin
end;
end;
function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean;
function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
begin
try
Result := Imaging.SaveImageToFile(FileName, Image);
@ -469,7 +469,7 @@ begin
end;
end;
function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt;
function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean;
begin
try
@ -479,7 +479,7 @@ begin
end;
end;
function ImSaveMultiImageToFile(FileName: PChar;
function ImSaveMultiImageToFile(FileName: PAnsiChar;
ImageList: TImageDataList): Boolean;
begin
try
@ -490,7 +490,7 @@ begin
end;
end;
function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt;
function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean;
begin
try
@ -612,7 +612,7 @@ begin
end;
end;
function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean;
function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
begin
try
Result := Imaging.RotateImage(Image, Angle);
@ -864,6 +864,10 @@ end;
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 ---------------------------------------------------
- changed PChars to PAnsiChars and some more D2009 friendly
casts.
-- 0.19 -----------------------------------------------------
- updated to reflect changes in low level interface (added pixel set/get, ...)
- changed ImInitImage to procedure to reflect change in Imaging.pas

View File

@ -1,5 +1,5 @@
{
$Id: ImagingFormats.pas 129 2008-08-06 20:01:30Z galfar $
$Id: ImagingFormats.pas 176 2009-10-12 10:53:17Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -388,6 +388,7 @@ var
BytesPerPixel: 1;
ChannelCount: 1;
PaletteEntries: 256;
HasAlphaChannel: True;
IsIndexed: True;
GetPixelsSize: GetStdPixelsSize;
CheckDimensions: CheckStdDimensions;
@ -1617,8 +1618,7 @@ begin
Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
Result[0][0].Weight := 1.0;
end
else
if Scale < 1.0 then
else if Scale < 1.0 then
begin
// Sub-sampling - scales from bigger to smaller
Radius := Radius / Scale;
@ -1649,8 +1649,7 @@ begin
Result[I][0].Pos := Floor(Center);
Result[I][0].Weight := 1.0;
end
else
if Count <> 0.0 then
else if Count <> 0.0 then
Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
end;
end
@ -1680,8 +1679,7 @@ begin
begin
if J < 0 then
N := SrcImageWidth + J
else
if J >= SrcImageWidth then
else if J >= SrcImageWidth then
N := J - SrcImageWidth
else
N := ClampInt(J, SrcLow, SrcHigh - 1);
@ -1723,13 +1721,19 @@ procedure StretchResample(const SrcImage: TImageData; SrcX, SrcY, SrcWidth,
DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
const
Channel8BitMax: Single = 255.0;
type
TBufferItem = record
A, R, G, B: Integer;
end;
var
MapX, MapY: TMappingTable;
I, J, X, Y: LongInt;
XMinimum, XMaximum: LongInt;
LineBuffer: array of TColorFPRec;
LineBufferFP: array of TColorFPRec;
LineBufferInt: array of TBufferItem;
ClusterX, ClusterY: TCluster;
Weight, AccumA, AccumR, AccumG, AccumB: Single;
IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
DstLine: PByte;
SrcColor: TColor32Rec;
SrcFloat: TColorFPRec;
@ -1759,10 +1763,10 @@ begin
try
// Find min and max X coords of pixels that will contribute to target image
FindExtremes(MapX, XMinimum, XMaximum);
SetLength(LineBuffer, XMaximum - XMinimum + 1);
if not UseOptimizedVersion then
begin
SetLength(LineBufferFP, XMaximum - XMinimum + 1);
// Following code works for the rest of data formats
for J := 0 to DstHeight - 1 do
begin
@ -1773,10 +1777,10 @@ begin
for X := XMinimum to XMaximum do
begin
// Clear accumulators
AccumA := 0.0;
AccumR := 0.0;
AccumG := 0.0;
AccumB := 0.0;
AccumA := 0;
AccumR := 0;
AccumG := 0;
AccumB := 0;
// For each pixel in line compute weighted sum of pixels
// in source column that will contribute to this pixel
for Y := 0 to Length(ClusterY) - 1 do
@ -1790,7 +1794,7 @@ begin
AccumA := AccumA + SrcFloat.A * Weight;
end;
// Store accumulated value for this pixel in buffer
with LineBuffer[X - XMinimum] do
with LineBufferFP[X - XMinimum] do
begin
A := AccumA;
R := AccumR;
@ -1806,17 +1810,17 @@ begin
begin
ClusterX := MapX[I];
// Clear accumulator
AccumA := 0.0;
AccumR := 0.0;
AccumG := 0.0;
AccumB := 0.0;
AccumA := 0;
AccumR := 0;
AccumG := 0;
AccumB := 0;
// Compute weighted sum of values (which are already
// computed weighted sums of pixels in source columns stored in LineBuffer)
// that will contribute to the current target pixel
for X := 0 to Length(ClusterX) - 1 do
begin
Weight := ClusterX[X].Weight;
with LineBuffer[ClusterX[X].Pos - XMinimum] do
with LineBufferFP[ClusterX[X].Pos - XMinimum] do
begin
AccumB := AccumB + B * Weight;
AccumG := AccumG + G * Weight;
@ -1838,37 +1842,35 @@ begin
end
else
begin
SetLength(LineBufferInt, XMaximum - XMinimum + 1);
// Following code is optimized for images with 8 bit channels
for J := 0 to DstHeight - 1 do
begin
ClusterY := MapY[J];
for X := XMinimum to XMaximum do
begin
AccumA := 0.0;
AccumR := 0.0;
AccumG := 0.0;
AccumB := 0.0;
IAccumA := 0;
IAccumR := 0;
IAccumG := 0;
IAccumB := 0;
for Y := 0 to Length(ClusterY) - 1 do
begin
Weight := ClusterY[Y].Weight;
IWeight := Round(256 * ClusterY[Y].Weight);
CopyPixel(
@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
@SrcColor, Info.BytesPerPixel);
AccumB := AccumB + SrcColor.B * Weight;
if Info.ChannelCount > 1 then
AccumG := AccumG + SrcColor.G * Weight;
if Info.ChannelCount > 2 then
AccumR := AccumR + SrcColor.R * Weight;
if Info.ChannelCount > 3 then
AccumA := AccumA + SrcColor.A * Weight;
IAccumB := IAccumB + SrcColor.B * IWeight;
IAccumG := IAccumG + SrcColor.G * IWeight;
IAccumR := IAccumR + SrcColor.R * IWeight;
IAccumA := IAccumA + SrcColor.A * IWeight;
end;
with LineBuffer[X - XMinimum] do
with LineBufferInt[X - XMinimum] do
begin
A := AccumA;
R := AccumR;
G := AccumG;
B := AccumB;
A := IAccumA;
R := IAccumR;
G := IAccumG;
B := IAccumB;
end;
end;
@ -1877,31 +1879,26 @@ begin
for I := 0 to DstWidth - 1 do
begin
ClusterX := MapX[I];
AccumA := 0.0;
AccumR := 0.0;
AccumG := 0.0;
AccumB := 0.0;
IAccumA := 0;
IAccumR := 0;
IAccumG := 0;
IAccumB := 0;
for X := 0 to Length(ClusterX) - 1 do
begin
Weight := ClusterX[X].Weight;
with LineBuffer[ClusterX[X].Pos - XMinimum] do
IWeight := Round(256 * ClusterX[X].Weight);
with LineBufferInt[ClusterX[X].Pos - XMinimum] do
begin
AccumB := AccumB + B * Weight;
if Info.ChannelCount > 1 then
AccumG := AccumG + G * Weight;
if Info.ChannelCount > 2 then
AccumR := AccumR + R * Weight;
if Info.ChannelCount > 3 then
AccumA := AccumA + A * Weight;
IAccumB := IAccumB + B * IWeight;
IAccumG := IAccumG + G * IWeight;
IAccumR := IAccumR + R * IWeight;
IAccumA := IAccumA + A * IWeight;
end;
end;
SrcColor.B := ClampToByte(Round(AccumB));
if Info.ChannelCount > 1 then
SrcColor.G := ClampToByte(Round(AccumG));
if Info.ChannelCount > 2 then
SrcColor.R := ClampToByte(Round(AccumR));
if Info.ChannelCount > 3 then
SrcColor.A := ClampToByte(Round(AccumA));
SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
Inc(DstLine, Info.BytesPerPixel);
@ -3234,11 +3231,11 @@ type
TPixelBlock = array[0..15] of TPixelInfo;
function DecodeCol(Color : Word): TColor32Rec;
function DecodeCol(Color: Word): TColor32Rec;
{$IFDEF USE_INLINE} inline; {$ENDIF}
begin
Result.A := $FF;
{Result.R := ((Color and $F800) shr 11) shl 3;
{ Result.R := ((Color and $F800) shr 11) shl 3;
Result.G := ((Color and $07E0) shr 5) shl 2;
Result.B := (Color and $001F) shl 3;}
// this color expansion is slower but gives better results
@ -3663,7 +3660,7 @@ begin
GetBlock(Pixels, SrcBits, X, Y, Width, Height);
for I := 0 to 7 do
PByteArray(@AlphaBlock.Alphas)[I] :=
((Pixels[I shl 1].Alpha shr 4) shl 4) or (Pixels[I shl 1 + 1].Alpha shr 4);
(Pixels[I shl 1].Alpha shr 4) or ((Pixels[I shl 1 + 1].Alpha shr 4) shl 4);
GetEndpoints(Pixels, Block.Color0, Block.Color1);
FixEndpoints(Block.Color0, Block.Color1, False);
Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
@ -4222,7 +4219,11 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
- rewrite StretchRect for 8bit channels to use integer math?
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Filtered resampling ~10% faster now.
- Fixed DXT3 alpha encoding.
- ifIndex8 format now has HasAlphaChannel=True.
-- 0.25.0 Changes/Bug Fixes -----------------------------------
- Made some resampling stuff public so that it can be used in canvas class.

View File

@ -1,5 +1,5 @@
{
$Id: ImagingGif.pas 132 2008-08-27 20:37:38Z galfar $
$Id: ImagingGif.pas 157 2009-02-15 14:24:58Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -44,9 +44,11 @@ type
its own color palette. GIF uses lossless LZW compression
(patent expired few years ago).
Imaging can load and save all GIFs with all frames and supports
transparency.}
transparency. Imaging can load just raw ifIndex8 frames or
also animate them in ifA8R8G8B8 format. See ImagingGIFLoadAnimated option.}
TGIFFileFormat = class(TImageFileFormat)
private
FLoadAnimated: LongBool;
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
@ -62,6 +64,8 @@ type
public
constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override;
published
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
end;
implementation
@ -70,10 +74,11 @@ const
SGIFFormatName = 'Graphics Interchange Format';
SGIFMasks = '*.gif';
GIFSupportedFormats: TImageFormats = [ifIndex8];
GIFDefaultLoadAnimated = True;
type
TGIFVersion = (gv87, gv89);
TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground,
TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
const
@ -144,6 +149,19 @@ type
Terminator: Byte;
end;
const
// Netscape sub block types
GIFAppLoopExtension = 1;
GIFAppBufferExtension = 2;
type
TGIFIdentifierCode = array[0..7] of AnsiChar;
TGIFAuthenticationCode = array[0..2] of AnsiChar;
TGIFApplicationRec = packed record
Identifier: TGIFIdentifierCode;
Authentication: TGIFAuthenticationCode;
end;
const
CodeTableSize = 4096;
HashTableSize = 17777;
@ -206,8 +224,10 @@ begin
FCanSave := True;
FIsMultiImageFormat := True;
FSupportedFormats := GIFSupportedFormats;
FLoadAnimated := GIFDefaultLoadAnimated;
AddMasks(SGIFMasks);
RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
end;
function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
@ -644,28 +664,56 @@ end;
function TGIFFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean;
type
TFrameInfo = record
Left, Top: Integer;
Width, Height: Integer;
Disposal: TDisposalMethod;
HasTransparency: Boolean;
HasLocalPal: Boolean;
TransIndex: Integer;
BackIndex: Integer;
end;
var
Header: TGIFHeader;
HasGlobalPal: Boolean;
GlobalPalLength: Integer;
GlobalPal: TPalette32Size256;
I: Integer;
ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
BlockID: Byte;
HasGraphicExt: Boolean;
GraphicExt: TGraphicControlExtension;
Disposals: array of TDisposalMethod;
FrameInfos: array of TFrameInfo;
AppRead: Boolean;
CachedFrame: TImageData;
AnimFrames: TDynImageDataArray;
function ReadBlockID: Byte;
begin
Result := GIFTrailer;
GetIO.Read(Handle, @Result, SizeOf(Result));
if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
Result := GIFTrailer;
end;
procedure ReadExtensions;
var
BlockSize, ExtType: Byte;
BlockSize, BlockType, ExtType: Byte;
AppRec: TGIFApplicationRec;
LoopCount: SmallInt;
procedure SkipBytes;
begin
with GetIO do
repeat
// Read block sizes and skip them
Read(Handle, @BlockSize, SizeOf(BlockSize));
Seek(Handle, BlockSize, smFromCurrent);
until BlockSize = 0;
end;
begin
HasGraphicExt := False;
AppRead := False;
// Read extensions until image descriptor is found. Only graphic extension
// is stored now (for transparency), others are skipped.
@ -674,47 +722,69 @@ var
begin
Read(Handle, @ExtType, SizeOf(ExtType));
if ExtType = GIFGraphicControlExtension then
while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
begin
HasGraphicExt := True;
Read(Handle, @GraphicExt, SizeOf(GraphicExt));
if ExtType = GIFGraphicControlExtension then
begin
HasGraphicExt := True;
Read(Handle, @GraphicExt, SizeOf(GraphicExt));
end
else if (ExtType = GIFApplicationExtension) and not AppRead then
begin
Read(Handle, @BlockSize, SizeOf(BlockSize));
if BlockSize >= SizeOf(AppRec) then
begin
Read(Handle, @AppRec, SizeOf(AppRec));
if (AppRec.Identifier = 'NETSCAPE') and (AppRec.Authentication = '2.0') then
begin
Read(Handle, @BlockSize, SizeOf(BlockSize));
while BlockSize <> 0 do
begin
BlockType := ReadBlockID;
Dec(BlockSize);
case BlockType of
GIFAppLoopExtension:
if (BlockSize >= SizeOf(LoopCount)) then
begin
// Read loop count
Read(Handle, @LoopCount, SizeOf(LoopCount));
Dec(BlockSize, SizeOf(LoopCount));
end;
GIFAppBufferExtension:
begin
Dec(BlockSize, SizeOf(Word));
Seek(Handle, SizeOf(Word), smFromCurrent);
end;
end;
end;
SkipBytes;
AppRead := True;
end
else
begin
// Revert all bytes reading
Seek(Handle, - SizeOf(AppRec) - SizeOf(BlockSize), smFromCurrent);
SkipBytes;
end;
end
else
begin
Seek(Handle, - BlockSize - SizeOf(BlockSize), smFromCurrent);
SkipBytes;
end;
end
else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
repeat
// Read block sizes and skip them
Read(Handle, @BlockSize, SizeOf(BlockSize));
Seek(Handle, BlockSize, smFromCurrent);
until BlockSize = 0;
// Read ID of following block
BlockID := ReadBlockID;
ExtType := BlockID;
end
else if ExtType in [GIFCommentExtension, GIFApplicationExtension, GIFPlainText] then
repeat
// Read block sizes and skip them
Read(Handle, @BlockSize, SizeOf(BlockSize));
Seek(Handle, BlockSize, smFromCurrent);
until BlockSize = 0;
// Read ID of following block
BlockID := ReadBlockID;
end;
end;
procedure CopyFrameTransparent(const Image, Frame: TImageData; Left, Top,
TransIndex: Integer; Disposal: TDisposalMethod);
var
X, Y: Integer;
Src, Dst: PByte;
begin
Src := Frame.Bits;
// Copy all pixels from frame to log screen but ignore the transparent ones
for Y := 0 to Frame.Height - 1 do
begin
Dst := @PByteArray(Image.Bits)[(Top + Y) * Image.Width + Left];
for X := 0 to Frame.Width - 1 do
begin
// If disposal methos is undefined copy all pixels regardless of
// transparency (transparency of whole image will be determined by TranspIndex
// in image palette) - same effect as filling the image with trasp color
// instead of backround color beforehand.
// For other methods don't copy transparent pixels from frame to image.
if (Src^ <> TransIndex) or (Disposal = dmUndefined) then
Dst^ := Src^;
Inc(Src);
Inc(Dst);
end;
end;
end;
@ -743,33 +813,49 @@ var
procedure ReadFrame;
var
ImageDesc: TImageDescriptor;
HasLocalPal, Interlaced, HasTransparency: Boolean;
I, Idx, LocalPalLength, TransIndex: Integer;
Interlaced: Boolean;
I, Idx, LocalPalLength: Integer;
LocalPal: TPalette32Size256;
BlockTerm: Byte;
Frame: TImageData;
LZWStream: TMemoryStream;
procedure RemoveBadFrame;
begin
FreeImage(Images[Idx]);
SetLength(Images, Length(Images) - 1);
end;
begin
Idx := Length(Images);
SetLength(Images, Idx + 1);
SetLength(FrameInfos, Idx + 1);
FillChar(LocalPal, SizeOf(LocalPal), 0);
with GetIO do
begin
// Read and parse image descriptor
Read(Handle, @ImageDesc, SizeOf(ImageDesc));
HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
FrameInfos[Idx].HasLocalPal := (ImageDesc.PackedFields and GIFLocalColorTable) = GIFLocalColorTable;
Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1)
// Create new logical screen
NewImage(Header.ScreenWidth, Header.ScreenHeight, ifIndex8, Images[Idx]);
// From Mozilla source
if (ImageDesc.Width = 0) or (ImageDesc.Width > Header.ScreenWidth) then
ImageDesc.Width := Header.ScreenWidth;
if (ImageDesc.Height = 0) or (ImageDesc.Height > Header.ScreenHeight) then
ImageDesc.Height := Header.ScreenHeight;
FrameInfos[Idx].Left := ImageDesc.Left;
FrameInfos[Idx].Top := ImageDesc.Top;
FrameInfos[Idx].Width := ImageDesc.Width;
FrameInfos[Idx].Height := ImageDesc.Height;
FrameInfos[Idx].BackIndex := Header.BackgroundColorIndex;
// Create new image for this frame which would be later pasted onto logical screen
InitImage(Frame);
NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Frame);
NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
// Load local palette if there is any
if HasLocalPal then
if FrameInfos[Idx].HasLocalPal then
for I := 0 to LocalPalLength - 1 do
begin
LocalPal[I].A := 255;
@ -780,87 +866,174 @@ var
// Use local pal if present or global pal if present or create
// default pal if neither of them is present
if HasLocalPal then
if FrameInfos[Idx].HasLocalPal then
Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
else if HasGlobalPal then
Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
else
FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
// Add default disposal method for this frame
SetLength(Disposals, Length(Disposals) + 1);
Disposals[High(Disposals)] := dmUndefined;
if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
begin
// Resize the screen if needed to fit the frame
ScreenWidth := Max(ScreenWidth, ImageDesc.Width + ImageDesc.Left);
ScreenHeight := Max(ScreenHeight, ImageDesc.Height + ImageDesc.Top);
end
else
begin
// Remove frame outside logical screen
RemoveBadFrame;
Exit;
end;
// If Grahic Control Extension is present make use of it
if HasGraphicExt then
begin
HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
Disposals[High(Disposals)] := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
if HasTransparency then
Images[Idx].Palette[GraphicExt.TransparentColorIndex].A := 0;
end
else
HasTransparency := False;
if Idx >= 1 then
begin
// If previous frame had some special disposal method we take it into
// account now
case Disposals[Idx - 1] of
dmUndefined: ; // Do nothing
dmLeave:
begin
// Leave previous frame on log screen
CopyRect(Images[Idx - 1], 0, 0, Images[Idx].Width,
Images[Idx].Height, Images[Idx], 0, 0);
end;
dmRestoreBackground:
begin
// Clear log screen with background color
FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
@Header.BackgroundColorIndex);
end;
dmRestorePrevious:
if Idx >= 2 then
begin
// Set log screen to "previous of previous" frame
CopyRect(Images[Idx - 2], 0, 0, Images[Idx].Width,
Images[Idx].Height, Images[Idx], 0, 0);
end;
FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
if FrameInfos[Idx].HasTransparency then
begin
FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
end;
end
else
begin
// First frame - just fill with background color
FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
@Header.BackgroundColorIndex);
end;
FrameInfos[Idx].HasTransparency := False;
LZWStream := TMemoryStream.Create;
try
// Copy LZW data to temp stream, needed for correct decompression
CopyLZWData(LZWStream);
LZWStream.Position := 0;
// Data decompression finally
LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits);
// Now copy frame to logical screen with skipping of transparent pixels (if enabled)
TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt);
CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top,
TransIndex, Disposals[Idx]);
try
// Copy LZW data to temp stream, needed for correct decompression
CopyLZWData(LZWStream);
LZWStream.Position := 0;
// Data decompression finally
LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
except
RemoveBadFrame;
Exit;
end;
finally
FreeImage(Frame);
LZWStream.Free;
end;
end;
end;
procedure CopyFrameTransparent32(const Image, Frame: TImageData; Left, Top: Integer);
var
X, Y: Integer;
Src: PByte;
Dst: PColor32;
begin
Src := Frame.Bits;
// Copy all pixels from frame to log screen but ignore the transparent ones
for Y := 0 to Frame.Height - 1 do
begin
Dst := @PColor32RecArray(Image.Bits)[(Top + Y) * Image.Width + Left];
for X := 0 to Frame.Width - 1 do
begin
if (Frame.Palette[Src^].A <> 0) then
Dst^ := Frame.Palette[Src^].Color;
Inc(Src);
Inc(Dst);
end;
end;
end;
procedure AnimateFrame(Index: Integer; var AnimFrame: TImageData);
var
I, First, Last: Integer;
UseCache: Boolean;
BGColor: TColor32;
begin
// We may need to use raw frame 0 to n to correctly animate n-th frame
Last := Index;
First := Max(0, Last);
// See if we can use last animate frame as a basis for this one
// (so we don't have to use previous raw frames).
UseCache := TestImage(CachedFrame) and (CachedIndex = Index - 1) and (CachedIndex >= 0) and
(FrameInfos[CachedIndex].Disposal <> dmRestorePrevious);
// Reuse or release cache
if UseCache then
CloneImage(CachedFrame, AnimFrame)
else
FreeImage(CachedFrame);
// Default color for clearing of the screen
BGColor := Images[Index].Palette[FrameInfos[Index].BackIndex].Color;
// Now prepare logical screen for drawing of raw frame at Index.
// We may need to use all previous raw frames to get the screen
// to proper state (according to their disposal methods).
if not UseCache then
begin
if FrameInfos[Index].HasTransparency then
BGColor := Images[Index].Palette[FrameInfos[Index].TransIndex].Color;
// Clear whole screen
FillMemoryLongWord(AnimFrame.Bits, AnimFrame.Size, BGColor);
// Try to maximize First so we don't have to use all 0 to n raw frames
while First > 0 do
begin
if (ScreenWidth = Images[First].Width) and (ScreenHeight = Images[First].Height) then
begin
if (FrameInfos[First].Disposal = dmRestoreBackground) and (First < Last) then
Break;
end;
Dec(First);
end;
for I := First to Last - 1 do
begin
case FrameInfos[I].Disposal of
dmNoRemoval, dmLeave:
begin
// Copy previous raw frame onto screen
CopyFrameTransparent32(AnimFrame, Images[I], FrameInfos[I].Left, FrameInfos[I].Top);
end;
dmRestoreBackground:
if (I > First) then
begin
// Restore background color
FillRect(AnimFrame, FrameInfos[I].Left, FrameInfos[I].Top,
FrameInfos[I].Width, FrameInfos[I].Height, @BGColor);
end;
dmRestorePrevious: ; // Do nothing - previous state is already on screen
end;
end;
end
else if FrameInfos[CachedIndex].Disposal = dmRestoreBackground then
begin
// We have our cached result but also need to restore
// background in a place of cached frame
if FrameInfos[CachedIndex].HasTransparency then
BGColor := Images[CachedIndex].Palette[FrameInfos[CachedIndex].TransIndex].Color;
FillRect(AnimFrame, FrameInfos[CachedIndex].Left, FrameInfos[CachedIndex].Top,
FrameInfos[CachedIndex].Width, FrameInfos[CachedIndex].Height, @BGColor);
end;
// Copy current raw frame to prepared screen
CopyFrameTransparent32(AnimFrame, Images[Index], FrameInfos[Index].Left, FrameInfos[Index].Top);
// Cache animated result
CloneImage(AnimFrame, CachedFrame);
CachedIndex := Index;
end;
begin
AppRead := False;
SetLength(Images, 0);
FillChar(GlobalPal, SizeOf(GlobalPal), 0);
with GetIO do
begin
// Read GIF header
Read(Handle, @Header, SizeOf(Header));
ScreenWidth := Header.ScreenWidth;
ScreenHeight := Header.ScreenHeight;
HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1)
@ -883,6 +1056,9 @@ begin
// Now read all data blocks in the file until file trailer is reached
while BlockID <> GIFTrailer do
begin
// Read blocks until we find the one of known type
while not (BlockID in [GIFTrailer, GIFExtensionIntroducer, GIFImageDescriptor]) do
BlockID := ReadBlockID;
// Read supported and skip unsupported extensions
ReadExtensions;
// If image frame is found read it
@ -895,6 +1071,31 @@ begin
BlockID := GIFTrailer;
end;
if FLoadAnimated then
begin
// Aniated frames will be stored in AnimFrames
SetLength(AnimFrames, Length(Images));
InitImage(CachedFrame);
CachedIndex := -1;
for I := 0 to High(Images) do
begin
// Create new logical screen
NewImage(ScreenWidth, ScreenHeight, ifA8R8G8B8, AnimFrames[I]);
// Animate frames to current log screen
AnimateFrame(I, AnimFrames[I]);
end;
// Now release raw 8bit frames and put animated 32bit ones
// to output array
FreeImage(CachedFrame);
for I := 0 to High(AnimFrames) do
begin
FreeImage(Images[I]);
Images[I] := AnimFrames[I];
end;
end;
Result := True;
end;
end;
@ -1007,6 +1208,14 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Fixed bug - loading of GIF with NETSCAPE app extensions
failed with Delphi 2009.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- GIF loading and animation mostly rewritten, based on
modification by Sergey Galezdinov (ExtraGIF in Extras/Contrib).
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed loading of some rare GIFs, problems with LZW
decompression.

View File

@ -1,5 +1,5 @@
{
$Id: ImagingJpeg.pas 128 2008-07-23 11:57:36Z galfar $
$Id: ImagingJpeg.pas 180 2009-10-16 01:07:26Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -43,22 +43,22 @@ unit ImagingJpeg;
{$DEFINE IMJPEGLIB}
{ $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus.}
{$IFDEF LCL}
{ Automatically use FPC's PasJpeg when compiling with Lazarus. But not when
WINDOWS is defined. See http://galfar.vevb.net/imaging/smf/index.php/topic,90.0.html}
{$IF Defined(LCL) and not Defined(WINDOWS)}
{$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG}
{$ENDIF}
{$IFEND}
interface
uses
SysUtils, ImagingTypes, Imaging, ImagingColors,
{$IF Defined(IMJPEGLIB)}
imjpeglib, imjmorecfg, imjcomapi, imjdapimin,
imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
{$ELSEIF Defined(PASJPEG)}
jpeglib, jmorecfg, jcomapi, jdapimin,
jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
{$IFEND}
ImagingUtility;
@ -70,7 +70,10 @@ uses
type
{ Class for loading/saving Jpeg images. Supports load/save of
8 bit grayscale and 24 bit RGB images.}
8 bit grayscale and 24 bit RGB images. Jpegs can be saved with optional
progressive encoding.
Based on IJG's JpegLib so doesn't support alpha channels and lossless
coding.}
TJpegFileFormat = class(TImageFileFormat)
private
FGrayScale: Boolean;
@ -110,10 +113,11 @@ const
const
{ Jpeg file identifiers.}
JpegMagic: TChar2 = #$FF#$D8;
JFIFSignature: TChar4 = 'JFIF';
EXIFSignature: TChar4 = 'Exif';
BufferSize = 16384;
resourcestring
SJpegError = 'JPEG Error';
type
TJpegContext = record
case Byte of
@ -139,40 +143,23 @@ type
var
JIO: TIOFunctions;
JpegErrorMgr: jpeg_error_mgr;
{ Intenal unit jpeglib support functions }
procedure JpegError(CurInfo: j_common_ptr);
begin
end;
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
procedure JpegError(CInfo: j_common_ptr);
var
Buffer: string;
begin
{ Create the message and raise exception }
CInfo^.err^.format_message(CInfo, buffer);
raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
end;
procedure OutputMessage(CurInfo: j_common_ptr);
begin
end;
procedure FormatMessage(CurInfo: j_common_ptr; var buffer: string);
begin
end;
procedure ResetErrorMgr(CurInfo: j_common_ptr);
begin
CurInfo^.err^.num_warnings := 0;
CurInfo^.err^.msg_code := 0;
end;
var
JpegErrorRec: jpeg_error_mgr = (
error_exit: JpegError;
emit_message: EmitMessage;
output_message: OutputMessage;
format_message: FormatMessage;
reset_error_mgr: ResetErrorMgr);
procedure ReleaseContext(var jc: TJpegContext);
begin
if jc.common.err = nil then
@ -221,7 +208,7 @@ begin
FillInputBuffer(cinfo);
end;
Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes];
// Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
//Inc(LongInt(Src.Pub.next_input_byte), num_bytes);
Dec(Src.Pub.bytes_in_buffer, num_bytes);
end;
end;
@ -311,7 +298,11 @@ end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
begin
FillChar(jc, sizeof(jc), 0);
jc.common.err := @JpegErrorRec;
// Set standard error handlers and then override some
jc.common.err := jpeg_std_error(JpegErrorMgr);
jc.common.err.error_exit := JpegError;
jc.common.err.output_message := OutputMessage;
jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True);
@ -329,15 +320,19 @@ procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat);
begin
FillChar(jc, sizeof(jc), 0);
jc.common.err := @JpegErrorRec;
// Set standard error handlers and then override some
jc.common.err := jpeg_std_error(JpegErrorMgr);
jc.common.err.error_exit := JpegError;
jc.common.err.output_message := OutputMessage;
jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle);
if Saver.FGrayScale then
jc.c.in_color_space := JCS_GRAYSCALE
else
jc.c.in_color_space := JCS_RGB;
jpeg_set_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True);
if Saver.FGrayScale then
jpeg_set_colorspace(@jc.c, JCS_GRAYSCALE)
else
jpeg_set_colorspace(@jc.c, JCS_YCbCr);
if Saver.FProgressive then
jpeg_simple_progression(@jc.c);
end;
@ -376,13 +371,14 @@ var
jc: TJpegContext;
Info: TImageFormatInfo;
Col32: PColor32Rec;
{$IFDEF RGBSWAPPED}
NeedsRedBlueSwap: Boolean;
Pix: PColor24Rec;
{$ENDIF}
begin
// Copy IO functions to global var used in JpegLib callbacks
Result := False;
SetJpegIO(GetIO);
SetLength(Images, 1);
with JIO, Images[0] do
try
InitDecompressor(Handle, jc);
@ -390,6 +386,8 @@ begin
JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8;
JCS_CMYK: Format := ifA8R8G8B8;
else
Exit;
end;
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d);
@ -398,11 +396,18 @@ begin
LinesPerCall := 1;
Dest := Bits;
// If Jpeg's colorspace is RGB and not YCbCr we need to swap
// R and B to get Imaging's native order
NeedsRedBlueSwap := jc.d.jpeg_color_space = JCS_RGB;
{$IFDEF RGBSWAPPED}
// Force R-B swap for FPC's PasJpeg
NeedsRedBlueSwap := True;
{$ENDIF}
while jc.d.output_scanline < jc.d.output_height do
begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
{$IFDEF RGBSWAPPED}
if Format = ifR8G8B8 then
if NeedsRedBlueSwap and (Format = ifR8G8B8) then
begin
Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do
@ -411,7 +416,6 @@ begin
Inc(Pix);
end;
end;
{$ENDIF}
Inc(Dest, PtrInc * LinesRead);
end;
@ -526,7 +530,7 @@ end;
function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var
ReadCount: LongInt;
ID: array[0..9] of Char;
ID: array[0..9] of AnsiChar;
begin
Result := False;
if Handle <> nil then
@ -554,8 +558,20 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.5 Changes/Bug Fixes ---------------------------------
- Fixed swapped Red-Blue order when loading Jpegs with
jc.d.jpeg_color_space = JCS_RGB.
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Changed the Jpeg error manager, messages were not properly formated.
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong color space setting in InitCompressor.
- Fixed problem with progressive Jpegs in FPC (modified JpegLib,
can't use FPC's PasJpeg in Windows).
-- 0.25.0 Changes/Bug Fixes ---------------------------------
-- FPC's PasJpeg wasn't really used in last version, fixed.
- FPC's PasJpeg wasn't really used in last version, fixed.
-- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed loading of CMYK jpeg images. Could cause heap corruption

File diff suppressed because it is too large Load Diff

View File

@ -1,5 +1,5 @@
{
$Id: ImagingOpenGL.pas 128 2008-07-23 11:57:36Z galfar $
$Id: ImagingOpenGL.pas 165 2009-08-14 12:34:40Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -33,32 +33,35 @@ unit ImagingOpenGL;
{$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.}
{.$DEFINE USE_DGL_HEADERS}
{ $DEFINE USE_DGL_HEADERS}
{ $DEFINE USE_GLSCENE_HEADERS}
interface
uses
SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats,
{$IFDEF USE_DGL_HEADERS}
{$IF Defined(USE_DGL_HEADERS)}
dglOpenGL,
{$ELSEIF Defined(USE_GLSCENE_HEADERS)}
OpenGL1x,
{$ELSE}
gl, glext,
{$ENDIF}
{$IFEND}
ImagingUtility;
type
{ Various texture capabilities of installed OpenGL driver.}
TGLTextureCaps = record
MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW
NonPowerOfTwo: Boolean; // HW has full support for NPOT textures
DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures
ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N)
LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N)
FloatTextures: Boolean; // HW supports floating point textures
MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering
MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW
NonPowerOfTwo: Boolean; // HW has full support for NPOT textures
DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures
ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N)
LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N)
FloatTextures: Boolean; // HW supports floating point textures
MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering
MaxSimultaneousTextures: LongInt; // Number of texture units
ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp
TextureLOD: Boolean; // GL_SGIS_texture_lod
ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp
TextureLOD: Boolean; // GL_SGIS_texture_lod
VertexTextureUnits: Integer; // Texture units accessible in vertex programs
end;
@ -278,6 +281,10 @@ const
GL_UNSIGNED_INT_2_10_10_10_REV = $8368;
GL_HALF_FLOAT_ARB = $140B;
// Other GL constants
GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS = $8B4C;
{$IFDEF MSWINDOWS}
GLLibName = 'opengl32.dll';
{$ENDIF}
@ -880,6 +887,9 @@ initialization
not only A8R8G8B8
- support for cube and 3D maps
-- 0.26.1 Changes/Bug Fixes ---------------------------------
- Added support for GLScene's OpenGL header.
-- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added 3Dc compressed texture formats support.
- Added detection of 3Dc formats to texture caps.

View File

@ -1,47 +1,53 @@
{ $Id: ImagingOptions.inc 132 2008-08-27 20:37:38Z galfar $ }
{ $Id: ImagingOptions.inc 174 2009-09-08 09:37:59Z galfar $ }
{
User Options
Following defines and options can be changed by user.
}
{ Source options. }
{ Source options }
{$DEFINE USE_INLINE} // use function inlining for some functions
// works in Free Pascal and Delphi 9+
{$DEFINE USE_ASM} // if defined, assembler versions of some
// functions will be used (only for x86)
{ $DEFINE DEBUG} // if defined, debug info, range/IO/overflow
{$DEFINE USE_INLINE} // Use function inlining for some functions
// works in Free Pascal and Delphi 9+.
{.$DEFINE USE_ASM} // Ff defined, assembler versions of some
// functions will be used (only for x86).
// Debug options: If none of these two are defined
// your project settings are used.
{ $DEFINE IMAGING_DEBUG} // If defined, debug info, range/IO/overflow
// checking, stack frames, assertions, and
// other debugging options will be turned on
// other debugging options will be turned on.
{$DEFINE IMAGING_RELEASE} // If defined, all debug info is off.
{ File format support linking options. Undefine formats which you don't want
to be registred automatically. }
{.$DEFINE LINK_JPEG} // link support for Jpeg images
{.$DEFINE LINK_PNG} // link support for PNG images
{$DEFINE LINK_TARGA} // link support for Targa images
{$DEFINE LINK_BITMAP} // link support for Windows Bitmap images
{.$DEFINE LINK_DDS} // link support for DDS images
{.$DEFINE LINK_GIF} // link support for GIF images
{.$DEFINE LINK_MNG} // link support for MNG images
{.$DEFINE LINK_JNG} // link support for JNG images
{.$DEFINE LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
{.$DEFINE LINK_EXTRAS} // link support for file formats defined in
// Extras package. Exactly which formats will be
// registered depends on settings in
// ImagingExtras.pas unit.
(* File format support linking options.
Define formats which you don't want to be registred automatically.
Default: all formats are registered = no symbols defined.
Example: If you want to disable JPEG support just uncomment //{$DEFINE DONT_LINK_JPEG} line
*)
//{$DEFINE DONT_LINK_JPEG} // link support for Jpeg images
//{$DEFINE DONT_LINK_PNG} // link support for PNG images
//{$DEFINE DONT_LINK_TARGA} // link support for Targa images
//{$DEFINE DONT_LINK_BITMAP} // link support for Windows Bitmap images
{$DEFINE DONT_LINK_DDS} // link support for DDS images
{$DEFINE DONT_LINK_GIF} // link support for GIF images
{$DEFINE DONT_LINK_MNG} // link support for MNG images
{$DEFINE DONT_LINK_JNG} // link support for JNG images
{$DEFINE DONT_LINK_PNM} // link support for PortableMap images (PBM, PGM, PPM, PAM, PFM)
{$DEFINE DONT_LINK_EXTRAS} // link support for file formats defined in
// Extras package. Exactly which formats will be
// registered depends on settings in
// ImagingExtras.pas unit.
{ Component set used in ImagignComponents.pas unit. You usually don't need
to be concerned with this - proper component library is selected automatically
according to your compiler (only exception is using CLX in Delphi 6/7). }
according to your compiler. }
{$DEFINE COMPONENT_SET_VCL} // use Borland's VCL
{ $DEFINE COMPONENT_SET_CLX} // use Borland's CLX (set automatically when using Kylix,
// must be se manually when compiling with Delphi 6/7)
{ $DEFINE COMPONENT_SET_LCL} // use Lazarus' LCL (set automatically when
// compiling with FPC)
{ $DEFINE COMPONENT_SET_VCL} // use Delphi VCL
{$DEFINE COMPONENT_SET_LCL} // use Lazarus LCL (set automatically when compiling with FPC)
{
Auto Options
@ -85,7 +91,7 @@
{$ENDIF}
{$IFEND}
{$IFDEF DEBUG}
{$IF Defined(IMAGING_DEBUG)}
{$ASSERTIONS ON}
{$DEBUGINFO ON}
{$RANGECHECKS ON}
@ -95,13 +101,13 @@
{$OPTIMIZATION OFF}
{$STACKFRAMES ON}
{$LOCALSYMBOLS ON}
{ $DEFINE MEMCHECK}
{$DEFINE MEMCHECK}
{$ENDIF}
{$IFDEF FPC}
{$S+}
{$CHECKPOINTER ON}
{$ENDIF}
{$ELSE}
{$ELSEIF Defined(IMAGING_RELEASE)}
{$ASSERTIONS OFF}
{$DEBUGINFO OFF}
{$RANGECHECKS OFF}
@ -115,7 +121,8 @@
{$IFDEF FPC}
{$S-}
{$ENDIF}
{$ENDIF}
{$IFEND}
{ Compiler capabilities }
@ -151,40 +158,11 @@
{$IFDEF FPC}
{$DEFINE COMPONENT_SET_LCL}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$ENDIF}
{$IFDEF KYLIX}
{$DEFINE COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF}
{$IFDEF DELPHI}
{$UNDEF COMPONENT_SET_LCL}
{$IF CompilerVersion >= 17}
{$UNDEF COMPONENT_SET_CLX} // Delphi 9+ has no CLX
{$IFEND}
{$IFNDEF COMPONENT_SET_VCL}
{$IFNDEF COMPONENT_SET_CLX}
{$DEFINE COMPONENT_SET_VCL} // use VCL as default if not set
{$ENDIF}
{$ENDIF}
{$ENDIF}
{$IFDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$DEFINE COMPONENT_SET_VCL}
{$ENDIF}
{ Platform options }
@ -220,16 +198,4 @@
{$INLINE ON} // turns inlining on for compilers that support it
{$ENDIF}
{ Extension dependencies check }
{$IFDEF LINK_MNG} // MNG uses internaly both PNG and JNG
{$DEFINE LINK_JNG}
{$DEFINE LINK_PNG}
{$ENDIF}
{$IFDEF LINK_JNG} // JNG uses internaly both PNG and JPEG
{$DEFINE LINK_PNG}
{$DEFINE LINK_JPEG}
{$ENDIF}

View File

@ -1,5 +1,5 @@
{
$Id: ImagingPortableMaps.pas 127 2008-05-31 01:57:13Z galfar $
$Id: ImagingPortableMaps.pas 163 2009-07-28 21:44:10Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -46,7 +46,7 @@ type
TPortableMapInfo = record
Width: LongInt;
Height: LongInt;
FormatId: Char;
FormatId: AnsiChar;
MaxVal: LongInt;
BitCount: LongInt;
Depth: LongInt;
@ -200,7 +200,7 @@ var
MonoData: Pointer;
Info: TImageFormatInfo;
PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of Char;
LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo;
LineBreak: string;
@ -228,7 +228,7 @@ var
function ReadString: string;
var
S: AnsiString;
C: Char;
C: AnsiChar;
begin
// First skip all whitespace chars
SetLength(S, 1);
@ -266,7 +266,7 @@ var
// Dec pos, current is the begining of the the string
Dec(LinePos);
Result := S;
Result := string(S);
end;
function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -276,7 +276,7 @@ var
procedure FindLineBreak;
var
C: Char;
C: AnsiChar;
begin
LineBreak := #10;
repeat
@ -586,7 +586,11 @@ var
begin
SetLength(S, Length(S) + 1);
S[Length(S)] := Delimiter;
{$IF Defined(DCC) and Defined(UNICODE)}
GetIO.Write(Handle, @AnsiString(S)[1], Length(S));
{$ELSE}
GetIO.Write(Handle, @S[1], Length(S));
{$IFEND}
Inc(LineLength, Length(S));
end;
@ -807,7 +811,6 @@ begin
FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks);
RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
FIdNumbers := '25';
end;
@ -818,7 +821,10 @@ var
MapInfo: TPortableMapInfo;
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
if FSaveBinary then
MapInfo.FormatId := FIdNumbers[1]
else
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
@ -853,7 +859,6 @@ begin
FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks);
RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
FIdNumbers := '36';
end;
@ -864,7 +869,10 @@ var
MapInfo: TPortableMapInfo;
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
MapInfo.FormatId := Iff(FSaveBinary, FIdNumbers[1], FIdNumbers[0]);
if FSaveBinary then
MapInfo.FormatId := FIdNumbers[1]
else
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
@ -952,11 +960,17 @@ var
begin
FillChar(MapInfo, SizeOf(MapInfo), 0);
Info := GetFormatInfo(Images[Index].Format);
if (Info.ChannelCount > 1) or Info.IsIndexed then
MapInfo.TupleType := ttRGBFP
else
MapInfo.TupleType := ttGrayScaleFP;
MapInfo.FormatId := Iff(MapInfo.TupleType = ttGrayScaleFP, FIdNumbers[1], FIdNumbers[0]);
if MapInfo.TupleType = ttGrayScaleFP then
MapInfo.FormatId := FIdNumbers[1]
else
MapInfo.FormatId := FIdNumbers[0];
MapInfo.Binary := True;
Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end;
@ -983,6 +997,9 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Fixed D2009 Unicode related bug in PNM saving.
-- 0.24.3 Changes/Bug Fixes -----------------------------------
- Improved compatibility of 16bit/component image loading.
- Changes for better thread safety.

View File

@ -1,5 +1,5 @@
{
$Id: ImagingTarga.pas 84 2007-05-27 13:54:27Z galfar $
$Id: ImagingTarga.pas 139 2008-09-18 02:01:42Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -89,11 +89,11 @@ type
{ Footer at the end of TGA file.}
TTargaFooter = packed record
ExtOff: LongWord; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset
Signature: array[0..15] of Char; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0
ExtOff: LongWord; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset
Signature: TChar16; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0
end;

View File

@ -1,5 +1,5 @@
{
$Id: ImagingTypes.pas 132 2008-08-27 20:37:38Z galfar $
$Id: ImagingTypes.pas 171 2009-09-02 01:34:19Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -39,7 +39,7 @@ const
{ Current Minor version of Imaging.}
ImagingVersionMinor = 26;
{ Current patch of Imaging.}
ImagingVersionPatch = 0;
ImagingVersionPatch = 4;
{ Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.}
@ -91,6 +91,11 @@ const
Allowed values are in range 0 (no compresstion) to 9 (best compression).
Default value is 5.}
ImagingPNGCompressLevel = 26;
{ Boolean option that specifies whether PNG images with more frames (APNG format)
are animated by Imaging (according to frame disposal/blend methods) or just
raw frames are loaded and sent to user (if you want to animate APNG yourself).
Default value is 1.}
ImagingPNGLoadAnimated = 27;
{ Specifies whether MNG animation frames are saved with lossy or lossless
compression. Lossless frames are saved as PNG images and lossy frames are
@ -140,10 +145,11 @@ const
{ Boolean option that specifies whether GIF images with more frames
are animated by Imaging (according to frame disposal methods) or just
raw frames are loaded and sent to user (if you want to animate GIF yourself).
Default value is 1.}
Default value is 1.
Raw frames are 256 color indexed images (ifIndex8), whereas
animated frames are always in 32bit ifA8R8G8B8 format (simplifies animating).}
ImagingGIFLoadAnimated = 56;
{ This option is used when reducing number of colors used in
image (mainly when converting from ARGB image to indexed
format). Mask is 'anded' (bitwise AND) with every pixel's

View File

@ -1,5 +1,5 @@
{
$Id: ImagingUtility.pas 128 2008-07-23 11:57:36Z galfar $
$Id: ImagingUtility.pas 175 2009-10-06 11:55:15Z galfar $
Vampyre Imaging Library
by Marek Mauder
http://imaginglib.sourceforge.net
@ -56,6 +56,7 @@ type
TBooleanArray = array[0..MaxInt - 1] of Boolean;
PBooleanArray = ^TBooleanArray;
TDynByteArray = array of Byte;
TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean;
@ -98,10 +99,11 @@ type
end;
PFloatHelper = ^TFloatHelper;
TChar2 = array[0..1] of Char;
TChar3 = array[0..2] of Char;
TChar4 = array[0..3] of Char;
TChar8 = array[0..7] of Char;
TChar2 = array[0..1] of AnsiChar;
TChar3 = array[0..2] of AnsiChar;
TChar4 = array[0..3] of AnsiChar;
TChar8 = array[0..7] of AnsiChar;
TChar16 = array[0..15] of AnsiChar;
{ Options for BuildFileList function:
flFullNames - file names in result will have full path names
@ -156,10 +158,13 @@ function PosNoCase(const SubStr, S: string; Offset: LongInt = 1): LongInt; {$IFD
function StrToken(var S: string; Sep: Char): string;
{ Same as StrToken but searches from the end of S string.}
function StrTokenEnd(var S: string; Sep: Char): string;
{ Fills instance of TStrings with tokens from string S where tokens are separated by
one of Seps characters.}
procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
{ Returns string representation of integer number (with digit grouping).}
function IntToStrFmt(const I: Int64): string;
function IntToStrFmt(const I: Int64): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Returns string representation of float number (with digit grouping).}
function FloatToStrFmt(const F: Double; Precision: Integer = 2): string;
function FloatToStrFmt(const F: Double; Precision: Integer = 2): string; {$IFDEF USE_INLINE}inline;{$ENDIF}
{ Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -447,7 +452,7 @@ var
if CaseSensitive then
Result := A = B
else
Result := UpCase(A) = UpCase(B);
Result := AnsiUpperCase (A) = AnsiUpperCase (B);
end;
function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
@ -609,101 +614,6 @@ begin
end;
function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt;
{$IFDEF USE_ASM}
asm
// The Original ASM Code is (C) Fastcode project.
test eax, eax
jz @Nil
test edx, edx
jz @Nil
dec ecx
jl @Nil
push esi
push ebx
mov esi, [edx-4] //Length(Str)
mov ebx, [eax-4] //Length(Substr)
sub esi, ecx //effective length of Str
add edx, ecx //addr of the first char at starting position
cmp esi, ebx
jl @Past //jump if EffectiveLength(Str)<Length(Substr)
test ebx, ebx
jle @Past //jump if Length(Substr)<=0
add esp, -12
add ebx, -1 //Length(Substr)-1
add esi, edx //addr of the terminator
add edx, ebx //addr of the last char at starting position
mov [esp+8], esi //save addr of the terminator
add eax, ebx //addr of the last char of Substr
sub ecx, edx //-@Str[Length(Substr)]
neg ebx //-(Length(Substr)-1)
mov [esp+4], ecx //save -@Str[Length(Substr)]
mov [esp], ebx //save -(Length(Substr)-1)
movzx ecx, byte ptr [eax] //the last char of Substr
@Loop:
cmp cl, [edx]
jz @Test0
@AfterTest0:
cmp cl, [edx+1]
jz @TestT
@AfterTestT:
add edx, 4
cmp edx, [esp+8]
jb @Continue
@EndLoop:
add edx, -2
cmp edx, [esp+8]
jb @Loop
@Exit:
add esp, 12
@Past:
pop ebx
pop esi
@Nil:
xor eax, eax
ret
@Continue:
cmp cl, [edx-2]
jz @Test2
cmp cl, [edx-1]
jnz @Loop
@Test1:
add edx, 1
@Test2:
add edx, -2
@Test0:
add edx, -1
@TestT:
mov esi, [esp]
test esi, esi
jz @Found
@String:
movzx ebx, word ptr [esi+eax]
cmp bx, word ptr [esi+edx+1]
jnz @AfterTestT
cmp esi, -2
jge @Found
movzx ebx, word ptr [esi+eax+2]
cmp bx, word ptr [esi+edx+3]
jnz @AfterTestT
add esi, 4
jl @String
@Found:
mov eax, [esp+4]
add edx, 2
cmp edx, [esp+8]
ja @Exit
add esp, 12
add eax, edx
pop ebx
pop esi
end;
{$ELSE}
var
I, X: LongInt;
Len, LenSubStr: LongInt;
@ -728,11 +638,10 @@ begin
end;
Result := 0;
end;
{$ENDIF}
function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
begin
Result := PosEx(LowerCase(SubStr), LowerCase(S), Offset);
Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset);
end;
function StrToken(var S: string; Sep: Char): string;
@ -775,6 +684,19 @@ begin
end;
end;
procedure StrTokensToList(const S: string; Sep: Char; Tokens: TStrings);
var
Token, Str: string;
begin
Tokens.Clear;
Str := S;
while Str <> '' do
begin
Token := StrToken(Str, Sep);
Tokens.Add(Token);
end;
end;
function IntToStrFmt(const I: Int64): string;
begin
Result := Format('%.0n', [I * 1.0]);
@ -790,8 +712,7 @@ begin
Result := Number;
if Result < Min then
Result := Min
else
if Result > Max then
else if Result > Max then
Result := Max;
end;
@ -800,8 +721,7 @@ begin
Result := Number;
if Result < Min then
Result := Min
else
if Result > Max then
else if Result > Max then
Result := Max;
end;
@ -831,7 +751,7 @@ end;
function NextPow2(Num: LongInt): LongInt;
begin
Result := Num and -Num;
while (Result < Num) do
while Result < Num do
Result := Result shl 1;
end;
@ -1335,11 +1255,11 @@ end;
function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
var
I: LongInt;
I: LongInt;
begin
Result := Depth;
for I := 1 to MipMaps - 1 do
Inc(Result, ClampInt(Depth shr I, 1, Depth));
Result := Depth;
for I := 1 to MipMaps - 1 do
Inc(Result, ClampInt(Depth shr I, 1, Depth));
end;
function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
@ -1552,6 +1472,12 @@ initialization
-- TODOS ----------------------------------------------------
- nothing now
-- 0.26.1 Changes/Bug Fixes -----------------------------------
- Some formatting changes.
- Changed some string functions to work with localized strings.
- ASM version of PosEx had bugs, removed it.
- Added StrTokensToList function.
-- 0.25.0 Changes/Bug Fixes -----------------------------------
- Fixed error in ClipCopyBounds which was causing ... bad clipping!

View File

@ -34,7 +34,7 @@ uses
{$IFDEF VER70}
{$ifndef NO_GETENV}
Dos, { DOS unit should declare getenv() }
{ function GetEnv(name : string) : string; }
{ function GetEnv(name : string) : string; }
{$endif}
imjmemdos; { import the system-dependent declarations }
{$ELSE}
@ -492,6 +492,7 @@ begin
{ Calculate max # of rows allowed in one allocation chunk }
ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div
(long(blocksperrow) * SIZEOF(JBLOCK));
if (ltemp <= 0) then
ERREXIT(cinfo, JERR_WIDTH_OVERFLOW);
if (ltemp < long(numrows)) then

View File

@ -27,13 +27,8 @@ uses
NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type
size_t and will be a multiple of sizeof(align_type). }
{$IFDEF WINDOWS}
const
MAX_ALLOC_CHUNK = long(32752);
{$ELSE}
const
MAX_ALLOC_CHUNK = long(1000000000);
{$ENDIF}
{GLOBAL}
procedure jpeg_open_backing_store (cinfo : j_common_ptr;

View File

@ -124,7 +124,7 @@ type
FStrmPos: Integer;
FOnProgress: TNotifyEvent;
FZRec: TZStreamRec;
FBuffer: array [Word] of Char;
FBuffer: array [Word] of Byte;
protected
procedure Progress(Sender: TObject); dynamic;
property OnProgress: TNotifyEvent read FOnProgress write FOnProgress;
@ -228,7 +228,7 @@ type
implementation
const
ZErrorMessages: array[0..9] of PChar = (
ZErrorMessages: array[0..9] of PAnsiChar = (
'need dictionary', // Z_NEED_DICT (2)
'stream end', // Z_STREAM_END (1)
'', // Z_OK (0)
@ -491,7 +491,7 @@ end;
function TDecompressionStream.Seek(Offset: Longint; Origin: Word): Longint;
var
I: Integer;
Buf: array [0..4095] of Char;
Buf: array [0..4095] of Byte;
begin
if (Offset = 0) and (Origin = soFromBeginning) then
begin

View File

@ -172,7 +172,7 @@ begin
c^.sub.lit := t^.base;
{$IFDEF DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: literal '+char(t^.base))
Tracevv('inflate: literal '+AnsiChar(t^.base))
else
Tracevv('inflate: literal '+IntToStr(t^.base));
{$ENDIF}

View File

@ -99,7 +99,7 @@ begin
Dec(k, t^.bits);
{$IFDEF DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: * literal '+char(t^.base))
Tracevv('inflate: * literal '+AnsiChar(t^.base))
else
Tracevv('inflate: * literal '+ IntToStr(t^.base));
{$ENDIF}
@ -241,7 +241,7 @@ begin
{$IFDEF DEBUG}
if (t^.base >= $20) and (t^.base < $7f) then
Tracevv('inflate: * literal '+char(t^.base))
Tracevv('inflate: * literal '+AnsiChar(t^.base))
else
Tracevv('inflate: * literal '+IntToStr(t^.base));
{$ENDIF}

View File

@ -376,23 +376,23 @@ const
{$IFDEF DEBUG}
procedure Assert(cond : boolean; msg : string);
procedure Assert(cond : boolean; msg : AnsiString);
{$ENDIF}
procedure Trace(x : string);
procedure Tracev(x : string);
procedure Tracevv(x : string);
procedure Tracevvv(x : string);
procedure Tracec(c : boolean; x : string);
procedure Tracecv(c : boolean; x : string);
procedure Trace(x : AnsiString);
procedure Tracev(x : AnsiString);
procedure Tracevv(x : AnsiString);
procedure Tracevvv(x : AnsiString);
procedure Tracec(c : boolean; x : AnsiString);
procedure Tracecv(c : boolean; x : AnsiString);
function zlibVersion : string;
function zlibVersion : AnsiString;
{ The application can compare zlibVersion and ZLIB_VERSION for consistency.
If the first character differs, the library code actually used is
not compatible with the zlib.h header file used by the application.
This check is automatically made by deflateInit and inflateInit. }
function zError(err : int) : string;
function zError(err : int) : AnsiString;
function ZALLOC (var strm : z_stream; items : uInt; size : uInt) : voidpf;
procedure ZFREE (var strm : z_stream; ptr : voidpf);
procedure TRY_FREE (var strm : z_stream; ptr : voidpf);
@ -416,9 +416,9 @@ const
const
z_verbose : int = 1;
function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: string;
function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString;
Stream_size: LongInt): LongInt;
function inflateInit_(var Stream: z_stream; const Version: string;
function inflateInit_(var Stream: z_stream; const Version: AnsiString;
Stream_size: Longint): LongInt;
{$IFDEF DEBUG}
@ -430,29 +430,29 @@ implementation
uses
imzdeflate, imzinflate;
function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: string;
function deflateInit_(var Stream: z_stream; Level: LongInt; const Version: AnsiString;
Stream_size: LongInt): LongInt;
begin
Result := imzdeflate.deflateInit_(@Stream, Level, Version, Stream_size);
end;
function inflateInit_(var Stream: z_stream; const Version: string;
function inflateInit_(var Stream: z_stream; const Version: AnsiString;
Stream_size: Longint): LongInt;
begin
Result := imzinflate.inflateInit_(@Stream, Version, Stream_size);
end;
function zError(err : int) : string;
function zError(err : int) : AnsiString;
begin
zError := z_errmsg[Z_NEED_DICT-err];
end;
function zlibVersion : string;
function zlibVersion : AnsiString;
begin
zlibVersion := ZLIB_VERSION;
end;
procedure z_error (m : string);
procedure z_error (m : AnsiString);
begin
WriteLn(output, m);
Write('Zlib - Halt...');
@ -460,42 +460,42 @@ begin
Halt(1);
end;
procedure Assert(cond : boolean; msg : string);
procedure Assert(cond : boolean; msg : AnsiString);
begin
if not cond then
z_error(msg);
end;
procedure Trace(x : string);
procedure Trace(x : AnsiString);
begin
WriteLn(x);
end;
procedure Tracev(x : string);
procedure Tracev(x : AnsiString);
begin
if (z_verbose>0) then
WriteLn(x);
end;
procedure Tracevv(x : string);
procedure Tracevv(x : AnsiString);
begin
if (z_verbose>1) then
WriteLn(x);
end;
procedure Tracevvv(x : string);
procedure Tracevvv(x : AnsiString);
begin
if (z_verbose>2) then
WriteLn(x);
end;
procedure Tracec(c : boolean; x : string);
procedure Tracec(c : boolean; x : AnsiString);
begin
if (z_verbose>0) and (c) then
WriteLn(x);
end;
procedure Tracecv(c : boolean; x : string);
procedure Tracecv(c : boolean; x : AnsiString);
begin
if (z_verbose>1) and c then
WriteLn(x);

View File

@ -637,7 +637,7 @@ const
}
const
Buf_size = (8 * 2*sizeof(char));
Buf_size = (8 * 2*sizeof(uch));
{ Number of bits used within bi_buf. (bi_buf might be implemented on
more than 16 bits on some systems.) }
@ -916,7 +916,7 @@ begin
{$ifdef DEBUG}
if (n>31) and (n<128) then
Tracecv(tree <> tree_ptr(@static_ltree),
(^M'n #'+IntToStr(n)+' '+char(n)+' l '+IntToStr(len)+' c '+
(^M'n #'+IntToStr(n)+' '+AnsiChar(n)+' l '+IntToStr(len)+' c '+
IntToStr(tree^[n].fc.Code)+' ('+IntToStr(next_code[len]-1)+')'))
else
Tracecv(tree <> tree_ptr(@static_ltree),
@ -1962,7 +1962,7 @@ begin
{ send a literal byte }
{$ifdef DEBUG}
Tracevvv(#13'cd '+IntToStr(lc));
Tracecv((lc > 31) and (lc < 128), ' '+char(lc)+' ');
Tracecv((lc > 31) and (lc < 128), ' '+AnsiChar(lc)+' ');
{$ENDIF}
send_bits(s, ltree[lc].fc.Code, ltree[lc].dl.Len);
end
@ -2106,7 +2106,7 @@ begin
{$endif} { STORED_FILE_OK }
{$ifdef FORCE_STORED}
if (buf <> pchar(0)) then
if (buf <> pcharf(0)) then
begin { force stored block }
{$else}
if (stored_len+4 <= opt_lenb) and (buf <> pcharf(0)) then

View File

@ -61,7 +61,7 @@ uses
function deflateInit_(strm : z_streamp;
level : int;
const version : string;
const version : AnsiString;
stream_size : int) : int;
@ -499,7 +499,7 @@ function deflateInit2_(var strm : z_stream;
windowBits : int;
memLevel : int;
strategy : int;
const version : string;
const version : AnsiString;
stream_size : int) : int;
var
s : deflate_state_ptr;
@ -622,7 +622,7 @@ end;
function deflateInit_(strm : z_streamp;
level : int;
const version : string;
const version : AnsiString;
stream_size : int) : int;
begin
if (strm = Z_NULL) then
@ -1528,7 +1528,7 @@ begin
begin
WriteLn(' start ',start,', match ',match ,' length ', length);
repeat
Write(char(s.window^[match]), char(s.window^[start]));
Write(AnsiChar(s.window^[match]), AnsiChar(s.window^[start]));
Inc(match);
Inc(start);
Dec(length);
@ -1539,7 +1539,7 @@ begin
begin
Write('\\[',start-match,',',length,']');
repeat
Write(char(s.window^[start]));
Write(AnsiChar(s.window^[start]));
Inc(start);
Dec(length);
Until (length = 0);
@ -1910,7 +1910,7 @@ end;
begin
{ No match, output a literal byte }
{$IFDEF DEBUG}
Tracevv(char(s.window^[s.strstart]));
Tracevv(AnsiChar(s.window^[s.strstart]));
{$ENDIF}
{_tr_tally_lit (s, 0, s.window^[s.strstart], bflush);}
bflush := _tr_tally (s, 0, s.window^[s.strstart]);
@ -2071,7 +2071,7 @@ begin
single literal. If there was a match but the current match
is longer, truncate the previous match to a single literal. }
{$IFDEF DEBUG}
Tracevv(char(s.window^[s.strstart-1]));
Tracevv(AnsiChar(s.window^[s.strstart-1]));
{$ENDIF}
bflush := _tr_tally (s, 0, s.window^[s.strstart-1]);
@ -2104,7 +2104,7 @@ begin
if (s.match_available) then
begin
{$IFDEF DEBUG}
Tracevv(char(s.window^[s.strstart-1]));
Tracevv(AnsiChar(s.window^[s.strstart-1]));
bflush :=
{$ENDIF}
_tr_tally (s, 0, s.window^[s.strstart-1]);

View File

@ -31,13 +31,13 @@ function inflateInit(var z : z_stream) : int;
function inflateInit_(z : z_streamp;
const version : string;
const version : AnsiString;
stream_size : int) : int;
function inflateInit2_(var z: z_stream;
w : int;
const version : string;
const version : AnsiString;
stream_size : int) : int;
function inflateInit2(var z: z_stream;
@ -246,7 +246,7 @@ end;
function inflateInit2_(var z: z_stream;
w : int;
const version : string;
const version : AnsiString;
stream_size : int) : int;
begin
if (version = '') or (version[1] <> ZLIB_VERSION[1]) or
@ -333,7 +333,7 @@ begin
end;
function inflateInit_(z : z_streamp;
const version : string;
const version : AnsiString;
stream_size : int) : int;
begin
{ initialize state }

View File

@ -0,0 +1,88 @@
<?xml version="1.0"?>
<CONFIG>
<ProjectOptions>
<PathDelim Value="\"/>
<Version Value="7"/>
<General>
<Flags>
<MainUnitHasCreateFormStatements Value="False"/>
<MainUnitHasTitleStatement Value="False"/>
</Flags>
<MainUnit Value="0"/>
<TargetFileExt Value=".exe"/>
<Icon Value="0"/>
<UseXPManifest Value="True"/>
<ActiveEditorIndexAtStart Value="0"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
</PublishOptions>
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<Units Count="1">
<Unit0>
<Filename Value="ConvertFontMap.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="ConvertFontMap"/>
<CursorPos X="25" Y="38"/>
<TopLine Value="33"/>
<EditorIndex Value="0"/>
<UsageCount Value="20"/>
<Loaded Value="True"/>
</Unit0>
</Units>
<JumpHistory Count="1" HistoryIndex="0">
<Position1>
<Filename Value="ConvertFontMap.lpr"/>
<Caret Line="82" Column="17" TopLine="54"/>
</Position1>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="8"/>
<PathDelim Value="\"/>
<Target>
<Filename Value="..\..\bin\ConvertFontMap"/>
</Target>
<SearchPaths>
<IncludeFiles Value="$(ProjOutDir)\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
</SearchPaths>
<CodeGeneration>
<SmartLinkUnit Value="True"/>
</CodeGeneration>
<Linking>
<Debugging>
<UseLineInfoUnit Value="False"/>
<StripSymbols Value="True"/>
</Debugging>
<LinkSmart Value="True"/>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
</CompilerOptions>
<Debugging>
<Exceptions Count="3">
<Item1>
<Name Value="EAbort"/>
</Item1>
<Item2>
<Name Value="ECodetoolError"/>
</Item2>
<Item3>
<Name Value="EFOpenError"/>
</Item3>
</Exceptions>
</Debugging>
</CONFIG>

View File

@ -0,0 +1,91 @@
(*
* CDDL HEADER START
*
* The contents of this file are subject to the terms of the
* Common Development and Distribution License, Version 1.0 only
* (the "License"). You may not use this file except in compliance
* with the License.
*
* You can obtain a copy of the license at
* http://www.opensource.org/licenses/cddl1.php.
* See the License for the specific language governing permissions
* and limitations under the License.
*
* When distributing Covered Code, include this CDDL HEADER in each
* file and include the License file at
* http://www.opensource.org/licenses/cddl1.php. If applicable,
* add the following below this CDDL HEADER, with the fields enclosed
* by brackets "[]" replaced with your own identifying * information:
* Portions Copyright [yyyy] [name of copyright owner]
*
* CDDL HEADER END
*
*
* Portions Copyright 2009 Andreas Schneider
*)
program ConvertFontMap;
{$mode objfpc}{$H+}
uses
Classes, sysutils, DOM, XMLRead;
{$IFDEF WINDOWS}{$R ConvertFontMap.rc}{$ENDIF}
type
TFontInfo = packed record
Character: char;
LeftOffset: SmallInt;
CharWidth: Word;
Width: Word;
Height: Word;
X1: Single;
Y1: Single;
X2: Single;
Y2: Single;
end;
var
xmlDoc: TXMLDocument;
chars: TDOMNodeList;
root, parent, charNode: TDOMElement;
outFile: TFileStream;
spaceWidth: Word;
fontInfo: TFontInfo;
i: Integer;
begin
if ParamCount = 2 then
begin
ReadXMLFile(xmlDoc, ParamStr(1));
outFile := TFileStream.Create(ParamStr(2), fmCreate);
root := xmlDoc.DocumentElement;
parent := TDOMElement(root.FindNode('characters'));
chars := parent.ChildNodes;
spaceWidth := StrToInt(root.AttribStrings['spacewidth']);
outFile.Write(spaceWidth, SizeOf(spaceWidth));
for i := 0 to chars.Count - 1 do
begin
charNode := TDOMElement(chars[i]);
fontInfo.Character := Char(StrToInt(charNode.AttribStrings['char']));
fontInfo.LeftOffset := StrToInt(charNode.AttribStrings['A']);
fontInfo.CharWidth := StrToInt(charNode.AttribStrings['C']);
fontInfo.Width := StrToInt(charNode.AttribStrings['wid']);
fontInfo.Height := StrToInt(charNode.AttribStrings['hgt']);
fontInfo.X1 := StrToFloat(charNode.AttribStrings['X1']);
fontInfo.Y1 := StrToFloat(charNode.AttribStrings['Y1']);
fontInfo.X2 := StrToFloat(charNode.AttribStrings['X2']);
fontInfo.Y2 := StrToFloat(charNode.AttribStrings['Y2']);
outFile.Write(fontInfo, SizeOf(fontInfo));
end;
outFile.Free;
xmlDoc.Free;
end else
Writeln('Usage: ', ExtractFileName(ParamStr(0)), ' <In Font XML> <Out Font Bin>');
end.