examples: added an example for ScanLine replacement

git-svn-id: trunk@10275 -

.gitattributes

@@ -1158,6 +1158,11 @@ examples/postscript/usamplepostscriptcanvas.lrs svneol=native#text/pascal
 examples/postscript/usamplepostscriptcanvas.pas svneol=native#text/pascal
 examples/progressbar.lpi svneol=native#text/plain
 examples/progressbar.pp svneol=native#text/pascal
+examples/scanline/bitmapscanline1.lpi svneol=native#text/plain
+examples/scanline/bitmapscanline1.lpr svneol=native#text/plain
+examples/scanline/unit1.lfm svneol=native#text/plain
+examples/scanline/unit1.lrs svneol=native#text/plain
+examples/scanline/unit1.pas svneol=native#text/plain
 examples/scrollbar.lpi svneol=native#text/plain
 examples/scrollbar.pp svneol=native#text/pascal
 examples/selection.pp svneol=native#text/pascal

examples/scanline/bitmapscanline1.lpi

@@ -0,0 +1,66 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="5"/>
+    <General>
+      <SessionStorage Value="InProjectDir"/>
+      <MainUnit Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=""/>
+      <Title Value="project1"/>
+    </General>
+    <VersionInfo>
+      <ProjectVersion Value=""/>
+    </VersionInfo>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="bitmapscanline1.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="BitmapScanLine1"/>
+      </Unit0>
+      <Unit1>
+        <Filename Value="unit1.pas"/>
+        <ComponentName Value="Form1"/>
+        <IsPartOfProject Value="True"/>
+        <ResourceFilename Value="unit1.lrs"/>
+        <UnitName Value="Unit1"/>
+      </Unit1>
+    </Units>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="5"/>
+    <SearchPaths>
+      <SrcPath Value="$(LazarusDir)/lcl/;$(LazarusDir)/lcl/interfaces/$(LCLWidgetType)/"/>
+    </SearchPaths>
+    <CodeGeneration>
+      <Generate Value="Faster"/>
+    </CodeGeneration>
+    <Linking>
+      <Options>
+        <Win32>
+          <GraphicApplication Value="True"/>
+        </Win32>
+      </Options>
+    </Linking>
+    <Other>
+      <CompilerPath Value="$(CompPath)"/>
+    </Other>
+  </CompilerOptions>
+</CONFIG>

examples/scanline/bitmapscanline1.lpr

@@ -0,0 +1,19 @@
+program BitmapScanLine1;
+
+{$mode objfpc}{$H+}
+
+uses
+  {$IFDEF UNIX}{$IFDEF UseCThreads}
+  cthreads,
+  {$ENDIF}{$ENDIF}
+  Interfaces, // this includes the LCL widgetset
+  Forms
+  { add your units here }, Unit1;
+
+begin
+  Application.Title:='project1';
+  Application.Initialize;
+  Application.CreateForm(TForm1, Form1);
+  Application.Run;
+end.
+

examples/scanline/unit1.lfm

@@ -0,0 +1,22 @@
+object Form1: TForm1
+  Left = 290
+  Height = 144
+  Top = 189
+  Width = 623
+  HorzScrollBar.Page = 622
+  VertScrollBar.Page = 143
+  Caption = 'Form1'
+  OnCreate = FormCreate
+  OnDestroy = FormDestroy
+  OnPaint = FormPaint
+  object Label1: TLabel
+    Left = 156
+    Height = 13
+    Top = 42
+    Width = 407
+    Caption = 'You should see a small rectangle filled with gray and a diagonal red line'
+    Color = clNone
+    ParentColor = False
+    WordWrap = True
+  end
+end

examples/scanline/unit1.lrs

