added sprite example

git-svn-id: trunk@6666 -

.gitattributes

@@ -629,6 +629,11 @@ examples/scrollbar.pp svneol=native#text/pascal
 examples/selection.pp svneol=native#text/pascal
 examples/selectionform.pp svneol=native#text/pascal
 examples/speedtest.pp svneol=native#text/pascal
+examples/sprites/playground.lfm svneol=native#text/plain
+examples/sprites/playground.lrs svneol=native#text/pascal
+examples/sprites/playground.pas svneol=native#text/pascal
+examples/sprites/spriteexample.lpi svneol=native#text/plain
+examples/sprites/spriteexample.lpr svneol=native#text/pascal
 examples/synchronize.pp svneol=native#text/pascal
 examples/synedit1.pas svneol=native#text/pascal
 examples/taborder.pas svneol=native#text/pascal

examples/sprites/playground.lfm

@@ -0,0 +1,21 @@
+object PlayGroundForm: TPlayGroundForm
+  Caption = 'PlayGroundForm'
+  ClientHeight = 300
+  ClientWidth = 400
+  OnClose = PlayGroundFormClose
+  OnCreate = PlayGroundFormCreate
+  OnDestroy = PlayGroundFormDestroy
+  PixelsPerInch = 90
+  HorzScrollBar.Page = 399
+  VertScrollBar.Page = 299
+  Left = 305
+  Height = 300
+  Top = 224
+  Width = 400
+  object Timer1: TTimer
+    Interval = 100
+    OnTimer = Timer1Timer
+    left = 164
+    top = 49
+  end
+end

examples/sprites/playground.lrs

@@ -0,0 +1,11 @@
+{ This is an automatically generated lazarus resource file }
+
+LazarusResources.Add('TPlayGroundForm','FORMDATA',[
+  'TPF0'#15'TPlayGroundForm'#14'PlayGroundForm'#7'Caption'#6#14'PlayGroundForm'
+  +#12'ClientHeight'#3','#1#11'ClientWidth'#3#144#1#7'OnClose'#7#19'PlayGroundF'
+  +'ormClose'#8'OnCreate'#7#20'PlayGroundFormCreate'#9'OnDestroy'#7#21'PlayGrou'
+  +'ndFormDestroy'#13'PixelsPerInch'#2'Z'#18'HorzScrollBar.Page'#3#143#1#18'Ver'
+  +'tScrollBar.Page'#3'+'#1#4'Left'#3'1'#1#6'Height'#3','#1#3'Top'#3#224#0#5'Wi'
+  +'dth'#3#144#1#0#6'TTimer'#6'Timer1'#8'Interval'#2'd'#7'OnTimer'#7#11'Timer1T'
+  +'imer'#4'left'#3#164#0#3'top'#2'1'#0#0#0
+]);

examples/sprites/playground.pas

