pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

- implementation for Carbon interface

Browse Source 
- fix compilation after graphics rewrite
- improved example application

git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@251 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
tomb0
2007-09-02 15:12:14 +00:00
parent 1be18f4bcc
commit 4ee0dd740f
12 changed files with 1094 additions and 638 deletions
Download Patch File Download Diff File Expand all files Collapse all files

283
components/rgbgraphics/example/rgbexample.lpi
View File

@ -5,17 +5,16 @@
<Version Value="5"/>
<General>
<MainUnit Value="0"/>
<IconPath Value="./"/>
<IconPath Value=".\"/>
<TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/>
<ActiveEditorIndexAtStart Value="4"/>
</General>
<VersionInfo>
<ProjectVersion Value=""/>
<Language Value=""/>
<CharSet Value=""/>
</VersionInfo>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedproject\"/>
<IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
@ -23,23 +22,25 @@
<RunParams>
<local>
<FormatVersion Value="1"/>
<LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
<LaunchingApplication PathPlusParams="\usr\X11R6\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
</local>
</RunParams>
<RequiredPackages Count="2">
<Item1>
<PackageName Value="LCL"/>
<PackageName Value="lazrgbgraphics"/>
</Item1>
<Item2>
<PackageName Value="lazrgbgraphics"/>
<PackageName Value="LCL"/>
</Item2>
</RequiredPackages>
<Units Count="7">
<Units Count="35">
<Unit0>
<Filename Value="rgbexample.lpr"/>
<IsPartOfProject Value="True"/>
<UnitName Value="RGBExample"/>
<UsageCount Value="21"/>
<CursorPos X="28" Y="6"/>
<TopLine Value="1"/>
<UsageCount Value="31"/>
</Unit0>
<Unit1>
<Filename Value="rgbunit.pas"/>
@ -47,20 +48,18 @@
<IsPartOfProject Value="True"/>
<ResourceFilename Value="rgbunit.lrs"/>
<UnitName Value="RGBUnit"/>
<CursorPos X="70" Y="110"/>
<TopLine Value="85"/>
<CursorPos X="32" Y="38"/>
<TopLine Value="65"/>
<EditorIndex Value="0"/>
<UsageCount Value="21"/>
<UsageCount Value="31"/>
<Loaded Value="True"/>
</Unit1>
<Unit2>
<Filename Value="..\rgbgraphics.pas"/>
<UnitName Value="RGBGraphics"/>
<CursorPos X="1" Y="9"/>
<TopLine Value="1"/>
<EditorIndex Value="1"/>
<CursorPos X="19" Y="85"/>
<TopLine Value="72"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2>
<Unit3>
<Filename Value="unit1.lrs"/>
@ -71,31 +70,263 @@
<Unit4>
<Filename Value="..\rgbroutines.pas"/>
<UnitName Value="RGBRoutines"/>
<CursorPos X="79" Y="9"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
<CursorPos X="15" Y="52"/>
<TopLine Value="47"/>
<UsageCount Value="12"/>
</Unit4>
<Unit5>
<Filename Value="..\rgbutils.pas"/>
<UnitName Value="RGBUtils"/>
<CursorPos X="79" Y="8"/>
<TopLine Value="1"/>
<CursorPos X="29" Y="53"/>
<TopLine Value="35"/>
<UsageCount Value="10"/>
</Unit5>
<Unit6>
<Filename Value="..\rgbtypes.pas"/>
<UnitName Value="RGBTypes"/>
<CursorPos X="79" Y="9"/>
<CursorPos X="3" Y="500"/>
<TopLine Value="498"/>
<UsageCount Value="11"/>
</Unit6>
<Unit7>
<Filename Value="..\lazrgbgraphics.pas"/>
<UnitName Value="LazRGBGraphics"/>
<CursorPos X="30" Y="10"/>
<TopLine Value="1"/>
<UsageCount Value="11"/>
</Unit7>
<Unit8>
<Filename Value="..\rgbwinroutines.pas"/>
<UnitName Value="RGBWinRoutines"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="16"/>
<UsageCount Value="11"/>
</Unit8>
<Unit9>
<Filename Value="..\rgbgtkroutines.pas"/>
<UnitName Value="RGBGTKRoutines"/>
<CursorPos X="15" Y="38"/>
<TopLine Value="16"/>
<UsageCount Value="10"/>
</Unit9>
<Unit10>
<Filename Value="..\..\..\lazarus\lcl\include\canvas.inc"/>
<CursorPos X="1" Y="1460"/>
<TopLine Value="1446"/>
<UsageCount Value="10"/>
</Unit10>
<Unit11>
<Filename Value="..\..\..\lazarus\lcl\include\customcontrol.inc"/>
<CursorPos X="1" Y="81"/>
<TopLine Value="67"/>
<UsageCount Value="10"/>
</Unit11>
<Unit12>
<Filename Value="..\..\..\lazarus\lcl\include\customform.inc"/>
<CursorPos X="1" Y="804"/>
<TopLine Value="790"/>
<UsageCount Value="10"/>
</Unit12>
<Unit13>
<Filename Value="..\..\..\lazarus\lcl\include\wincontrol.inc"/>
<CursorPos X="1" Y="3062"/>
<TopLine Value="3048"/>
<UsageCount Value="10"/>
</Unit13>
<Unit14>
<Filename Value="..\..\..\lazarus\lcl\interfaces\gtk\gtkproc.inc"/>
<CursorPos X="1" Y="3645"/>
<TopLine Value="3631"/>
<UsageCount Value="10"/>
</Unit14>
<Unit15>
<Filename Value="..\..\..\lazarus\lcl\interfaces\win32\interfaces.pp"/>
<UnitName Value="Interfaces"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="17"/>
<UsageCount Value="10"/>
</Unit15>
<Unit16>
<Filename Value="..\rgbcarbonroutines.pas"/>
<UnitName Value="RGBCarbonRoutines"/>
<CursorPos X="61" Y="73"/>
<TopLine Value="43"/>
<UsageCount Value="11"/>
</Unit16>
<Unit17>
<Filename Value="\usr\local\share\fpcsrc\packages\extra\gtk2\gtk+\gtk\gtk2.pas"/>
<UnitName Value="gtk2"/>
<CursorPos X="1" Y="1"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit6>
</Unit17>
<Unit18>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\interfaces.pas"/>
<UnitName Value="Interfaces"/>
<CursorPos X="52" Y="11"/>
<TopLine Value="1"/>
<UsageCount Value="10"/>
</Unit18>
<Unit19>
<Filename Value="..\..\..\..\lazarus\lcl\extdlgs.pas"/>
<UnitName Value="ExtDlgs"/>
<CursorPos X="30" Y="55"/>
<TopLine Value="41"/>
<UsageCount Value="10"/>
</Unit19>
<Unit20>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carboncanvas.pp"/>
<UnitName Value="CarbonCanvas"/>
<CursorPos X="1" Y="708"/>
<TopLine Value="694"/>
<UsageCount Value="10"/>
</Unit20>
<Unit21>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbonint.pas"/>
<UnitName Value="CarbonInt"/>
<CursorPos X="20" Y="114"/>
<TopLine Value="152"/>
<UsageCount Value="10"/>
</Unit21>
<Unit22>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbonmenus.pp"/>
<UnitName Value="CarbonMenus"/>
<CursorPos X="52" Y="351"/>
<TopLine Value="324"/>
<UsageCount Value="10"/>
</Unit22>
<Unit23>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbonlclintf.inc"/>
<CursorPos X="67" Y="499"/>
<TopLine Value="484"/>
<UsageCount Value="10"/>
</Unit23>
<Unit24>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbonprivate.pp"/>
<UnitName Value="CarbonPrivate"/>
<CursorPos X="17" Y="322"/>
<TopLine Value="312"/>
<UsageCount Value="10"/>
</Unit24>
<Unit25>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbonprivatewindow.inc"/>
<CursorPos X="9" Y="748"/>
<TopLine Value="744"/>
<UsageCount Value="10"/>
</Unit25>
<Unit26>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbongdiobjects.pp"/>
<UnitName Value="CarbonGDIObjects"/>
<CursorPos X="24" Y="163"/>
<TopLine Value="161"/>
<UsageCount Value="10"/>
</Unit26>
<Unit27>
<Filename Value="..\..\..\..\lazarus\lcl\interfaces\carbon\carbonwinapi.inc"/>
<CursorPos X="24" Y="181"/>
<TopLine Value="184"/>
<UsageCount Value="10"/>
</Unit27>
<Unit28>
<Filename Value="..\..\..\lazarus\lcl\lclintf.pas"/>
<UnitName Value="LCLIntf"/>
<CursorPos X="35" Y="38"/>
<TopLine Value="24"/>
<UsageCount Value="10"/>
</Unit28>
<Unit29>
<Filename Value="..\..\..\lazarus\lcl\interfaces\win32\win32int.pp"/>
<UnitName Value="Win32Int"/>
<CursorPos X="22" Y="188"/>
<TopLine Value="182"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit29>
<Unit30>
<Filename Value="..\..\..\lazarus\lcl\interfaces\win32\win32object.inc"/>
<CursorPos X="16" Y="422"/>
<TopLine Value="420"/>
<EditorIndex Value="2"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit30>
<Unit31>
<Filename Value="..\..\..\lazarus\lcl\interfacebase.pp"/>
<UnitName Value="InterfaceBase"/>
<CursorPos X="5" Y="62"/>
<TopLine Value="48"/>
<UsageCount Value="10"/>
</Unit31>
<Unit32>
<Filename Value="..\..\..\lazarus\lcl\interfaces\carbon\carbonobject.inc"/>
<CursorPos X="17" Y="873"/>
<TopLine Value="869"/>
<UsageCount Value="10"/>
</Unit32>
<Unit33>
<Filename Value="..\..\..\lazarus\ide\compileroptionsdlg.pp"/>
<UnitName Value="CompilerOptionsDlg"/>
<CursorPos X="31" Y="2452"/>
<TopLine Value="2436"/>
<EditorIndex Value="3"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit33>
<Unit34>
<Filename Value="..\..\..\lazarus\ide\lazconf.pp"/>
<UnitName Value="LazConf"/>
<CursorPos X="38" Y="62"/>
<TopLine Value="44"/>
<EditorIndex Value="4"/>
<UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit34>
</Units>
<JumpHistory Count="0" HistoryIndex="-1"/>
<JumpHistory Count="9" HistoryIndex="8">
<Position1>
<Filename Value="rgbunit.pas"/>
<Caret Line="22" Column="36" TopLine="124"/>
</Position1>
<Position2>
<Filename Value="rgbunit.pas"/>
<Caret Line="33" Column="10" TopLine="28"/>
</Position2>
<Position3>
<Filename Value="rgbunit.pas"/>
<Caret Line="33" Column="10" TopLine="28"/>
</Position3>
<Position4>
<Filename Value="..\..\..\lazarus\lcl\interfaces\win32\win32object.inc"/>
<Caret Line="422" Column="16" TopLine="420"/>
</Position4>
<Position5>
<Filename Value="..\..\..\lazarus\ide\compileroptionsdlg.pp"/>
<Caret Line="89" Column="26" TopLine="73"/>
</Position5>
<Position6>
<Filename Value="..\..\..\lazarus\ide\compileroptionsdlg.pp"/>
<Caret Line="546" Column="26" TopLine="529"/>
</Position6>
<Position7>
<Filename Value="..\..\..\lazarus\ide\compileroptionsdlg.pp"/>
<Caret Line="548" Column="26" TopLine="534"/>
</Position7>
<Position8>
<Filename Value="..\..\..\lazarus\ide\compileroptionsdlg.pp"/>
<Caret Line="863" Column="27" TopLine="849"/>
</Position8>
<Position9>
<Filename Value="..\..\..\lazarus\ide\compileroptionsdlg.pp"/>
<Caret Line="2452" Column="31" TopLine="2436"/>
</Position9>
</JumpHistory>
</ProjectOptions>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<LCLWidgetType Value="win32"/>
<SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/>
</SearchPaths>
<CodeGeneration>
@ -103,9 +334,7 @@
</CodeGeneration>
<Linking>
<Options>
<Win32>
<GraphicApplication Value="True"/>
</Win32>
<LinkerOptions Value="-framework carbon"/>
</Options>
</Linking>
<Other>