@@ -0,0 +1,11 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TForm1','FORMDATA',[
+  'TPF0'#6'TForm1'#5'Form1'#4'Left'#3'"'#1#6'Height'#3#144#0#3'Top'#3#189#0#5'W'
+  +'idth'#3'o'#2#18'HorzScrollBar.Page'#3'n'#2#18'VertScrollBar.Page'#3#143#0#7
+  +'Caption'#6#5'Form1'#8'OnCreate'#7#10'FormCreate'#9'OnDestroy'#7#11'FormDest'
+  +'roy'#7'OnPaint'#7#9'FormPaint'#0#6'TLabel'#6'Label1'#4'Left'#3#156#0#6'Heig'
+  +'ht'#2#13#3'Top'#2'*'#5'Width'#3#151#1#7'Caption'#6'IYou should see a small '
+  +'rectangle filled with gray and a diagonal red line'#5'Color'#7#6'clNone'#11
+  +'ParentColor'#8#8'WordWrap'#9#0#0#0
+]);

examples/scanline/unit1.pas

@@ -0,0 +1,126 @@
+{
+ ***************************************************************************
+ *                                                                         *
+ *   This source is free software; you can redistribute it and/or modify   *
+ *   it under the terms of the GNU General Public License as published by  *
+ *   the Free Software Foundation; either version 2 of the License, or     *
+ *   (at your option) any later version.                                   *
+ *                                                                         *
+ *   This code is distributed in the hope that it will be useful, but      *
+ *   WITHOUT ANY WARRANTY; without even the implied warranty of            *
+ *   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU     *
+ *   General Public License for more details.                              *
+ *                                                                         *
+ *   A copy of the GNU General Public License is available on the World    *
+ *   Wide Web at <http://www.gnu.org/copyleft/gpl.html>. You can also      *
+ *   obtain it by writing to the Free Software Foundation,                 *
+ *   Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.        *
+ *                                                                         *
+ ***************************************************************************
+
+  Abstract:
+    This example demonstrates how to
+    - create an image with an internal format similar to Delphi's pf24bit
+    - convert it to current format and create a TBitmap from it
+    - use an approach similar to Delphi's TBitmap.ScanLine.
+    
+  Delphi's TBitmap implementation only supports windows formats. For example
+  the TBitmap.ScanLine function gives a direct pointer to the memory. This is
+  not possible under all widget sets. And even those who supports it, uses
+  different formats than windows. So Delphi code using TBitmap.ScanLine has to
+  be changed anyway. How much depends on how much speed is needed.
+  
+  If the goal is to quickly port some Delphi code using TBitmap.Scanline, then
+  the below code gives some hints how to achieve it.
+}
+unit Unit1;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
+  FPImage, GraphType, IntfGraphics, StdCtrls;
+
+type
+
+  { TForm1 }
+
+  TForm1 = class(TForm)
+    Label1: TLabel;
+    procedure FormCreate(Sender: TObject);
+    procedure FormDestroy(Sender: TObject);
+    procedure FormPaint(Sender: TObject);
+  private
+  public
+    MyBitmap: TBitmap;
+    procedure PaintToRGB32bitScanLine(Row, ImgWidth: integer; LineStart: Pointer);
+  end;
+
+var
+  Form1: TForm1; 
+
+implementation
+
+{ TForm1 }
+
+procedure TForm1.FormCreate(Sender: TObject);
+var
+  IntfImage: TLazIntfImage;
+  ScanLineImage: TLazIntfImage;
+  y: Integer;
+begin
+  MyBitmap:=TBitmap.Create;
+
+  // create an image with a format similar to Delphi's pf32bit
+  // keep in mind that you access it in bytes, not words or dwords
+  // For example PowerPC uses another byte order (endian big)
+  ScanLineImage:=TLazIntfImage.Create(0,0);
+  ScanLineImage.Set_BPP32_B8G8R8_A1_BIO_TTB(30,20);
+
+  // call the very fast and very specific drawing function
+  for y:=0 to ScanLineImage.Height-1 do
+    PaintToRGB32bitScanLine(y,ScanLineImage.Width,
+                            ScanLineImage.GetDataLineStart(y));
+
+  // create IntfImage with the format of the current LCL interface
+  IntfImage:=MyBitmap.CreateIntfImage;
+  // convert the content from the very specific to the current format
+  IntfImage.CopyPixels(ScanLineImage);
+  MyBitmap.LoadFromIntfImage(IntfImage);
+
+  ScanLineImage.Free;
+  IntfImage.Free;
+end;
+
+procedure TForm1.FormDestroy(Sender: TObject);
+begin
+  MyBitmap.Free;
+end;
+
+procedure TForm1.FormPaint(Sender: TObject);
+begin
+  Canvas.Draw(10,10,MyBitmap);
+end;
+
+procedure TForm1.PaintToRGB32bitScanLine(Row, ImgWidth: integer;
+  LineStart: Pointer);
+// LineStart is pointer to the start of a scanline with the following format:
+// 4 bytes per pixel. First byte is blue, second green, third is red.
+// Black is 0,0,0, white is 255,255,255
+var
+  i: Integer;
+begin
+  // fill line with gray
+  for i:=0 to (ImgWidth*4)-1 do
+    PByte(LineStart)[i]:=128; // set red, green and blue to 128
+  // set one pixel to red
+  PByte(LineStart)[(Row mod ImgWidth)*4+2]:=255;
+end;
+
+initialization
+  {$I unit1.lrs}
+
+end.
+