@@ -0,0 +1,163 @@
+unit PlayGround;
+
+{$mode objfpc}{$H+}
+
+interface
+
+uses
+  Classes, SysUtils, LResources, Forms, Controls, Graphics, Dialogs,
+  ExtCtrls;
+
+type
+
+  { TPictureControl }
+
+  TPictureControl = class(TCustomControl)
+    procedure PictureChanged(Sender: TObject);
+  private
+    FPicture: TPicture;
+    procedure SetPicture(const AValue: TPicture);
+  public
+    constructor Create(TheOwner: TComponent); override;
+    destructor Destroy; override;
+    procedure Paint; override;
+  published
+    property Picture: TPicture read FPicture write SetPicture;
+  end;
+
+  { TPlayGroundForm }
+
+  TPlayGroundForm = class(TForm)
+    Timer1: TTimer;
+    procedure PlayGroundFormClose(Sender: TObject; var CloseAction: TCloseAction
+      );
+    procedure PlayGroundFormCreate(Sender: TObject);
+    procedure PlayGroundFormDestroy(Sender: TObject);
+    procedure Timer1Timer(Sender: TObject);
+  private
+    procedure UpdateImage;
+  public
+    PictureControl: TPictureControl;
+    SpriteImg: TBitmap;
+    BackgroundImg: TBitmap;
+    BufferImg: TBitmap;
+  end;
+
+var
+  PlayGroundForm: TPlayGroundForm;
+
+implementation
+
+{ TPlayGroundForm }
+
+procedure TPlayGroundForm.PlayGroundFormCreate(Sender: TObject);
+begin
+  PictureControl:=TPictureControl.Create(Self);
+  with PictureControl do begin
+    Parent:=Self;
+    Align:=alClient;
+  end;
+
+  SpriteImg:=TPortableNetworkGraphic.Create;
+  BackgroundImg:=TBitmap.Create;
+  BufferImg:=TBitmap.Create;
+
+  SpriteImg.LoadFromFile(SetDirSeparators('../../images/ide_icon48x48.png'));
+  BackgroundImg.LoadFromFile(SetDirSeparators('../../images/lazarus.xpm'));
+  BufferImg.Width:=BackgroundImg.Width;
+  BufferImg.Height:=BackgroundImg.Height;
+  
+  UpdateImage;
+end;
+
+procedure TPlayGroundForm.PlayGroundFormClose(Sender: TObject;
+  var CloseAction: TCloseAction);
+begin
+  Timer1.Enabled:=false;
+end;
+
+procedure TPlayGroundForm.PlayGroundFormDestroy(Sender: TObject);
+begin
+  SpriteImg.Free;
+  BackgroundImg.Free;
+  BufferImg.Free;
+end;
+
+procedure TPlayGroundForm.Timer1Timer(Sender: TObject);
+begin
+  if csDestroying in ComponentState then exit;
+  UpdateImage;
+end;
+
+procedure TPlayGroundForm.UpdateImage;
+var
+  DestImg: TBitmap;
+  t: Double;
+  x: Int64;
+  y: Integer;
+  CenterX: Integer;
+  CenterY: Integer;
+begin
+  // paint first on the buffer
+  
+  // paint background
+  //writeln('TPlayGroundForm.UpdateImage A');
+  BufferImg.Canvas.CopyRect(Rect(0,0,BufferImg.Width,BufferImg.Height),
+       BackgroundImg.Canvas,Rect(0,0,BackgroundImg.Width,BackgroundImg.Height));
+  // paint sprite
+  CenterX:=BufferImg.Width div 2;
+  CenterY:=BufferImg.Height div 2;
+  t:=Now*86400;
+  x:=CenterX+round(cos(t)*CenterX*2/3)-(SpriteImg.Width div 2);
+  y:=CenterY+round(sin(t*0.7)*CenterY*2/3)-(SpriteImg.Height div 2);
+  //writeln('TPlayGroundForm.UpdateImage B ',x,',',y,' ',t);
+  BufferImg.Canvas.CopyRect(Rect(x,y,x+SpriteImg.Width,y+SpriteImg.Height),
+                   SpriteImg.Canvas,Rect(0,0,SpriteImg.Width,SpriteImg.Height));
+  //writeln('TPlayGroundForm.UpdateImage C');
+
+  // copy to image
+  DestImg:=PictureControl.Picture.Bitmap;
+  DestImg.Width:=BufferImg.Width;
+  DestImg.Height:=BufferImg.Height;
+  DestImg.Canvas.Draw(0,0,BufferImg);
+  //writeln('TPlayGroundForm.UpdateImage D');
+end;
+
+{ TPictureControl }
+
+procedure TPictureControl.SetPicture(const AValue: TPicture);
+begin
+  if FPicture=AValue then exit;
+  FPicture.Assign(AValue);
+end;
+
+procedure TPictureControl.PictureChanged(Sender: TObject);
+begin
+  Invalidate;
+end;
+
+constructor TPictureControl.Create(TheOwner: TComponent);
+begin
+  inherited Create(TheOwner);
+  FPicture:=TPicture.Create;
+  FPicture.OnChange:=@PictureChanged;
+end;
+
+destructor TPictureControl.Destroy;
+begin
+  FreeAndNil(FPicture);
+  inherited Destroy;
+end;
+
+procedure TPictureControl.Paint;
+begin
+  if Picture.Graphic<>nil then
+    Canvas.StretchDraw(Rect(0,0,Width,Height),Picture.Graphic);
+  inherited Paint;
+end;
+
+initialization
+  {$I playground.lrs}
+
+end.
+

examples/sprites/spriteexample.lpi

@@ -0,0 +1,74 @@
+<?xml version="1.0"?>
+<CONFIG>
+  <ProjectOptions>
+    <PathDelim Value="/"/>
+    <Version Value="5"/>
+    <General>
+      <Flags>
+        <SaveClosedFiles Value="False"/>
+        <SaveOnlyProjectUnits Value="True"/>
+      </Flags>
+      <MainUnit Value="0"/>
+      <ActiveEditorIndexAtStart Value="0"/>
+      <IconPath Value="./"/>
+      <TargetFileExt Value=""/>
+      <Title Value="spriteexample"/>
+    </General>
+    <Units Count="2">
+      <Unit0>
+        <Filename Value="spriteexample.lpr"/>
+        <IsPartOfProject Value="True"/>
+        <UnitName Value="SpriteExample"/>
+        <UsageCount Value="21"/>
+      </Unit0>
+      <Unit1>
+        <CursorPos X="11" Y="82"/>
+        <EditorIndex Value="0"/>
+        <Filename Value="playground.pas"/>
+        <ComponentName Value="PlayGroundForm"/>
+        <IsPartOfProject Value="True"/>
+        <Loaded Value="True"/>
+        <ResourceFilename Value="playground.lrs"/>
+        <TopLine Value="63"/>
+        <UnitName Value="PlayGround"/>
+        <UsageCount Value="21"/>
+      </Unit1>
+    </Units>
+    <PublishOptions>
+      <Version Value="2"/>
+      <IgnoreBinaries Value="False"/>
+      <IncludeFileFilter Value="*.(pas|pp|inc|lfm|lpr|lrs|lpi|lpk|sh|xml)"/>
+      <ExcludeFileFilter Value="*.(bak|ppu|ppw|o|so);*~;backup"/>
+    </PublishOptions>
+    <RunParams>
+      <local>
+        <FormatVersion Value="1"/>
+        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+      </local>
+    </RunParams>
+    <RequiredPackages Count="1">
+      <Item1>
+        <PackageName Value="LCL"/>
+      </Item1>
+    </RequiredPackages>
+  </ProjectOptions>
+  <CompilerOptions>
+    <Version Value="4"/>
+    <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/sprites/spriteexample.lpr