62
components/rgbgraphics/example/rgbunit.lfm
View File

@ -1,56 +1,64 @@
object FormExample: TFormExample
Left = 267
Height = 514
Top = 150
Width = 645
HorzScrollBar.Page = 644
VertScrollBar.Page = 513
ActiveControl = ButtonRedLine
Caption = 'LazRGBGraphics Example'
ClientHeight = 443
ClientWidth = 575
ClientHeight = 514
ClientWidth = 645
OnCreate = FormCreate
OnDestroy = FormDestroy
OnPaint = FormPaint
PixelsPerInch = 96
HorzScrollBar.Page = 574
VertScrollBar.Page = 442
Left = 301
Height = 443
Top = 155
Width = 575
object ButtonRedLine: TButton
Left = 6
Height = 26
Top = 8
Width = 89
AutoSize = True
BorderSpacing.InnerBorder = 4
Caption = 'Draw red line'
OnClick = ButtonRedLineClick
TabOrder = 0
Left = 6
Height = 25
Top = 8
Width = 126
end
object ButtonRotate90: TButton
Left = 6
Height = 26
Top = 39
Width = 131
AutoSize = True
BorderSpacing.InnerBorder = 4
Caption = 'Rotate 90� clockwise'
Caption = 'Rotate 90 clockwise'
OnClick = ButtonRotate90Click
TabOrder = 1
Left = 6
Height = 25
Top = 39
Width = 126
end
object ButtonInvert: TButton
Left = 6
Height = 26
Top = 72
Width = 83
AutoSize = True
BorderSpacing.InnerBorder = 4
Caption = 'Invert colors'
OnClick = ButtonInvertClick
TabOrder = 2
Left = 6
Height = 25
Top = 72
Width = 126
end
object ButtonReplace: TButton
Left = 6
Height = 26
Top = 106
Width = 136
AutoSize = True
BorderSpacing.InnerBorder = 4
Caption = 'Replace white with blue'
Caption = 'Replace red with blue'
OnClick = ButtonReplaceClick
TabOrder = 3
Left = 6
Height = 25
Top = 106
Width = 126
end
object OpenPictureDialog: TOpenPictureDialog
Title = 'Open picture'
left = 211
top = 81
end
end

38
components/rgbgraphics/example/rgbunit.lrs
View File

@ -1,19 +1,23 @@
{ This is an automatically generated lazarus resource file }
LazarusResources.Add('TFormExample','FORMDATA',[
'TPF0'#12'TFormExample'#11'FormExample'#13'ActiveControl'#7#13'ButtonRedLine'
+#7'Caption'#6#22'LazRGBGraphics Example'#12'ClientHeight'#3#187#1#11'ClientW'
+'idth'#3'?'#2#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#7
+'OnPaint'#7#9'FormPaint'#13'PixelsPerInch'#2'`'#18'HorzScrollBar.Page'#3'>'#2
+#18'VertScrollBar.Page'#3#186#1#4'Left'#3'-'#1#6'Height'#3#187#1#3'Top'#3#155
+#0#5'Width'#3'?'#2#0#7'TButton'#13'ButtonRedLine'#25'BorderSpacing.InnerBord'
+'er'#2#4#7'Caption'#6#13'Draw red line'#7'OnClick'#7#18'ButtonRedLineClick'#8
+'TabOrder'#2#0#4'Left'#2#6#6'Height'#2#25#3'Top'#2#8#5'Width'#2'~'#0#0#7'TBu'
+'tton'#14'ButtonRotate90'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#20
+'Rotate 90'#176' clockwise'#7'OnClick'#7#19'ButtonRotate90Click'#8'TabOrder'
+#2#1#4'Left'#2#6#6'Height'#2#25#3'Top'#2''''#5'Width'#2'~'#0#0#7'TButton'#12
+'ButtonInvert'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Invert colo'
+'rs'#7'OnClick'#7#17'ButtonInvertClick'#8'TabOrder'#2#2#4'Left'#2#6#6'Height'
+#2#25#3'Top'#2'H'#5'Width'#2'~'#0#0#7'TButton'#13'ButtonReplace'#25'BorderSp'
+'acing.InnerBorder'#2#4#7'Caption'#6#23'Replace white with blue'#7'OnClick'#7
+#18'ButtonReplaceClick'#8'TabOrder'#2#3#4'Left'#2#6#6'Height'#2#25#3'Top'#2
+'j'#5'Width'#2'~'#0#0#0
'TPF0'#12'TFormExample'#11'FormExample'#4'Left'#3#11#1#6'Height'#3#2#2#3'Top'
+#3#150#0#5'Width'#3#133#2#18'HorzScrollBar.Page'#3#132#2#18'VertScrollBar.Pa'
+'ge'#3#1#2#13'ActiveControl'#7#13'ButtonRedLine'#7'Caption'#6#22'LazRGBGraph'
+'ics Example'#12'ClientHeight'#3#2#2#11'ClientWidth'#3#133#2#8'OnCreate'#7#10
+'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#7'OnPaint'#7#9'FormPaint'#0#7'TB'
+'utton'#13'ButtonRedLine'#4'Left'#2#6#6'Height'#2#26#3'Top'#2#8#5'Width'#2'Y'
+#8'AutoSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Draw red li'
+'ne'#7'OnClick'#7#18'ButtonRedLineClick'#8'TabOrder'#2#0#0#0#7'TButton'#14'B'
+'uttonRotate90'#4'Left'#2#6#6'Height'#2#26#3'Top'#2''''#5'Width'#3#131#0#8'A'
+'utoSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#19'Rotate 90 cloc'
+'kwise'#7'OnClick'#7#19'ButtonRotate90Click'#8'TabOrder'#2#1#0#0#7'TButton'
+#12'ButtonInvert'#4'Left'#2#6#6'Height'#2#26#3'Top'#2'H'#5'Width'#2'S'#8'Aut'
+'oSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Invert colors'#7
+'OnClick'#7#17'ButtonInvertClick'#8'TabOrder'#2#2#0#0#7'TButton'#13'ButtonRe'
+'place'#4'Left'#2#6#6'Height'#2#26#3'Top'#2'j'#5'Width'#3#136#0#8'AutoSize'#9
+#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#21'Replace red with blue'#7
+'OnClick'#7#18'ButtonReplaceClick'#8'TabOrder'#2#3#0#0#18'TOpenPictureDialog'
+#17'OpenPictureDialog'#5'Title'#6#12'Open picture'#4'left'#3#211#0#3'top'#2
+'Q'#0#0#0
]);

52
components/rgbgraphics/example/rgbunit.pas
View File

