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"/> <Version Value="5"/>
<General> <General>
<MainUnit Value="0"/> <MainUnit Value="0"/>
<IconPath Value="./"/> <IconPath Value=".\"/>
<TargetFileExt Value=".exe"/> <TargetFileExt Value=".exe"/>
<ActiveEditorIndexAtStart Value="0"/> <ActiveEditorIndexAtStart Value="4"/>
</General> </General>
<VersionInfo> <VersionInfo>
<ProjectVersion Value=""/> <ProjectVersion Value=""/>
<Language Value=""/>
<CharSet Value=""/>
</VersionInfo> </VersionInfo>
<PublishOptions> <PublishOptions>
<Version Value="2"/> <Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedproject\"/>
<IgnoreBinaries Value="False"/> <IgnoreBinaries Value="False"/>
<IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/> <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
<ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/> <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
@ -23,23 +22,25 @@
<RunParams> <RunParams>
<local> <local>
<FormatVersion Value="1"/> <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> </local>
</RunParams> </RunParams>
<RequiredPackages Count="2"> <RequiredPackages Count="2">
<Item1> <Item1>
<PackageName Value="LCL"/> <PackageName Value="lazrgbgraphics"/>
</Item1> </Item1>
<Item2> <Item2>
<PackageName Value="lazrgbgraphics"/> <PackageName Value="LCL"/>
</Item2> </Item2>
</RequiredPackages> </RequiredPackages>
<Units Count="7"> <Units Count="35">
<Unit0> <Unit0>
<Filename Value="rgbexample.lpr"/> <Filename Value="rgbexample.lpr"/>
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<UnitName Value="RGBExample"/> <UnitName Value="RGBExample"/>
<UsageCount Value="21"/> <CursorPos X="28" Y="6"/>
<TopLine Value="1"/>
<UsageCount Value="31"/>
</Unit0> </Unit0>
<Unit1> <Unit1>
<Filename Value="rgbunit.pas"/> <Filename Value="rgbunit.pas"/>
@ -47,20 +48,18 @@
<IsPartOfProject Value="True"/> <IsPartOfProject Value="True"/>
<ResourceFilename Value="rgbunit.lrs"/> <ResourceFilename Value="rgbunit.lrs"/>
<UnitName Value="RGBUnit"/> <UnitName Value="RGBUnit"/>
<CursorPos X="70" Y="110"/> <CursorPos X="32" Y="38"/>
<TopLine Value="85"/> <TopLine Value="65"/>
<EditorIndex Value="0"/> <EditorIndex Value="0"/>
<UsageCount Value="21"/> <UsageCount Value="31"/>
<Loaded Value="True"/> <Loaded Value="True"/>
</Unit1> </Unit1>
<Unit2> <Unit2>
<Filename Value="..\rgbgraphics.pas"/> <Filename Value="..\rgbgraphics.pas"/>
<UnitName Value="RGBGraphics"/> <UnitName Value="RGBGraphics"/>
<CursorPos X="1" Y="9"/> <CursorPos X="19" Y="85"/>
<TopLine Value="1"/> <TopLine Value="72"/>
<EditorIndex Value="1"/>
<UsageCount Value="10"/> <UsageCount Value="10"/>
<Loaded Value="True"/>
</Unit2> </Unit2>
<Unit3> <Unit3>
<Filename Value="unit1.lrs"/> <Filename Value="unit1.lrs"/>
@ -71,31 +70,263 @@
<Unit4> <Unit4>
<Filename Value="..\rgbroutines.pas"/> <Filename Value="..\rgbroutines.pas"/>
<UnitName Value="RGBRoutines"/> <UnitName Value="RGBRoutines"/>
<CursorPos X="79" Y="9"/> <CursorPos X="15" Y="52"/>
<TopLine Value="1"/> <TopLine Value="47"/>
<UsageCount Value="10"/> <UsageCount Value="12"/>
</Unit4> </Unit4>
<Unit5> <Unit5>
<Filename Value="..\rgbutils.pas"/> <Filename Value="..\rgbutils.pas"/>
<UnitName Value="RGBUtils"/> <UnitName Value="RGBUtils"/>
<CursorPos X="79" Y="8"/> <CursorPos X="29" Y="53"/>
<TopLine Value="1"/> <TopLine Value="35"/>
<UsageCount Value="10"/> <UsageCount Value="10"/>
</Unit5> </Unit5>
<Unit6> <Unit6>
<Filename Value="..\rgbtypes.pas"/> <Filename Value="..\rgbtypes.pas"/>
<UnitName Value="RGBTypes"/> <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"/> <TopLine Value="1"/>
<UsageCount Value="10"/> <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> </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> </ProjectOptions>
<CompilerOptions> <CompilerOptions>
<Version Value="5"/> <Version Value="5"/>
<PathDelim Value="\"/> <PathDelim Value="\"/>
<SearchPaths> <SearchPaths>
<LCLWidgetType Value="win32"/>
<SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/> <SrcPath Value="$(LazarusDir)\lcl\;$(LazarusDir)\lcl\interfaces\$(LCLWidgetType)\"/>
</SearchPaths> </SearchPaths>
<CodeGeneration> <CodeGeneration>
@ -103,9 +334,7 @@
</CodeGeneration> </CodeGeneration>
<Linking> <Linking>
<Options> <Options>
<Win32> <LinkerOptions Value="-framework carbon"/>
<GraphicApplication Value="True"/>
</Win32>
</Options> </Options>
</Linking> </Linking>
<Other> <Other>

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