lcl/graphics.pp

@@ -1171,7 +1171,8 @@ type
     procedure GetSupportedSourceMimeTypes(List: TStrings); override;
     function GetDefaultMimeType: string; override;
     class function GetFileExtensions: string; override;
-    Procedure LoadFromXPMFile(const Filename: String);
+    procedure LoadFromXPMFile(const Filename: String);
+    procedure LoadFromIntfImage(IntfImage: TLazIntfImage);
     procedure Mask(ATransparentColor: TColor);
     procedure SaveToStream(Stream: TStream); override;
     procedure ReadStream(Stream: TStream; UseSize: boolean; Size: Longint); virtual;

lcl/include/bitmap.inc

@@ -488,6 +488,15 @@ Begin
   LoadFromFile(Filename);
 end;
 
+procedure TBitmap.LoadFromIntfImage(IntfImage: TLazIntfImage);
+var
+  ImgHandle, ImgMaskHandle: HBitmap;
+begin
+  IntfImage.CreateBitmap(ImgHandle,ImgMaskHandle,false);
+  Handle:=ImgHandle;
+  MaskHandle:=ImgMaskHandle;
+end;
+
 function TBitmap.GetMonochrome: Boolean;
 begin
   with FImage.FDIB.dsbm do

lcl/intfgraphics.pas

@@ -181,6 +181,7 @@ type
                               ExceptionOnError: boolean): boolean; virtual;
     procedure GetDescriptionFromDevice(DC: HDC); virtual;
     procedure GetDescriptionFromBitmap(Bitmap: HBitmap); virtual;
+    procedure Set_BPP32_B8G8R8_A1_BIO_TTB(NewWidth, NewHeight: integer);
     procedure LoadFromDevice(DC: HDC); virtual;
     procedure LoadFromBitmap(Bitmap, MaskBitmap: HBitmap; AWidth: integer = -1; AHeight: integer = -1); virtual;
     procedure CreateBitmap(var Bitmap, MaskBitmap: HBitmap;
@@ -188,8 +189,10 @@ type
     procedure SetRawImage(const RawImage: TRawImage); virtual;
     procedure GetRawImage(out RawImage: TRawImage); virtual;
     procedure FillPixels(const Color: TFPColor); virtual;
+    procedure CopyPixels(Src: TFPCustomImage); virtual;
     procedure GetXYDataPostion(x, y: integer; var Position: TRawImagePosition);
     procedure GetXYMaskPostion(x, y: integer; var Position: TRawImagePosition);
+    function GetDataLineStart(y: integer): Pointer;// similar to Delphi TBitmap.ScanLine. Only works with byte aligned lines.
     procedure CreateAllData; virtual;
     procedure CreatePixelData; virtual;
     procedure CreateMaskData; virtual;
@@ -1667,6 +1670,13 @@ begin
   inc(Position.Byte,BitOffset shr 3);
 end;
 
+function TLazIntfImage.GetDataLineStart(y: integer): Pointer;
+begin
+  if FDataDescription.LineOrder=riloBottomToTop then
+    y:=Height-y;
+  Result:=FPixelData+FLineStarts[y].Byte;
+end;
+
 procedure TLazIntfImage.LoadFromDevice(DC: HDC);
 var
   ARect: TRect;
@@ -1681,7 +1691,7 @@ begin
 end;
 
 procedure TLazIntfImage.LoadFromBitmap(Bitmap, MaskBitmap: HBitmap;
-  AWidth, AHeight: integer);
+  AWidth: integer; AHeight: integer);
 var
   ARect: TRect;
   ARawImage: TRawImage;