@ -22,13 +22,15 @@
}
unit RGBUnit;
{$mode objfpc}{$H+}
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface
uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
RGBGraphics;
RGBGraphics, ExtDlgs, ExtCtrls;
type
@ -39,6 +41,7 @@ type
ButtonInvert: TButton;
ButtonRotate90: TButton;
ButtonRedLine: TButton;
OpenPictureDialog: TOpenPictureDialog;
procedure ButtonInvertClick(Sender: TObject);
procedure ButtonRedLineClick(Sender: TObject);
procedure ButtonReplaceClick(Sender: TObject);
@ -53,6 +56,7 @@ type
var
FormExample: TFormExample;
RGBBitmap: TRGB32Bitmap;
RGBMask: TRGBMask;
implementation
@ -60,7 +64,31 @@ implementation
procedure TFormExample.FormCreate(Sender: TObject);
begin
RGBBitmap := TRGB32Bitmap.CreateFromFile('splash_logo.xpm');
if OpenPictureDialog.Execute then
begin
RGBBitmap := TRGB32Bitmap.CreateFromFile(OpenPictureDialog.FileName);
end
else
begin
RGBBitmap := TRGB32Bitmap.Create(400, 300);
RGBBitmap.Canvas.DrawMode := dmFill;
RGBBitmap.Canvas.Fill(clBlack);
RGBBitmap.Canvas.FillColor := clRed;
RGBBitmap.Canvas.Ellipse(100, 0, 300, 200);
RGBBitmap.Canvas.FillColor := clGreen;
RGBBitmap.Canvas.Ellipse(50, 100, 250, 300);
RGBBitmap.Canvas.FillColor := clBlue;
RGBBitmap.Canvas.Ellipse(150, 100, 350, 300);
RGBBitmap.Canvas.FillColor := clWhite;
RGBBitmap.Canvas.Ellipse(150, 100, 250, 200);
RGBBitmap.Canvas.DrawMode := dmFillAndOutline;
end;
RGBMask := TRGBMask.Create(160, 100);
RGBMask.Clear;
RGBMask.Ellipse(10, 10, 150, 90);
end;
procedure TFormExample.ButtonRedLineClick(Sender: TObject);
@ -73,13 +101,13 @@ end;
procedure TFormExample.ButtonReplaceClick(Sender: TObject);
begin
RGBBitmap.Canvas.EraseMode := emReplace;
RGBBitmap.Canvas.FillColor := clWhite;
RGBBitmap.Canvas.EraseMode := ermReplace;
RGBBitmap.Canvas.FillColor := clRed;
RGBBitmap.Canvas.PaperColor := clBlue;
RGBBitmap.Canvas.FillRect(0, 0, Pred(RGBBitmap.Width), Pred(RGBBitmap.Height));
RGBBitmap.Canvas.EraseMode := emNone;
RGBBitmap.Canvas.EraseMode := ermNone;
Invalidate;
end;
@ -87,6 +115,7 @@ end;
procedure TFormExample.ButtonInvertClick(Sender: TObject);
begin
RGBBitmap.Invert;
RGBMask.Invert;
Invalidate;
end;
@ -94,6 +123,7 @@ end;
procedure TFormExample.ButtonRotate90Click(Sender: TObject);
begin
RGBBitmap.Rotate90;
RGBMask.Rotate90;
Invalidate;
end;
@ -101,16 +131,20 @@ end;
procedure TFormExample.FormDestroy(Sender: TObject);
begin
RGBBitmap.Free;
RGBMask.Free;
end;
procedure TFormExample.FormPaint(Sender: TObject);
begin
if RGBBitmap = nil then Exit;
// draw bitmap 2x smaller
RGBBitmap.Canvas.StretchDrawTo(Canvas, 140, 10, RGBBitmap.Width div 2,
RGBBitmap.Height div 2);
// draw bitmap
RGBBitmap.Canvas.DrawTo(Canvas, 180, 10);
RGBMask.DrawTo(Canvas, 10, 160);
RGBMask.DrawShapeTo(Canvas, 10, 340);
end;
initialization
{$I rgbunit.lrs}

35
components/rgbgraphics/lazrgbgraphics.lpk
View File

@ -4,16 +4,23 @@
<PathDelim Value="\"/>
<Name Value="LazRGBGraphics"/>
<Author Value="Tom Gregorovic (_tom_@centrum.cz)"/>
<AutoUpdate Value="OnRebuildingAll"/>
<CompilerOptions>
<Version Value="5"/>
<PathDelim Value="\"/>
<SearchPaths>
<IncludeFiles Value="include\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
<LCLWidgetType Value="gtk2"/>
</SearchPaths>
<CodeGeneration>
<Generate Value="Faster"/>
</CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
</Linking>
<Other>
<CompilerPath Value="$(CompPath)"/>
</Other>
@ -22,8 +29,8 @@
"/>
<License Value="Modified LGPL
"/>
<Version Minor="1"/>
<Files Count="4">
<Version Minor="2"/>
<Files Count="7">
<Item1>
<Filename Value="rgbgraphics.pas"/>
<UnitName Value="RGBGraphics"/>
@ -40,14 +47,29 @@
<Filename Value="rgbroutines.pas"/>
<UnitName Value="RGBRoutines"/>
</Item4>
<Item5>
<Filename Value="rgbwinroutines.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="RGBWinRoutines"/>
</Item5>
<Item6>
<Filename Value="rgbgtkroutines.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="RGBGTKRoutines"/>
</Item6>
<Item7>
<Filename Value="rgbcarbonroutines.pas"/>
<AddToUsesPkgSection Value="False"/>
<UnitName Value="RGBCarbonRoutines"/>
</Item7>
</Files>
<RequiredPkgs Count="2">
<Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2>
</RequiredPkgs>
<UsageOptions>
@ -55,6 +77,7 @@
</UsageOptions>
<PublishOptions>
<Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedpackage\"/>
<IgnoreBinaries Value="False"/>
</PublishOptions>
</Package>

86
components/rgbgraphics/rgbcarbonroutines.pas Normal file
View File

@ -0,0 +1,86 @@
{
/***************************************************************************
RGBGTKRoutines.pas
***************************************************************************/
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Tom Gregorovic (_tom_@centrum.cz)
Abstract:
This unit contains routines for GTK interfaces.
}
unit RGBCarbonRoutines;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface
uses
SysUtils, Classes, LCLType,
FPCMacOSAll, CarbonProc, CarbonGDIObjects, CarbonCanvas,
RGBTypes, RGBUtils;
procedure WidgetSetDrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB32BitmapCore);
procedure WidgetSetDrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB8BitmapCore);
implementation
procedure WidgetSetDrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth,
SrcHeight: Integer; Bitmap: TRGB32BitmapCore);
var
CGImage: CGImageRef;
CarbonBitmap: TCarbonBitmap;
begin
if not CheckDC(Dest, 'WidgetSetDrawRGB32Bitmap') then Exit;
CarbonBitmap := TCarbonBitmap.Create(Bitmap.Width, Bitmap.Height, 24, 32, cbaDWord, cbtRGB, Bitmap.Pixels, False);
try
CGImage := CarbonBitmap.CreateSubImage(Bounds(SrcX, SrcY, SrcWidth, SrcHeight));
TCarbonDeviceContext(Dest).DrawCGImage(DstX, DstY, SrcWidth, SrcHeight, CGImage);
CGImageRelease(CGImage);
finally
CarbonBitmap.Free;
end;
end;
procedure WidgetSetDrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; Bitmap: TRGB8BitmapCore);
var
CGImage: CGImageRef;
CarbonBitmap: TCarbonBitmap;
begin
if not CheckDC(Dest, 'WidgetSetDrawRGB8Bitmap') then Exit;
CarbonBitmap := TCarbonBitmap.Create(Bitmap.Width, Bitmap.Height, 8, 8, cbaDWord, cbtGray, Bitmap.Pixels, False);
try
CGImage := CarbonBitmap.CreateSubImage(Bounds(SrcX, SrcY, SrcWidth, SrcHeight));
TCarbonDeviceContext(Dest).DrawCGImage(DstX, DstY, SrcWidth, SrcHeight, CGImage);
CGImageRelease(CGImage);
finally
CarbonBitmap.Free;
end;
end;
end.

37
components/rgbgraphics/rgbgraphics.pas
View File