@ -1,56 +1,64 @@
object FormExample: TFormExample object FormExample: TFormExample
Left = 267
Height = 514
Top = 150
Width = 645
HorzScrollBar.Page = 644
VertScrollBar.Page = 513
ActiveControl = ButtonRedLine ActiveControl = ButtonRedLine
Caption = 'LazRGBGraphics Example' Caption = 'LazRGBGraphics Example'
ClientHeight = 443 ClientHeight = 514
ClientWidth = 575 ClientWidth = 645
OnCreate = FormCreate OnCreate = FormCreate
OnDestroy = FormDestroy OnDestroy = FormDestroy
OnPaint = FormPaint OnPaint = FormPaint
PixelsPerInch = 96
HorzScrollBar.Page = 574
VertScrollBar.Page = 442
Left = 301
Height = 443
Top = 155
Width = 575
object ButtonRedLine: TButton object ButtonRedLine: TButton
Left = 6
Height = 26
Top = 8
Width = 89
AutoSize = True
BorderSpacing.InnerBorder = 4 BorderSpacing.InnerBorder = 4
Caption = 'Draw red line' Caption = 'Draw red line'
OnClick = ButtonRedLineClick OnClick = ButtonRedLineClick
TabOrder = 0 TabOrder = 0
Left = 6
Height = 25
Top = 8
Width = 126
end end
object ButtonRotate90: TButton object ButtonRotate90: TButton
Left = 6
Height = 26
Top = 39
Width = 131
AutoSize = True
BorderSpacing.InnerBorder = 4 BorderSpacing.InnerBorder = 4
Caption = 'Rotate 90� clockwise' Caption = 'Rotate 90 clockwise'
OnClick = ButtonRotate90Click OnClick = ButtonRotate90Click
TabOrder = 1 TabOrder = 1
Left = 6
Height = 25
Top = 39
Width = 126
end end
object ButtonInvert: TButton object ButtonInvert: TButton
Left = 6
Height = 26
Top = 72
Width = 83
AutoSize = True
BorderSpacing.InnerBorder = 4 BorderSpacing.InnerBorder = 4
Caption = 'Invert colors' Caption = 'Invert colors'
OnClick = ButtonInvertClick OnClick = ButtonInvertClick
TabOrder = 2 TabOrder = 2
Left = 6
Height = 25
Top = 72
Width = 126
end end
object ButtonReplace: TButton object ButtonReplace: TButton
Left = 6
Height = 26
Top = 106
Width = 136
AutoSize = True
BorderSpacing.InnerBorder = 4 BorderSpacing.InnerBorder = 4
Caption = 'Replace white with blue' Caption = 'Replace red with blue'
OnClick = ButtonReplaceClick OnClick = ButtonReplaceClick
TabOrder = 3 TabOrder = 3
Left = 6 end
Height = 25 object OpenPictureDialog: TOpenPictureDialog
Top = 106 Title = 'Open picture'
Width = 126 left = 211
top = 81
end end
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',[ LazarusResources.Add('TFormExample','FORMDATA',[
'TPF0'#12'TFormExample'#11'FormExample'#13'ActiveControl'#7#13'ButtonRedLine' 'TPF0'#12'TFormExample'#11'FormExample'#4'Left'#3#11#1#6'Height'#3#2#2#3'Top'
+#7'Caption'#6#22'LazRGBGraphics Example'#12'ClientHeight'#3#187#1#11'ClientW' +#3#150#0#5'Width'#3#133#2#18'HorzScrollBar.Page'#3#132#2#18'VertScrollBar.Pa'
+'idth'#3'?'#2#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#7 +'ge'#3#1#2#13'ActiveControl'#7#13'ButtonRedLine'#7'Caption'#6#22'LazRGBGraph'
+'OnPaint'#7#9'FormPaint'#13'PixelsPerInch'#2'`'#18'HorzScrollBar.Page'#3'>'#2 +'ics Example'#12'ClientHeight'#3#2#2#11'ClientWidth'#3#133#2#8'OnCreate'#7#10
+#18'VertScrollBar.Page'#3#186#1#4'Left'#3'-'#1#6'Height'#3#187#1#3'Top'#3#155 +'FormCreate'#9'OnDestroy'#7#11'FormDestroy'#7'OnPaint'#7#9'FormPaint'#0#7'TB'
+#0#5'Width'#3'?'#2#0#7'TButton'#13'ButtonRedLine'#25'BorderSpacing.InnerBord' +'utton'#13'ButtonRedLine'#4'Left'#2#6#6'Height'#2#26#3'Top'#2#8#5'Width'#2'Y'
+'er'#2#4#7'Caption'#6#13'Draw red line'#7'OnClick'#7#18'ButtonRedLineClick'#8 +#8'AutoSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Draw red li'
+'TabOrder'#2#0#4'Left'#2#6#6'Height'#2#25#3'Top'#2#8#5'Width'#2'~'#0#0#7'TBu' +'ne'#7'OnClick'#7#18'ButtonRedLineClick'#8'TabOrder'#2#0#0#0#7'TButton'#14'B'
+'tton'#14'ButtonRotate90'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#20 +'uttonRotate90'#4'Left'#2#6#6'Height'#2#26#3'Top'#2''''#5'Width'#3#131#0#8'A'
+'Rotate 90'#176' clockwise'#7'OnClick'#7#19'ButtonRotate90Click'#8'TabOrder' +'utoSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#19'Rotate 90 cloc'
+#2#1#4'Left'#2#6#6'Height'#2#25#3'Top'#2''''#5'Width'#2'~'#0#0#7'TButton'#12 +'kwise'#7'OnClick'#7#19'ButtonRotate90Click'#8'TabOrder'#2#1#0#0#7'TButton'
+'ButtonInvert'#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Invert colo' +#12'ButtonInvert'#4'Left'#2#6#6'Height'#2#26#3'Top'#2'H'#5'Width'#2'S'#8'Aut'
+'rs'#7'OnClick'#7#17'ButtonInvertClick'#8'TabOrder'#2#2#4'Left'#2#6#6'Height' +'oSize'#9#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#13'Invert colors'#7
+#2#25#3'Top'#2'H'#5'Width'#2'~'#0#0#7'TButton'#13'ButtonReplace'#25'BorderSp' +'OnClick'#7#17'ButtonInvertClick'#8'TabOrder'#2#2#0#0#7'TButton'#13'ButtonRe'
+'acing.InnerBorder'#2#4#7'Caption'#6#23'Replace white with blue'#7'OnClick'#7 +'place'#4'Left'#2#6#6'Height'#2#26#3'Top'#2'j'#5'Width'#3#136#0#8'AutoSize'#9
+#18'ButtonReplaceClick'#8'TabOrder'#2#3#4'Left'#2#6#6'Height'#2#25#3'Top'#2 +#25'BorderSpacing.InnerBorder'#2#4#7'Caption'#6#21'Replace red with blue'#7
+'j'#5'Width'#2'~'#0#0#0 +'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; unit RGBUnit;
{$mode objfpc}{$H+} {$ifdef fpc}
{$mode objfpc}{$H+}
{$endif}
interface interface
uses uses
Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons, Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs, Buttons,
RGBGraphics; RGBGraphics, ExtDlgs, ExtCtrls;
type type
@ -39,6 +41,7 @@ type
ButtonInvert: TButton; ButtonInvert: TButton;
ButtonRotate90: TButton; ButtonRotate90: TButton;
ButtonRedLine: TButton; ButtonRedLine: TButton;
OpenPictureDialog: TOpenPictureDialog;
procedure ButtonInvertClick(Sender: TObject); procedure ButtonInvertClick(Sender: TObject);
procedure ButtonRedLineClick(Sender: TObject); procedure ButtonRedLineClick(Sender: TObject);
procedure ButtonReplaceClick(Sender: TObject); procedure ButtonReplaceClick(Sender: TObject);
@ -53,6 +56,7 @@ type
var var
FormExample: TFormExample; FormExample: TFormExample;
RGBBitmap: TRGB32Bitmap; RGBBitmap: TRGB32Bitmap;
RGBMask: TRGBMask;
implementation implementation
@ -60,7 +64,31 @@ implementation
procedure TFormExample.FormCreate(Sender: TObject); procedure TFormExample.FormCreate(Sender: TObject);
begin 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; end;
procedure TFormExample.ButtonRedLineClick(Sender: TObject); procedure TFormExample.ButtonRedLineClick(Sender: TObject);
@ -73,13 +101,13 @@ end;
procedure TFormExample.ButtonReplaceClick(Sender: TObject); procedure TFormExample.ButtonReplaceClick(Sender: TObject);
begin begin
RGBBitmap.Canvas.EraseMode := emReplace; RGBBitmap.Canvas.EraseMode := ermReplace;
RGBBitmap.Canvas.FillColor := clWhite; RGBBitmap.Canvas.FillColor := clRed;
RGBBitmap.Canvas.PaperColor := clBlue; RGBBitmap.Canvas.PaperColor := clBlue;
RGBBitmap.Canvas.FillRect(0, 0, Pred(RGBBitmap.Width), Pred(RGBBitmap.Height)); RGBBitmap.Canvas.FillRect(0, 0, Pred(RGBBitmap.Width), Pred(RGBBitmap.Height));
RGBBitmap.Canvas.EraseMode := emNone; RGBBitmap.Canvas.EraseMode := ermNone;
Invalidate; Invalidate;
end; end;
@ -87,6 +115,7 @@ end;
procedure TFormExample.ButtonInvertClick(Sender: TObject); procedure TFormExample.ButtonInvertClick(Sender: TObject);
begin begin
RGBBitmap.Invert; RGBBitmap.Invert;
RGBMask.Invert;
Invalidate; Invalidate;
end; end;
@ -94,6 +123,7 @@ end;
procedure TFormExample.ButtonRotate90Click(Sender: TObject); procedure TFormExample.ButtonRotate90Click(Sender: TObject);
begin begin
RGBBitmap.Rotate90; RGBBitmap.Rotate90;
RGBMask.Rotate90;
Invalidate; Invalidate;
end; end;
@ -101,16 +131,20 @@ end;
procedure TFormExample.FormDestroy(Sender: TObject); procedure TFormExample.FormDestroy(Sender: TObject);
begin begin
RGBBitmap.Free; RGBBitmap.Free;
RGBMask.Free;
end; end;
procedure TFormExample.FormPaint(Sender: TObject); procedure TFormExample.FormPaint(Sender: TObject);
begin begin
if RGBBitmap = nil then Exit; if RGBBitmap = nil then Exit;
// draw bitmap 2x smaller // draw bitmap
RGBBitmap.Canvas.StretchDrawTo(Canvas, 140, 10, RGBBitmap.Width div 2, RGBBitmap.Canvas.DrawTo(Canvas, 180, 10);
RGBBitmap.Height div 2);
RGBMask.DrawTo(Canvas, 10, 160);
RGBMask.DrawShapeTo(Canvas, 10, 340);
end; end;
initialization initialization
{$I rgbunit.lrs} {$I rgbunit.lrs}

