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

View File

@ -40,7 +40,7 @@ uses
UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo, UfrmLargeScaleCommand, UfrmVirtualLayer, UfrmFilter, UfrmTileInfo,
UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets, UGUIPlatformUtils, UPlatformTypes, UfrmRegionControl, UPackets,
UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow, UPacketHandlers, UAdminHandling, UGameResources, ULandscape, UfrmToolWindow,
Logging, UMap, UWorldItem, UStatics, UTiledata; Logging, UMap, UWorldItem, UStatics, UTiledata, UGLFont;
{$IFDEF WINDOWS}{$R CentrED.rc}{$ENDIF} {$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/LeftTopArrow.tga
Overlay/TopArrow.tga Overlay/TopArrow.tga
Overlay/VirtualLayer.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 interface
uses uses
SysUtils, Classes, math, LCLIntf, GL, GLU, ImagingOpenGL, Imaging, SysUtils, Classes, math, LCLIntf, GL, GLu, ImagingOpenGL, Imaging,
ImagingClasses, ImagingTypes, ImagingUtility, ImagingClasses, ImagingTypes, ImagingUtility,
UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem, UGenericIndex, UMap, UStatics, UArt, UTexture, UTiledata, UHue, UWorldItem,
UMulBlock, UMulBlock,
UVector, UEnhancedMemoryStream, UVector, UEnhancedMemoryStream, UGLFont,
UCacheManager; UCacheManager;
type type
@ -196,6 +196,19 @@ type
procedure UpdateWriteMap(AStream: TEnhancedMemoryStream); procedure UpdateWriteMap(AStream: TEnhancedMemoryStream);
end; 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); TScreenState = (ssNormal, ssFiltered, ssGhost);
PBlockInfo = ^TBlockInfo; PBlockInfo = ^TBlockInfo;
@ -212,6 +225,7 @@ type
HueOverride: Boolean; HueOverride: Boolean;
CheckRealQuad: Boolean; CheckRealQuad: Boolean;
Translucent: Boolean; Translucent: Boolean;
Text: TGLText;
Next: PBlockInfo; Next: PBlockInfo;
end; end;
@ -1213,6 +1227,7 @@ begin
Result^.State := ssNormal; Result^.State := ssNormal;
Result^.Highlighted := False; Result^.Highlighted := False;
Result^.Translucent := False; Result^.Translucent := False;
Result^.Text := nil;
Result^.Next := nil; Result^.Next := nil;
if FShortCuts[0] = nil then //First element if FShortCuts[0] = nil then //First element
@ -1239,6 +1254,7 @@ begin
current^.Item.Locked := False; current^.Item.Locked := False;
current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved); current^.Item.OnDestroy.UnregisterEvent(@OnTileRemoved);
if current^.Normals <> nil then Dispose(current^.Normals); if current^.Normals <> nil then Dispose(current^.Normals);
current^.Text.Free;
Dispose(current); Dispose(current);
current := next; current := next;
end; end;
@ -1266,6 +1282,7 @@ begin
if last <> nil then last^.Next := current^.Next; if last <> nil then last^.Next := current^.Next;
if current^.Normals <> nil then Dispose(current^.Normals); if current^.Normals <> nil then Dispose(current^.Normals);
current^.Text.Free;
Dispose(current); Dispose(current);
Dec(FCount); Dec(FCount);
@ -1356,6 +1373,7 @@ begin
Result^.State := ssNormal; Result^.State := ssNormal;
Result^.Highlighted := False; Result^.Highlighted := False;
Result^.Translucent := False; Result^.Translucent := False;
Result^.Text := nil;
if (FShortCuts[0] = nil) or (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then if (FShortCuts[0] = nil) or (CompareWorldItems(AItem, FShortCuts[0]^.Item) < 0) then
begin begin
@ -1490,5 +1508,27 @@ begin
Delete(TWorldItem(ATile)); Delete(TWorldItem(ATile));
end; 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. end.

View File

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

View File

@ -31,10 +31,10 @@ interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Menus, 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, StdCtrls, Spin, UEnums, VirtualTrees, Buttons, UMulBlock, UWorldItem, math,
LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList, fgl, LCLIntf, UOverlayUI, UStatics, UEnhancedMemoryStream, ActnList, fgl,
ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket; ImagingClasses, dateutils, UPlatformTypes, UMap, UPacket, UGLFont;
type type
TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object; TAccessChangedListener = procedure(AAccessLevel: TAccessLevel) of object;
@ -269,6 +269,7 @@ type
Node: PVirtualNode; Stream: TStream); Node: PVirtualNode; Stream: TStream);
protected protected
{ Members } { Members }
FAppDir: String;
FX: Integer; FX: Integer;
FY: Integer; FY: Integer;
FDrawDistance: Integer; FDrawDistance: Integer;
@ -294,6 +295,7 @@ type
FRepaintNeeded: Boolean; FRepaintNeeded: Boolean;
FSelection: TRect; FSelection: TRect;
FUndoList: TPacketList; FUndoList: TPacketList;
FGLFont: TGLFont;
{ Methods } { Methods }
procedure BuildTileList; procedure BuildTileList;
function ConfirmAction: Boolean; function ConfirmAction: Boolean;
@ -784,6 +786,8 @@ var
virtualLayerGraphic: TSingleImage; virtualLayerGraphic: TSingleImage;
searchRec: TSearchRec; searchRec: TSearchRec;
begin begin
FAppDir := IncludeTrailingPathDelimiter(ExtractFilePath(Application.ExeName));
FLandscape := ResMan.Landscape; FLandscape := ResMan.Landscape;
FLandscape.OnChange := @OnLandscapeChanged; FLandscape.OnChange := @OnLandscapeChanged;
FLandscape.OnMapChanged := @OnMapChanged; FLandscape.OnMapChanged := @OnMapChanged;
@ -812,8 +816,7 @@ begin
vstChat.NodeDataSize := SizeOf(TChatInfo); vstChat.NodeDataSize := SizeOf(TChatInfo);
pnlChatHeader.AnchorSide[akBottom].Control := pnlBottom; pnlChatHeader.AnchorSide[akBottom].Control := pnlBottom;
FLocationsFile := IncludeTrailingPathDelimiter(ExtractFilePath( FLocationsFile := FAppDir + 'Locations.dat';
Application.ExeName)) + 'Locations.dat';
vstLocations.NodeDataSize := SizeOf(TLocationInfo); vstLocations.NodeDataSize := SizeOf(TLocationInfo);
if FileExists(FLocationsFile) then vstLocations.LoadFromFile(FLocationsFile); if FileExists(FLocationsFile) then vstLocations.LoadFromFile(FLocationsFile);
@ -824,11 +827,14 @@ begin
virtualLayerGraphic.Height, virtualLayerGraphic); virtualLayerGraphic.Height, virtualLayerGraphic);
virtualLayerGraphic.Free; virtualLayerGraphic.Free;
FGLFont := TGLFont.Create;
FGLFont.LoadImage(ResourceManager.GetResource(3));
FGLFont.LoadFontInfo(ResourceManager.GetResource(4));
FVirtualTiles := TWorldItemList.Create(True); FVirtualTiles := TWorldItemList.Create(True);
FUndoList := TPacketList.Create(True); FUndoList := TPacketList.Create(True);
FRandomPresetLocation := IncludeTrailingPathDelimiter(ExtractFilePath( FRandomPresetLocation := FAppDir + 'RandomPresets' + PathDelim;
Application.ExeName)) + 'RandomPresets' + PathDelim;
if not DirectoryExists(FRandomPresetLocation) then if not DirectoryExists(FRandomPresetLocation) then
CreateDir(FRandomPresetLocation); CreateDir(FRandomPresetLocation);
@ -1116,6 +1122,7 @@ begin
FreeAndNil(FVLayerMaterial); FreeAndNil(FVLayerMaterial);
FreeAndNil(FVirtualTiles); FreeAndNil(FVirtualTiles);
FreeAndNil(FUndoList); FreeAndNil(FUndoList);
FreeAndNil(FGLFont);
RegisterPacketHandler($0C, nil); RegisterPacketHandler($0C, nil);
end; end;
@ -1783,9 +1790,11 @@ procedure TfrmMain.InitSize;
begin begin
glViewport(0, 0, oglGameWindow.Width, oglGameWindow.Height); glViewport(0, 0, oglGameWindow.Width, oglGameWindow.Height);
glMatrixMode(GL_PROJECTION); glMatrixMode(GL_PROJECTION);
glPushMatrix;
glLoadIdentity; glLoadIdentity;
gluOrtho2D(0, oglGameWindow.Width, oglGameWindow.Height, 0); gluOrtho2D(0, oglGameWindow.Width, oglGameWindow.Height, 0);
glMatrixMode(GL_MODELVIEW); glMatrixMode(GL_MODELVIEW);
glPushMatrix;
glLoadIdentity; glLoadIdentity;
end; end;
@ -1923,6 +1932,10 @@ begin
CheckRealQuad := True; CheckRealQuad := True;
end; end;
end; end;
end else
begin
ABlockInfo^.Text.Free;
ABlockInfo^.Text := TGLText.Create(FGLFont, IntToStr(item.Z));
end; end;
if not ABlockInfo^.CheckRealQuad then if not ABlockInfo^.CheckRealQuad then
@ -2082,6 +2095,9 @@ begin
if highlight then if highlight then
glDisable(GL_COLOR_LOGIC_OP); glDisable(GL_COLOR_LOGIC_OP);
if (blockInfo^.Text <> nil) then
blockInfo^.Text.Render(blockInfo^.ScreenRect);
end; end;
FOverlayUI.Draw(oglGameWindow); 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net 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.} Pal must be allocated to have at least MaxColors entries.}
function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32; function MakePaletteForImages(var Images: TDynImageDataArray; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean; MaxColors: LongInt; ConvertImages: Boolean): Boolean;
{ Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise. { Rotates image by Angle degrees counterclockwise. All angles are allowed.}
Only multiples of 90 degrees are allowed.} function RotateImage(var Image: TImageData; Angle: Single): Boolean;
function RotateImage(var Image: TImageData; Angle: LongInt): Boolean;
{ Drawing/Pixel functions } { Drawing/Pixel functions }
@ -303,7 +302,7 @@ function PopOptions: Boolean;
{ Image Format Functions } { Image Format Functions }
{ Returns short information about given image format.} { 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.} { Returns size in bytes of Width x Height area of pixels. Works for all formats.}
function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt; function GetPixelsSize(Format: TImageFormat; Width, Height: LongInt): LongInt;
@ -534,28 +533,28 @@ procedure RaiseImaging(const Msg: string; const Args: array of const);
implementation implementation
uses uses
{$IFDEF LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
ImagingBitmap, ImagingBitmap,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
ImagingJpeg, ImagingJpeg,
{$ENDIF} {$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, ImagingNetworkGraphics,
{$IFEND} {$IFEND}
{$IFDEF LINK_GIF} {$IFNDEF DONT_LINK_GIF}
ImagingGif, ImagingGif,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_DDS} {$IFNDEF DONT_LINK_DDS}
ImagingDds, ImagingDds,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
ImagingTarga, ImagingTarga,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_PNM} {$IFNDEF DONT_LINK_PNM}
ImagingPortableMaps, ImagingPortableMaps,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_EXTRAS} {$IFNDEF DONT_LINK_EXTRAS}
ImagingExtras, ImagingExtras,
{$ENDIF} {$ENDIF}
ImagingFormats, ImagingUtility, ImagingIO; ImagingFormats, ImagingUtility, ImagingIO;
@ -606,8 +605,9 @@ resourcestring
SErrorFreePalette = 'Error while freeing palette @%p'; SErrorFreePalette = 'Error while freeing palette @%p';
SErrorCopyPalette = 'Error while copying %d entries from palette @%p to @%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'; 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.'; SErrorStretchRect = 'Error while stretching rect from image %s to image %s.';
SErrorEmptyStream = 'Input stream has no data. Check Position property.';
const const
// initial size of array with options information // initial size of array with options information
@ -727,7 +727,7 @@ function NewImage(Width, Height: LongInt; Format: TImageFormat; var Image:
var var
FInfo: PImageFormatInfo; FInfo: PImageFormatInfo;
begin begin
Assert((Width >= 0) and (Height >= 0)); Assert((Width > 0) and (Height >0));
Assert(IsImageFormatValid(Format)); Assert(IsImageFormatValid(Format));
Result := False; Result := False;
FreeImage(Image); FreeImage(Image);
@ -996,6 +996,8 @@ var
I: LongInt; I: LongInt;
begin begin
Assert(Stream <> nil); Assert(Stream <> nil);
if Stream.Size - Stream.Position = 0 then
RaiseImaging(SErrorEmptyStream, []);
Result := False; Result := False;
Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream)); Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
if Format <> nil then if Format <> nil then
@ -1057,6 +1059,8 @@ var
Format: TImageFileFormat; Format: TImageFileFormat;
begin begin
Assert(Stream <> nil); Assert(Stream <> nil);
if Stream.Size - Stream.Position = 0 then
RaiseImaging(SErrorEmptyStream, []);
Result := False; Result := False;
Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream)); Format := FindImageFileFormatByExt(DetermineStreamFormat(Stream));
if Format <> nil then if Format <> nil then
@ -1416,7 +1420,10 @@ begin
// Free old image and assign new image to it // Free old image and assign new image to it
FreeMemNil(Image.Bits); FreeMemNil(Image.Bits);
if Image.Palette <> nil then if Image.Palette <> nil then
begin
FreeMem(WorkImage.Palette);
WorkImage.Palette := Image.Palette; WorkImage.Palette := Image.Palette;
end;
Image := WorkImage; Image := WorkImage;
Result := True; Result := True;
except except
@ -1854,33 +1861,154 @@ begin
end; end;
end; end;
function RotateImage(var Image: TImageData; Angle: LongInt): Boolean; function RotateImage(var Image: TImageData; Angle: Single): Boolean;
var var
X, Y, BytesPerPixel: LongInt;
RotImage: TImageData;
Pix, RotPix: PByte;
OldFmt: TImageFormat; OldFmt: TImageFormat;
begin
Assert(Angle mod 90 = 0);
Result := False;
if TestImage(Image) then procedure XShear(var Src, Dst: TImageData; Row, Offset, Weight, Bpp: Integer);
try var
if (Angle < -360) or (Angle > 360) then Angle := Angle mod 360; I, J, XPos: Integer;
if (Angle = 0) or (Abs(Angle) = 360) then 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 begin
Result := True; CopyPixel(SrcPtr, @PixSrc, Bpp);
Exit; 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; end;
Angle := Iff(Angle = -90, 270, Angle); XPos := Src.Width + Offset;
Angle := Iff(Angle = -270, 90, Angle); if XPos < Dst.Width then
Angle := Iff(Angle = -180, 180, Angle); CopyPixel(@PixOldLeft, @LineDst[XPos * Bpp], Bpp);
end;
OldFmt := Image.Format; procedure YShear(var Src, Dst: TImageData; Col, Offset, Weight, Bpp: Integer);
if ImageFormatInfos[Image.Format].IsSpecial then var
ConvertImage(Image, ifDefault); 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); InitImage(RotImage);
BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel; BytesPerPixel := ImageFormatInfos[Image.Format].BytesPerPixel;
@ -1920,8 +2048,7 @@ begin
begin begin
for Y := 0 to RotImage.Height - 1 do for Y := 0 to RotImage.Height - 1 do
begin begin
Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Pix := @PByteArray(Image.Bits)[((Image.Height - 1) * Image.Width + Y) * BytesPerPixel];
Y) * BytesPerPixel];
for X := 0 to RotImage.Width - 1 do for X := 0 to RotImage.Width - 1 do
begin begin
CopyPixel(Pix, RotPix, BytesPerPixel); CopyPixel(Pix, RotPix, BytesPerPixel);
@ -1935,6 +2062,46 @@ begin
FreeMemNil(Image.Bits); FreeMemNil(Image.Bits);
RotImage.Palette := Image.Palette; RotImage.Palette := Image.Palette;
Image := RotImage; 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 if OldFmt <> Image.Format then
ConvertImage(Image, OldFmt); ConvertImage(Image, OldFmt);
@ -2421,7 +2588,7 @@ end;
{ Image Format Functions } { Image Format Functions }
function GetImageFormatInfo(Format: TImageFormat; var Info: TImageFormatInfo): Boolean; function GetImageFormatInfo(Format: TImageFormat; out Info: TImageFormatInfo): Boolean;
begin begin
FillChar(Info, SizeOf(Info), 0); FillChar(Info, SizeOf(Info), 0);
if ImageFormatInfos[Format] <> nil then if ImageFormatInfos[Format] <> nil then
@ -2527,7 +2694,7 @@ begin
if OptionId >= Length(Options) then if OptionId >= Length(Options) then
SetLength(Options, OptionId + InitialOptions); 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 begin
Options[OptionId] := Variable; Options[OptionId] := Variable;
Result := True; Result := True;
@ -2539,7 +2706,7 @@ var
I: LongInt; I: LongInt;
begin begin
Result := nil; 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 if TImageFileFormat(ImageFileFormats[I]).Extensions.IndexOf(Ext) >= 0 then
begin begin
Result := TImageFileFormat(ImageFileFormats[I]); Result := TImageFileFormat(ImageFileFormats[I]);
@ -2552,7 +2719,7 @@ var
I: LongInt; I: LongInt;
begin begin
Result := nil; 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 if TImageFileFormat(ImageFileFormats[I]).TestFileName(FileName) then
begin begin
Result := TImageFileFormat(ImageFileFormats[I]); Result := TImageFileFormat(ImageFileFormats[I]);
@ -3289,6 +3456,19 @@ finalization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.24.3 Changes/Bug Fixes ---------------------------------
- GenerateMipMaps now generates all smaller levels from - GenerateMipMaps now generates all smaller levels from
original big image (better results when using more advanced filters). 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -118,6 +118,8 @@ type
TDynFPPixelArray = array of TColorFPRec; TDynFPPixelArray = array of TColorFPRec;
THistogramArray = array[Byte] of Integer;
TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec; TSelectPixelFunction = function(var Pixels: TDynFPPixelArray): TColorFPRec;
{ Base canvas class for drawing objects, applying effects, and other. { Base canvas class for drawing objects, applying effects, and other.
@ -128,7 +130,7 @@ type
recompute some data size related stuff). recompute some data size related stuff).
TImagingCanvas works for all image data formats except special ones 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 with colors in ifA32R32G32B32F format). If you want fast drawing you
can use one of fast canvas clases. These descendants of TImagingCanvas 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 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 filled by using the current fill settings. Rect specifies bounding rectangle
of ellipse to be drawn.} of ellipse to be drawn.}
procedure Ellipse(const Rect: TRect); 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. { Draws contents of this canvas onto another canvas with pixel blending.
Blending factors are chosen using TBlendingFactor parameters. Blending factors are chosen using TBlendingFactor parameters.
@ -225,7 +233,7 @@ type
DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor); DestX, DestY: Integer; SrcFactor, DestFactor: TBlendingFactor);
{ Draws contents of this canvas onto another one with typical alpha { Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} 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 { Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).} (source and dest factors are bfOne).}
procedure DrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; DestX, DestY: Integer); 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 { Draws contents of this canvas onto another one with typical alpha
blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)} blending (Src 'over' Dest, factors are bfSrcAlpha and bfOneMinusSrcAlpha.)}
procedure StretchDrawAlpha(const SrcRect: TRect; DestCanvas: TImagingCanvas; 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 { Draws contents of this canvas onto another one using additive blending
(source and dest factors are bfOne).} (source and dest factors are bfOne).}
procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas; procedure StretchDrawAdd(const SrcRect: TRect; DestCanvas: TImagingCanvas;
@ -286,10 +294,36 @@ type
{ Gamma correction of individual color channels. Range is (0, +inf), { Gamma correction of individual color channels. Range is (0, +inf),
1.0 means no change.} 1.0 means no change.}
procedure GammaCorection(Red, Green, Blue: Single); procedure GammaCorection(Red, Green, Blue: Single);
{ Inverts colors of all image pixels, makes negative image.} { Inverts colors of all image pixels, makes negative image. Ignores alpha channel.}
procedure InvertColors; procedure InvertColors; virtual;
{ Simple single level thresholding with threshold level for each color channel.} { Simple single level thresholding with threshold level (in range [0, 1])
for each color channel.}
procedure Threshold(Red, Green, Blue: Single); 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.} { Color used when drawing lines, frames, and outlines of objects.}
property PenColor32: TColor32 read FPenColor32 write SetPenColor32; property PenColor32: TColor32 read FPenColor32 write SetPenColor32;
@ -337,6 +371,7 @@ type
TFastARGB32Canvas = class(TImagingCanvas) TFastARGB32Canvas = class(TImagingCanvas)
protected protected
FScanlines: PScanlineArray; FScanlines: PScanlineArray;
procedure AlphaBlendPixels(SrcPix, DestPix: PColor32Rec); {$IFDEF USE_INLINE}inline;{$ENDIF}
function GetPixel32(X, Y: LongInt): TColor32; override; function GetPixel32(X, Y: LongInt): TColor32; override;
procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override; procedure SetPixel32(X, Y: LongInt; const Value: TColor32); override;
public public
@ -344,6 +379,11 @@ type
procedure UpdateCanvasState; override; 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; property Scanlines: PScanlineArray read FScanlines;
class function GetSupportedFormats: TImageFormats; override; class function GetSupportedFormats: TImageFormats; override;
@ -600,13 +640,16 @@ procedure PixelAlphaProc(const SrcPix: TColorFPRec; DestPtr: PByte;
DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor); DestInfo: PImageFormatInfo; SrcFactor, DestFactor: TBlendingFactor);
var var
DestPix: TColorFPRec; DestPix: TColorFPRec;
SrcAlpha, DestAlpha: Single;
begin begin
DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil); DestPix := DestInfo.GetPixelFP(DestPtr, DestInfo, nil);
// Blend the two pixels (Src 'over' Dest alpha composition operation) // 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.A := SrcPix.A + DestPix.A - SrcPix.A * DestPix.A;
DestPix.G := SrcPix.G * SrcPix.A + DestPix.G * DestPix.A * (1.0 - SrcPix.A); SrcAlpha := IffFloat(DestPix.A = 0, 0, SrcPix.A / DestPix.A);
DestPix.B := SrcPix.B * SrcPix.A + DestPix.B * DestPix.A * (1.0 - SrcPix.A); DestAlpha := 1.0 - SrcAlpha;
DestPix.A := SrcPix.A + DestPix.A * (1.0 - SrcPix.A); 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 // Write blended pixel
DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix); DestInfo.SetPixelFP(DestPtr, DestInfo, nil, DestPix);
end; end;
@ -691,7 +734,7 @@ begin
end; end;
end; end;
function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, Ignore: Single): TColorFPRec; function TransformContrastBrightness(const Pixel: TColorFPRec; C, B, P3: Single): TColorFPRec;
begin begin
Result.A := Pixel.A; Result.A := Pixel.A;
Result.R := Pixel.R * C + B; Result.R := Pixel.R * C + B;
@ -707,7 +750,7 @@ begin
Result.B := Power(Pixel.B, 1.0 / B); Result.B := Power(Pixel.B, 1.0 / B);
end; end;
function TransformInvert(const Pixel: TColorFPRec; A, B, C: Single): TColorFPRec; function TransformInvert(const Pixel: TColorFPRec; P1, P2, P3: Single): TColorFPRec;
begin begin
Result.A := Pixel.A; Result.A := Pixel.A;
Result.R := 1.0 - Pixel.R; Result.R := 1.0 - Pixel.R;
@ -723,6 +766,49 @@ begin
Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0); Result.B := IffFloat(Pixel.B >= B, 1.0, 0.0);
end; 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 } { TImagingCanvas class implementation }
constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData); constructor TImagingCanvas.CreateForData(ImageDataPointer: PImageData);
@ -1175,6 +1261,98 @@ begin
end; end;
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; procedure TImagingCanvas.DrawInternal(const SrcRect: TRect;
DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor, DestCanvas: TImagingCanvas; DestX, DestY: Integer; SrcFactor,
DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc); DestFactor: TBlendingFactor; PixelWriteProc: TPixelWriteProc);
@ -1533,7 +1711,7 @@ end;
procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single); procedure TImagingCanvas.ModifyContrastBrightness(Contrast, Brightness: Single);
begin begin
PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100, PointTransform(TransformContrastBrightness, 1.0 + Contrast / 100,
Brightness / 100, 0.0); Brightness / 100, 0);
end; end;
procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single); procedure TImagingCanvas.GammaCorection(Red, Green, Blue: Single);
@ -1551,6 +1729,98 @@ begin
PointTransform(TransformThreshold, Red, Green, Blue); PointTransform(TransformThreshold, Red, Green, Blue);
end; 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; class function TImagingCanvas.GetSupportedFormats: TImageFormats;
begin begin
Result := [ifIndex8..Pred(ifDXT1)]; Result := [ifIndex8..Pred(ifDXT1)];
@ -1564,6 +1834,55 @@ begin
inherited Destroy; inherited Destroy;
end; 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; function TFastARGB32Canvas.GetPixel32(X, Y: LongInt): TColor32;
begin begin
Result := FScanlines[Y, X].Color; Result := FScanlines[Y, X].Color;
@ -1578,6 +1897,189 @@ begin
end; end;
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; procedure TFastARGB32Canvas.UpdateCanvasState;
var var
I: LongInt; I: LongInt;
@ -1601,6 +2103,24 @@ begin
Result := [ifA8R8G8B8]; Result := [ifA8R8G8B8];
end; 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 initialization
RegisterCanvas(TFastARGB32Canvas); RegisterCanvas(TFastARGB32Canvas);
@ -1616,6 +2136,19 @@ finalization
- add blending (*image and object drawing) - add blending (*image and object drawing)
- more objects (arc, polygon) - 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 --------------------------------- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed error that could cause AV in linear and nonlinear filters. - Fixed error that could cause AV in linear and nonlinear filters.
- Added blended rect filling function FillRectBlend. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -68,7 +68,7 @@ type
constructor CreateFromImage(AImage: TBaseImage); constructor CreateFromImage(AImage: TBaseImage);
destructor Destroy; override; destructor Destroy; override;
{ Returns info about current image.} { 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 { Creates a new image data with the given size and format. Old image
data is lost. Works only for the current image of TMultiImage.} 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 { Mirrors current image. Reverses the image along its vertical axis the left
side becomes the right and vice versa.} side becomes the right and vice versa.}
procedure Mirror; procedure Mirror;
{ Rotates image by 90, 180, 270, -90, -180, or -270 degrees counterclockwise.} { Rotates image by Angle degrees counterclockwise.}
procedure Rotate(Angle: LongInt); procedure Rotate(Angle: Single);
{ Copies rectangular part of SrcImage to DstImage. No blending is performed - { Copies rectangular part of SrcImage to DstImage. No blending is performed -
alpha is simply copied to destination image. Operates also with alpha is simply copied to destination image. Operates also with
negative X and Y coordinates. negative X and Y coordinates.
@ -451,7 +451,7 @@ begin
DoPixelsChanged; DoPixelsChanged;
end; end;
procedure TBaseImage.Rotate(Angle: LongInt); procedure TBaseImage.Rotate(Angle: Single);
begin begin
if Valid and Imaging.RotateImage(FPData^, Angle) then if Valid and Imaging.RotateImage(FPData^, Angle) then
DoPixelsChanged; 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net 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.} { Converts CMYK to RGB color.}
procedure CMYKToRGB16(C, M, Y, K: Word; var R, G, B: Word); 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 implementation
procedure RGBToYUV(R, G, B: Byte; var Y, U, V: Byte); 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 begin
RGBToCMY(R, G, B, C, M, Y); RGBToCMY(R, G, B, C, M, Y);
K := Min(C, Min(M, Y)); K := Min(C, Min(M, Y));
if K > 0 then if K = 255 then
begin begin
C := C - K; C := 0;
M := M - K; M := 0;
Y := Y - K; 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;
end; end;
@ -168,11 +180,17 @@ procedure RGBToCMYK16(R, G, B: Word; var C, M, Y, K: Word);
begin begin
RGBToCMY16(R, G, B, C, M, Y); RGBToCMY16(R, G, B, C, M, Y);
K := Min(C, Min(M, Y)); K := Min(C, Min(M, Y));
if K > 0 then if K = 65535 then
begin begin
C := C - K; C := 0;
M := M - K; M := 0;
Y := Y - K; 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;
end; end;
@ -183,12 +201,35 @@ begin
B := 65535 - (Y - MulDiv(Y, K, 65535) + K); B := 65535 - (Y - MulDiv(Y, K, 65535) + K);
end; 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: File Notes:
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - nothing now
-- 0.26.3 Changes/Bug Fixes ---------------------------------
- Added RGB<>YCoCg conversion functions.
- Fixed RGB>>CMYK conversions.
-- 0.23 Changes/Bug Fixes ----------------------------------- -- 0.23 Changes/Bug Fixes -----------------------------------
- Added RGB<>CMY(K) converion functions for 16 bit channels - Added RGB<>CMY(K) converion functions for 16 bit channels
(needed by PSD loading code). (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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -26,7 +26,7 @@
For more information about the LGPL: http://www.gnu.org/copyleft/lesser.html 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.} for saving and loading.}
unit ImagingComponents; unit ImagingComponents;
@ -34,6 +34,17 @@ unit ImagingComponents;
interface 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 uses
SysUtils, Types, Classes, SysUtils, Types, Classes,
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
@ -42,10 +53,6 @@ uses
{$IFDEF COMPONENT_SET_VCL} {$IFDEF COMPONENT_SET_VCL}
Graphics, Graphics,
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
Qt,
QGraphics,
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
InterfaceBase, InterfaceBase,
GraphType, GraphType,
@ -71,6 +78,8 @@ type
procedure ReadDataFromStream(Stream: TStream); virtual; procedure ReadDataFromStream(Stream: TStream); virtual;
procedure AssignTo(Dest: TPersistent); override; procedure AssignTo(Dest: TPersistent); override;
public public
constructor Create; override;
{ Loads new image from the stream. It can load all image { Loads new image from the stream. It can load all image
file formats supported by Imaging (and enabled of course) file formats supported by Imaging (and enabled of course)
even though it is called by descendant class capable of even though it is called by descendant class capable of
@ -114,8 +123,7 @@ type
{ Returns file extensions of this graphic class.} { Returns file extensions of this graphic class.}
class function GetFileExtensions: string; override; class function GetFileExtensions: string; override;
{ Returns default MIME type of this graphic class.} { Returns default MIME type of this graphic class.}
function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here function GetMimeType: string; override;
//function GetDefaultMimeType: string; override;
{$ENDIF} {$ENDIF}
{ Default (the most common) file extension of this graphic class.} { Default (the most common) file extension of this graphic class.}
property DefaultFileExt: string read FDefaultFileExt; property DefaultFileExt: string read FDefaultFileExt;
@ -123,7 +131,7 @@ type
TImagingGraphicForSaveClass = class of TImagingGraphicForSave; TImagingGraphicForSaveClass = class of TImagingGraphicForSave;
{$IFDEF LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
{ TImagingGraphic descendant for loading/saving Windows bitmaps. { TImagingGraphic descendant for loading/saving Windows bitmaps.
VCL/CLX/LCL all have native support for bitmaps so you might VCL/CLX/LCL all have native support for bitmaps so you might
want to disable this class (although you can save bitmaps with want to disable this class (although you can save bitmaps with
@ -140,7 +148,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
{ TImagingGraphic descendant for loading/saving JPEG images.} { TImagingGraphic descendant for loading/saving JPEG images.}
TImagingJpeg = class(TImagingGraphicForSave) TImagingJpeg = class(TImagingGraphicForSave)
protected protected
@ -151,8 +159,7 @@ type
procedure SaveToStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override; class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here function GetMimeType: string; override;
function GetDefaultMimeType: string; override;
{$ENDIF} {$ENDIF}
{ See ImagingJpegQuality option for details.} { See ImagingJpegQuality option for details.}
property Quality: LongInt read FQuality write FQuality; property Quality: LongInt read FQuality write FQuality;
@ -161,7 +168,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_PNG} {$IFNDEF DONT_LINK_PNG}
{ TImagingGraphic descendant for loading/saving PNG images.} { TImagingGraphic descendant for loading/saving PNG images.}
TImagingPNG = class(TImagingGraphicForSave) TImagingPNG = class(TImagingGraphicForSave)
protected protected
@ -178,7 +185,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_GIF} {$IFNDEF DONT_LINK_GIF}
{ TImagingGraphic descendant for loading/saving GIF images.} { TImagingGraphic descendant for loading/saving GIF images.}
TImagingGIF = class(TImagingGraphicForSave) TImagingGIF = class(TImagingGraphicForSave)
public public
@ -186,7 +193,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
{ TImagingGraphic descendant for loading/saving Targa images.} { TImagingGraphic descendant for loading/saving Targa images.}
TImagingTarga = class(TImagingGraphicForSave) TImagingTarga = class(TImagingGraphicForSave)
protected protected
@ -200,7 +207,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_DDS} {$IFNDEF DONT_LINK_DDS}
{ Compresssion type used when saving DDS files by TImagingDds.} { Compresssion type used when saving DDS files by TImagingDds.}
TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5); TDDSCompresion = (dcNone, dcDXT1, dcDXT3, dcDXT5);
@ -218,7 +225,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_MNG} {$IFNDEF DONT_LINK_MNG}
{ TImagingGraphic descendant for loading/saving MNG images.} { TImagingGraphic descendant for loading/saving MNG images.}
TImagingMNG = class(TImagingGraphicForSave) TImagingMNG = class(TImagingGraphicForSave)
protected protected
@ -233,8 +240,7 @@ type
procedure SaveToStream(Stream: TStream); override; procedure SaveToStream(Stream: TStream); override;
class function GetFileFormat: TImageFileFormat; override; class function GetFileFormat: TImageFileFormat; override;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function GetMimeType: string; override; // uncomment for Laz 0.9.25 if you get error here function GetMimeType: string; override;
function GetDefaultMimeType: string; override;
{$ENDIF} {$ENDIF}
{ See ImagingMNGLossyCompression option for details.} { See ImagingMNGLossyCompression option for details.}
property LossyCompression: Boolean read FLossyCompression write FLossyCompression; property LossyCompression: Boolean read FLossyCompression write FLossyCompression;
@ -251,7 +257,7 @@ type
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JNG} {$IFNDEF DONT_LINK_JNG}
{ TImagingGraphic descendant for loading/saving JNG images.} { TImagingGraphic descendant for loading/saving JNG images.}
TImagingJNG = class(TImagingGraphicForSave) TImagingJNG = class(TImagingGraphicForSave)
protected protected
@ -328,29 +334,29 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T
implementation implementation
uses uses
{$IF Defined(UNIX) and Defined(COMPONENT_SET_LCL)} {$IF Defined(LCL)}
{$IFDEF LCLGTK2} {$IF Defined(LCLGTK2)}
GLib2, GDK2, GTK2, GTKDef, GTKProc, GLib2, GDK2, GTK2, GTKDef, GTKProc,
{$ELSE} {$ELSEIF Defined(LCLGTK)}
GDK, GTK, GTKDef, GTKProc, GDK, GTK, GTKDef, GTKProc,
{$ENDIF} {$IFEND}
{$IFEND} {$IFEND}
{$IFDEF LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
ImagingBitmap, ImagingBitmap,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
ImagingJpeg, ImagingJpeg,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_GIF} {$IFNDEF DONT_LINK_GIF}
ImagingGif, ImagingGif,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
ImagingTarga, ImagingTarga,
{$ENDIF} {$ENDIF}
{$IFDEF LINK_DDS} {$IFNDEF DONT_LINK_DDS}
ImagingDds, ImagingDds,
{$ENDIF} {$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, ImagingNetworkGraphics,
{$IFEND} {$IFEND}
ImagingUtility; ImagingUtility;
@ -359,9 +365,10 @@ resourcestring
SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s'; SBadFormatDataToBitmap = 'Cannot find compatible bitmap format for image %s';
SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p'; SBadFormatBitmapToData = 'Cannot find compatible data format for bitmap %p';
SBadFormatDisplay = 'Unsupported image format passed'; SBadFormatDisplay = 'Unsupported image format passed';
SUnsupportedLCLWidgetSet = 'This function is not implemented for current LCL widget set';
SImagingGraphicName = 'Imaging Graphic AllInOne'; SImagingGraphicName = 'Imaging Graphic AllInOne';
{ Registers types to VCL/CLX/LCL.} { Registers types to VCL/LCL.}
procedure RegisterTypes; procedure RegisterTypes;
var var
I: LongInt; I: LongInt;
@ -387,87 +394,85 @@ var
begin begin
for I := Imaging.GetFileFormatCount - 1 downto 0 do for I := Imaging.GetFileFormatCount - 1 downto 0 do
RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I)); RegisterFileFormatAllInOne(Imaging.GetFileFormatAtIndex(I));
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGraphic);{$ENDIF} Classes.RegisterClass(TImagingGraphic);
{$IFDEF LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
RegisterFileFormat(TImagingTarga); RegisterFileFormat(TImagingTarga);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingTarga);{$ENDIF} Classes.RegisterClass(TImagingTarga);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_DDS} {$IFNDEF DONT_LINK_DDS}
RegisterFileFormat(TImagingDDS); RegisterFileFormat(TImagingDDS);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingDDS);{$ENDIF} Classes.RegisterClass(TImagingDDS);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JNG} {$IFNDEF DONT_LINK_JNG}
RegisterFileFormat(TImagingJNG); RegisterFileFormat(TImagingJNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJNG);{$ENDIF} Classes.RegisterClass(TImagingJNG);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_MNG} {$IFNDEF DONT_LINK_MNG}
RegisterFileFormat(TImagingMNG); RegisterFileFormat(TImagingMNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingMNG);{$ENDIF} Classes.RegisterClass(TImagingMNG);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_GIF} {$IFNDEF DONT_LINK_GIF}
RegisterFileFormat(TImagingGIF); RegisterFileFormat(TImagingGIF);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingGIF);{$ENDIF} Classes.RegisterClass(TImagingGIF);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_PNG} {$IFNDEF DONT_LINK_PNG}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
// Unregister Lazarus´ default PNG loader which crashes on some PNG files // Unregister Lazarus´ default PNG loader which crashes on some PNG files
TPicture.UnregisterGraphicClass(TPortableNetworkGraphic); TPicture.UnregisterGraphicClass(TPortableNetworkGraphic);
{$ENDIF} {$ENDIF}
RegisterFileFormat(TImagingPNG); RegisterFileFormat(TImagingPNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingPNG);{$ENDIF} Classes.RegisterClass(TImagingPNG);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
RegisterFileFormat(TImagingJpeg); RegisterFileFormat(TImagingJpeg);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingJpeg);{$ENDIF} Classes.RegisterClass(TImagingJpeg);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
RegisterFileFormat(TImagingBitmap); RegisterFileFormat(TImagingBitmap);
{$IFNDEF COMPONENT_SET_CLX}Classes.RegisterClass(TImagingBitmap);{$ENDIF} Classes.RegisterClass(TImagingBitmap);
{$ENDIF} {$ENDIF}
end; end;
{ Unregisters types from VCL/CLX/LCL.} { Unregisters types from VCL/LCL.}
procedure UnRegisterTypes; procedure UnRegisterTypes;
begin begin
{$IFDEF LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
TPicture.UnregisterGraphicClass(TImagingBitmap); TPicture.UnregisterGraphicClass(TImagingBitmap);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingBitmap);{$ENDIF} Classes.UnRegisterClass(TImagingBitmap);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
TPicture.UnregisterGraphicClass(TImagingJpeg); TPicture.UnregisterGraphicClass(TImagingJpeg);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingJpeg);{$ENDIF} Classes.UnRegisterClass(TImagingJpeg);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_PNG} {$IFNDEF DONT_LINK_PNG}
TPicture.UnregisterGraphicClass(TImagingPNG); TPicture.UnregisterGraphicClass(TImagingPNG);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingPNG);{$ENDIF} Classes.UnRegisterClass(TImagingPNG);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_GIF} {$IFNDEF DONT_LINK_GIF}
TPicture.UnregisterGraphicClass(TImagingGIF); TPicture.UnregisterGraphicClass(TImagingGIF);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGIF);{$ENDIF} Classes.UnRegisterClass(TImagingGIF);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
TPicture.UnregisterGraphicClass(TImagingTarga); TPicture.UnregisterGraphicClass(TImagingTarga);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingTarga);{$ENDIF} Classes.UnRegisterClass(TImagingTarga);
{$ENDIF} {$ENDIF}
{$IFDEF LINK_DDS} {$IFNDEF DONT_LINK_DDS}
TPicture.UnregisterGraphicClass(TImagingDDS); TPicture.UnregisterGraphicClass(TImagingDDS);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingDDS);{$ENDIF} Classes.UnRegisterClass(TImagingDDS);
{$ENDIF} {$ENDIF}
TPicture.UnregisterGraphicClass(TImagingGraphic); TPicture.UnregisterGraphicClass(TImagingGraphic);
{$IFNDEF COMPONENT_SET_CLX}Classes.UnRegisterClass(TImagingGraphic);{$ENDIF} Classes.UnRegisterClass(TImagingGraphic);
end; end;
function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat; function DataFormatToPixelFormat(Format: TImageFormat): TPixelFormat;
begin begin
case Format of case Format of
{$IFNDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_VCL}
ifIndex8: Result := pf8bit; ifIndex8: Result := pf8bit;
{$ENDIF}
{$IF (not Defined(COMPONENT_SET_CLX)) and (not Defined(COMPONENT_SET_LCL))}
ifR5G6B5: Result := pf16bit; ifR5G6B5: Result := pf16bit;
ifR8G8B8: Result := pf24bit; ifR8G8B8: Result := pf24bit;
{$IFEND} {$ENDIF}
ifA8R8G8B8, ifA8R8G8B8,
ifX8R8G8B8: Result := pf32bit; ifX8R8G8B8: Result := pf32bit;
else else
@ -479,11 +484,9 @@ function PixelFormatToDataFormat(Format: TPixelFormat): TImageFormat;
begin begin
case Format of case Format of
pf8bit: Result := ifIndex8; pf8bit: Result := ifIndex8;
{$IFNDEF COMPONENT_SET_CLX}
pf15bit: Result := ifA1R5G5B5; pf15bit: Result := ifA1R5G5B5;
pf16bit: Result := ifR5G6B5; pf16bit: Result := ifR5G6B5;
pf24bit: Result := ifR8G8B8; pf24bit: Result := ifR8G8B8;
{$ENDIF}
pf32bit: Result := ifA8R8G8B8; pf32bit: Result := ifA8R8G8B8;
else else
Result := ifUnknown; Result := ifUnknown;
@ -499,9 +502,6 @@ var
{$IFDEF COMPONENT_SET_VCL} {$IFDEF COMPONENT_SET_VCL}
LogPalette: TMaxLogPalette; LogPalette: TMaxLogPalette;
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
ColorTable: PPalette32;
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
RawImage: TRawImage; RawImage: TRawImage;
ImgHandle, ImgMaskHandle: HBitmap; ImgHandle, ImgMaskHandle: HBitmap;
@ -517,19 +517,16 @@ begin
if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then if Info.IsFloatingPoint or Info.HasAlphaChannel or Info.IsSpecial then
Imaging.ConvertImage(WorkData, ifA8R8G8B8) Imaging.ConvertImage(WorkData, ifA8R8G8B8)
else else
{$IFNDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_VCL}
if Info.IsIndexed or Info.HasGrayChannel then if Info.IsIndexed or Info.HasGrayChannel then
Imaging.ConvertImage(WorkData, ifIndex8) Imaging.ConvertImage(WorkData, ifIndex8)
else if Info.UsePixelFormat then
Imaging.ConvertImage(WorkData, ifR5G6B5)
else else
{$ENDIF} Imaging.ConvertImage(WorkData, ifR8G8B8);
{$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);
{$ELSE} {$ELSE}
Imaging.ConvertImage(WorkData, ifA8R8G8B8); Imaging.ConvertImage(WorkData, ifA8R8G8B8);
{$IFEND} {$ENDIF}
PF := DataFormatToPixelFormat(WorkData.Format); PF := DataFormatToPixelFormat(WorkData.Format);
GetImageFormatInfo(WorkData.Format, Info); GetImageFormatInfo(WorkData.Format, Info);
@ -565,27 +562,13 @@ begin
// Copy scanlines // Copy scanlines
for I := 0 to WorkData.Height - 1 do for I := 0 to WorkData.Height - 1 do
Move(PByteArray(WorkData.Bits)[I * LineBytes], Bitmap.Scanline[I]^, LineBytes); 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 // Delphi 2009 and newer support alpha transparency fro TBitmap
begin {$IF Defined(DELPHI) and (CompilerVersion >= 20.0)}
// Copy palette if Bitmap.PixelFormat = pf32bit then
ColorTable := Bitmap.ColorTable; Bitmap.AlphaFormat := afDefined;
for I := 0 to Info.PaletteEntries - 1 do {$IFEND}
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);
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
// Create 32bit raw image from image data // Create 32bit raw image from image data
@ -594,9 +577,9 @@ begin
begin begin
Width := WorkData.Width; Width := WorkData.Width;
Height := WorkData.Height; Height := WorkData.Height;
BitsPerPixel := Info.BytesPerPixel * 8; BitsPerPixel := 32;
Format := ricfRGBA; Format := ricfRGBA;
LineEnd := rileByteBoundary; LineEnd := rileDWordBoundary;
BitOrder := riboBitsInOrder; BitOrder := riboBitsInOrder;
ByteOrder := riboLSBFirst; ByteOrder := riboLSBFirst;
LineOrder := riloTopToBottom; LineOrder := riloTopToBottom;
@ -608,14 +591,13 @@ begin
RedShift := 16; RedShift := 16;
GreenShift := 8; GreenShift := 8;
BlueShift := 0; BlueShift := 0;
Depth := 24; Depth := 32; // Must be 32 for alpha blending (and for working in MacOSX Carbon)
end; end;
RawImage.Data := WorkData.Bits; RawImage.Data := WorkData.Bits;
RawImage.DataSize := WorkData.Size; RawImage.DataSize := WorkData.Size;
// Create bitmap from raw image // Create bitmap from raw image
{ If you get complitation error here upgrade to Lazarus 0.9.24+ } if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle) then
if RawImage_CreateBitmaps(RawImage, ImgHandle, ImgMaskHandle, False) then
begin begin
Bitmap.Handle := ImgHandle; Bitmap.Handle := ImgHandle;
Bitmap.MaskHandle := ImgMaskHandle; Bitmap.MaskHandle := ImgMaskHandle;
@ -634,9 +616,6 @@ var
Colors: Word; Colors: Word;
LogPalette: TMaxLogPalette; LogPalette: TMaxLogPalette;
{$ENDIF} {$ENDIF}
{$IFDEF COMPONENT_SET_CLX}
ColorTable: PPalette32;
{$ENDIF}
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
RawImage: TRawImage; RawImage: TRawImage;
LineLazBytes: LongInt; LineLazBytes: LongInt;
@ -650,7 +629,6 @@ begin
// trough RawImage api and cannot be changed to mirror some Imaging format // trough RawImage api and cannot be changed to mirror some Imaging format
// (so formats with no coresponding Imaging format cannot be saved now). // (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 if RawImage_DescriptionFromBitmap(Bitmap.Handle, RawImage.Description) then
case RawImage.Description.BitsPerPixel of case RawImage.Description.BitsPerPixel of
8: Format := ifIndex8; 8: Format := ifIndex8;
@ -707,28 +685,9 @@ begin
for I := 0 to Data.Height - 1 do for I := 0 to Data.Height - 1 do
Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes); Move(Bitmap.ScanLine[I]^, PByteArray(Data.Bits)[I * LineBytes], LineBytes);
{$ENDIF} {$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} {$IFDEF COMPONENT_SET_LCL}
// Get raw image from bitmap (mask handle must be 0 or expect violations) // 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, nil) then
//if RawImage_FromBitmap(RawImage, Bitmap.Handle, 0, Classes.Rect(0, 0, Data.Width, Data.Height)) then
begin begin
LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel, LineLazBytes := GetBytesPerLine(Data.Width, RawImage.Description.BitsPerPixel,
RawImage.Description.LineEnd); RawImage.Description.LineEnd);
@ -757,6 +716,7 @@ procedure DisplayImageDataOnDC(DC: HDC; const DstRect: TRect; const ImageData: T
var var
OldMode: Integer; OldMode: Integer;
BitmapInfo: Windows.TBitmapInfo; BitmapInfo: Windows.TBitmapInfo;
Bmp: TBitmap;
begin begin
if TestImage(ImageData) then if TestImage(ImageData) then
begin begin
@ -780,10 +740,22 @@ begin
end; end;
try try
with SrcRect, ImageData do with SrcRect, ImageData do
Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top, if Windows.StretchDIBits(DC, DstRect.Left, DstRect.Top,
DstRect.Right - DstRect.Left, DstRect.Bottom - DstRect.Top, Left, 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 finally
Windows.SetStretchBltMode(DC, OldMode); Windows.SetStretchBltMode(DC, OldMode);
end; end;
@ -792,50 +764,21 @@ end;
{$ENDIF} {$ENDIF}
procedure DisplayImageData(DstCanvas: TCanvas; const DstRect: TRect; const ImageData: TImageData; const SrcRect: TRect); 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 begin
DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect); DisplayImageDataOnDC(DstCanvas.Handle, DstRect, ImageData, SrcRect);
end; end;
{$ELSEIF Defined(COMPONENT_SET_CLX)} {$ELSEIF Defined(LCLGTK) or Defined(LCLGTK2)}
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)}
procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, procedure GDKDrawBitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; ImageData: TImageData); SrcWidth, SrcHeight: Integer; ImageData: TImageData);
var var
P: TPoint; P: TPoint;
begin 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 := TGtkDeviceContext(Dest).Offset;
//P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X); Inc(DstX, P.X);
Inc(DstY, P.Y); Inc(DstY, P.Y);
gdk_draw_rgb_32_image(TGtkDeviceContext(Dest).Drawable, TGtkDeviceContext(Dest).GC, 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, DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
@PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4); @PLongWordArray(ImageData.Bits)[SrcY * ImageData.Width + SrcX], ImageData.Width * 4);
end; end;
@ -890,6 +833,10 @@ begin
end; end;
end; end;
end; end;
{$ELSE}
begin
raise Exception.Create(SUnsupportedLCLWidgetSet);
end;
{$IFEND} {$IFEND}
procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage); procedure DisplayImage(DstCanvas: TCanvas; DstX, DstY: LongInt; Image: TBaseImage);
@ -911,6 +858,12 @@ end;
{ TImagingGraphic class implementation } { TImagingGraphic class implementation }
constructor TImagingGraphic.Create;
begin
inherited Create;
PixelFormat := pf24Bit;
end;
procedure TImagingGraphic.LoadFromStream(Stream: TStream); procedure TImagingGraphic.LoadFromStream(Stream: TStream);
begin begin
ReadDataFromStream(Stream); ReadDataFromStream(Stream);
@ -1020,14 +973,13 @@ begin
Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]); Result := StringReplace(GetFileFormat.Extensions.CommaText, ',', ';', [rfReplaceAll]);
end; end;
function TImagingGraphicForSave.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here function TImagingGraphicForSave.GetMimeType: string;
//function TImagingGraphicForSave.GetDefaultMimeType: string;
begin begin
Result := 'image/' + FDefaultFileExt; Result := 'image/' + FDefaultFileExt;
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_BITMAP} {$IFNDEF DONT_LINK_BITMAP}
{ TImagingBitmap class implementation } { TImagingBitmap class implementation }
@ -1051,7 +1003,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JPEG} {$IFNDEF DONT_LINK_JPEG}
{ TImagingJpeg class implementation } { TImagingJpeg class implementation }
@ -1068,8 +1020,7 @@ begin
end; end;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function TImagingJpeg.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here function TImagingJpeg.GetMimeType: string;
function TImagingJpeg.GetDefaultMimeType: string;
begin begin
Result := 'image/jpeg'; Result := 'image/jpeg';
end; end;
@ -1086,7 +1037,7 @@ end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_PNG} {$IFNDEF DONT_LINK_PNG}
{ TImagingPNG class implementation } { TImagingPNG class implementation }
@ -1112,7 +1063,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_GIF} {$IFNDEF DONT_LINK_GIF}
{ TImagingGIF class implementation} { TImagingGIF class implementation}
@ -1123,7 +1074,7 @@ end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_TARGA} {$IFNDEF DONT_LINK_TARGA}
{ TImagingTarga class implementation } { TImagingTarga class implementation }
@ -1147,7 +1098,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_DDS} {$IFNDEF DONT_LINK_DDS}
{ TImagingDDS class implementation } { TImagingDDS class implementation }
@ -1180,7 +1131,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_MNG} {$IFNDEF DONT_LINK_MNG}
{ TImagingMNG class implementation } { TImagingMNG class implementation }
@ -1201,8 +1152,7 @@ begin
end; end;
{$IFDEF COMPONENT_SET_LCL} {$IFDEF COMPONENT_SET_LCL}
//function TImagingMNG.GetMimeType: string; // uncomment for Laz 0.9.25 if you get error here function TImagingMNG.GetMimeType: string;
function TImagingMNG.GetDefaultMimeType: string;
begin begin
Result := 'video/mng'; Result := 'video/mng';
end; end;
@ -1222,7 +1172,7 @@ begin
end; end;
{$ENDIF} {$ENDIF}
{$IFDEF LINK_JNG} {$IFNDEF DONT_LINK_JNG}
{ TImagingJNG class implementation } { TImagingJNG class implementation }
@ -1259,12 +1209,30 @@ initialization
finalization finalization
UnRegisterTypes; UnRegisterTypes;
{$IFEND} // {$IF not Defined(COMPONENT_SET_LCL) and not Defined(COMPONENT_SET_VCL)}
{ {
File Notes: File Notes:
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus - Fixed wrong IFDEF causing that Imaging wouldn't compile in Lazarus
with GTK2 target. 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -52,14 +52,14 @@ function ImTestImage(var Image: TImageData): Boolean; cdecl;
function ImFreeImage(var Image: TImageData): Boolean; cdecl; function ImFreeImage(var Image: TImageData): Boolean; cdecl;
{ Look at DetermineFileFormat for details. Ext should have enough space for { Look at DetermineFileFormat for details. Ext should have enough space for
result file extension.} 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 { Look at DetermineMemoryFormat for details. Ext should have enough space for
result file extension.} 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.} { Look at IsFileFormatSupported for details.}
function ImIsFileFormatSupported(FileName: PChar): Boolean; cdecl; function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean; cdecl;
{ Look at EnumFileFormats for details.} { 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; var CanSave, IsMultiImageFormat: Boolean): Boolean; cdecl;
{ Inits image list.} { Inits image list.}
@ -82,24 +82,24 @@ function ImTestImagesInList(ImageList: TImageDataList): Boolean; cdecl;
function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl; function ImFreeImageList(var ImageList: TImageDataList): Boolean; cdecl;
{ Look at LoadImageFromFile for details.} { 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.} { Look at LoadImageFromMemory for details.}
function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl; function ImLoadImageFromMemory(Data: Pointer; Size: LongInt; var Image: TImageData): Boolean; cdecl;
{ Look at LoadMultiImageFromFile for details.} { 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.} { Look at LoadMultiImageFromMemory for details.}
function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt; function ImLoadMultiImageFromMemory(Data: Pointer; Size: LongInt;
var ImageList: TImageDataList): Boolean; cdecl; var ImageList: TImageDataList): Boolean; cdecl;
{ Look at SaveImageToFile for details.} { 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.} { 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; const Image: TImageData): Boolean; cdecl;
{ Look at SaveMultiImageToFile for details.} { 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.} { 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; ImageList: TImageDataList): Boolean; cdecl;
{ Look at CloneImage for details.} { Look at CloneImage for details.}
@ -131,7 +131,7 @@ function ImSplitImage(var Image: TImageData; var Chunks: TImageDataList;
function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32; function ImMakePaletteForImages(Images: TImageDataList; Pal: PPalette32;
MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl; MaxColors: LongInt; ConvertImages: Boolean): Boolean; cdecl;
{ Look at RotateImage for details.} { 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.} { Look at CopyRect for details.}
function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt; function ImCopyRect(const SrcImage: TImageData; SrcX, SrcY, Width, Height: LongInt;
@ -262,33 +262,33 @@ begin
end; end;
end; end;
function ImDetermineFileFormat(FileName, Ext: PChar): Boolean; function ImDetermineFileFormat(FileName, Ext: PAnsiChar): Boolean;
var var
S: string; S: string;
begin begin
try try
S := Imaging.DetermineFileFormat(FileName); S := Imaging.DetermineFileFormat(FileName);
Result := S <> ''; Result := S <> '';
StrCopy(Ext, PChar(S)); StrCopy(Ext, PAnsiChar(AnsiString(S)));
except except
Result := False; Result := False;
end; end;
end; end;
function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PChar): Boolean; function ImDetermineMemoryFormat(Data: Pointer; Size: LongInt; Ext: PAnsiChar): Boolean;
var var
S: string; S: string;
begin begin
try try
S := Imaging.DetermineMemoryFormat(Data, Size); S := Imaging.DetermineMemoryFormat(Data, Size);
Result := S <> ''; Result := S <> '';
StrCopy(Ext, PChar(S)); StrCopy(Ext, PAnsiChar(AnsiString(S)));
except except
Result := False; Result := False;
end; end;
end; end;
function ImIsFileFormatSupported(FileName: PChar): Boolean; function ImIsFileFormatSupported(FileName: PAnsiChar): Boolean;
begin begin
try try
Result := Imaging.IsFileFormatSupported(FileName); Result := Imaging.IsFileFormatSupported(FileName);
@ -297,7 +297,7 @@ begin
end; end;
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 CanSave, IsMultiImageFormat: Boolean): Boolean;
var var
StrName, StrDefaultExt, StrMasks: string; StrName, StrDefaultExt, StrMasks: string;
@ -305,9 +305,9 @@ begin
try try
Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave, Result := Imaging.EnumFileFormats(Index, StrName, StrDefaultExt, StrMasks, CanSave,
IsMultiImageFormat); IsMultiImageFormat);
StrCopy(Name, PChar(StrName)); StrCopy(Name, PAnsiChar(AnsiString(StrName)));
StrCopy(DefaultExt, PChar(StrDefaultExt)); StrCopy(DefaultExt, PAnsiChar(AnsiString(StrDefaultExt)));
StrCopy(Masks, PChar(StrMasks)); StrCopy(Masks, PAnsiChar(AnsiString(StrMasks)));
except except
Result := False; Result := False;
end; end;
@ -419,7 +419,7 @@ begin
end; end;
end; end;
function ImLoadImageFromFile(FileName: PChar; var Image: TImageData): Boolean; function ImLoadImageFromFile(FileName: PAnsiChar; var Image: TImageData): Boolean;
begin begin
try try
Result := Imaging.LoadImageFromFile(FileName, Image); Result := Imaging.LoadImageFromFile(FileName, Image);
@ -437,7 +437,7 @@ begin
end; end;
end; end;
function ImLoadMultiImageFromFile(FileName: PChar; var ImageList: TImageDataList): function ImLoadMultiImageFromFile(FileName: PAnsiChar; var ImageList: TImageDataList):
Boolean; Boolean;
begin begin
try try
@ -460,7 +460,7 @@ begin
end; end;
end; end;
function ImSaveImageToFile(FileName: PChar; const Image: TImageData): Boolean; function ImSaveImageToFile(FileName: PAnsiChar; const Image: TImageData): Boolean;
begin begin
try try
Result := Imaging.SaveImageToFile(FileName, Image); Result := Imaging.SaveImageToFile(FileName, Image);
@ -469,7 +469,7 @@ begin
end; end;
end; end;
function ImSaveImageToMemory(Ext: PChar; Data: Pointer; var Size: LongInt; function ImSaveImageToMemory(Ext: PAnsiChar; Data: Pointer; var Size: LongInt;
const Image: TImageData): Boolean; const Image: TImageData): Boolean;
begin begin
try try
@ -479,7 +479,7 @@ begin
end; end;
end; end;
function ImSaveMultiImageToFile(FileName: PChar; function ImSaveMultiImageToFile(FileName: PAnsiChar;
ImageList: TImageDataList): Boolean; ImageList: TImageDataList): Boolean;
begin begin
try try
@ -490,7 +490,7 @@ begin
end; end;
end; end;
function ImSaveMultiImageToMemory(Ext: PChar; Data: Pointer; Size: PLongInt; function ImSaveMultiImageToMemory(Ext: PAnsiChar; Data: Pointer; Size: PLongInt;
ImageList: TImageDataList): Boolean; ImageList: TImageDataList): Boolean;
begin begin
try try
@ -612,7 +612,7 @@ begin
end; end;
end; end;
function ImRotateImage(var Image: TImageData; Angle: LongInt): Boolean; function ImRotateImage(var Image: TImageData; Angle: Single): Boolean;
begin begin
try try
Result := Imaging.RotateImage(Image, Angle); Result := Imaging.RotateImage(Image, Angle);
@ -864,6 +864,10 @@ end;
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - nothing now
-- 0.26.3 ---------------------------------------------------
- changed PChars to PAnsiChars and some more D2009 friendly
casts.
-- 0.19 ----------------------------------------------------- -- 0.19 -----------------------------------------------------
- updated to reflect changes in low level interface (added pixel set/get, ...) - updated to reflect changes in low level interface (added pixel set/get, ...)
- changed ImInitImage to procedure to reflect change in Imaging.pas - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -388,6 +388,7 @@ var
BytesPerPixel: 1; BytesPerPixel: 1;
ChannelCount: 1; ChannelCount: 1;
PaletteEntries: 256; PaletteEntries: 256;
HasAlphaChannel: True;
IsIndexed: True; IsIndexed: True;
GetPixelsSize: GetStdPixelsSize; GetPixelsSize: GetStdPixelsSize;
CheckDimensions: CheckStdDimensions; CheckDimensions: CheckStdDimensions;
@ -1617,8 +1618,7 @@ begin
Result[0][0].Pos := (SrcLow + SrcHigh) div 2; Result[0][0].Pos := (SrcLow + SrcHigh) div 2;
Result[0][0].Weight := 1.0; Result[0][0].Weight := 1.0;
end end
else else if Scale < 1.0 then
if Scale < 1.0 then
begin begin
// Sub-sampling - scales from bigger to smaller // Sub-sampling - scales from bigger to smaller
Radius := Radius / Scale; Radius := Radius / Scale;
@ -1649,8 +1649,7 @@ begin
Result[I][0].Pos := Floor(Center); Result[I][0].Pos := Floor(Center);
Result[I][0].Weight := 1.0; Result[I][0].Weight := 1.0;
end end
else else if Count <> 0.0 then
if Count <> 0.0 then
Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count; Result[I][K div 2].Weight := Result[I][K div 2].Weight - Count;
end; end;
end end
@ -1680,8 +1679,7 @@ begin
begin begin
if J < 0 then if J < 0 then
N := SrcImageWidth + J N := SrcImageWidth + J
else else if J >= SrcImageWidth then
if J >= SrcImageWidth then
N := J - SrcImageWidth N := J - SrcImageWidth
else else
N := ClampInt(J, SrcLow, SrcHigh - 1); 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); DstHeight: LongInt; Filter: TFilterFunction; Radius: Single; WrapEdges: Boolean);
const const
Channel8BitMax: Single = 255.0; Channel8BitMax: Single = 255.0;
type
TBufferItem = record
A, R, G, B: Integer;
end;
var var
MapX, MapY: TMappingTable; MapX, MapY: TMappingTable;
I, J, X, Y: LongInt; I, J, X, Y: LongInt;
XMinimum, XMaximum: LongInt; XMinimum, XMaximum: LongInt;
LineBuffer: array of TColorFPRec; LineBufferFP: array of TColorFPRec;
LineBufferInt: array of TBufferItem;
ClusterX, ClusterY: TCluster; ClusterX, ClusterY: TCluster;
Weight, AccumA, AccumR, AccumG, AccumB: Single; Weight, AccumA, AccumR, AccumG, AccumB: Single;
IWeight, IAccumA, IAccumR, IAccumG, IAccumB: Integer;
DstLine: PByte; DstLine: PByte;
SrcColor: TColor32Rec; SrcColor: TColor32Rec;
SrcFloat: TColorFPRec; SrcFloat: TColorFPRec;
@ -1759,10 +1763,10 @@ begin
try try
// Find min and max X coords of pixels that will contribute to target image // Find min and max X coords of pixels that will contribute to target image
FindExtremes(MapX, XMinimum, XMaximum); FindExtremes(MapX, XMinimum, XMaximum);
SetLength(LineBuffer, XMaximum - XMinimum + 1);
if not UseOptimizedVersion then if not UseOptimizedVersion then
begin begin
SetLength(LineBufferFP, XMaximum - XMinimum + 1);
// Following code works for the rest of data formats // Following code works for the rest of data formats
for J := 0 to DstHeight - 1 do for J := 0 to DstHeight - 1 do
begin begin
@ -1773,10 +1777,10 @@ begin
for X := XMinimum to XMaximum do for X := XMinimum to XMaximum do
begin begin
// Clear accumulators // Clear accumulators
AccumA := 0.0; AccumA := 0;
AccumR := 0.0; AccumR := 0;
AccumG := 0.0; AccumG := 0;
AccumB := 0.0; AccumB := 0;
// For each pixel in line compute weighted sum of pixels // For each pixel in line compute weighted sum of pixels
// in source column that will contribute to this pixel // in source column that will contribute to this pixel
for Y := 0 to Length(ClusterY) - 1 do for Y := 0 to Length(ClusterY) - 1 do
@ -1790,7 +1794,7 @@ begin
AccumA := AccumA + SrcFloat.A * Weight; AccumA := AccumA + SrcFloat.A * Weight;
end; end;
// Store accumulated value for this pixel in buffer // Store accumulated value for this pixel in buffer
with LineBuffer[X - XMinimum] do with LineBufferFP[X - XMinimum] do
begin begin
A := AccumA; A := AccumA;
R := AccumR; R := AccumR;
@ -1806,17 +1810,17 @@ begin
begin begin
ClusterX := MapX[I]; ClusterX := MapX[I];
// Clear accumulator // Clear accumulator
AccumA := 0.0; AccumA := 0;
AccumR := 0.0; AccumR := 0;
AccumG := 0.0; AccumG := 0;
AccumB := 0.0; AccumB := 0;
// Compute weighted sum of values (which are already // Compute weighted sum of values (which are already
// computed weighted sums of pixels in source columns stored in LineBuffer) // computed weighted sums of pixels in source columns stored in LineBuffer)
// that will contribute to the current target pixel // that will contribute to the current target pixel
for X := 0 to Length(ClusterX) - 1 do for X := 0 to Length(ClusterX) - 1 do
begin begin
Weight := ClusterX[X].Weight; Weight := ClusterX[X].Weight;
with LineBuffer[ClusterX[X].Pos - XMinimum] do with LineBufferFP[ClusterX[X].Pos - XMinimum] do
begin begin
AccumB := AccumB + B * Weight; AccumB := AccumB + B * Weight;
AccumG := AccumG + G * Weight; AccumG := AccumG + G * Weight;
@ -1838,37 +1842,35 @@ begin
end end
else else
begin begin
SetLength(LineBufferInt, XMaximum - XMinimum + 1);
// Following code is optimized for images with 8 bit channels // Following code is optimized for images with 8 bit channels
for J := 0 to DstHeight - 1 do for J := 0 to DstHeight - 1 do
begin begin
ClusterY := MapY[J]; ClusterY := MapY[J];
for X := XMinimum to XMaximum do for X := XMinimum to XMaximum do
begin begin
AccumA := 0.0; IAccumA := 0;
AccumR := 0.0; IAccumR := 0;
AccumG := 0.0; IAccumG := 0;
AccumB := 0.0; IAccumB := 0;
for Y := 0 to Length(ClusterY) - 1 do for Y := 0 to Length(ClusterY) - 1 do
begin begin
Weight := ClusterY[Y].Weight; IWeight := Round(256 * ClusterY[Y].Weight);
CopyPixel( CopyPixel(
@PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel], @PByteArray(SrcImage.Bits)[(ClusterY[Y].Pos * SrcImage.Width + X) * Info.BytesPerPixel],
@SrcColor, Info.BytesPerPixel); @SrcColor, Info.BytesPerPixel);
AccumB := AccumB + SrcColor.B * Weight; IAccumB := IAccumB + SrcColor.B * IWeight;
if Info.ChannelCount > 1 then IAccumG := IAccumG + SrcColor.G * IWeight;
AccumG := AccumG + SrcColor.G * Weight; IAccumR := IAccumR + SrcColor.R * IWeight;
if Info.ChannelCount > 2 then IAccumA := IAccumA + SrcColor.A * IWeight;
AccumR := AccumR + SrcColor.R * Weight;
if Info.ChannelCount > 3 then
AccumA := AccumA + SrcColor.A * Weight;
end; end;
with LineBuffer[X - XMinimum] do with LineBufferInt[X - XMinimum] do
begin begin
A := AccumA; A := IAccumA;
R := AccumR; R := IAccumR;
G := AccumG; G := IAccumG;
B := AccumB; B := IAccumB;
end; end;
end; end;
@ -1877,31 +1879,26 @@ begin
for I := 0 to DstWidth - 1 do for I := 0 to DstWidth - 1 do
begin begin
ClusterX := MapX[I]; ClusterX := MapX[I];
AccumA := 0.0; IAccumA := 0;
AccumR := 0.0; IAccumR := 0;
AccumG := 0.0; IAccumG := 0;
AccumB := 0.0; IAccumB := 0;
for X := 0 to Length(ClusterX) - 1 do for X := 0 to Length(ClusterX) - 1 do
begin begin
Weight := ClusterX[X].Weight; IWeight := Round(256 * ClusterX[X].Weight);
with LineBuffer[ClusterX[X].Pos - XMinimum] do with LineBufferInt[ClusterX[X].Pos - XMinimum] do
begin begin
AccumB := AccumB + B * Weight; IAccumB := IAccumB + B * IWeight;
if Info.ChannelCount > 1 then IAccumG := IAccumG + G * IWeight;
AccumG := AccumG + G * Weight; IAccumR := IAccumR + R * IWeight;
if Info.ChannelCount > 2 then IAccumA := IAccumA + A * IWeight;
AccumR := AccumR + R * Weight;
if Info.ChannelCount > 3 then
AccumA := AccumA + A * Weight;
end; end;
end; end;
SrcColor.B := ClampToByte(Round(AccumB));
if Info.ChannelCount > 1 then SrcColor.B := ClampInt(IAccumB, 0, $00FF0000) shr 16;
SrcColor.G := ClampToByte(Round(AccumG)); SrcColor.G := ClampInt(IAccumG, 0, $00FF0000) shr 16;
if Info.ChannelCount > 2 then SrcColor.R := ClampInt(IAccumR, 0, $00FF0000) shr 16;
SrcColor.R := ClampToByte(Round(AccumR)); SrcColor.A := ClampInt(IAccumA, 0, $00FF0000) shr 16;
if Info.ChannelCount > 3 then
SrcColor.A := ClampToByte(Round(AccumA));
CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel); CopyPixel(@SrcColor, DstLine, Info.BytesPerPixel);
Inc(DstLine, Info.BytesPerPixel); Inc(DstLine, Info.BytesPerPixel);
@ -3234,11 +3231,11 @@ type
TPixelBlock = array[0..15] of TPixelInfo; TPixelBlock = array[0..15] of TPixelInfo;
function DecodeCol(Color : Word): TColor32Rec; function DecodeCol(Color: Word): TColor32Rec;
{$IFDEF USE_INLINE} inline; {$ENDIF} {$IFDEF USE_INLINE} inline; {$ENDIF}
begin begin
Result.A := $FF; 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.G := ((Color and $07E0) shr 5) shl 2;
Result.B := (Color and $001F) shl 3;} Result.B := (Color and $001F) shl 3;}
// this color expansion is slower but gives better results // this color expansion is slower but gives better results
@ -3663,7 +3660,7 @@ begin
GetBlock(Pixels, SrcBits, X, Y, Width, Height); GetBlock(Pixels, SrcBits, X, Y, Width, Height);
for I := 0 to 7 do for I := 0 to 7 do
PByteArray(@AlphaBlock.Alphas)[I] := 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); GetEndpoints(Pixels, Block.Color0, Block.Color1);
FixEndpoints(Block.Color0, Block.Color1, False); FixEndpoints(Block.Color0, Block.Color1, False);
Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels); Block.Mask := GetColorMask(Block.Color0, Block.Color1, 4, Pixels);
@ -4222,7 +4219,11 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 ----------------------------------- -- 0.25.0 Changes/Bug Fixes -----------------------------------
- Made some resampling stuff public so that it can be used in canvas class. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -44,9 +44,11 @@ type
its own color palette. GIF uses lossless LZW compression its own color palette. GIF uses lossless LZW compression
(patent expired few years ago). (patent expired few years ago).
Imaging can load and save all GIFs with all frames and supports 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) TGIFFileFormat = class(TImageFileFormat)
private private
FLoadAnimated: LongBool;
function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; function InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle; procedure LZWDecompress(Stream: TStream; Handle: TImagingHandle;
Width, Height: Integer; Interlaced: Boolean; Data: Pointer); Width, Height: Integer; Interlaced: Boolean; Data: Pointer);
@ -62,6 +64,8 @@ type
public public
constructor Create; override; constructor Create; override;
function TestFormat(Handle: TImagingHandle): Boolean; override; function TestFormat(Handle: TImagingHandle): Boolean; override;
published
property LoadAnimated: LongBool read FLoadAnimated write FLoadAnimated;
end; end;
implementation implementation
@ -70,10 +74,11 @@ const
SGIFFormatName = 'Graphics Interchange Format'; SGIFFormatName = 'Graphics Interchange Format';
SGIFMasks = '*.gif'; SGIFMasks = '*.gif';
GIFSupportedFormats: TImageFormats = [ifIndex8]; GIFSupportedFormats: TImageFormats = [ifIndex8];
GIFDefaultLoadAnimated = True;
type type
TGIFVersion = (gv87, gv89); TGIFVersion = (gv87, gv89);
TDisposalMethod = (dmUndefined, dmLeave, dmRestoreBackground, TDisposalMethod = (dmNoRemoval, dmLeave, dmRestoreBackground,
dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7); dmRestorePrevious, dmReserved4, dmReserved5, dmReserved6, dmReserved7);
const const
@ -144,6 +149,19 @@ type
Terminator: Byte; Terminator: Byte;
end; 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 const
CodeTableSize = 4096; CodeTableSize = 4096;
HashTableSize = 17777; HashTableSize = 17777;
@ -206,8 +224,10 @@ begin
FCanSave := True; FCanSave := True;
FIsMultiImageFormat := True; FIsMultiImageFormat := True;
FSupportedFormats := GIFSupportedFormats; FSupportedFormats := GIFSupportedFormats;
FLoadAnimated := GIFDefaultLoadAnimated;
AddMasks(SGIFMasks); AddMasks(SGIFMasks);
RegisterOption(ImagingGIFLoadAnimated, @FLoadAnimated);
end; end;
function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer; function TGIFFileFormat.InterlaceStep(Y, Height: Integer; var Pass: Integer): Integer;
@ -644,28 +664,56 @@ end;
function TGIFFileFormat.LoadData(Handle: TImagingHandle; function TGIFFileFormat.LoadData(Handle: TImagingHandle;
var Images: TDynImageDataArray; OnlyFirstLevel: Boolean): Boolean; 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 var
Header: TGIFHeader; Header: TGIFHeader;
HasGlobalPal: Boolean; HasGlobalPal: Boolean;
GlobalPalLength: Integer; GlobalPalLength: Integer;
GlobalPal: TPalette32Size256; GlobalPal: TPalette32Size256;
I: Integer; ScreenWidth, ScreenHeight, I, CachedIndex: Integer;
BlockID: Byte; BlockID: Byte;
HasGraphicExt: Boolean; HasGraphicExt: Boolean;
GraphicExt: TGraphicControlExtension; GraphicExt: TGraphicControlExtension;
Disposals: array of TDisposalMethod; FrameInfos: array of TFrameInfo;
AppRead: Boolean;
CachedFrame: TImageData;
AnimFrames: TDynImageDataArray;
function ReadBlockID: Byte; function ReadBlockID: Byte;
begin begin
Result := GIFTrailer; Result := GIFTrailer;
GetIO.Read(Handle, @Result, SizeOf(Result)); if GetIO.Read(Handle, @Result, SizeOf(Result)) < SizeOf(Result) then
Result := GIFTrailer;
end; end;
procedure ReadExtensions; procedure ReadExtensions;
var 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 begin
HasGraphicExt := False; HasGraphicExt := False;
AppRead := False;
// Read extensions until image descriptor is found. Only graphic extension // Read extensions until image descriptor is found. Only graphic extension
// is stored now (for transparency), others are skipped. // is stored now (for transparency), others are skipped.
@ -674,47 +722,69 @@ var
begin begin
Read(Handle, @ExtType, SizeOf(ExtType)); Read(Handle, @ExtType, SizeOf(ExtType));
if ExtType = GIFGraphicControlExtension then while ExtType in [GIFGraphicControlExtension, GIFCommentExtension, GIFApplicationExtension, GIFPlainText] do
begin begin
HasGraphicExt := True; if ExtType = GIFGraphicControlExtension then
Read(Handle, @GraphicExt, SizeOf(GraphicExt)); 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 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;
end; end;
@ -743,33 +813,49 @@ var
procedure ReadFrame; procedure ReadFrame;
var var
ImageDesc: TImageDescriptor; ImageDesc: TImageDescriptor;
HasLocalPal, Interlaced, HasTransparency: Boolean; Interlaced: Boolean;
I, Idx, LocalPalLength, TransIndex: Integer; I, Idx, LocalPalLength: Integer;
LocalPal: TPalette32Size256; LocalPal: TPalette32Size256;
BlockTerm: Byte;
Frame: TImageData;
LZWStream: TMemoryStream; LZWStream: TMemoryStream;
procedure RemoveBadFrame;
begin
FreeImage(Images[Idx]);
SetLength(Images, Length(Images) - 1);
end;
begin begin
Idx := Length(Images); Idx := Length(Images);
SetLength(Images, Idx + 1); SetLength(Images, Idx + 1);
SetLength(FrameInfos, Idx + 1);
FillChar(LocalPal, SizeOf(LocalPal), 0); FillChar(LocalPal, SizeOf(LocalPal), 0);
with GetIO do with GetIO do
begin begin
// Read and parse image descriptor // Read and parse image descriptor
Read(Handle, @ImageDesc, SizeOf(ImageDesc)); 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; Interlaced := (ImageDesc.PackedFields and GIFInterlaced) = GIFInterlaced;
LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize; LocalPalLength := ImageDesc.PackedFields and GIFColorTableSize;
LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1) LocalPalLength := 1 shl (LocalPalLength + 1); // Total pal length is 2^(n+1)
// Create new logical screen // From Mozilla source
NewImage(Header.ScreenWidth, Header.ScreenHeight, ifIndex8, Images[Idx]); 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 // Create new image for this frame which would be later pasted onto logical screen
InitImage(Frame); NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Images[Idx]);
NewImage(ImageDesc.Width, ImageDesc.Height, ifIndex8, Frame);
// Load local palette if there is any // Load local palette if there is any
if HasLocalPal then if FrameInfos[Idx].HasLocalPal then
for I := 0 to LocalPalLength - 1 do for I := 0 to LocalPalLength - 1 do
begin begin
LocalPal[I].A := 255; LocalPal[I].A := 255;
@ -780,87 +866,174 @@ var
// Use local pal if present or global pal if present or create // Use local pal if present or global pal if present or create
// default pal if neither of them is present // default pal if neither of them is present
if HasLocalPal then if FrameInfos[Idx].HasLocalPal then
Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal)) Move(LocalPal, Images[Idx].Palette^, SizeOf(LocalPal))
else if HasGlobalPal then else if HasGlobalPal then
Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal)) Move(GlobalPal, Images[Idx].Palette^, SizeOf(GlobalPal))
else else
FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2); FillCustomPalette(Images[Idx].Palette, GlobalPalLength, 3, 3, 2);
// Add default disposal method for this frame if (ImageDesc.Left <= Header.ScreenWidth + 1) and (ImageDesc.Top <= Header.ScreenHeight + 1) then
SetLength(Disposals, Length(Disposals) + 1); begin
Disposals[High(Disposals)] := dmUndefined; // 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 Grahic Control Extension is present make use of it
if HasGraphicExt then if HasGraphicExt then
begin begin
HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent; FrameInfos[Idx].HasTransparency := (GraphicExt.PackedFields and GIFTransparent) = GIFTransparent;
Disposals[High(Disposals)] := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2); FrameInfos[Idx].Disposal := TDisposalMethod((GraphicExt.PackedFields and GIFDisposalMethod) shr 2);
if HasTransparency then if FrameInfos[Idx].HasTransparency then
Images[Idx].Palette[GraphicExt.TransparentColorIndex].A := 0; begin
end FrameInfos[Idx].TransIndex := GraphicExt.TransparentColorIndex;
else Images[Idx].Palette[FrameInfos[Idx].TransIndex].A := 0;
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;
end; end;
end end
else else
begin FrameInfos[Idx].HasTransparency := False;
// First frame - just fill with background color
FillRect(Images[Idx], 0, 0, Images[Idx].Width, Images[Idx].Height,
@Header.BackgroundColorIndex);
end;
LZWStream := TMemoryStream.Create; LZWStream := TMemoryStream.Create;
try try
// Copy LZW data to temp stream, needed for correct decompression try
CopyLZWData(LZWStream); // Copy LZW data to temp stream, needed for correct decompression
LZWStream.Position := 0; CopyLZWData(LZWStream);
// Data decompression finally LZWStream.Position := 0;
LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Frame.Bits); // Data decompression finally
// Now copy frame to logical screen with skipping of transparent pixels (if enabled) LZWDecompress(LZWStream, Handle, ImageDesc.Width, ImageDesc.Height, Interlaced, Images[Idx].Bits);
TransIndex := Iff(HasTransparency, GraphicExt.TransparentColorIndex, MaxInt); except
CopyFrameTransparent(Images[Idx], Frame, ImageDesc.Left, ImageDesc.Top, RemoveBadFrame;
TransIndex, Disposals[Idx]); Exit;
end;
finally finally
FreeImage(Frame);
LZWStream.Free; LZWStream.Free;
end; end;
end; 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 begin
AppRead := False;
SetLength(Images, 0); SetLength(Images, 0);
FillChar(GlobalPal, SizeOf(GlobalPal), 0); FillChar(GlobalPal, SizeOf(GlobalPal), 0);
with GetIO do with GetIO do
begin begin
// Read GIF header // Read GIF header
Read(Handle, @Header, SizeOf(Header)); Read(Handle, @Header, SizeOf(Header));
ScreenWidth := Header.ScreenWidth;
ScreenHeight := Header.ScreenHeight;
HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7 HasGlobalPal := Header.PackedFields and GIFGlobalColorTable = GIFGlobalColorTable; // Bit 7
GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2 GlobalPalLength := Header.PackedFields and GIFColorTableSize; // Bits 0-2
GlobalPalLength := 1 shl (GlobalPalLength + 1); // Total pal length is 2^(n+1) 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 // Now read all data blocks in the file until file trailer is reached
while BlockID <> GIFTrailer do while BlockID <> GIFTrailer do
begin 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 // Read supported and skip unsupported extensions
ReadExtensions; ReadExtensions;
// If image frame is found read it // If image frame is found read it
@ -895,6 +1071,31 @@ begin
BlockID := GIFTrailer; BlockID := GIFTrailer;
end; 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; Result := True;
end; end;
end; end;
@ -1007,6 +1208,14 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- Fixed loading of some rare GIFs, problems with LZW - Fixed loading of some rare GIFs, problems with LZW
decompression. 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -43,22 +43,22 @@ unit ImagingJpeg;
{$DEFINE IMJPEGLIB} {$DEFINE IMJPEGLIB}
{ $DEFINE PASJPEG} { $DEFINE PASJPEG}
{ Automatically use FPC's PasJpeg when compiling with Lazarus.} { 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}
{$IFDEF LCL} {$IF Defined(LCL) and not Defined(WINDOWS)}
{$UNDEF IMJPEGLIB} {$UNDEF IMJPEGLIB}
{$DEFINE PASJPEG} {$DEFINE PASJPEG}
{$ENDIF} {$IFEND}
interface interface
uses uses
SysUtils, ImagingTypes, Imaging, ImagingColors, SysUtils, ImagingTypes, Imaging, ImagingColors,
{$IF Defined(IMJPEGLIB)} {$IF Defined(IMJPEGLIB)}
imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjpeglib, imjmorecfg, imjcomapi, imjdapimin, imjdeferr, imjerror,
imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam, imjdapistd, imjcapimin, imjcapistd, imjdmarker, imjcparam,
{$ELSEIF Defined(PASJPEG)} {$ELSEIF Defined(PASJPEG)}
jpeglib, jmorecfg, jcomapi, jdapimin, jpeglib, jmorecfg, jcomapi, jdapimin, jdeferr, jerror,
jdapistd, jcapimin, jcapistd, jdmarker, jcparam, jdapistd, jcapimin, jcapistd, jdmarker, jcparam,
{$IFEND} {$IFEND}
ImagingUtility; ImagingUtility;
@ -70,7 +70,10 @@ uses
type type
{ Class for loading/saving Jpeg images. Supports load/save of { 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) TJpegFileFormat = class(TImageFileFormat)
private private
FGrayScale: Boolean; FGrayScale: Boolean;
@ -110,10 +113,11 @@ const
const const
{ Jpeg file identifiers.} { Jpeg file identifiers.}
JpegMagic: TChar2 = #$FF#$D8; JpegMagic: TChar2 = #$FF#$D8;
JFIFSignature: TChar4 = 'JFIF';
EXIFSignature: TChar4 = 'Exif';
BufferSize = 16384; BufferSize = 16384;
resourcestring
SJpegError = 'JPEG Error';
type type
TJpegContext = record TJpegContext = record
case Byte of case Byte of
@ -139,40 +143,23 @@ type
var var
JIO: TIOFunctions; JIO: TIOFunctions;
JpegErrorMgr: jpeg_error_mgr;
{ Intenal unit jpeglib support functions } { Intenal unit jpeglib support functions }
procedure JpegError(CurInfo: j_common_ptr); procedure JpegError(CInfo: j_common_ptr);
begin var
end; Buffer: string;
procedure EmitMessage(CurInfo: j_common_ptr; msg_level: Integer);
begin begin
{ Create the message and raise exception }
CInfo^.err^.format_message(CInfo, buffer);
raise EImagingError.CreateFmt(SJPEGError + ' %d: ' + Buffer, [CInfo.err^.msg_code]);
end; end;
procedure OutputMessage(CurInfo: j_common_ptr); procedure OutputMessage(CurInfo: j_common_ptr);
begin begin
end; 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); procedure ReleaseContext(var jc: TJpegContext);
begin begin
if jc.common.err = nil then if jc.common.err = nil then
@ -221,7 +208,7 @@ begin
FillInputBuffer(cinfo); FillInputBuffer(cinfo);
end; end;
Src.Pub.next_input_byte := @PByteArray(Src.Pub.next_input_byte)[num_bytes]; 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); Dec(Src.Pub.bytes_in_buffer, num_bytes);
end; end;
end; end;
@ -311,7 +298,11 @@ end;
procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext); procedure InitDecompressor(Handle: TImagingHandle; var jc: TJpegContext);
begin begin
FillChar(jc, sizeof(jc), 0); 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)); jpeg_CreateDecompress(@jc.d, JPEG_LIB_VERSION, sizeof(jc.d));
JpegStdioSrc(jc.d, Handle); JpegStdioSrc(jc.d, Handle);
jpeg_read_header(@jc.d, True); jpeg_read_header(@jc.d, True);
@ -329,15 +320,19 @@ procedure InitCompressor(Handle: TImagingHandle; var jc: TJpegContext;
Saver: TJpegFileFormat); Saver: TJpegFileFormat);
begin begin
FillChar(jc, sizeof(jc), 0); 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)); jpeg_CreateCompress(@jc.c, JPEG_LIB_VERSION, sizeof(jc.c));
JpegStdioDest(jc.c, Handle); 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_defaults(@jc.c);
jpeg_set_quality(@jc.c, Saver.FQuality, True); 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 if Saver.FProgressive then
jpeg_simple_progression(@jc.c); jpeg_simple_progression(@jc.c);
end; end;
@ -376,13 +371,14 @@ var
jc: TJpegContext; jc: TJpegContext;
Info: TImageFormatInfo; Info: TImageFormatInfo;
Col32: PColor32Rec; Col32: PColor32Rec;
{$IFDEF RGBSWAPPED} NeedsRedBlueSwap: Boolean;
Pix: PColor24Rec; Pix: PColor24Rec;
{$ENDIF}
begin begin
// Copy IO functions to global var used in JpegLib callbacks // Copy IO functions to global var used in JpegLib callbacks
Result := False;
SetJpegIO(GetIO); SetJpegIO(GetIO);
SetLength(Images, 1); SetLength(Images, 1);
with JIO, Images[0] do with JIO, Images[0] do
try try
InitDecompressor(Handle, jc); InitDecompressor(Handle, jc);
@ -390,6 +386,8 @@ begin
JCS_GRAYSCALE: Format := ifGray8; JCS_GRAYSCALE: Format := ifGray8;
JCS_RGB: Format := ifR8G8B8; JCS_RGB: Format := ifR8G8B8;
JCS_CMYK: Format := ifA8R8G8B8; JCS_CMYK: Format := ifA8R8G8B8;
else
Exit;
end; end;
NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]); NewImage(jc.d.image_width, jc.d.image_height, Format, Images[0]);
jpeg_start_decompress(@jc.d); jpeg_start_decompress(@jc.d);
@ -398,11 +396,18 @@ begin
LinesPerCall := 1; LinesPerCall := 1;
Dest := Bits; 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 while jc.d.output_scanline < jc.d.output_height do
begin begin
LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall); LinesRead := jpeg_read_scanlines(@jc.d, @Dest, LinesPerCall);
{$IFDEF RGBSWAPPED} if NeedsRedBlueSwap and (Format = ifR8G8B8) then
if Format = ifR8G8B8 then
begin begin
Pix := PColor24Rec(Dest); Pix := PColor24Rec(Dest);
for I := 0 to Width - 1 do for I := 0 to Width - 1 do
@ -411,7 +416,6 @@ begin
Inc(Pix); Inc(Pix);
end; end;
end; end;
{$ENDIF}
Inc(Dest, PtrInc * LinesRead); Inc(Dest, PtrInc * LinesRead);
end; end;
@ -526,7 +530,7 @@ end;
function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean; function TJpegFileFormat.TestFormat(Handle: TImagingHandle): Boolean;
var var
ReadCount: LongInt; ReadCount: LongInt;
ID: array[0..9] of Char; ID: array[0..9] of AnsiChar;
begin begin
Result := False; Result := False;
if Handle <> nil then if Handle <> nil then
@ -554,8 +558,20 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 --------------------------------- -- 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 --------------------------------- -- 0.24.1 Changes/Bug Fixes ---------------------------------
- Fixed loading of CMYK jpeg images. Could cause heap corruption - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -33,32 +33,35 @@ unit ImagingOpenGL;
{$I ImagingOptions.inc} {$I ImagingOptions.inc}
{ Define this symbol if you want to use dglOpenGL header.} { Define this symbol if you want to use dglOpenGL header.}
{.$DEFINE USE_DGL_HEADERS} { $DEFINE USE_DGL_HEADERS}
{ $DEFINE USE_GLSCENE_HEADERS}
interface interface
uses uses
SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats, SysUtils, Classes, ImagingTypes, Imaging, ImagingFormats,
{$IFDEF USE_DGL_HEADERS} {$IF Defined(USE_DGL_HEADERS)}
dglOpenGL, dglOpenGL,
{$ELSEIF Defined(USE_GLSCENE_HEADERS)}
OpenGL1x,
{$ELSE} {$ELSE}
gl, glext, gl, glext,
{$ENDIF} {$IFEND}
ImagingUtility; ImagingUtility;
type type
{ Various texture capabilities of installed OpenGL driver.} { Various texture capabilities of installed OpenGL driver.}
TGLTextureCaps = record TGLTextureCaps = record
MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW MaxTextureSize: LongInt; // Max size of texture in pixels supported by HW
NonPowerOfTwo: Boolean; // HW has full support for NPOT textures NonPowerOfTwo: Boolean; // HW has full support for NPOT textures
DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures DXTCompression: Boolean; // HW supports S3TC/DXTC compressed textures
ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N) ATI3DcCompression: Boolean; // HW supports ATI 3Dc compressed textures (ATI2N)
LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N) LATCCompression: Boolean; // HW supports LATC/RGTC compressed textures (ATI1N+ATI2N)
FloatTextures: Boolean; // HW supports floating point textures FloatTextures: Boolean; // HW supports floating point textures
MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering MaxAnisotropy: LongInt; // Max anisotropy for aniso texture filtering
MaxSimultaneousTextures: LongInt; // Number of texture units MaxSimultaneousTextures: LongInt; // Number of texture units
ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp ClampToEdge: Boolean; // GL_EXT_texture_edge_clamp
TextureLOD: Boolean; // GL_SGIS_texture_lod TextureLOD: Boolean; // GL_SGIS_texture_lod
VertexTextureUnits: Integer; // Texture units accessible in vertex programs VertexTextureUnits: Integer; // Texture units accessible in vertex programs
end; end;
@ -278,6 +281,10 @@ const
GL_UNSIGNED_INT_2_10_10_10_REV = $8368; GL_UNSIGNED_INT_2_10_10_10_REV = $8368;
GL_HALF_FLOAT_ARB = $140B; GL_HALF_FLOAT_ARB = $140B;
// Other GL constants
GL_MAX_VERTEX_TEXTURE_IMAGE_UNITS = $8B4C;
{$IFDEF MSWINDOWS} {$IFDEF MSWINDOWS}
GLLibName = 'opengl32.dll'; GLLibName = 'opengl32.dll';
{$ENDIF} {$ENDIF}
@ -880,6 +887,9 @@ initialization
not only A8R8G8B8 not only A8R8G8B8
- support for cube and 3D maps - 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 --------------------------------- -- 0.25.0 Changes/Bug Fixes ---------------------------------
- Added 3Dc compressed texture formats support. - Added 3Dc compressed texture formats support.
- Added detection of 3Dc formats to texture caps. - 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 User Options
Following defines and options can be changed by user. Following defines and options can be changed by user.
} }
{ Source options. } { Source options }
{$DEFINE USE_INLINE} // use function inlining for some functions {$DEFINE USE_INLINE} // Use function inlining for some functions
// works in Free Pascal and Delphi 9+ // works in Free Pascal and Delphi 9+.
{$DEFINE USE_ASM} // if defined, assembler versions of some {.$DEFINE USE_ASM} // Ff defined, assembler versions of some
// functions will be used (only for x86) // functions will be used (only for x86).
{ $DEFINE DEBUG} // if defined, debug info, range/IO/overflow
// 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 // 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 (* File format support linking options.
// Extras package. Exactly which formats will be Define formats which you don't want to be registred automatically.
// registered depends on settings in Default: all formats are registered = no symbols defined.
// ImagingExtras.pas unit. 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 { Component set used in ImagignComponents.pas unit. You usually don't need
to be concerned with this - proper component library is selected automatically 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_VCL} // use Delphi VCL
{ $DEFINE COMPONENT_SET_CLX} // use Borland's CLX (set automatically when using Kylix, {$DEFINE COMPONENT_SET_LCL} // use Lazarus LCL (set automatically when compiling with FPC)
// must be se manually when compiling with Delphi 6/7)
{ $DEFINE COMPONENT_SET_LCL} // use Lazarus' LCL (set automatically when
// compiling with FPC)
{ {
Auto Options Auto Options
@ -85,7 +91,7 @@
{$ENDIF} {$ENDIF}
{$IFEND} {$IFEND}
{$IFDEF DEBUG} {$IF Defined(IMAGING_DEBUG)}
{$ASSERTIONS ON} {$ASSERTIONS ON}
{$DEBUGINFO ON} {$DEBUGINFO ON}
{$RANGECHECKS ON} {$RANGECHECKS ON}
@ -95,13 +101,13 @@
{$OPTIMIZATION OFF} {$OPTIMIZATION OFF}
{$STACKFRAMES ON} {$STACKFRAMES ON}
{$LOCALSYMBOLS ON} {$LOCALSYMBOLS ON}
{ $DEFINE MEMCHECK} {$DEFINE MEMCHECK}
{$ENDIF} {$ENDIF}
{$IFDEF FPC} {$IFDEF FPC}
{$S+} {$S+}
{$CHECKPOINTER ON} {$CHECKPOINTER ON}
{$ENDIF} {$ENDIF}
{$ELSE} {$ELSEIF Defined(IMAGING_RELEASE)}
{$ASSERTIONS OFF} {$ASSERTIONS OFF}
{$DEBUGINFO OFF} {$DEBUGINFO OFF}
{$RANGECHECKS OFF} {$RANGECHECKS OFF}
@ -115,7 +121,8 @@
{$IFDEF FPC} {$IFDEF FPC}
{$S-} {$S-}
{$ENDIF} {$ENDIF}
{$ENDIF} {$IFEND}
{ Compiler capabilities } { Compiler capabilities }
@ -151,40 +158,11 @@
{$IFDEF FPC} {$IFDEF FPC}
{$DEFINE COMPONENT_SET_LCL} {$DEFINE COMPONENT_SET_LCL}
{$UNDEF COMPONENT_SET_VCL} {$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_CLX}
{$ENDIF}
{$IFDEF KYLIX}
{$DEFINE COMPONENT_SET_CLX}
{$UNDEF COMPONENT_SET_VCL}
{$UNDEF COMPONENT_SET_LCL}
{$ENDIF} {$ENDIF}
{$IFDEF DELPHI} {$IFDEF DELPHI}
{$UNDEF COMPONENT_SET_LCL} {$UNDEF COMPONENT_SET_LCL}
{$IF CompilerVersion >= 17} {$DEFINE COMPONENT_SET_VCL}
{$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}
{$ENDIF} {$ENDIF}
{ Platform options } { Platform options }
@ -220,16 +198,4 @@
{$INLINE ON} // turns inlining on for compilers that support it {$INLINE ON} // turns inlining on for compilers that support it
{$ENDIF} {$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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -46,7 +46,7 @@ type
TPortableMapInfo = record TPortableMapInfo = record
Width: LongInt; Width: LongInt;
Height: LongInt; Height: LongInt;
FormatId: Char; FormatId: AnsiChar;
MaxVal: LongInt; MaxVal: LongInt;
BitCount: LongInt; BitCount: LongInt;
Depth: LongInt; Depth: LongInt;
@ -200,7 +200,7 @@ var
MonoData: Pointer; MonoData: Pointer;
Info: TImageFormatInfo; Info: TImageFormatInfo;
PixelFP: TColorFPRec; PixelFP: TColorFPRec;
LineBuffer: array[0..LineBufferCapacity - 1] of Char; LineBuffer: array[0..LineBufferCapacity - 1] of AnsiChar;
LineEnd, LinePos: LongInt; LineEnd, LinePos: LongInt;
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
LineBreak: string; LineBreak: string;
@ -228,7 +228,7 @@ var
function ReadString: string; function ReadString: string;
var var
S: AnsiString; S: AnsiString;
C: Char; C: AnsiChar;
begin begin
// First skip all whitespace chars // First skip all whitespace chars
SetLength(S, 1); SetLength(S, 1);
@ -266,7 +266,7 @@ var
// Dec pos, current is the begining of the the string // Dec pos, current is the begining of the the string
Dec(LinePos); Dec(LinePos);
Result := S; Result := string(S);
end; end;
function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function ReadIntValue: LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -276,7 +276,7 @@ var
procedure FindLineBreak; procedure FindLineBreak;
var var
C: Char; C: AnsiChar;
begin begin
LineBreak := #10; LineBreak := #10;
repeat repeat
@ -586,7 +586,11 @@ var
begin begin
SetLength(S, Length(S) + 1); SetLength(S, Length(S) + 1);
S[Length(S)] := Delimiter; 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)); GetIO.Write(Handle, @S[1], Length(S));
{$IFEND}
Inc(LineLength, Length(S)); Inc(LineLength, Length(S));
end; end;
@ -807,7 +811,6 @@ begin
FName := SPGMFormatName; FName := SPGMFormatName;
FSupportedFormats := PGMSupportedFormats; FSupportedFormats := PGMSupportedFormats;
AddMasks(SPGMMasks); AddMasks(SPGMMasks);
RegisterOption(ImagingPGMSaveBinary, @FSaveBinary); RegisterOption(ImagingPGMSaveBinary, @FSaveBinary);
FIdNumbers := '25'; FIdNumbers := '25';
end; end;
@ -818,7 +821,10 @@ var
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
begin begin
FillChar(MapInfo, SizeOf(MapInfo), 0); 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; MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
@ -853,7 +859,6 @@ begin
FName := SPPMFormatName; FName := SPPMFormatName;
FSupportedFormats := PPMSupportedFormats; FSupportedFormats := PPMSupportedFormats;
AddMasks(SPPMMasks); AddMasks(SPPMMasks);
RegisterOption(ImagingPPMSaveBinary, @FSaveBinary); RegisterOption(ImagingPPMSaveBinary, @FSaveBinary);
FIdNumbers := '36'; FIdNumbers := '36';
end; end;
@ -864,7 +869,10 @@ var
MapInfo: TPortableMapInfo; MapInfo: TPortableMapInfo;
begin begin
FillChar(MapInfo, SizeOf(MapInfo), 0); 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; MapInfo.Binary := FSaveBinary;
Result := SaveDataInternal(Handle, Images, Index, MapInfo); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
@ -952,11 +960,17 @@ var
begin begin
FillChar(MapInfo, SizeOf(MapInfo), 0); FillChar(MapInfo, SizeOf(MapInfo), 0);
Info := GetFormatInfo(Images[Index].Format); Info := GetFormatInfo(Images[Index].Format);
if (Info.ChannelCount > 1) or Info.IsIndexed then if (Info.ChannelCount > 1) or Info.IsIndexed then
MapInfo.TupleType := ttRGBFP MapInfo.TupleType := ttRGBFP
else else
MapInfo.TupleType := ttGrayScaleFP; 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; MapInfo.Binary := True;
Result := SaveDataInternal(Handle, Images, Index, MapInfo); Result := SaveDataInternal(Handle, Images, Index, MapInfo);
end; end;
@ -983,6 +997,9 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - nothing now
-- 0.26.3 Changes/Bug Fixes -----------------------------------
- Fixed D2009 Unicode related bug in PNM saving.
-- 0.24.3 Changes/Bug Fixes ----------------------------------- -- 0.24.3 Changes/Bug Fixes -----------------------------------
- Improved compatibility of 16bit/component image loading. - Improved compatibility of 16bit/component image loading.
- Changes for better thread safety. - 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -89,11 +89,11 @@ type
{ Footer at the end of TGA file.} { Footer at the end of TGA file.}
TTargaFooter = packed record TTargaFooter = packed record
ExtOff: LongWord; // Extension Area Offset ExtOff: LongWord; // Extension Area Offset
DevDirOff: LongWord; // Developer Directory Offset DevDirOff: LongWord; // Developer Directory Offset
Signature: array[0..15] of Char; // TRUEVISION-XFILE Signature: TChar16; // TRUEVISION-XFILE
Reserved: Byte; // ASCII period '.' Reserved: Byte; // ASCII period '.'
NullChar: Byte; // 0 NullChar: Byte; // 0
end; 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -39,7 +39,7 @@ const
{ Current Minor version of Imaging.} { Current Minor version of Imaging.}
ImagingVersionMinor = 26; ImagingVersionMinor = 26;
{ Current patch of Imaging.} { Current patch of Imaging.}
ImagingVersionPatch = 0; ImagingVersionPatch = 4;
{ Imaging Option Ids whose values can be set/get by SetOption/ { Imaging Option Ids whose values can be set/get by SetOption/
GetOption functions.} GetOption functions.}
@ -91,6 +91,11 @@ const
Allowed values are in range 0 (no compresstion) to 9 (best compression). Allowed values are in range 0 (no compresstion) to 9 (best compression).
Default value is 5.} Default value is 5.}
ImagingPNGCompressLevel = 26; 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 { Specifies whether MNG animation frames are saved with lossy or lossless
compression. Lossless frames are saved as PNG images and lossy frames are 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 { Boolean option that specifies whether GIF images with more frames
are animated by Imaging (according to frame disposal methods) or just 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). 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; ImagingGIFLoadAnimated = 56;
{ This option is used when reducing number of colors used in { This option is used when reducing number of colors used in
image (mainly when converting from ARGB image to indexed image (mainly when converting from ARGB image to indexed
format). Mask is 'anded' (bitwise AND) with every pixel's 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 Vampyre Imaging Library
by Marek Mauder by Marek Mauder
http://imaginglib.sourceforge.net http://imaginglib.sourceforge.net
@ -56,6 +56,7 @@ type
TBooleanArray = array[0..MaxInt - 1] of Boolean; TBooleanArray = array[0..MaxInt - 1] of Boolean;
PBooleanArray = ^TBooleanArray; PBooleanArray = ^TBooleanArray;
TDynByteArray = array of Byte;
TDynIntegerArray = array of Integer; TDynIntegerArray = array of Integer;
TDynBooleanArray = array of Boolean; TDynBooleanArray = array of Boolean;
@ -98,10 +99,11 @@ type
end; end;
PFloatHelper = ^TFloatHelper; PFloatHelper = ^TFloatHelper;
TChar2 = array[0..1] of Char; TChar2 = array[0..1] of AnsiChar;
TChar3 = array[0..2] of Char; TChar3 = array[0..2] of AnsiChar;
TChar4 = array[0..3] of Char; TChar4 = array[0..3] of AnsiChar;
TChar8 = array[0..7] of Char; TChar8 = array[0..7] of AnsiChar;
TChar16 = array[0..15] of AnsiChar;
{ Options for BuildFileList function: { Options for BuildFileList function:
flFullNames - file names in result will have full path names 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; function StrToken(var S: string; Sep: Char): string;
{ Same as StrToken but searches from the end of S string.} { Same as StrToken but searches from the end of S string.}
function StrTokenEnd(var S: string; Sep: Char): 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).} { 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).} { 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>} { Clamps integer value to range <Min, Max>}
function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF} function ClampInt(Number: LongInt; Min, Max: LongInt): LongInt; {$IFDEF USE_INLINE}inline;{$ENDIF}
@ -447,7 +452,7 @@ var
if CaseSensitive then if CaseSensitive then
Result := A = B Result := A = B
else else
Result := UpCase(A) = UpCase(B); Result := AnsiUpperCase (A) = AnsiUpperCase (B);
end; end;
function MatchAt(MaskPos, KeyPos: LongInt): Boolean; function MatchAt(MaskPos, KeyPos: LongInt): Boolean;
@ -609,101 +614,6 @@ begin
end; end;
function PosEx(const SubStr, S: string; Offset: LongInt = 1): LongInt; 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 var
I, X: LongInt; I, X: LongInt;
Len, LenSubStr: LongInt; Len, LenSubStr: LongInt;
@ -728,11 +638,10 @@ begin
end; end;
Result := 0; Result := 0;
end; end;
{$ENDIF}
function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt; function PosNoCase(const SubStr, S: string; Offset: LongInt): LongInt;
begin begin
Result := PosEx(LowerCase(SubStr), LowerCase(S), Offset); Result := PosEx(AnsiLowerCase(SubStr), AnsiLowerCase(S), Offset);
end; end;
function StrToken(var S: string; Sep: Char): string; function StrToken(var S: string; Sep: Char): string;
@ -775,6 +684,19 @@ begin
end; end;
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; function IntToStrFmt(const I: Int64): string;
begin begin
Result := Format('%.0n', [I * 1.0]); Result := Format('%.0n', [I * 1.0]);
@ -790,8 +712,7 @@ begin
Result := Number; Result := Number;
if Result < Min then if Result < Min then
Result := Min Result := Min
else else if Result > Max then
if Result > Max then
Result := Max; Result := Max;
end; end;
@ -800,8 +721,7 @@ begin
Result := Number; Result := Number;
if Result < Min then if Result < Min then
Result := Min Result := Min
else else if Result > Max then
if Result > Max then
Result := Max; Result := Max;
end; end;
@ -831,7 +751,7 @@ end;
function NextPow2(Num: LongInt): LongInt; function NextPow2(Num: LongInt): LongInt;
begin begin
Result := Num and -Num; Result := Num and -Num;
while (Result < Num) do while Result < Num do
Result := Result shl 1; Result := Result shl 1;
end; end;
@ -1335,11 +1255,11 @@ end;
function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt; function GetVolumeLevelCount(Depth, MipMaps: LongInt): LongInt;
var var
I: LongInt; I: LongInt;
begin begin
Result := Depth; Result := Depth;
for I := 1 to MipMaps - 1 do for I := 1 to MipMaps - 1 do
Inc(Result, ClampInt(Depth shr I, 1, Depth)); Inc(Result, ClampInt(Depth shr I, 1, Depth));
end; end;
function BoundsToRect(X, Y, Width, Height: LongInt): TRect; function BoundsToRect(X, Y, Width, Height: LongInt): TRect;
@ -1552,6 +1472,12 @@ initialization
-- TODOS ---------------------------------------------------- -- TODOS ----------------------------------------------------
- nothing now - 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 ----------------------------------- -- 0.25.0 Changes/Bug Fixes -----------------------------------
- Fixed error in ClipCopyBounds which was causing ... bad clipping! - Fixed error in ClipCopyBounds which was causing ... bad clipping!

View File

@ -34,7 +34,7 @@ uses
{$IFDEF VER70} {$IFDEF VER70}
{$ifndef NO_GETENV} {$ifndef NO_GETENV}
Dos, { DOS unit should declare getenv() } Dos, { DOS unit should declare getenv() }
{ function GetEnv(name : string) : string; } { function GetEnv(name : string) : string; }
{$endif} {$endif}
imjmemdos; { import the system-dependent declarations } imjmemdos; { import the system-dependent declarations }
{$ELSE} {$ELSE}
@ -492,6 +492,7 @@ begin
{ Calculate max # of rows allowed in one allocation chunk } { Calculate max # of rows allowed in one allocation chunk }
ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div ltemp := (MAX_ALLOC_CHUNK-SIZEOF(large_pool_hdr)) div
(long(blocksperrow) * SIZEOF(JBLOCK)); (long(blocksperrow) * SIZEOF(JBLOCK));
if (ltemp <= 0) then if (ltemp <= 0) then
ERREXIT(cinfo, JERR_WIDTH_OVERFLOW); ERREXIT(cinfo, JERR_WIDTH_OVERFLOW);
if (ltemp < long(numrows)) then 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 NB: jmemmgr.c expects that MAX_ALLOC_CHUNK will be representable as type
size_t and will be a multiple of sizeof(align_type). } size_t and will be a multiple of sizeof(align_type). }
{$IFDEF WINDOWS}
const
MAX_ALLOC_CHUNK = long(32752);
{$ELSE}
const const
MAX_ALLOC_CHUNK = long(1000000000); MAX_ALLOC_CHUNK = long(1000000000);
{$ENDIF}
{GLOBAL} {GLOBAL}
procedure jpeg_open_backing_store (cinfo : j_common_ptr; procedure jpeg_open_backing_store (cinfo : j_common_ptr;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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