@ -33,7 +33,7 @@ interface
uses
Classes, SysUtils, LCLIntf,
LCLType, LCLProc, Interfaces, FPImage, LResources, IntfGraphics,
LCLType, LCLProc, FPImage, LResources, IntfGraphics,
Graphics, Forms, Math, Clipbrd,
RGBTypes, RGBRoutines, RGBUtils;
@ -120,7 +120,7 @@ type
procedure SetOutlineColor(const AValue: TColor);
procedure SetPaperColor(const AValue: TColor);
protected
function PixelMasked(X, Y: Integer): Boolean; inline;
function PixelMasked(X, Y: Integer): Boolean;
function SamePixelUnsafe(X, Y: Integer; Value: TRGB32Pixel): Boolean;
function SamePixelUnmasked(X, Y: Integer; Value: TRGB32Pixel): Boolean;
@ -224,6 +224,19 @@ type
implementation
function AbsByte(Src: Integer): Byte; inline;
begin
if Src >= 0 then Result := Src
else Result := -Src;
end;
function RGB32PixelDifference(A, B: TRGB32Pixel): TPixelDifference; inline;
begin
Result := AbsByte(((A shr 16) and $FF) - ((B shr 16) and $FF))
+ AbsByte(((A shr 8) and $FF) - ((B shr 8) and $FF))
+ AbsByte((A and $FF) - (B and $FF));
end;
{ TRGB32Bitmap }
constructor TRGB32Bitmap.Create(AWidth, AHeight: Integer);
@ -257,7 +270,6 @@ begin
Image := TLazIntfImage.Create(0, 0);
Reader := GetFPImageReaderForFileExtension(ExtractFileExt(FileName)).Create;
try
Image.GetDescriptionFromDevice(0);
Image.LoadFromFile(FileName, Reader);
CreateFromLazIntfImage(Image);
finally
@ -345,7 +357,6 @@ begin
Image := TLazIntfImage.Create(0, 0);
Writer := GetFPImageWriterForFileExtension(ExtractFileExt(FileName)).Create;
try
Image.GetDescriptionFromDevice(0);
inherited SaveToLazIntfImage(Image);
Image.SaveToFile(FileName, Writer);
finally
@ -515,38 +526,38 @@ var
P: PRGB32Pixel;
begin
P := FOwner.Get32PixelPtr(X, Y);
if P <> nil then Result := RGB32PixelToColorInline(P^)
if P <> nil then Result := RGB32PixelToColor(P^)
else Result := clNone;
end;
function TRGB32Canvas.GetFillColor: TColor;
begin
Result := RGB32PixelToColorInline(FFillColor);
Result := RGB32PixelToColor(FFillColor);
end;
function TRGB32Canvas.GetOutlineColor: TColor;
begin
Result := RGB32PixelToColorInline(FOutlineColor);
Result := RGB32PixelToColor(FOutlineColor);
end;
function TRGB32Canvas.GetPaperColor: TColor;
begin
Result := RGB32PixelToColorInline(FPaperColor);
Result := RGB32PixelToColor(FPaperColor);
end;
procedure TRGB32Canvas.SetFillColor(const AValue: TColor);
begin
FFillColor := ColorToRGB32PixelInline(AValue);
FFillColor := ColorToRGB32Pixel(AValue);
end;
procedure TRGB32Canvas.SetOutlineColor(const AValue: TColor);
begin
FOutlineColor := ColorToRGB32PixelInline(AValue);
FOutlineColor := ColorToRGB32Pixel(AValue);
end;
procedure TRGB32Canvas.SetPaperColor(const AValue: TColor);
begin
FPaperColor := ColorToRGB32PixelInline(AValue);
FPaperColor := ColorToRGB32Pixel(AValue);
end;
function TRGB32Canvas.PixelMasked(X, Y: Integer): Boolean;
@ -565,13 +576,13 @@ end;
function TRGB32Canvas.SamePixelUnsafe(X, Y: Integer; Value: TRGB32Pixel): Boolean;
begin
Result := PixelMasked(X, Y) and (RGB32PixelDifferenceInline(FOwner.Get32PixelPtrUnsafe(X, Y)^, Value)
Result := PixelMasked(X, Y) and (RGB32PixelDifference(FOwner.Get32PixelUnsafe(X, Y), Value)
<= FFloodFillTolerance);
end;
function TRGB32Canvas.SamePixelUnmasked(X, Y: Integer; Value: TRGB32Pixel): Boolean;
begin
Result := RGB32PixelDifferenceInline(FOwner.Get32PixelPtrUnsafe(X, Y)^, Value)
Result := RGB32PixelDifference(FOwner.Get32PixelUnsafe(X, Y), Value)
<= FFloodFillTolerance;
end;

84
components/rgbgraphics/rgbgtkroutines.pas Normal file
View File

@ -0,0 +1,84 @@
{
/***************************************************************************
RGBGTKRoutines.pas
***************************************************************************/
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Tom Gregorovic (_tom_@centrum.cz)
Abstract:
This unit contains routines for GTK interfaces.
}
unit RGBGTKRoutines;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface
uses
SysUtils, Classes, LCLType,
{$IFDEF LCLgtk2}
glib2, gdk2, gtk2,
{$ENDIF}
{$IFDEF LCLgtk}
glib, gdk, gtk,
{$ENDIF}
gtkDef, gtkProc,
RGBTypes, RGBUtils;
procedure WidgetSetDrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB32BitmapCore);
procedure WidgetSetDrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB8BitmapCore);
implementation
procedure WidgetSetDrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth,
SrcHeight: Integer; Bitmap: TRGB32BitmapCore);
var
P: TPoint;
begin
P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X);
Inc(DstY, P.Y);
gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
Pguchar(Bitmap.GetPixelPtrUnsafe(SrcX, SrcY)), Bitmap.RowPixelStride shl 2);
end;
procedure WidgetSetDrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; Bitmap: TRGB8BitmapCore);
var
P: TPoint;
begin
P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X);
Inc(DstY, P.Y);
gdk_draw_gray_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
Pguchar(Bitmap.Get8PixelPtrUnsafe(SrcX, SrcY)), Bitmap.RowPixelStride);
end;
initialization
gdk_rgb_init;
end.

389
components/rgbgraphics/rgbroutines.pas
View File