@@ -1775,6 +1785,43 @@ begin
   DataDescription:=NewDataDescription;
 end;
 
+procedure TLazIntfImage.Set_BPP32_B8G8R8_A1_BIO_TTB(NewWidth, NewHeight: integer
+  );
+// Format=ricfRGBA HasPalette=false Depth=24 PaletteColorCount=0
+// BitOrder=riboBitsInOrder ByteOrder=DefaultByteOrder
+// LineOrder=riloTopToBottom
+// BitsPerPixel=32 LineEnd=rileDWordBoundary
+// RedPrec=8 RedShift=16 GreenPrec=8 GreenShift=8 BluePrec=8 BlueShift=0
+// AlphaSeparate=false
+var
+  ADesc: TRawImageDescription;
+begin
+  // setup an artificial ScanLineImage with format RGB 24 bit, 32bit depth format
+  FillChar(ADesc,SizeOf(ADesc),0);
+  with ADesc do begin
+    Format:=ricfRGBA;
+    Depth:=24; // used bits per pixel
+    Width:=0;
+    Height:=0;
+    BitOrder:=riboBitsInOrder;
+    ByteOrder:=DefaultByteOrder;
+    LineOrder:=riloTopToBottom;
+    BitsPerPixel:=32; // bits per pixel. can be greater than Depth.
+    LineEnd:=rileDWordBoundary;
+    RedPrec:=8; // red precision. bits for red
+    RedShift:=16;
+    GreenPrec:=8;
+    GreenShift:=8; // bitshift. Direction: from least to most signifikant
+    BluePrec:=8;
+    BlueShift:=0;
+    AlphaPrec:=0;
+    AlphaSeparate:=false;
+  end;
+
+  DataDescription:=ADesc;
+  SetSize(NewWidth,NewHeight);
+end;
+
 procedure TLazIntfImage.FillPixels(const Color: TFPColor);
 var
   ColorChar: char;
@@ -1823,6 +1870,34 @@ begin
   // ToDo: mask
 end;
 
+procedure TLazIntfImage.CopyPixels(Src: TFPCustomImage);
+var
+  y: Integer;
+  x: Integer;
+  SrcImg: TLazIntfImage;
+begin
+  if (Src.Width<>Width) or (Src.Height<>Height) then
+    SetSize(Src.Width,Src.Height);
+  if Src is TLazIntfImage then begin
+    SrcImg:=TLazIntfImage(Src);
+    if CompareMem(@FDataDescription,@SrcImg.FDataDescription,
+      SizeOf(FDataDescription))
+    then begin
+      // same description -> copy
+      if FPixelData<>nil then
+        System.Move(SrcImg.FPixelData^,FPixelData^,FPixelDataSize);
+      if FMaskData<>nil then
+        System.Move(SrcImg.FMaskData^,FMaskData^,FMaskDataSize);
+      exit;
+    end;
+  end;
+    
+  // copy pixels
+  for y:=0 to Height-1 do
+    for x:=0 to Width-1 do
+      Colors[x,y]:=Src.Colors[x,y];
+end;
+
 { TLazReaderXPM }
 
 type