@@ -0,0 +1,15 @@
+program SpriteExample;
+
+{$mode objfpc}{$H+}
+
+uses
+  Interfaces, // this includes the LCL widgetset
+  Forms
+  { add your units here }, PlayGround;
+
+begin
+  Application.Initialize;
+  Application.CreateForm(TPlayGroundForm, PlayGroundForm);
+  Application.Run;
+end.
+

lcl/controls.pp

@@ -1725,6 +1725,7 @@ type
   TCustomControl = class(TWinControl)
   private
     FCanvas: TCanvas;
+    FOnPaint: TNotifyEvent;
   protected
     procedure WMPaint(var Message: TLMPaint); message LM_PAINT;
     procedure PaintWindow(DC: HDC); override;
@@ -1733,9 +1734,10 @@ type
     destructor Destroy; override;
     procedure DestroyComponent; override;
     procedure Paint; virtual;
-
+  public
     property Canvas: TCanvas read FCanvas write FCanvas;
     property BorderStyle;
+    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
   end;
 
 
@@ -2851,6 +2853,9 @@ end.
 { =============================================================================
 
   $Log$
+  Revision 1.273  2005/01/22 22:26:16  mattias
+  added sprite example
+
   Revision 1.272  2005/01/21 11:52:01  micha
   cleanup focus; fix tabbing
 

lcl/include/customcontrol.inc

@@ -77,6 +77,7 @@ end;
  ------------------------------------------------------------------------------}
 Procedure TCustomControl.Paint;
 begin
+  if Assigned(FOnPaint) then FOnPaint(Self);
 end;
 
 {------------------------------------------------------------------------------
@@ -121,6 +122,9 @@ end;
 { =============================================================================
 
   $Log$
+  Revision 1.12  2005/01/22 22:26:16  mattias
+  added sprite example
+
   Revision 1.11  2004/04/10 17:58:57  mattias
   implemented mainunit hints for include files
 

lcl/include/customimage.inc

@@ -19,7 +19,7 @@
 constructor TCustomImage.Create(TheOwner: TComponent);
 begin
   inherited Create(TheOwner);
-  FCompStyle := csImage;
+  // obsolete: FCompStyle := csImage;
   ControlStyle:= [csCaptureMouse, csClickEvents, csDoubleClicks];
   AutoSize := False;
   FCenter := False;

lcl/interfaces/gtk/gtkcallback.inc

@@ -2360,7 +2360,7 @@ begin
       Result:=GdkTrue; // timer will go on
     end
     else begin
-      Result := GdkFalse;       // stop timer
+      Result := GdkFalse; // stop timer
     end;
   end;
 
@@ -2376,7 +2376,7 @@ begin
     {$ENDIF}
     // timer will be stopped
     // -> free timer data, if not already done
-    if (FTimerData.IndexOf(Data)>=0) then begin
+    if (FTimerData<>nil) and (FTimerData.IndexOf(Data)>=0) then begin
       FTimerData.Remove(Data);
       Dispose (TimerInfo);     // free memory with timer data
     end;
@@ -2969,6 +2969,9 @@ end;
 { =============================================================================
 
   $Log$
+  Revision 1.259  2005/01/22 22:26:16  mattias
+  added sprite example
+
   Revision 1.258  2005/01/11 19:01:51  mattias
   fixed adding main file in gtk filediaog twice
 

lcl/interfaces/gtk/gtkobject.inc

@@ -1582,7 +1582,8 @@ End;
 
   Design: A callback to the TTimer class is implemented.
  ------------------------------------------------------------------------------}
-function TGtkWidgetSet.CreateTimer(Interval: integer; TimerFunc: TFNTimerProc) : integer;
+function TGtkWidgetSet.CreateTimer(Interval: integer;
+  TimerFunc: TFNTimerProc) : integer;
 var
   TimerInfo: PGtkITimerinfo;
 begin
@@ -7014,6 +7015,9 @@ end;
  { =============================================================================
 
   $Log$
+  Revision 1.620  2005/01/22 22:26:16  mattias
+  added sprite example
+
   Revision 1.619  2005/01/18 00:59:49  marc
   * oops, fixed line end calculation