@ -20,7 +20,7 @@
Abstract:
This unit contains routines for manipulating rgb bitmaps (stretching,
drawing on canvas, rotating...) and for drawing primitives (lines,
drawing on canvas...) and for drawing primitives (lines,
ellipses...).
}
@ -28,42 +28,36 @@ unit RGBRoutines;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$define hasinline}
{$endif}
{$ifndef fpc}
{$define Windows}
{$endif}
{$ifdef win32}
{$define Windows}
{$endif}
interface
uses
SysUtils, Math, Forms, LCLIntf,
LCLType, LCLProc, InterfaceBase, Interfaces, FPImage, IntfGraphics,
{$IFDEF Windows}
Windows,
{$ELSE}
{$IFDEF gtk2}
glib2, gdk2, gtk2, gtkDef, gtkProc,
{$DEFINE gtk}
{$ELSE}
glib, gdk, gtk, gtkDef, gtkProc,
{$DEFINE gtk}
{$ENDIF}
{$ENDIF}
LCLType, LCLProc, FPImage, IntfGraphics,
Classes,
{$IFDEF LCLwin32}
RGBWinRoutines,
{$ENDIF}
{$IFDEF LCLgtk}
{$DEFINE StretchRGB32}
RGBGTKRoutines,
{$ENDIF}
{$IFDEF LCLgtk2}
{$DEFINE StretchRGB32}
RGBGTKRoutines,
{$ENDIF}
{$IFDEF LCLcarbon}
{$DEFINE StretchRGB32}
RGBCarbonRoutines,
{$ENDIF}
RGBTypes, RGBUtils;
procedure DrawRGB32Bitmap(Dst: TRGB32BitmapCore; X, Y: Integer; Src: TRGB32BitmapCore); overload;
procedure DrawRGB8Bitmap(Dst: TRGB8BitmapCore; X, Y: Integer; Src: TRGB8BitmapCore); overload;
procedure StretchRGB32BitmapTrunc(Dst, Src: TRGB32BitmapCore);
procedure StretchRGB8BitmapTrunc(Dst, Src: TRGB8BitmapCore);
procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB32BitmapCore); overload;
procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer;
@ -74,21 +68,6 @@ uses
procedure DrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB8BitmapCore); overload;
procedure FlipHorzRGBBitmap(Bitmap: TRGBBitmapCore);
procedure FlipVertRGBBitmap(Bitmap: TRGBBitmapCore);
// intensity tables
function GetIntensityFloatTable(A, B: Single): TIntensityFloatTable;
// rotate clockwise
procedure Rotate90CWRGBBitmap(Bitmap: TRGBBitmapCore);
procedure Rotate180CWRGBBitmap(Bitmap: TRGBBitmapCore);
procedure Rotate270CWRGBBitmap(Bitmap: TRGBBitmapCore);
procedure InvertRGBBitmap(Bitmap: TRGBBitmapCore);
procedure GrayscaleRGB32Bitmap(Bitmap: TRGB32BitmapCore);
procedure DisableRGB32Bitmap(Bitmap: TRGB32BitmapCore);
type
TDrawPixelProcedure = procedure (X, Y: Integer) of Object;
TGetPixelFunction = function (X, Y: Integer): TRGB32Pixel of Object;
@ -97,7 +76,6 @@ type
procedure LineBresenham(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure);
procedure FillPixelRect(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure);
procedure FillPixelRow(X1, X2, Y: Integer; DrawPixel: TDrawPixelProcedure); {$ifdef hasinline}inline;{$endif}
procedure NormalRectangle(X1, Y1, X2, Y2: Integer;
DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure);
@ -410,7 +388,7 @@ procedure StretchRGB32BitmapTrunc(Dst: TRGB32BitmapCore;
var
Cols: TIntArray;
Rows: TIntArray;
X, Y, PX, TX, OX, PY, TY, OY: Integer;
X, Y: Integer;
SX, SY, DX, DY: Integer;
I, J, C: Integer;
PD, PS, PDLine, PSLine: PRGB32Pixel;
@ -539,17 +517,11 @@ procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth,
Bitmap: TRGB32BitmapCore);
var
Clip: TRect;
{$IFDEF Win32}
Info: BITMAPINFO;
{$ENDIF}
{$IFDEF gtk}
P: TPoint;
{$ENDIF}
begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit;
Widgetset.GetClipBox(Dest, @Clip);
GetClipBox(Dest, @Clip);
if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or
(DstX + SrcWidth < Clip.Left) or (DstY + SrcHeight < Clip.Top) then Exit;
@ -558,63 +530,25 @@ begin
ClipDimension(Clip.Left, Clip.Right, DstX, SrcX, SrcWidth);
ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight);
{$IFDEF Windows}
with Info.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
biSizeImage := 0;
biClrImportant := 0;
end;
SetStretchBltMode(Dest, COLORONCOLOR);
StretchDIBits(Dest, DstX, Pred(DstY + SrcHeight), SrcWidth, -SrcHeight,
SrcX, SrcY, SrcWidth, SrcHeight, Bitmap.Pixels, Info, DIB_RGB_COLORS, SRCCOPY);
{$ENDIF}
{$IFDEF gtk}
P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X);
Inc(DstY, P.Y);
gdk_draw_rgb_32_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
Pguchar(Bitmap.GetPixelPtrUnsafe(SrcX, SrcY)), Bitmap.RowPixelStride shl 2);
{$ENDIF}
WidgetSetDrawRGB32Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap);
end;
// ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height
// ! results in mash
{$DEFINE StretchRGB32}
{$IFDEF Windows}
{ $UNDEF StretchRGB32}
{$ENDIF}
procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer;
SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore);
var
Clip: TRect;
{$IFDEF StretchRGB32}
{$IFDEF gtk}
P: TPoint;
{$ENDIF}
Temp: TRGB32BitmapCore;
X, Y, W, H: Integer;
{$ELSE}
{$IFDEF Windows}
Info: BITMAPINFO;
{$ENDIF}
{$ENDIF}
begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit;
if (DstWidth <= 0) or (DstHeight <= 0) then Exit;
Widgetset.GetClipBox(Dest, @Clip);
GetClipBox(Dest, @Clip);
if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or
(DstX + DstWidth < Clip.Left) or (DstY + DstHeight < Clip.Top) then Exit;
@ -640,21 +574,8 @@ begin
Temp.Free;
end;
{$ELSE}
with Info.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
biSizeImage := 0;
biClrImportant := 0;
end;
SetStretchBltMode(Dest, COLORONCOLOR);
StretchDIBits(Dest, DstX, Pred(DstY + DstHeight), DstWidth, -DstHeight, SrcX, SrcY,
SrcWidth, SrcHeight, Bitmap.Pixels, Info, DIB_RGB_COLORS, SRCCOPY);
WidgetSetStretchDrawRGB32Bitmap(Dest, DstX, DstY, DstWidth, DstHeight,
SrcX, SrcY, SrcWidth, SrcHeight, Bitmap);
{$ENDIF}
end;
@ -795,7 +716,7 @@ begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (DstWidth <= 0) or (DstHeight <= 0) then Exit;
Widgetset.GetClipBox(Dest, @Clip);
GetClipBox(Dest, @Clip);
ZoomX := DstWidth / Bitmap.Width;
ZoomY := DstHeight / Bitmap.Height;
@ -814,19 +735,11 @@ procedure DrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, S
Bitmap: TRGB8BitmapCore);
var
Clip: TRect;
{$IFDEF Win32}
Info: PBITMAPINFO;
I: Byte;
PColor: PRGBQUAD;
{$ENDIF}
{$IFDEF gtk}
P: TPoint;
{$ENDIF}
begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit;
Widgetset.GetClipBox(Dest, @Clip);
GetClipBox(Dest, @Clip);
if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or
(DstX + SrcWidth < Clip.Left) or (DstY + SrcHeight < Clip.Top) then Exit;
@ -835,243 +748,7 @@ begin
ClipDimension(Clip.Left, Clip.Right, DstX, SrcX, SrcWidth);
ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight);
{$IFDEF Windows}
GetMem(Info, SizeOf(BITMAPINFO) + 256 * SizeOf(RGBQUAD));
try
with Info^.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 8;
biCompression := BI_RGB;
biSizeImage := 0;
biClrUsed := 256;
biClrImportant := 0;
end;
PColor := @(Info^.bmiColors[0]);
for I := 0 to 255 do
begin
PColor^.rgbRed := I;
PColor^.rgbGreen := I;
PColor^.rgbBlue := I;
Inc(PColor);
end;
SetStretchBltMode(Dest, COLORONCOLOR);
StretchDIBits(Dest, DstX, Pred(DstY + SrcHeight), SrcWidth, -SrcHeight,
SrcX, SrcY, SrcWidth, SrcHeight, Bitmap.Pixels, Info^, DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Info);
end;
{$ENDIF}
{$IFDEF gtk}
P := GetDCOffset(TDeviceContext(Dest));
Inc(DstX, P.X);
Inc(DstY, P.Y);
gdk_draw_gray_image(TDeviceContext(Dest).Drawable, TDeviceContext(Dest).GC,
DstX, DstY, SrcWidth, SrcHeight, GDK_RGB_DITHER_NONE,
Pguchar(Bitmap.Get8PixelPtrUnsafe(SrcX, SrcY)), Bitmap.RowPixelStride);
{$ENDIF}
end;
procedure FlipHorzRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
begin
for Y := 0 to Pred(Bitmap.Height) do
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Y);
POld := Bitmap.GetPixelPtrUnsafe(Pred(Bitmap.Width), Y);
for X := 0 to Pred(Bitmap.Width shr 1) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Dec(POld, Bitmap.SizeOfPixel);
end;
end;
end;
procedure FlipVertRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
begin
for Y := 0 to Pred(Bitmap.Height shr 1) do
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Y);
POld := Bitmap.GetPixelPtrUnsafe(0, Pred(Bitmap.Height) - Y);
for X := 0 to Pred(Bitmap.Width) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Inc(POld, Bitmap.SizeOfPixel);
end;
end;
end;
(*
Creates look-up table T[I = 0..255] = A + I * B.
*)
function GetIntensityFloatTable(A, B: Single): TIntensityFloatTable;
var
I: Integer;
C: Single;
begin
C := A;
for I := 0 to High(Result) do
begin
Result[I] := FloatToIntensityFloatInline(C);
C := C + B;
end;
end;
procedure Rotate90CWRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
Result: TRGBBitmapCore;
begin
Result := TRGBBitmapCore.Create(Bitmap.Height, Bitmap.Width, Bitmap.SizeOfPixel);
try
for Y := 0 to Pred(Bitmap.Height) do
begin
PNew := Result.GetPixelPtrUnsafe(Pred(Bitmap.Height) - Y, 0);
POld := Bitmap.GetPixelPtrUnsafe(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
CopyRGBPixels(POld, PNew, Result.SizeOfPixel);
Inc(PNew, Result.RowPixelStride * Result.SizeOfPixel);
Inc(POld, Result.SizeOfPixel);
end;
end;
Bitmap.SwapWith(Result);
finally
FreeAndNil(Result);
end;
end;
procedure Rotate180CWRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
begin
for Y := 0 to Pred(Bitmap.Height shr 1) do
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Y);
POld := Bitmap.GetPixelPtrUnsafe(Pred(Bitmap.Width), Pred(Bitmap.Height) - Y);
for X := 0 to Pred(Bitmap.Width) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Dec(POld, Bitmap.SizeOfPixel);
end;
end;
if Odd(Bitmap.Height) then
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Bitmap.Height shr 1);
POld := Bitmap.GetPixelPtrUnsafe(Pred(Bitmap.Width), Bitmap.Height shr 1);
for X := 0 to Pred(Bitmap.Width shr 1) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Dec(POld, Bitmap.SizeOfPixel);
end;
end;
end;
procedure Rotate270CWRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
Result: TRGBBitmapCore;
begin
Result := TRGBBitmapCore.Create(Bitmap.Height, Bitmap.Width, Bitmap.SizeOfPixel);
try
for Y := 0 to Pred(Bitmap.Height) do
begin
PNew := Result.GetPixelPtrUnsafe(Y, Pred(Bitmap.Width));
POld := Bitmap.GetPixelPtrUnsafe(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
CopyRGBPixels(POld, PNew, Result.SizeOfPixel);
Dec(PNew, Result.RowPixelStride * Result.SizeOfPixel);
Inc(POld, Result.SizeOfPixel);
end;
end;
Bitmap.SwapWith(Result);
finally
FreeAndNil(Result);
end;
end;
procedure InvertRGBBitmap(Bitmap: TRGBBitmapCore);
var
I: Integer;
P: PRGBPixel;
begin
P := Bitmap.Pixels;
for I := 0 to Pred(Bitmap.Height * Bitmap.RowPixelStride * Bitmap.SizeOfPixel) do
begin
P^ := $FF - P^;
Inc(P);
end;
end;
procedure GrayscaleRGB32Bitmap(Bitmap: TRGB32BitmapCore);
var
X, Y: Integer;
P: PRGB32Pixel;
S: Byte;
R, G, B: TIntensityFloatTable;
begin
// R * 0.299 + G * 0.587 + B * 0.114
R := GetIntensityFloatTable(0, 0.299);
G := GetIntensityFloatTable(0, 0.587);
B := GetIntensityFloatTable(0, 0.114);
for Y := 0 to Pred(Bitmap.Height) do
begin
P := Bitmap.Get32PixelPtr(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
S := RoundIntensityFloatInline(R[GetRedInline(P^)] + G[GetGreenInline(P^)]
+ B[GetBlueInline(P^)]);
P^ := RGBToRGB32PixelInline(S, S, S);
Inc(P);
end;
end;
end;
procedure DisableRGB32Bitmap(Bitmap: TRGB32BitmapCore);
var
X, Y: Integer;
P: PRGB32Pixel;
S: Byte;
R, G, B: TIntensityFloatTable;
begin
// 128 + R * 0.299 / 4 + G * 0.587 / 4 + B * 0.114 / 4
R := GetIntensityFloatTable(128, 0.299 / 4);
G := GetIntensityFloatTable(0, 0.587 / 4);
B := GetIntensityFloatTable(0, 0.114 / 4);
for Y := 0 to Pred(Bitmap.Height) do
begin
P := Bitmap.Get32PixelPtr(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
S := RoundIntensityFloatInline(R[GetRedInline(P^)] + G[GetGreenInline(P^)]
+ B[GetBlueInline(P^)]);
P^ := RGBToRGB32PixelInline(S, S, S);
Inc(P);
end;
end;
WidgetSetDrawRGB8Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap);
end;
(*
@ -1153,7 +830,7 @@ begin
for X := X1 to X2 do DrawPixel(X, Y);
end;
procedure FillPixelRow(X1, X2, Y: Integer; DrawPixel: TDrawPixelProcedure);
procedure FillPixelRow(X1, X2, Y: Integer; DrawPixel: TDrawPixelProcedure); inline;
var
X: Integer;
begin
@ -1343,7 +1020,7 @@ var
Stack: Array of Integer;
StackCount: Integer;
function CheckPixel(AX, AY: Integer): Boolean; {$ifdef hasinline}inline;{$endif}
function CheckPixel(AX, AY: Integer): Boolean; inline;
begin
if Visited[AX + AY * W] = 1 then Result := False
else
@ -1352,7 +1029,7 @@ var
end;
end;
procedure Push(AX, AY: Integer); {$ifdef hasinline}inline;{$endif}
procedure Push(AX, AY: Integer); inline;
begin
if StackCount >= High(Stack) then SetLength(Stack, Length(Stack) shl 1);
@ -1360,7 +1037,7 @@ var
Inc(StackCount);
end;
procedure Pop(var AX, AY: Integer); {$ifdef hasinline}inline;{$endif}
procedure Pop(var AX, AY: Integer); inline;
begin
Dec(StackCount);
AX := Stack[StackCount] and $FFFF;
@ -1417,10 +1094,6 @@ begin
end;
end;
initialization
{$IFDEF gtk}
gdk_rgb_init;
{$ENDIF}
end.

530
components/rgbgraphics/rgbtypes.pas
View File

@ -28,21 +28,17 @@ unit RGBTypes;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$define hasinline}
{$endif}
{$ifndef fpc}
{$define Windows}
{$endif}
{$ifdef win32}
{$define Windows}
{$ifdef LCLwin32}
{$define RGB}
{$endif}
interface
uses
Classes, SysUtils, FPImage, IntfGraphics, Graphics, Math, LCLProc;
Classes, SysUtils, FPImage, IntfGraphics, Graphics, Math, LCLProc,
RGBUtils;
type
PRGBPixel = PByte;
@ -74,6 +70,7 @@ type
FWidth: Integer;
FHeight: Integer;
FRowPixelStride: Integer;
function GetSize: Integer;
public
constructor Create(AWidth, AHeight: Integer; ASizeOfPixel: Integer); virtual;
constructor CreateAsCopy(ABitmap: TRGBBitmapCore; ASizeOfPixel: Integer); virtual;
@ -82,8 +79,8 @@ type
procedure Assign(Source: TPersistent); override;
procedure SwapWith(ABitmap: TRGBBitmapCore); virtual;
public
function GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel; {$ifdef hasinline}inline;{$endif}
function GetPixelPtr(X, Y: Integer): PRGBPixel; {$ifdef hasinline}inline;{$endif}
function GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel;
function GetPixelPtr(X, Y: Integer): PRGBPixel;
procedure Clear; virtual;
procedure ClearWhite; virtual;
@ -99,6 +96,7 @@ type
property Height: Integer read FHeight;
property Pixels: PRGBPixel read FPixels;
property RowPixelStride: Integer read FRowPixelStride;
property Size: Integer read GetSize;
property SizeOfPixel: Integer read FSizeOfPixel;
end;
@ -116,12 +114,12 @@ type
procedure Assign(Source: TPersistent); override;
procedure SwapWith(ABitmap: TRGBBitmapCore); override;
public
function Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel; {$ifdef hasinline}inline;{$endif}
function Get8PixelPtr(X, Y: Integer): PRGB8Pixel; {$ifdef hasinline}inline;{$endif}
function Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel;
function Get8PixelPtr(X, Y: Integer): PRGB8Pixel;
function Get8PixelUnsafe(X, Y: Integer): TRGB8Pixel;
procedure Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel); {$ifdef hasinline}inline;{$endif}
procedure Set8Pixel(X, Y: Integer; Value: TRGB8Pixel); {$ifdef hasinline}inline;{$endif}
procedure Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel);
procedure Set8Pixel(X, Y: Integer; Value: TRGB8Pixel);
end;
{ TRGB32BitmapCore }
@ -137,39 +135,127 @@ type
procedure SaveToLazIntfImage(AImage: TLazIntfImage); virtual;
procedure SaveToLazIntfImage(AImage: TLazIntfImage; const ARect: TRect); virtual;
public
function Get32PixelPtrUnsafe(X, Y: Integer): PRGB32Pixel; {$ifdef hasinline}inline;{$endif}
function Get32PixelPtr(X, Y: Integer): PRGB32Pixel; {$ifdef hasinline}inline;{$endif}
function Get32PixelPtrUnsafe(X, Y: Integer): PRGB32Pixel;
function Get32PixelPtr(X, Y: Integer): PRGB32Pixel;
function Get32PixelUnsafe(X, Y: Integer): TRGB32Pixel;
procedure Set32PixelUnsafe(X, Y: Integer; Value: TRGB32Pixel); {$ifdef hasinline}inline;{$endif}
procedure Set32Pixel(X, Y: Integer; Value: TRGB32Pixel); {$ifdef hasinline}inline;{$endif}
procedure Set32PixelUnsafe(X, Y: Integer; Value: TRGB32Pixel);
procedure Set32Pixel(X, Y: Integer; Value: TRGB32Pixel);
end;
procedure SwapRGBPixels(A, B: PRGBPixel; const Size: Integer); {$ifdef hasinline}inline;{$endif}
procedure CopyRGBPixels(Src, Dest: PRGBPixel; const Size: Integer); {$ifdef hasinline}inline;{$endif}
procedure FlipHorzRGBBitmap(Bitmap: TRGBBitmapCore);
procedure FlipVertRGBBitmap(Bitmap: TRGBBitmapCore);
// intensity tables
function GetIntensityFloatTable(A, B: Single): TIntensityFloatTable;
// rotate clockwise
procedure Rotate90CWRGBBitmap(Bitmap: TRGBBitmapCore);
procedure Rotate180CWRGBBitmap(Bitmap: TRGBBitmapCore);
procedure Rotate270CWRGBBitmap(Bitmap: TRGBBitmapCore);
procedure InvertRGBBitmap(Bitmap: TRGBBitmapCore);
procedure GrayscaleRGB32Bitmap(Bitmap: TRGB32BitmapCore);
procedure DisableRGB32Bitmap(Bitmap: TRGB32BitmapCore);
function RGB32PixelToColor(P: TRGB32Pixel): TColor;
function ColorToRGB32Pixel(C: TColor): TRGB32Pixel;
function GetRedInline(P: TRGB32Pixel): Byte; {$ifdef hasinline}inline;{$endif}
function GetGreenInline(P: TRGB32Pixel): Byte; {$ifdef hasinline}inline;{$endif}
function GetBlueInline(P: TRGB32Pixel): Byte; {$ifdef hasinline}inline;{$endif}
function RGBToRGB32PixelInline(R, G, B: Byte): TRGB32Pixel; {$ifdef hasinline}inline;{$endif}
function RGB32PixelToColorInline(P: TRGB32Pixel): TColor; {$ifdef hasinline}inline;{$endif}
function ColorToRGB32PixelInline(C: TColor): TRGB32Pixel; {$ifdef hasinline}inline;{$endif}
function RGB32PixelDifferenceInline(A, B: TRGB32Pixel): TPixelDifference; {$ifdef hasinline}inline;{$endif}
function FloatToIntensityFloatInline(F: Extended): TIntensityFloat; {$ifdef hasinline}inline;{$endif}
function RoundIntensityFloatInline(V: TIntensityFloat): Byte; {$ifdef hasinline}inline;{$endif}
implementation
uses
RGBRoutines, RGBUtils;
function GetRedInline(P: TRGB32Pixel): Byte; inline;
begin
{$IFDEF RGB}
Result := (P and $FF0000) shr 16;
{$ELSE}
Result := P and $FF;
{$ENDIF}
end;
procedure SwapRGBPixels(A, B: PRGBPixel; const Size: Integer);
function GetGreenInline(P: TRGB32Pixel): Byte; inline;
begin
{$IFDEF RGB}
Result := (P and $FF00) shr 8;
{$ELSE}
Result := (P and $FF00) shr 8;
{$ENDIF}
end;
function GetBlueInline(P: TRGB32Pixel): Byte; inline;
begin
{$IFDEF RGB}
Result := P and $FF;
{$ELSE}
Result := (P and $FF0000) shr 16;
{$ENDIF}
end;
function RGBToRGB32PixelInline(R, G, B: Byte): TRGB32Pixel; inline;
begin
{$IFDEF RGB}
Result := B or (G shl 8) or (R shl 16);
{$ELSE}
Result := R or (G shl 8) or (B shl 16);
{$ENDIF}
end;
function RGB32PixelToColorInline(P: TRGB32Pixel): TColor; inline;
begin
{$IFDEF RGB}
Result := ((P and $FF0000) shr 16) or (P and $FF00) or ((P and $FF) shl 16);
{$ELSE}
Result := P and $FFFFFF;
{$ENDIF}
end;
function ColorToRGB32PixelInline(C: TColor): TRGB32Pixel; inline;
begin
{$IFDEF RGB}
Result := ((C and $FF0000) shr 16) or (C and $FF00) or ((C and $FF) shl 16);
{$ELSE}
Result := C and $FFFFFF;
{$ENDIF}
end;
function FPColorToRGB32PixelInline(F: TFPColor): TRGB32Pixel; inline;
begin
{$IFDEF RGB}
Result := ((F.Blue shr 8) and $FF) or (F.Green and $FF00) or ((F.Red shl 8) and $FF0000);
{$ELSE}
Result := ((F.Red shr 8) and $FF) or (F.Green and $FF00) or ((F.Blue shl 8) and $FF0000);
{$ENDIF}
end;
function RGB32PixelToFPColorInline(P: TRGB32Pixel): TFPColor; inline;
begin
{$IFDEF RGB}
Result.Red := (P shr 16) and $FF;
Result.Red := Result.Red or (Result.Red shl 8);
Result.Green := P and $FF00;
Result.Green := Result.Green or (Result.Green shr 8);
Result.Blue := P and $FF;
Result.Blue := Result.Blue or (Result.Blue shl 8);
{$ELSE}
Result.Red := P and $FF;
Result.Red := Result.Red or (Result.Red shl 8);
Result.Green := P and $FF00;
Result.Green := Result.Green or (Result.Green shr 8);
Result.Blue := (P shr 16) and $FF;
Result.Blue := Result.Blue or (Result.Blue shl 8);
{$ENDIF}
end;
function RGB32PixelToColor(P: TRGB32Pixel): TColor;
begin
Result := RGB32PixelToColorInline(P);
end;
function ColorToRGB32Pixel(C: TColor): TRGB32Pixel;
begin
Result := ColorToRGB32PixelInline(C);
end;
procedure SwapRGBPixels(A, B: PRGBPixel; const Size: Integer); inline;
var
T32: TRGB32Pixel;
T8: TRGB8Pixel;
@ -188,7 +274,7 @@ begin
end;
end;
procedure CopyRGBPixels(Src, Dest: PRGBPixel; const Size: Integer);
procedure CopyRGBPixels(Src, Dest: PRGBPixel; const Size: Integer); inline;
begin
if Size = 4 then PRGB32Pixel(Dest)^ := PRGB32Pixel(Src)^
else
@ -197,124 +283,218 @@ begin
end;
end;
function GetRedInline(P: TRGB32Pixel): Byte;
function GetRGBBitmapPixelPtr(const Bitmap: TRGBBitmapCore; X, Y: Integer): PRGBPixel; inline;
begin
{$IFDEF Windows}
Result := (P and $FF0000) shr 16;
{$ELSE}
Result := P and $FF;
{$ENDIF}
Result := Bitmap.FPixels;
Inc(Result, Y * Bitmap.FRowPixelStride * Bitmap.FSizeOfPixel + X * Bitmap.FSizeOfPixel);
end;
function GetGreenInline(P: TRGB32Pixel): Byte;
begin
{$IFDEF Windows}
Result := (P and $FF00) shr 8;
{$ELSE}
Result := (P and $FF00) shr 8;
{$ENDIF}
end;
function GetBlueInline(P: TRGB32Pixel): Byte;
begin
{$IFDEF Windows}
Result := P and $FF;
{$ELSE}
Result := (P and $FF0000) shr 16;
{$ENDIF}
end;
function RGBToRGB32PixelInline(R, G, B: Byte): TRGB32Pixel;
begin
{$IFDEF Windows}
Result := B or (G shl 8) or (R shl 16);
{$ELSE}
Result := R or (G shl 8) or (B shl 16);
{$ENDIF}
end;
// TODO: check on big-endian arch.
function RGB32PixelToColorInline(P: TRGB32Pixel): TColor;
begin
{$IFDEF Windows}
Result := ((P and $FF0000) shr 16) or (P and $FF00) or ((P and $FF) shl 16);
{$ELSE}
Result := P and $FFFFFF;
{$ENDIF}
end;
function ColorToRGB32PixelInline(C: TColor): TRGB32Pixel;
begin
{$IFDEF Windows}
Result := ((C and $FF0000) shr 16) or (C and $FF00) or ((C and $FF) shl 16);
{$ELSE}
Result := C and $FFFFFF;
{$ENDIF}
end;
function FPColorToRGB32PixelInline(F: TFPColor): TRGB32Pixel;
begin
{$IFDEF Windows}
Result := ((F.Blue shr 8) and $FF) or (F.Green and $FF00) or ((F.Red shl 8) and $FF0000);
{$ELSE}
Result := ((F.Red shr 8) and $FF) or (F.Green and $FF00) or ((F.Blue shl 8) and $FF0000);
{$ENDIF}
end;
function RGB32PixelToFPColorInline(P: TRGB32Pixel): TFPColor;
begin
{$IFDEF Windows}
Result.Red := (P shr 16) and $FF;
Result.Red := Result.Red or (Result.Red shl 8);
Result.Green := P and $FF00;
Result.Green := Result.Green or (Result.Green shr 8);
Result.Blue := P and $FF;
Result.Blue := Result.Blue or (Result.Blue shl 8);
{$ELSE}
Result.Red := P and $FF;
Result.Red := Result.Red or (Result.Red shl 8);
Result.Green := P and $FF00;
Result.Green := Result.Green or (Result.Green shr 8);
Result.Blue := (P shr 16) and $FF;
Result.Blue := Result.Blue or (Result.Blue shl 8);
{$ENDIF}
end;
function AbsByte(Src: Integer): Byte; {$ifdef hasinline}inline;{$endif}
begin
if Src >= 0 then Result := Src
else Result := -Src;
end;
function RGB32PixelDifferenceInline(A, B: TRGB32Pixel): TPixelDifference;
begin
Result := AbsByte(((A shr 16) and $FF) - ((B shr 16) and $FF))
+ AbsByte(((A shr 8) and $FF) - ((B shr 8) and $FF))
+ AbsByte((A and $FF) - (B and $FF));
end;
function RGB32PixelToColor(P: TRGB32Pixel): TColor;
begin
Result := RGB32PixelToColorInline(P);
end;
function ColorToRGB32Pixel(C: TColor): TRGB32Pixel;
begin
Result := ColorToRGB32PixelInline(C);
end;
function FloatToIntensityFloatInline(F: Extended): TIntensityFloat;
begin
Result := Round(F * 256);
end;
function RoundIntensityFloatInline(V: TIntensityFloat): Byte;
function RoundIntensityFloatInline(V: TIntensityFloat): Byte; inline;
begin
Result := Max(0, Min(255, (V + 128) shr 8));
end;
procedure FlipHorzRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
begin
for Y := 0 to Pred(Bitmap.Height) do
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Y);
POld := Bitmap.GetPixelPtrUnsafe(Pred(Bitmap.Width), Y);
for X := 0 to Pred(Bitmap.Width shr 1) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Dec(POld, Bitmap.SizeOfPixel);
end;
end;
end;
procedure FlipVertRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
begin
for Y := 0 to Pred(Bitmap.Height shr 1) do
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Y);
POld := Bitmap.GetPixelPtrUnsafe(0, Pred(Bitmap.Height) - Y);
for X := 0 to Pred(Bitmap.Width) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Inc(POld, Bitmap.SizeOfPixel);
end;
end;
end;
(*
Creates look-up table T[I = 0..255] = A + I * B.
*)
function GetIntensityFloatTable(A, B: Single): TIntensityFloatTable;
var
I: Integer;
C: Single;
begin
C := A;
for I := 0 to High(Result) do
begin
Result[I] := Round(C * 256);
C := C + B;
end;
end;
procedure Rotate90CWRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
Result: TRGBBitmapCore;
begin
Result := TRGBBitmapCore.Create(Bitmap.Height, Bitmap.Width, Bitmap.SizeOfPixel);
try
for Y := 0 to Pred(Bitmap.Height) do
begin
PNew := Result.GetPixelPtrUnsafe(Pred(Bitmap.Height) - Y, 0);
POld := Bitmap.GetPixelPtrUnsafe(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
CopyRGBPixels(POld, PNew, Result.SizeOfPixel);
Inc(PNew, Result.RowPixelStride * Result.SizeOfPixel);
Inc(POld, Result.SizeOfPixel);
end;
end;
Bitmap.SwapWith(Result);
finally
FreeAndNil(Result);
end;
end;
procedure Rotate180CWRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
begin
for Y := 0 to Pred(Bitmap.Height shr 1) do
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Y);
POld := Bitmap.GetPixelPtrUnsafe(Pred(Bitmap.Width), Pred(Bitmap.Height) - Y);
for X := 0 to Pred(Bitmap.Width) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Dec(POld, Bitmap.SizeOfPixel);
end;
end;
if Odd(Bitmap.Height) then
begin
PNew := Bitmap.GetPixelPtrUnsafe(0, Bitmap.Height shr 1);
POld := Bitmap.GetPixelPtrUnsafe(Pred(Bitmap.Width), Bitmap.Height shr 1);
for X := 0 to Pred(Bitmap.Width shr 1) do
begin
SwapRGBPixels(PNew, POld, Bitmap.SizeOfPixel);
Inc(PNew, Bitmap.SizeOfPixel);
Dec(POld, Bitmap.SizeOfPixel);
end;
end;
end;
procedure Rotate270CWRGBBitmap(Bitmap: TRGBBitmapCore);
var
X, Y: Integer;
PNew, POld: PRGBPixel;
Result: TRGBBitmapCore;
begin
Result := TRGBBitmapCore.Create(Bitmap.Height, Bitmap.Width, Bitmap.SizeOfPixel);
try
for Y := 0 to Pred(Bitmap.Height) do
begin
PNew := Result.GetPixelPtrUnsafe(Y, Pred(Bitmap.Width));
POld := Bitmap.GetPixelPtrUnsafe(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
CopyRGBPixels(POld, PNew, Result.SizeOfPixel);
Dec(PNew, Result.RowPixelStride * Result.SizeOfPixel);
Inc(POld, Result.SizeOfPixel);
end;
end;
Bitmap.SwapWith(Result);
finally
FreeAndNil(Result);
end;
end;
procedure InvertRGBBitmap(Bitmap: TRGBBitmapCore);
var
I: Integer;
P: PRGBPixel;
begin
P := Bitmap.Pixels;
for I := 0 to Pred(Bitmap.Height * Bitmap.RowPixelStride * Bitmap.SizeOfPixel) do
begin
P^ := $FF - P^;
Inc(P);
end;
end;
procedure GrayscaleRGB32Bitmap(Bitmap: TRGB32BitmapCore);
var
X, Y: Integer;
P: PRGB32Pixel;
S: Byte;
R, G, B: TIntensityFloatTable;
begin
// R * 0.299 + G * 0.587 + B * 0.114
R := GetIntensityFloatTable(0, 0.299);
G := GetIntensityFloatTable(0, 0.587);
B := GetIntensityFloatTable(0, 0.114);
for Y := 0 to Pred(Bitmap.Height) do
begin
P := Bitmap.Get32PixelPtr(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
S := RoundIntensityFloatInline(R[GetRedInline(P^)] + G[GetGreenInline(P^)]
+ B[GetBlueInline(P^)]);
P^ := RGBToRGB32PixelInline(S, S, S);
Inc(P);
end;
end;
end;
procedure DisableRGB32Bitmap(Bitmap: TRGB32BitmapCore);
var
X, Y: Integer;
P: PRGB32Pixel;
S: Byte;
R, G, B: TIntensityFloatTable;
begin
// 128 + R * 0.299 / 4 + G * 0.587 / 4 + B * 0.114 / 4
R := GetIntensityFloatTable(128, 0.299 / 4);
G := GetIntensityFloatTable(0, 0.587 / 4);
B := GetIntensityFloatTable(0, 0.114 / 4);
for Y := 0 to Pred(Bitmap.Height) do
begin
P := Bitmap.Get32PixelPtr(0, Y);
for X := 0 to Pred(Bitmap.Width) do
begin
S := RoundIntensityFloatInline(R[GetRedInline(P^)] + G[GetGreenInline(P^)]
+ B[GetBlueInline(P^)]);
P^ := RGBToRGB32PixelInline(S, S, S);
Inc(P);
end;
end;
end;
{ TRGBBitmapCore }
function TRGBBitmapCore.GetSize: Integer;
begin
Result := Height * RowPixelStride * SizeOfPixel;
end;
constructor TRGBBitmapCore.Create(AWidth, AHeight: Integer; ASizeOfPixel: Integer);
begin
inherited Create;
@ -371,9 +551,6 @@ begin
end;
procedure TRGBBitmapCore.SwapWith(ABitmap: TRGBBitmapCore);
var
Temp: Pointer;
TempInt: Integer;
begin
if ABitmap = nil then Exit;
@ -386,26 +563,25 @@ end;
function TRGBBitmapCore.GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel;
begin
Result := FPixels;
Inc(Result, Y * FRowPixelStride * FSizeOfPixel + X * FSizeOfPixel);
Result := GetRGBBitmapPixelPtr(Self, X, Y);
end;
function TRGBBitmapCore.GetPixelPtr(X, Y: Integer): PRGBPixel;
begin
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
Result := GetPixelPtrUnsafe(X, Y)
Result := GetRGBBitmapPixelPtr(Self, X, Y)
else
Result := nil;
end;
procedure TRGBBitmapCore.Clear;
begin
FillByte(Pixels^, Height * RowPixelStride * SizeOfPixel, 0);
FillByte(Pixels^, Size, 0);
end;
procedure TRGBBitmapCore.ClearWhite;
begin
FillByte(Pixels^, Height * RowPixelStride * SizeOfPixel, $FF);
FillByte(Pixels^, Size, $FF);
end;
procedure TRGBBitmapCore.Invert;
@ -430,7 +606,7 @@ end;
procedure TRGBBitmapCore.Rotate180;
begin
Rotate180CWRGBBitmap(Self);
Rotate180CWRGBBitmap(Self);
end;
procedure TRGBBitmapCore.Rotate270;
@ -497,7 +673,6 @@ var
begin
W := ARect.Right - ARect.Left;
H := ARect.Bottom - ARect.Top;
AImage.GetDescriptionFromDevice(0);
AImage.SetSize(W, H);
try
for J := 0 to Pred(H) do
@ -517,34 +692,32 @@ end;
function TRGB32BitmapCore.Get32PixelPtrUnsafe(X, Y: Integer
): PRGB32Pixel;
begin
Result := PRGB32Pixel(GetPixelPtrUnsafe(X, Y));
Result := PRGB32Pixel(GetRGBBitmapPixelPtr(Self, X, Y));
end;
function TRGB32BitmapCore.Get32PixelPtr(X, Y: Integer): PRGB32Pixel;
begin
Result := PRGB32Pixel(GetPixelPtr(X, Y));
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
Result := PRGB32Pixel(GetRGBBitmapPixelPtr(Self, X, Y))
else
Result := nil;
end;
function TRGB32BitmapCore.Get32PixelUnsafe(X, Y: Integer): TRGB32Pixel;
begin
Result := Get32PixelPtrUnsafe(X, Y)^;
Result := GetRGBBitmapPixelPtr(Self, X, Y)^;
end;
procedure TRGB32BitmapCore.Set32PixelUnsafe(X, Y: Integer;
Value: TRGB32Pixel);
begin
Get32PixelPtrUnsafe(X, Y)^ := Value;
GetRGBBitmapPixelPtr(Self, X, Y)^ := Value;
end;
procedure TRGB32BitmapCore.Set32Pixel(X, Y: Integer; Value: TRGB32Pixel);
var
P: PRGB32Pixel;
begin
P := Get32PixelPtr(X, Y);
if P <> nil then
begin
P^ := Value;
end;
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
PRGB32Pixel(GetRGBBitmapPixelPtr(Self, X, Y))^ := Value;
end;
{ TRGB8BitmapCore }
@ -616,34 +789,33 @@ end;
function TRGB8BitmapCore.Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel;
begin
Result := GetPixelPtrUnsafe(X, Y);
Result := GetRGBBitmapPixelPtr(Self, X, Y);
end;
function TRGB8BitmapCore.Get8PixelPtr(X, Y: Integer): PRGB8Pixel;
begin
Result := GetPixelPtr(X, Y);
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
Result := GetRGBBitmapPixelPtr(Self, X, Y)
else
Result := nil;
end;
function TRGB8BitmapCore.Get8PixelUnsafe(X, Y: Integer): TRGB8Pixel;
begin
Result := GetPixelPtrUnsafe(X, Y)^;
Result := GetRGBBitmapPixelPtr(Self, X, Y)^;
end;
procedure TRGB8BitmapCore.Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel);
begin
GetPixelPtrUnsafe(X, Y)^ := Value;
GetRGBBitmapPixelPtr(Self, X, Y)^ := Value;
end;
procedure TRGB8BitmapCore.Set8Pixel(X, Y: Integer; Value: TRGB8Pixel);
var
P: PRGB8Pixel;
begin
P := Get8PixelPtr(X, Y);
if P <> nil then
begin
P^ := Value;
end;
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
GetRGBBitmapPixelPtr(Self, X, Y)^ := Value;
end;
end.

3
components/rgbgraphics/rgbutils.pas
View File

@ -24,7 +24,6 @@ unit RGBUtils;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$define hasinline}
{$endif}
interface
@ -41,7 +40,7 @@ type
procedure SwapInt(var A, B: Integer);
procedure SwapPtr(var A, B: Pointer);
procedure MinMax(var A, B: Integer); {$ifdef hasinline}inline;{$endif}
procedure MinMax(var A, B: Integer);
procedure SortRect(var X1, Y1, X2, Y2: Integer); overload;
procedure SortRect(var R: TRect); overload;