35
components/rgbgraphics/lazrgbgraphics.lpk
View File

@ -4,16 +4,23 @@
<PathDelim Value="\"/> <PathDelim Value="\"/>
<Name Value="LazRGBGraphics"/> <Name Value="LazRGBGraphics"/>
<Author Value="Tom Gregorovic (_tom_@centrum.cz)"/> <Author Value="Tom Gregorovic (_tom_@centrum.cz)"/>
<AutoUpdate Value="OnRebuildingAll"/>
<CompilerOptions> <CompilerOptions>
<Version Value="5"/> <Version Value="5"/>
<PathDelim Value="\"/> <PathDelim Value="\"/>
<SearchPaths> <SearchPaths>
<IncludeFiles Value="include\"/> <IncludeFiles Value="include\"/>
<UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)-$(LCLWidgetType)"/>
<LCLWidgetType Value="gtk2"/>
</SearchPaths> </SearchPaths>
<CodeGeneration> <CodeGeneration>
<Generate Value="Faster"/> <Generate Value="Faster"/>
</CodeGeneration> </CodeGeneration>
<Linking>
<Debugging>
<GenerateDebugInfo Value="True"/>
</Debugging>
</Linking>
<Other> <Other>
<CompilerPath Value="$(CompPath)"/> <CompilerPath Value="$(CompPath)"/>
</Other> </Other>
@ -22,8 +29,8 @@
"/> "/>
<License Value="Modified LGPL <License Value="Modified LGPL
"/> "/>
<Version Minor="1"/> <Version Minor="2"/>
<Files Count="4"> <Files Count="7">
<Item1> <Item1>
<Filename Value="rgbgraphics.pas"/> <Filename Value="rgbgraphics.pas"/>
<UnitName Value="RGBGraphics"/> <UnitName Value="RGBGraphics"/>
@ -40,14 +47,29 @@
<Filename Value="rgbroutines.pas"/> <Filename Value="rgbroutines.pas"/>
<UnitName Value="RGBRoutines"/> <UnitName Value="RGBRoutines"/>
</Item4> </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> </Files>
<RequiredPkgs Count="2"> <RequiredPkgs Count="2">
<Item1> <Item1>
<PackageName Value="LCL"/>
</Item1>
<Item2>
<PackageName Value="FCL"/> <PackageName Value="FCL"/>
<MinVersion Major="1" Valid="True"/> <MinVersion Major="1" Valid="True"/>
</Item1>
<Item2>
<PackageName Value="LCL"/>
</Item2> </Item2>
</RequiredPkgs> </RequiredPkgs>
<UsageOptions> <UsageOptions>
@ -55,6 +77,7 @@
</UsageOptions> </UsageOptions>
<PublishOptions> <PublishOptions>
<Version Value="2"/> <Version Value="2"/>
<DestinationDirectory Value="$(TestDir)\publishedpackage\"/>
<IgnoreBinaries Value="False"/> <IgnoreBinaries Value="False"/>
</PublishOptions> </PublishOptions>
</Package> </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 uses
Classes, SysUtils, LCLIntf, Classes, SysUtils, LCLIntf,
LCLType, LCLProc, Interfaces, FPImage, LResources, IntfGraphics, LCLType, LCLProc, FPImage, LResources, IntfGraphics,
Graphics, Forms, Math, Clipbrd, Graphics, Forms, Math, Clipbrd,
RGBTypes, RGBRoutines, RGBUtils; RGBTypes, RGBRoutines, RGBUtils;
@ -120,7 +120,7 @@ type
procedure SetOutlineColor(const AValue: TColor); procedure SetOutlineColor(const AValue: TColor);
procedure SetPaperColor(const AValue: TColor); procedure SetPaperColor(const AValue: TColor);
protected protected
function PixelMasked(X, Y: Integer): Boolean; inline; function PixelMasked(X, Y: Integer): Boolean;
function SamePixelUnsafe(X, Y: Integer; Value: TRGB32Pixel): Boolean; function SamePixelUnsafe(X, Y: Integer; Value: TRGB32Pixel): Boolean;
function SamePixelUnmasked(X, Y: Integer; Value: TRGB32Pixel): Boolean; function SamePixelUnmasked(X, Y: Integer; Value: TRGB32Pixel): Boolean;
@ -224,6 +224,19 @@ type
implementation 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 } { TRGB32Bitmap }
constructor TRGB32Bitmap.Create(AWidth, AHeight: Integer); constructor TRGB32Bitmap.Create(AWidth, AHeight: Integer);
@ -257,7 +270,6 @@ begin
Image := TLazIntfImage.Create(0, 0); Image := TLazIntfImage.Create(0, 0);
Reader := GetFPImageReaderForFileExtension(ExtractFileExt(FileName)).Create; Reader := GetFPImageReaderForFileExtension(ExtractFileExt(FileName)).Create;
try try
Image.GetDescriptionFromDevice(0);
Image.LoadFromFile(FileName, Reader); Image.LoadFromFile(FileName, Reader);
CreateFromLazIntfImage(Image); CreateFromLazIntfImage(Image);
finally finally
@ -345,7 +357,6 @@ begin
Image := TLazIntfImage.Create(0, 0); Image := TLazIntfImage.Create(0, 0);
Writer := GetFPImageWriterForFileExtension(ExtractFileExt(FileName)).Create; Writer := GetFPImageWriterForFileExtension(ExtractFileExt(FileName)).Create;
try try
Image.GetDescriptionFromDevice(0);
inherited SaveToLazIntfImage(Image); inherited SaveToLazIntfImage(Image);
Image.SaveToFile(FileName, Writer); Image.SaveToFile(FileName, Writer);
finally finally
@ -515,38 +526,38 @@ var
P: PRGB32Pixel; P: PRGB32Pixel;
begin begin
P := FOwner.Get32PixelPtr(X, Y); P := FOwner.Get32PixelPtr(X, Y);
if P <> nil then Result := RGB32PixelToColorInline(P^) if P <> nil then Result := RGB32PixelToColor(P^)
else Result := clNone; else Result := clNone;
end; end;
function TRGB32Canvas.GetFillColor: TColor; function TRGB32Canvas.GetFillColor: TColor;
begin begin
Result := RGB32PixelToColorInline(FFillColor); Result := RGB32PixelToColor(FFillColor);
end; end;
function TRGB32Canvas.GetOutlineColor: TColor; function TRGB32Canvas.GetOutlineColor: TColor;
begin begin
Result := RGB32PixelToColorInline(FOutlineColor); Result := RGB32PixelToColor(FOutlineColor);
end; end;
function TRGB32Canvas.GetPaperColor: TColor; function TRGB32Canvas.GetPaperColor: TColor;
begin begin
Result := RGB32PixelToColorInline(FPaperColor); Result := RGB32PixelToColor(FPaperColor);
end; end;
procedure TRGB32Canvas.SetFillColor(const AValue: TColor); procedure TRGB32Canvas.SetFillColor(const AValue: TColor);
begin begin
FFillColor := ColorToRGB32PixelInline(AValue); FFillColor := ColorToRGB32Pixel(AValue);
end; end;
procedure TRGB32Canvas.SetOutlineColor(const AValue: TColor); procedure TRGB32Canvas.SetOutlineColor(const AValue: TColor);
begin begin
FOutlineColor := ColorToRGB32PixelInline(AValue); FOutlineColor := ColorToRGB32Pixel(AValue);
end; end;
procedure TRGB32Canvas.SetPaperColor(const AValue: TColor); procedure TRGB32Canvas.SetPaperColor(const AValue: TColor);
begin begin
FPaperColor := ColorToRGB32PixelInline(AValue); FPaperColor := ColorToRGB32Pixel(AValue);
end; end;
function TRGB32Canvas.PixelMasked(X, Y: Integer): Boolean; function TRGB32Canvas.PixelMasked(X, Y: Integer): Boolean;
@ -565,13 +576,13 @@ end;
function TRGB32Canvas.SamePixelUnsafe(X, Y: Integer; Value: TRGB32Pixel): Boolean; function TRGB32Canvas.SamePixelUnsafe(X, Y: Integer; Value: TRGB32Pixel): Boolean;
begin begin
Result := PixelMasked(X, Y) and (RGB32PixelDifferenceInline(FOwner.Get32PixelPtrUnsafe(X, Y)^, Value) Result := PixelMasked(X, Y) and (RGB32PixelDifference(FOwner.Get32PixelUnsafe(X, Y), Value)
<= FFloodFillTolerance); <= FFloodFillTolerance);
end; end;
function TRGB32Canvas.SamePixelUnmasked(X, Y: Integer; Value: TRGB32Pixel): Boolean; function TRGB32Canvas.SamePixelUnmasked(X, Y: Integer; Value: TRGB32Pixel): Boolean;
begin begin
Result := RGB32PixelDifferenceInline(FOwner.Get32PixelPtrUnsafe(X, Y)^, Value) Result := RGB32PixelDifference(FOwner.Get32PixelUnsafe(X, Y), Value)
<= FFloodFillTolerance; <= FFloodFillTolerance;
end; 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: Abstract:
This unit contains routines for manipulating rgb bitmaps (stretching, 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...). ellipses...).
} }
@ -28,42 +28,36 @@ unit RGBRoutines;
{$ifdef fpc} {$ifdef fpc}
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$define hasinline}
{$endif} {$endif}
{$ifndef fpc}
{$define Windows}
{$endif}
{$ifdef win32}
{$define Windows}
{$endif}
interface interface
uses uses
SysUtils, Math, Forms, LCLIntf, SysUtils, Math, Forms, LCLIntf,
LCLType, LCLProc, InterfaceBase, Interfaces, FPImage, IntfGraphics, LCLType, LCLProc, 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}
Classes, 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; RGBTypes, RGBUtils;
procedure DrawRGB32Bitmap(Dst: TRGB32BitmapCore; X, Y: Integer; Src: TRGB32BitmapCore); overload; procedure DrawRGB32Bitmap(Dst: TRGB32BitmapCore; X, Y: Integer; Src: TRGB32BitmapCore); overload;
procedure DrawRGB8Bitmap(Dst: TRGB8BitmapCore; X, Y: Integer; Src: TRGB8BitmapCore); overload; procedure DrawRGB8Bitmap(Dst: TRGB8BitmapCore; X, Y: Integer; Src: TRGB8BitmapCore); overload;
procedure StretchRGB32BitmapTrunc(Dst, Src: TRGB32BitmapCore); procedure StretchRGB32BitmapTrunc(Dst, Src: TRGB32BitmapCore);
procedure StretchRGB8BitmapTrunc(Dst, Src: TRGB8BitmapCore); procedure StretchRGB8BitmapTrunc(Dst, Src: TRGB8BitmapCore);
procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer; procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB32BitmapCore); overload; Bitmap: TRGB32BitmapCore); overload;
procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer; 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; procedure DrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, SrcHeight: Integer;
Bitmap: TRGB8BitmapCore); overload; 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 type
TDrawPixelProcedure = procedure (X, Y: Integer) of Object; TDrawPixelProcedure = procedure (X, Y: Integer) of Object;
TGetPixelFunction = function (X, Y: Integer): TRGB32Pixel 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 LineBresenham(X1, Y1, X2, Y2: Integer; DrawPixel: TDrawPixelProcedure);
procedure FillPixelRect(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; procedure NormalRectangle(X1, Y1, X2, Y2: Integer;
DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure); DrawOutlinePixel, DrawFillPixel: TDrawPixelProcedure);
@ -410,7 +388,7 @@ procedure StretchRGB32BitmapTrunc(Dst: TRGB32BitmapCore;
var var
Cols: TIntArray; Cols: TIntArray;
Rows: TIntArray; Rows: TIntArray;
X, Y, PX, TX, OX, PY, TY, OY: Integer; X, Y: Integer;
SX, SY, DX, DY: Integer; SX, SY, DX, DY: Integer;
I, J, C: Integer; I, J, C: Integer;
PD, PS, PDLine, PSLine: PRGB32Pixel; PD, PS, PDLine, PSLine: PRGB32Pixel;
@ -539,17 +517,11 @@ procedure DrawRGB32Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth,
Bitmap: TRGB32BitmapCore); Bitmap: TRGB32BitmapCore);
var var
Clip: TRect; Clip: TRect;
{$IFDEF Win32}
Info: BITMAPINFO;
{$ENDIF}
{$IFDEF gtk}
P: TPoint;
{$ENDIF}
begin begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (SrcWidth <= 0) or (SrcHeight <= 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 if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or
(DstX + SrcWidth < Clip.Left) or (DstY + SrcHeight < Clip.Top) then Exit; (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.Left, Clip.Right, DstX, SrcX, SrcWidth);
ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight); ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight);
{$IFDEF Windows} WidgetSetDrawRGB32Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap);
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}
end; end;
// ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height // ! SrcX < 0, SrcY < 0, SrcX + SrcWidth > Bitmap.Width, SrcY + SrcHeight > Bitmap.Height
// ! results in mash // ! results in mash
{$DEFINE StretchRGB32}
{$IFDEF Windows}
{ $UNDEF StretchRGB32}
{$ENDIF}
procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer; procedure StretchDrawRGB32Bitmap(Dest: HDC; DstX, DstY, DstWidth, DstHeight: Integer;
SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore); SrcX, SrcY, SrcWidth, SrcHeight: Integer; Bitmap: TRGB32BitmapCore);
var var
Clip: TRect; Clip: TRect;
{$IFDEF StretchRGB32} {$IFDEF StretchRGB32}
{$IFDEF gtk}
P: TPoint;
{$ENDIF}
Temp: TRGB32BitmapCore; Temp: TRGB32BitmapCore;
X, Y, W, H: Integer; X, Y, W, H: Integer;
{$ELSE}
{$IFDEF Windows}
Info: BITMAPINFO;
{$ENDIF}
{$ENDIF} {$ENDIF}
begin begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit; if (SrcWidth <= 0) or (SrcHeight <= 0) then Exit;
if (DstWidth <= 0) or (DstHeight <= 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 if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or
(DstX + DstWidth < Clip.Left) or (DstY + DstHeight < Clip.Top) then Exit; (DstX + DstWidth < Clip.Left) or (DstY + DstHeight < Clip.Top) then Exit;
@ -640,21 +574,8 @@ begin
Temp.Free; Temp.Free;
end; end;
{$ELSE} {$ELSE}
with Info.bmiHeader do WidgetSetStretchDrawRGB32Bitmap(Dest, DstX, DstY, DstWidth, DstHeight,
begin SrcX, SrcY, SrcWidth, SrcHeight, Bitmap);
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);
{$ENDIF} {$ENDIF}
end; end;
@ -795,7 +716,7 @@ begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (DstWidth <= 0) or (DstHeight <= 0) then Exit; if (DstWidth <= 0) or (DstHeight <= 0) then Exit;
Widgetset.GetClipBox(Dest, @Clip); GetClipBox(Dest, @Clip);
ZoomX := DstWidth / Bitmap.Width; ZoomX := DstWidth / Bitmap.Width;
ZoomY := DstHeight / Bitmap.Height; ZoomY := DstHeight / Bitmap.Height;
@ -814,19 +735,11 @@ procedure DrawRGB8Bitmap(Dest: HDC; DstX, DstY: Integer; SrcX, SrcY, SrcWidth, S
Bitmap: TRGB8BitmapCore); Bitmap: TRGB8BitmapCore);
var var
Clip: TRect; Clip: TRect;
{$IFDEF Win32}
Info: PBITMAPINFO;
I: Byte;
PColor: PRGBQUAD;
{$ENDIF}
{$IFDEF gtk}
P: TPoint;
{$ENDIF}
begin begin
if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit; if (Bitmap = nil) or (Bitmap.Pixels = nil) then Exit;
if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit; if (Bitmap.Width <= 0) or (Bitmap.Height <= 0) then Exit;
if (SrcWidth <= 0) or (SrcHeight <= 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 if (DstX >= Clip.Right) or (DstY >= Clip.Bottom) or
(DstX + SrcWidth < Clip.Left) or (DstY + SrcHeight < Clip.Top) then Exit; (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.Left, Clip.Right, DstX, SrcX, SrcWidth);
ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight); ClipDimension(Clip.Top, Clip.Bottom, DstY, SrcY, SrcHeight);
{$IFDEF Windows} WidgetSetDrawRGB8Bitmap(Dest, DstX, DstY, SrcX, SrcY, SrcWidth, SrcHeight, Bitmap);
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;
end; end;
(* (*
@ -1153,7 +830,7 @@ begin
for X := X1 to X2 do DrawPixel(X, Y); for X := X1 to X2 do DrawPixel(X, Y);
end; end;
procedure FillPixelRow(X1, X2, Y: Integer; DrawPixel: TDrawPixelProcedure); procedure FillPixelRow(X1, X2, Y: Integer; DrawPixel: TDrawPixelProcedure); inline;
var var
X: Integer; X: Integer;
begin begin
@ -1343,7 +1020,7 @@ var
Stack: Array of Integer; Stack: Array of Integer;
StackCount: Integer; StackCount: Integer;
function CheckPixel(AX, AY: Integer): Boolean; {$ifdef hasinline}inline;{$endif} function CheckPixel(AX, AY: Integer): Boolean; inline;
begin begin
if Visited[AX + AY * W] = 1 then Result := False if Visited[AX + AY * W] = 1 then Result := False
else else
@ -1352,7 +1029,7 @@ var
end; end;
end; end;
procedure Push(AX, AY: Integer); {$ifdef hasinline}inline;{$endif} procedure Push(AX, AY: Integer); inline;
begin begin
if StackCount >= High(Stack) then SetLength(Stack, Length(Stack) shl 1); if StackCount >= High(Stack) then SetLength(Stack, Length(Stack) shl 1);
@ -1360,7 +1037,7 @@ var
Inc(StackCount); Inc(StackCount);
end; end;
procedure Pop(var AX, AY: Integer); {$ifdef hasinline}inline;{$endif} procedure Pop(var AX, AY: Integer); inline;
begin begin
Dec(StackCount); Dec(StackCount);
AX := Stack[StackCount] and $FFFF; AX := Stack[StackCount] and $FFFF;
@ -1417,10 +1094,6 @@ begin
end; end;
end; end;
initialization
{$IFDEF gtk}
gdk_rgb_init;
{$ENDIF}
end. end.

530
components/rgbgraphics/rgbtypes.pas
View File

@ -28,21 +28,17 @@ unit RGBTypes;
{$ifdef fpc} {$ifdef fpc}
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
{$define hasinline}
{$endif} {$endif}
{$ifndef fpc} {$ifdef LCLwin32}
{$define Windows} {$define RGB}
{$endif}
{$ifdef win32}
{$define Windows}
{$endif} {$endif}
interface interface
uses uses
Classes, SysUtils, FPImage, IntfGraphics, Graphics, Math, LCLProc; Classes, SysUtils, FPImage, IntfGraphics, Graphics, Math, LCLProc,
RGBUtils;
type type
PRGBPixel = PByte; PRGBPixel = PByte;
@ -74,6 +70,7 @@ type
FWidth: Integer; FWidth: Integer;
FHeight: Integer; FHeight: Integer;
FRowPixelStride: Integer; FRowPixelStride: Integer;
function GetSize: Integer;
public public
constructor Create(AWidth, AHeight: Integer; ASizeOfPixel: Integer); virtual; constructor Create(AWidth, AHeight: Integer; ASizeOfPixel: Integer); virtual;
constructor CreateAsCopy(ABitmap: TRGBBitmapCore; ASizeOfPixel: Integer); virtual; constructor CreateAsCopy(ABitmap: TRGBBitmapCore; ASizeOfPixel: Integer); virtual;
@ -82,8 +79,8 @@ type
procedure Assign(Source: TPersistent); override; procedure Assign(Source: TPersistent); override;
procedure SwapWith(ABitmap: TRGBBitmapCore); virtual; procedure SwapWith(ABitmap: TRGBBitmapCore); virtual;
public public
function GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel; {$ifdef hasinline}inline;{$endif} function GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel;
function GetPixelPtr(X, Y: Integer): PRGBPixel; {$ifdef hasinline}inline;{$endif} function GetPixelPtr(X, Y: Integer): PRGBPixel;
procedure Clear; virtual; procedure Clear; virtual;
procedure ClearWhite; virtual; procedure ClearWhite; virtual;
@ -99,6 +96,7 @@ type
property Height: Integer read FHeight; property Height: Integer read FHeight;
property Pixels: PRGBPixel read FPixels; property Pixels: PRGBPixel read FPixels;
property RowPixelStride: Integer read FRowPixelStride; property RowPixelStride: Integer read FRowPixelStride;
property Size: Integer read GetSize;
property SizeOfPixel: Integer read FSizeOfPixel; property SizeOfPixel: Integer read FSizeOfPixel;
end; end;
@ -116,12 +114,12 @@ type
procedure Assign(Source: TPersistent); override; procedure Assign(Source: TPersistent); override;
procedure SwapWith(ABitmap: TRGBBitmapCore); override; procedure SwapWith(ABitmap: TRGBBitmapCore); override;
public public
function Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel; {$ifdef hasinline}inline;{$endif} function Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel;
function Get8PixelPtr(X, Y: Integer): PRGB8Pixel; {$ifdef hasinline}inline;{$endif} function Get8PixelPtr(X, Y: Integer): PRGB8Pixel;
function Get8PixelUnsafe(X, Y: Integer): TRGB8Pixel; function Get8PixelUnsafe(X, Y: Integer): TRGB8Pixel;
procedure Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel); {$ifdef hasinline}inline;{$endif} procedure Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel);
procedure Set8Pixel(X, Y: Integer; Value: TRGB8Pixel); {$ifdef hasinline}inline;{$endif} procedure Set8Pixel(X, Y: Integer; Value: TRGB8Pixel);
end; end;
{ TRGB32BitmapCore } { TRGB32BitmapCore }
@ -137,39 +135,127 @@ type
procedure SaveToLazIntfImage(AImage: TLazIntfImage); virtual; procedure SaveToLazIntfImage(AImage: TLazIntfImage); virtual;
procedure SaveToLazIntfImage(AImage: TLazIntfImage; const ARect: TRect); virtual; procedure SaveToLazIntfImage(AImage: TLazIntfImage; const ARect: TRect); virtual;
public public
function Get32PixelPtrUnsafe(X, Y: Integer): PRGB32Pixel; {$ifdef hasinline}inline;{$endif} function Get32PixelPtrUnsafe(X, Y: Integer): PRGB32Pixel;
function Get32PixelPtr(X, Y: Integer): PRGB32Pixel; {$ifdef hasinline}inline;{$endif} function Get32PixelPtr(X, Y: Integer): PRGB32Pixel;
function Get32PixelUnsafe(X, Y: Integer): TRGB32Pixel; function Get32PixelUnsafe(X, Y: Integer): TRGB32Pixel;
procedure Set32PixelUnsafe(X, Y: Integer; Value: TRGB32Pixel); {$ifdef hasinline}inline;{$endif} procedure Set32PixelUnsafe(X, Y: Integer; Value: TRGB32Pixel);
procedure Set32Pixel(X, Y: Integer; Value: TRGB32Pixel); {$ifdef hasinline}inline;{$endif} procedure Set32Pixel(X, Y: Integer; Value: TRGB32Pixel);
end; 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 RGB32PixelToColor(P: TRGB32Pixel): TColor;
function ColorToRGB32Pixel(C: TColor): TRGB32Pixel; 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 implementation
uses function GetRedInline(P: TRGB32Pixel): Byte; inline;
RGBRoutines, RGBUtils; 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 var
T32: TRGB32Pixel; T32: TRGB32Pixel;
T8: TRGB8Pixel; T8: TRGB8Pixel;
@ -188,7 +274,7 @@ begin
end; end;
end; end;
procedure CopyRGBPixels(Src, Dest: PRGBPixel; const Size: Integer); procedure CopyRGBPixels(Src, Dest: PRGBPixel; const Size: Integer); inline;
begin begin
if Size = 4 then PRGB32Pixel(Dest)^ := PRGB32Pixel(Src)^ if Size = 4 then PRGB32Pixel(Dest)^ := PRGB32Pixel(Src)^
else else
@ -197,124 +283,218 @@ begin
end; end;
end; end;
function GetRedInline(P: TRGB32Pixel): Byte; function GetRGBBitmapPixelPtr(const Bitmap: TRGBBitmapCore; X, Y: Integer): PRGBPixel; inline;
begin begin
{$IFDEF Windows} Result := Bitmap.FPixels;
Result := (P and $FF0000) shr 16; Inc(Result, Y * Bitmap.FRowPixelStride * Bitmap.FSizeOfPixel + X * Bitmap.FSizeOfPixel);
{$ELSE}
Result := P and $FF;
{$ENDIF}
end; end;
function GetGreenInline(P: TRGB32Pixel): Byte; function RoundIntensityFloatInline(V: TIntensityFloat): Byte; inline;
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;
begin begin
Result := Max(0, Min(255, (V + 128) shr 8)); Result := Max(0, Min(255, (V + 128) shr 8));
end; 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 } { TRGBBitmapCore }
function TRGBBitmapCore.GetSize: Integer;
begin
Result := Height * RowPixelStride * SizeOfPixel;
end;
constructor TRGBBitmapCore.Create(AWidth, AHeight: Integer; ASizeOfPixel: Integer); constructor TRGBBitmapCore.Create(AWidth, AHeight: Integer; ASizeOfPixel: Integer);
begin begin
inherited Create; inherited Create;
@ -371,9 +551,6 @@ begin
end; end;
procedure TRGBBitmapCore.SwapWith(ABitmap: TRGBBitmapCore); procedure TRGBBitmapCore.SwapWith(ABitmap: TRGBBitmapCore);
var
Temp: Pointer;
TempInt: Integer;
begin begin
if ABitmap = nil then Exit; if ABitmap = nil then Exit;
@ -386,26 +563,25 @@ end;
function TRGBBitmapCore.GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel; function TRGBBitmapCore.GetPixelPtrUnsafe(X, Y: Integer): PRGBPixel;
begin begin
Result := FPixels; Result := GetRGBBitmapPixelPtr(Self, X, Y);
Inc(Result, Y * FRowPixelStride * FSizeOfPixel + X * FSizeOfPixel);
end; end;
function TRGBBitmapCore.GetPixelPtr(X, Y: Integer): PRGBPixel; function TRGBBitmapCore.GetPixelPtr(X, Y: Integer): PRGBPixel;
begin begin
if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
Result := GetPixelPtrUnsafe(X, Y) Result := GetRGBBitmapPixelPtr(Self, X, Y)
else else
Result := nil; Result := nil;
end; end;
procedure TRGBBitmapCore.Clear; procedure TRGBBitmapCore.Clear;
begin begin
FillByte(Pixels^, Height * RowPixelStride * SizeOfPixel, 0); FillByte(Pixels^, Size, 0);
end; end;
procedure TRGBBitmapCore.ClearWhite; procedure TRGBBitmapCore.ClearWhite;
begin begin
FillByte(Pixels^, Height * RowPixelStride * SizeOfPixel, $FF); FillByte(Pixels^, Size, $FF);
end; end;
procedure TRGBBitmapCore.Invert; procedure TRGBBitmapCore.Invert;
@ -430,7 +606,7 @@ end;
procedure TRGBBitmapCore.Rotate180; procedure TRGBBitmapCore.Rotate180;
begin begin
Rotate180CWRGBBitmap(Self); Rotate180CWRGBBitmap(Self);
end; end;
procedure TRGBBitmapCore.Rotate270; procedure TRGBBitmapCore.Rotate270;
@ -497,7 +673,6 @@ var
begin begin
W := ARect.Right - ARect.Left; W := ARect.Right - ARect.Left;
H := ARect.Bottom - ARect.Top; H := ARect.Bottom - ARect.Top;
AImage.GetDescriptionFromDevice(0);
AImage.SetSize(W, H); AImage.SetSize(W, H);
try try
for J := 0 to Pred(H) do for J := 0 to Pred(H) do
@ -517,34 +692,32 @@ end;
function TRGB32BitmapCore.Get32PixelPtrUnsafe(X, Y: Integer function TRGB32BitmapCore.Get32PixelPtrUnsafe(X, Y: Integer
): PRGB32Pixel; ): PRGB32Pixel;
begin begin
Result := PRGB32Pixel(GetPixelPtrUnsafe(X, Y)); Result := PRGB32Pixel(GetRGBBitmapPixelPtr(Self, X, Y));
end; end;
function TRGB32BitmapCore.Get32PixelPtr(X, Y: Integer): PRGB32Pixel; function TRGB32BitmapCore.Get32PixelPtr(X, Y: Integer): PRGB32Pixel;
begin 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; end;
function TRGB32BitmapCore.Get32PixelUnsafe(X, Y: Integer): TRGB32Pixel; function TRGB32BitmapCore.Get32PixelUnsafe(X, Y: Integer): TRGB32Pixel;
begin begin
Result := Get32PixelPtrUnsafe(X, Y)^; Result := GetRGBBitmapPixelPtr(Self, X, Y)^;
end; end;
procedure TRGB32BitmapCore.Set32PixelUnsafe(X, Y: Integer; procedure TRGB32BitmapCore.Set32PixelUnsafe(X, Y: Integer;
Value: TRGB32Pixel); Value: TRGB32Pixel);
begin begin
Get32PixelPtrUnsafe(X, Y)^ := Value; GetRGBBitmapPixelPtr(Self, X, Y)^ := Value;
end; end;
procedure TRGB32BitmapCore.Set32Pixel(X, Y: Integer; Value: TRGB32Pixel); procedure TRGB32BitmapCore.Set32Pixel(X, Y: Integer; Value: TRGB32Pixel);
var
P: PRGB32Pixel;
begin begin
P := Get32PixelPtr(X, Y); if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
if P <> nil then PRGB32Pixel(GetRGBBitmapPixelPtr(Self, X, Y))^ := Value;
begin
P^ := Value;
end;
end; end;
{ TRGB8BitmapCore } { TRGB8BitmapCore }
@ -616,34 +789,33 @@ end;
function TRGB8BitmapCore.Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel; function TRGB8BitmapCore.Get8PixelPtrUnsafe(X, Y: Integer): PRGB8Pixel;
begin begin
Result := GetPixelPtrUnsafe(X, Y); Result := GetRGBBitmapPixelPtr(Self, X, Y);
end; end;
function TRGB8BitmapCore.Get8PixelPtr(X, Y: Integer): PRGB8Pixel; function TRGB8BitmapCore.Get8PixelPtr(X, Y: Integer): PRGB8Pixel;
begin 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; end;
function TRGB8BitmapCore.Get8PixelUnsafe(X, Y: Integer): TRGB8Pixel; function TRGB8BitmapCore.Get8PixelUnsafe(X, Y: Integer): TRGB8Pixel;
begin begin
Result := GetPixelPtrUnsafe(X, Y)^; Result := GetRGBBitmapPixelPtr(Self, X, Y)^;
end; end;
procedure TRGB8BitmapCore.Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel); procedure TRGB8BitmapCore.Set8PixelUnsafe(X, Y: Integer; Value: TRGB8Pixel);
begin begin
GetPixelPtrUnsafe(X, Y)^ := Value; GetRGBBitmapPixelPtr(Self, X, Y)^ := Value;
end; end;
procedure TRGB8BitmapCore.Set8Pixel(X, Y: Integer; Value: TRGB8Pixel); procedure TRGB8BitmapCore.Set8Pixel(X, Y: Integer; Value: TRGB8Pixel);
var
P: PRGB8Pixel;
begin begin
P := Get8PixelPtr(X, Y); if (X >= 0) and (X < FWidth) and (Y >= 0) and (Y < FHeight) then
if P <> nil then GetRGBBitmapPixelPtr(Self, X, Y)^ := Value;
begin
P^ := Value;
end;
end; end;
end. end.

3
components/rgbgraphics/rgbutils.pas
View File

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