133
components/rgbgraphics/rgbwinroutines.pas Normal file
View File

@ -0,0 +1,133 @@
{
/***************************************************************************
RGBWinRoutines.pas
***************************************************************************/
*****************************************************************************
* *
* See the file COPYING.modifiedLGPL, included in this distribution, *
* for details about the copyright. *
* *
* This program is distributed in the hope that it will be useful, *
* but WITHOUT ANY WARRANTY; without even the implied warranty of *
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. *
* *
*****************************************************************************
Author: Tom Gregorovic (_tom_@centrum.cz)
Abstract:
This unit contains routines for win32 interface.
}
unit RGBWinRoutines;
{$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface
uses
SysUtils, Windows, Classes,
RGBTypes;
procedure WidgetSetDrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB32BitmapCore);
procedure WidgetSetStretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer;
SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore);
procedure WidgetSetDrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB8BitmapCore);
implementation
procedure WidgetSetDrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth,
SrcHeight: Integer; Bitmap: TRGB32BitmapCore);
var
Info: BITMAPINFO;
begin
with Info.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
biSizeImage := 0;
biClrImportant := 0;
end;
SetStretchBltMode(Dest, COLORONCOLOR);
StretchDIBits(Dest, DstX, Pred(DstY + SrcHeight), SrcWidth, -SrcHeight,
SrcX, SrcY, SrcWidth, SrcHeight, Bitmap.Pixels, Info, DIB_RGB_COLORS, SRCCOPY);
end;
procedure WidgetSetStretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth,
DstHeight: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB32BitmapCore);
var
Info: BITMAPINFO;
begin
with Info.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 32;
biCompression := BI_RGB;
biSizeImage := 0;
biClrImportant := 0;
end;
SetStretchBltMode(Dest, COLORONCOLOR);
StretchDIBits(Dest, DstX, Pred(DstY + DstHeight), DstWidth, -DstHeight, SrcX, SrcY,
SrcWidth, SrcHeight, Bitmap.Pixels, Info, DIB_RGB_COLORS, SRCCOPY);
end;
procedure WidgetSetDrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY,
SrcWidth, SrcHeight: Integer; Bitmap: TRGB8BitmapCore);
var
Info: PBITMAPINFO;
I: Byte;
PColor: PRGBQUAD;
begin
GetMem(Info, SizeOf(BITMAPINFO) + 256 * SizeOf(RGBQUAD));
try
with Info^.bmiHeader do
begin
biSize := SizeOf(BITMAPINFOHEADER);
biWidth := Bitmap.Width;
biHeight := Bitmap.Height;
biPlanes := 1;
biBitCount := 8;
biCompression := BI_RGB;
biSizeImage := 0;
biClrUsed := 256;
biClrImportant := 0;
end;
PColor := @(Info^.bmiColors[0]);
for I := 0 to 255 do
begin
PColor^.rgbRed := I;
PColor^.rgbGreen := I;
PColor^.rgbBlue := I;
Inc(PColor);
end;
SetStretchBltMode(Dest, COLORONCOLOR);
StretchDIBits(Dest, DstX, Pred(DstY + SrcHeight), SrcWidth, -SrcHeight,
SrcX, SrcY, SrcWidth, SrcHeight, Bitmap.Pixels, Info^, DIB_RGB_COLORS, SRCCOPY);
finally
FreeMem(Info);
end;
end;
end.