From b681f94950d2d2942a27d045d190626d8e40ba5a Mon Sep 17 00:00:00 2001 From: marc Date: Thu, 5 Apr 2007 00:00:37 +0000 Subject: [PATCH] * Step 1 of the native imagelist implementation git-svn-id: trunk@10875 - --- ide/buildlazdialog.pas | 32 +- ide/codebrowser.pas | 3 +- ide/codeexplorer.pas | 3 +- ide/compileroptionsdlg.pp | 3 +- ide/projectinspector.pas | 3 +- ide/sourcemarks.pas | 3 +- ideintf/componenttreeview.pas | 8 +- ideintf/imagelisteditor.pp | 3 +- lcl/graphics.pp | 2 +- lcl/imglist.pp | 76 +++- lcl/include/imglist.inc | 414 +++++++++++++++++---- lcl/interfaces/gtk/gtkpagecallback.inc | 4 + lcl/interfaces/gtk/gtkproc.inc | 12 + lcl/interfaces/gtk/gtkproc.pp | 15 +- lcl/interfaces/gtk/gtkwscomctrls.pp | 5 + lcl/interfaces/gtk/gtkwscustomlistview.inc | 10 + lcl/intfgraphics.pas | 20 + lcl/lcltype.pp | 9 + 18 files changed, 497 insertions(+), 128 deletions(-) diff --git a/ide/buildlazdialog.pas b/ide/buildlazdialog.pas index 910b91befa..237933dcc1 100644 --- a/ide/buildlazdialog.pas +++ b/ide/buildlazdialog.pas @@ -758,25 +758,23 @@ begin ButtonRect, DFC_BUTTON, ButtonState); // draw icon case mm of - mmBuild: ImgIndex:=ImageIndexBuild; - mmCleanBuild: ImgIndex:=ImageIndexCleanBuild; - else ImgIndex:=ImageIndexNone; + mmBuild: ImgIndex:=ImageIndexBuild; + mmCleanBuild: ImgIndex:=ImageIndexCleanBuild; + else + ImgIndex:=ImageIndexNone; end; - ImageList.GetInternalImage(ImgIndex,CurIcon,Mask,IconRect); - if CurIcon<>nil then begin - IconWidth:=IconRect.Right-IconRect.Left; - IconHeight:=IconRect.Bottom-IconRect.Top; - DestRect.Left:=ARect.Left+x+((ButtonWidth-IconWidth) div 2); - DestRect.Top:=ARect.Top+((ARect.Bottom-ARect.Top-IconHeight) div 2); - DestRect.Right:=DestRect.Left+IconWidth; - DestRect.Bottom:=DestRect.Top+IconHeight; - StretchMaskBlt(ItemsListBox.Canvas.Handle, - DestRect.Left, DestRect.Top, IconWidth, IconHeight, - CurIcon.Canvas.Handle, 0, 0, IconWidth, IconHeight, - CurIcon.MaskHandle, 0, 0, SRCCOPY); - end; - inc(x,ButtonWidth); + + if ImgIndex <> ImageIndexNone + then + ImageList.Draw( + ItemsListBox.Canvas, + ARect.Left + x + ((ButtonWidth - ImageList.Width) div 2), + ARect.Top + ((ARect.Bottom - ARect.Top - ImageList.Height) div 2), + ImgIndex + ) ; + Inc(x, ButtonWidth); end; + // draw description ItemsListBox.Canvas.Brush.Style:=bsClear; ItemsListBox.Canvas.TextOut(x+2, diff --git a/ide/codebrowser.pas b/ide/codebrowser.pas index d0c0d8623e..4a625a3a8d 100644 --- a/ide/codebrowser.pas +++ b/ide/codebrowser.pas @@ -701,7 +701,8 @@ procedure TCodeBrowserView.InitImageList; DebugLn('TCodeExplorerView.CodeExplorerViewCREATE: ', ' WARNING: icon not found: "',ResName,'"'); Pixmap.LoadFromLazarusResource(ResName); - ImgID:=ImgList.AddDirect(Pixmap,nil) + ImgID:=ImgList.Add(Pixmap,nil); + Pixmap.Free; end; begin diff --git a/ide/codeexplorer.pas b/ide/codeexplorer.pas index 45f65e1e9d..6a93bbf061 100644 --- a/ide/codeexplorer.pas +++ b/ide/codeexplorer.pas @@ -210,7 +210,8 @@ procedure TCodeExplorerView.CodeExplorerViewCREATE(Sender: TObject); DebugLn('TCodeExplorerView.CodeExplorerViewCREATE: ', ' WARNING: icon not found: "',ResName,'"'); Pixmap.LoadFromLazarusResource(ResName); - ImgID:=ImgList.AddDirect(Pixmap,nil) + ImgID:=ImgList.Add(Pixmap, nil); + Pixmap.Free; end; begin diff --git a/ide/compileroptionsdlg.pp b/ide/compileroptionsdlg.pp index 8de28b80d0..f18565ce00 100644 --- a/ide/compileroptionsdlg.pp +++ b/ide/compileroptionsdlg.pp @@ -322,7 +322,8 @@ constructor TfrmCompilerOptions.Create(TheOwner: TComponent); Pixmap:=TPixmap.Create; Pixmap.TransparentColor:=clWhite; Pixmap.LoadFromLazarusResource(ResName); - ImageList.AddDirect(Pixmap,nil) + ImageList.Add(Pixmap,nil); + Pixmap.Free; end; var Page: integer; diff --git a/ide/projectinspector.pas b/ide/projectinspector.pas index fecdc79f5b..00dc580cd0 100644 --- a/ide/projectinspector.pas +++ b/ide/projectinspector.pas @@ -419,7 +419,8 @@ procedure TProjectInspectorForm.SetupComponents; Pixmap:=TPixmap.Create; Pixmap.TransparentColor:=clWhite; Pixmap.LoadFromLazarusResource(ResName); - ImageList.AddDirect(Pixmap,nil) + ImageList.Add(Pixmap,nil); + Pixmap.Free; end; begin diff --git a/ide/sourcemarks.pas b/ide/sourcemarks.pas index 282e87e95a..8d788cbed9 100644 --- a/ide/sourcemarks.pas +++ b/ide/sourcemarks.pas @@ -685,7 +685,8 @@ begin APixmap.TransparentColor:=clBtnFace; APixmap.LoadFromLazarusResource(ResName); Result:=ImgList.Count; - ImgList.AddDirect(APixmap,nil); + ImgList.Add(APixmap,nil); + APixmap.Free; end; function TSourceMarks.GetSourceEditor(AMark: TSourceMark): TObject; diff --git a/ideintf/componenttreeview.pas b/ideintf/componenttreeview.pas index 45342ce365..cda8bf659c 100644 --- a/ideintf/componenttreeview.pas +++ b/ideintf/componenttreeview.pas @@ -247,10 +247,10 @@ begin FComponentList:=TBackupComponentList.Create; Options:=Options+[tvoAllowMultiselect,tvoAutoItemHeight,tvoKeepCollapsedNodes]; FImageList := TImageList.Create(nil); - FImageList.AddFromLazarusResource('oi_form'); - FImageList.AddFromLazarusResource('oi_comp'); - FImageList.AddFromLazarusResource('oi_control'); - FImageList.AddFromLazarusResource('oi_box'); + FImageList.AddLazarusResource('oi_form'); + FImageList.AddLazarusResource('oi_comp'); + FImageList.AddLazarusResource('oi_control'); + FImageList.AddLazarusResource('oi_box'); Images := FImageList; end; diff --git a/ideintf/imagelisteditor.pp b/ideintf/imagelisteditor.pp index ddd3069862..c005a5f3fc 100644 --- a/ideintf/imagelisteditor.pp +++ b/ideintf/imagelisteditor.pp @@ -523,7 +523,8 @@ begin Bmp := CreateGlyphSplit(v_CompositeBmp, ImageList.Width, ImageList.Height, c_Part); Glyph := CreateGlyph(Bmp, ImageList.Width, ImageList.Height, gaNone); - I := ImageList.AddDirect(Glyph, nil); + I := ImageList.Add(Glyph, nil); + Glyph.Free; New(P); P^.Bitmap := Bmp; diff --git a/lcl/graphics.pp b/lcl/graphics.pp index 25291de1a2..fcc6809ed8 100644 --- a/lcl/graphics.pp +++ b/lcl/graphics.pp @@ -1169,8 +1169,8 @@ type function PaletteAllocated: boolean; procedure CreateFromBitmapHandles(SrcBitmap, SrcMaskBitmap: HBitmap; const SrcRect: TRect); - procedure LoadFromDevice(DC: HDC); virtual; function LazarusResourceTypeValid(const ResourceType: string): boolean; virtual; + procedure LoadFromDevice(DC: HDC); virtual; procedure LoadFromStream(Stream: TStream); override; procedure LoadFromLazarusResource(const ResName: String); override; procedure LoadFromResourceName(Instance: THandle; const ResName: String); virtual; diff --git a/lcl/imglist.pp b/lcl/imglist.pp index b867f943f2..b533b6d061 100644 --- a/lcl/imglist.pp +++ b/lcl/imglist.pp @@ -79,33 +79,52 @@ type { TCustomImageList } { @abstract(Contains a list of images) - Introduced by Marc Weustink + Introduced by Marc Weustink - ToDo: - Delphis TCustomImageList has internally only one bitmap to hold all - images. This reduces handle allocation, which is a problem under win9x, - but it is not very fast. - Because the LCL runs on many platforms, that do not have this limitations, - the TCustomImageList should also support a one handle per image mode. - The TCustomImageList should ask the interface, if handle allocation - should be reduced and if so do it like Delphi. - - The current TCustomImageList is simply a list of bitmaps. The masks are - not saved at all yet. + Delphis TCustomImageList is based on the Win32 imagelists which has + internally only one bitmap to hold all images. This reduces handle + allocation. + The original TCustomImageList implementation was LCL only based, so for + other platforms the single bitmap implementation had some speed drawbacks. + Therefore it was implemented as list of bitmaps, however it doesnt reduce + handle allocation. + In its current form, the imagelist is again based on a 32bit RGBA raw + imagedata and the widgetset is notified when images are added or removed, + so the widgetset can create its own optimal storage. The LCL keeps only the + data, so all transparency info will be stored cross platform. (not all + platforms have a 8bit alpha channel). - So a lot ToDo. + NOTE: due to its implementation, the TCustomImageList is not a TBitmap + collection. If a fast storage of bitmaps is needed, create your on list! } + + // Some temp rework defines, for old functionality both need so be set + + {$define IMGLIST_OLDSTYLE} // Set to keep original functionality + {$define IMGLIST_KEEP_EXTRA} // Not needed for Delphi compat. + + {$ifdef IMGLIST_OLDSTYLE} + // hack to set defines in dependent widgetsets. + TOldstyleCustomImageList = Boolean; + {$endif} + TDrawingStyle = (dsFocus, dsSelected, dsNormal, dsTransparent); TImageType = (itImage, itMask); - TCustomImageList = Class(TLCLComponent) + TCustomImageList = class(TLCLHandleComponent) private FDrawingStyle: TDrawingStyle; + FData: array of TRGBAQuad; + {$ifdef IMGLIST_OLDSTYLE} + FHandle: THandle; FImageList: TList; FMaskList: TList; + {$endif} + {$ifdef IMGLIST_KEEP_EXTRA} FBitmap: TBitmap; - FImageType: TImageType; FMaskBitmap: TBitmap; + {$endif} + FImageType: TImageType; FHeight: Integer; FMasked: boolean; FShareImages: Boolean; @@ -117,9 +136,14 @@ type FOnChange: TNotifyEvent; FChangeLinkList: TList; FBkColor: TColor; - FHandle: THandle; FChanged: boolean; + {$ifdef IMGLIST_OLDSTYLE} procedure AllocBitmap(Amount: Integer); + {$else} + procedure AllocData(ACount: Integer); + {$endif} + + procedure NotifyChangeLink; procedure SetBkColor(const Value: TColor); procedure SetDrawingStyle(const AValue: TDrawingStyle); @@ -131,12 +155,14 @@ type procedure ShiftImages(const Source: TCanvas; Start, Shift: Integer); protected FUpdateCount: integer; + procedure CheckIndex(AIndex: Integer; AForInsert: Boolean = False); + procedure FillDescription(ADesc: TRawImageDescription); procedure GetImages(Index: Integer; const Image, Mask: TBitmap); procedure Initialize; virtual; procedure DefineProperties(Filer: TFiler); override; procedure SetWidthHeight(NewWidth,NewHeight: integer); virtual; public - constructor Create(TheOwner: TComponent); override; + constructor Create(AOwner: TComponent); override; procedure AssignTo(Dest: TPersistent); override; procedure Assign(Source: TPersistent); override; @@ -146,24 +172,33 @@ type procedure EndUpdate; function Add(Image, Mask: TBitmap): Integer; // using AddCopy for Delphi compatibility + {$ifdef IMGLIST_OLDSTYLE} function AddDirect(Image, Mask: TBitmap): Integer; function AddCopy(SrcImage, SrcMask: TBitmap): Integer; + {$endif} function AddIcon(Image: TIcon): Integer; procedure AddImages(Value: TCustomImageList); function AddMasked(Image: TBitmap; MaskColor: TColor): Integer; - function AddFromLazarusResource(const ResourceName: string): integer; + function AddLazarusResource(const ResourceName: string; MaskColor: TColor = clNone): integer; procedure Change; procedure Clear; + {.$ifdef IMGLIST_KEEP_EXTRA} constructor CreateSize(AWidth, AHeight: Integer); + {.$endif} procedure Delete(Index: Integer); destructor Destroy; override; procedure Draw(Canvas: TCanvas; X, Y, Index: Integer; Enabled: Boolean = True); procedure GetBitmap(Index: Integer; Image: TBitmap); + {$ifdef IMGLIST_KEEP_EXTRA} procedure GetInternalImage(Index: integer; var Image, Mask: TBitmap; var ImageRect: TRect); + {$endif} function GetHotSpot: TPoint; virtual; procedure GetIcon(Index: Integer; Image: TIcon); + + {$ifdef IMGLIST_OLDSTYLE} function HandleAllocated: Boolean; + {$endif} procedure Insert(Index: Integer; Image, Mask: TBitmap); procedure InsertIcon(Index: Integer; Image: TIcon); procedure InsertMasked(Index: Integer; Image: TBitmap; MaskColor: TColor); @@ -172,6 +207,7 @@ type procedure ReplaceIcon(Index: Integer; Image: TIcon); procedure ReplaceMasked(Index: Integer; NewImage: TBitmap; MaskColor: TColor); procedure RegisterChanges(Value: TChangeLink); + procedure StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean = True); procedure UnRegisterChanges(Value: TChangeLink); public property AllocBy: Integer read FAllocBy write FAllocBy default 4; @@ -179,13 +215,17 @@ type property BkColor: TColor read FBkColor write SetBkColor default clNone; property Count: Integer read FCount; property DrawingStyle: TDrawingStyle read FDrawingStyle write SetDrawingStyle default dsNormal; + {$ifdef IMGLIST_OLDSTYLE} property Handle: THandle read FHandle; + {$endif} property Height: Integer read FHeight write SetHeight default 16; property Width: Integer read FWidth write SetWidth default 16; property OnChange: TNotifyEvent read FOnChange write FOnChange; property Masked: boolean read FMasked write SetMasked; + {$ifdef IMGLIST_KEEP_EXTRA} property Bitmap: TBitmap read FBitmap; property MaskBitmap: TBitmap read FMaskBitmap; + {$endif} property ShareImages: Boolean read FShareImages write SetShareImages; property ImageType: TImageType read FImageType write FImageType default itImage; end; diff --git a/lcl/include/imglist.inc b/lcl/include/imglist.inc index 1d92287065..1a9e24859d 100644 --- a/lcl/include/imglist.inc +++ b/lcl/include/imglist.inc @@ -24,6 +24,7 @@ type const SIG_LAZ1 = #1#0; SIG_LAZ2 = 'li'; + SIG_LAZ3 = 'Li'; SIG_D3 = 'IL'; {------------------------------------------------------------------------------ @@ -61,9 +62,15 @@ end; ------------------------------------------------------------------------------} function TCustomImageList.Add(Image, Mask: TBitmap): Integer; begin + {$ifdef IMGLIST_OLDSTYLE} Result:=AddCopy(Image,Mask); + {$else} + Result := Count; + Insert(Result, Image, Mask); + {$endif} end; +{$ifdef IMGLIST_OLDSTYLE} function TCustomImageList.AddDirect(Image, Mask: TBitmap): Integer; begin try @@ -76,7 +83,9 @@ begin end; end; end; +{$endif} +{$ifdef IMGLIST_OLDSTYLE} function TCustomImageList.AddCopy(SrcImage, SrcMask: TBitmap): Integer; var NewImage: TBitmap; @@ -100,6 +109,7 @@ begin NewMask.Free; end; end; +{$endif} {------------------------------------------------------------------------------ Function: TCustomImageList.AddIcon @@ -133,6 +143,8 @@ var NewMask: TBitmap; begin if (Value = nil) or (Value=Self) then exit; + + {$ifdef IMGLIST_OLDSTYLE} BeginUpdate; for n := 0 to Value.Count - 1 do begin SrcImage:=TBitmap(Value.FImageList[n]); @@ -149,6 +161,9 @@ begin end; end; EndUpdate; + {$else} + {$note implement} + {$endif} end; {------------------------------------------------------------------------------ @@ -179,14 +194,21 @@ end; Load TBitmap from lazarus resources and add it. ------------------------------------------------------------------------------} -function TCustomImageList.AddFromLazarusResource(const ResourceName: string - ): integer; +function TCustomImageList.AddLazarusResource(const ResourceName: string; MaskColor: TColor): integer; var - ABitmap: TBitmap; + Bmp: TBitmap; begin - ABitmap:=TBitmap.Create; - ABitmap.LoadFromLazarusResource(ResourceName); - Result:=AddDirect(ABitmap,nil); + Bmp := TBitmap.Create; + + Bmp.LoadFromLazarusResource(ResourceName); + if MaskColor <> clNone then + Bmp.TransparentColor := MaskColor; + {$ifdef IMGLIST_OLDSTYLE} + Result := AddDirect(Bmp, nil); + {$else} + Result := Add(Bmp, nil); + Bmp.Free; + {$endif} end; {------------------------------------------------------------------------------ @@ -197,27 +219,46 @@ end; Checks if there is enough space for Amount images, increases the internal list if necessary . ------------------------------------------------------------------------------} +{$ifdef IMGLIST_OLDSTYLE} procedure TCustomImageList.AllocBitmap(Amount: Integer); var - Num: Integer; + n: Integer; begin Assert(FAllocCount >= FCount, 'Less space allocated than images'); - if FAllocCount < FCount + Amount - then begin - // calculate number of blocks - Num := Amount div FAllocBy; - // add an extra block for the remainder. - if Amount mod FAllocBy <> 0 then Inc(Num); + if FAllocCount >= FCount + Amount + then Exit; - if FBitMap<>nil then - FBitMap.Height := FBitMap.Height + Num * FAllocBy * FHeight; - if FMaskBitmap<>nil then - FMaskBitmap.Height := FBitMap.Height; - Inc(FAllocCount, Num * FAllocBy); - end; + // calculate number of blocks, add an extra block for the remainder. + n := Amount mod FAllocBy; + if n <> 0 + then Inc(Amount, FAllocBy - n); - //raise Exception.Create('Unable to allocate bitmap space'); + if FBitMap<>nil then + FBitMap.Height := FBitMap.Height + Amount * FHeight; + if FMaskBitmap<>nil then + FMaskBitmap.Height := FBitMap.Height; + + Inc(FAllocCount, Amount); end; +{$else} +procedure TCustomImageList.AllocData(ACount: Integer); +var + n: Integer; +begin + Assert(FAllocCount >= FCount, 'Less space allocated than images'); + if FAllocCount >= FCount + ACount + then Exit; + + // calculate number of blocks, add an extra block for the remainder. + n := ACount mod FAllocBy; + if n <> 0 + then Inc(ACount, FAllocBy - n); + + SetLength(FData, ACount * FWidth * FHeight * SizeOf(FData[0])); + + Inc(FAllocCount, ACount); +end; +{$endif} {------------------------------------------------------------------------------ Method: TCustomImageList.Assign @@ -283,6 +324,22 @@ begin FChanged := false; end; +procedure TCustomImageList.CheckIndex(AIndex: Integer; AForInsert: Boolean); + // aviod exceptionframe generation + procedure Error; + begin + raise EInvalidOperation.Create(SInvalidIndex); + end; +begin + if AForInsert + then begin + if AIndex > FCount then Error; + end + else begin + if AIndex >= FCount then Error; + end; +end; + {------------------------------------------------------------------------------ Method: TCustomImageList.Clear Params: None @@ -292,12 +349,17 @@ end; ------------------------------------------------------------------------------} procedure TCustomImageList.Clear; begin - if FCount=0 then exit; - While Count>0 do + if FCount = 0 then Exit; + {$ifdef IMGLIST_OLDSTYLE} + while Count>0 do Delete(0); - FCount := 0; FImageList.Clear; FMaskList.Clear; + {$else} + {$note implement} + {$endif} + + FCount := 0; Change; end; @@ -308,13 +370,16 @@ end; Constructor for the class. ------------------------------------------------------------------------------} -constructor TCustomImageList.Create(TheOwner: TComponent); +constructor TCustomImageList.Create(AOwner: TComponent); begin - inherited Create(TheOwner); + inherited Create(AOwner); FHeight := 16; FWidth := 16; + + {$ifdef IMGLIST_OLDSTYLE} FImageList := TList.Create; //shane FMaskList := TList.Create; + {$endif} Initialize; end; @@ -326,15 +391,20 @@ end; Runtime constructor for the class with a given width and height. ------------------------------------------------------------------------------} +{.$ifdef IMGLIST_KEEP_EXTRA} constructor TCustomImageList.CreateSize(AWidth, AHeight: Integer); begin inherited Create(nil); FHeight := AHeight; FWidth := AWidth; + {$ifdef IMGLIST_OLDSTYLE} FImageList := TList.Create; //shane FMaskList := TList.Create; + {$endif} Initialize; end; +{.$endif} + {------------------------------------------------------------------------------ Method: TCustomImageList.DefineProperties @@ -379,6 +449,7 @@ begin Clear else begin + {$ifdef IMGLIST_OLDSTYLE} Obj:=TObject(fImageList.Items[Index]); If Assigned(Obj) then Obj.Free; @@ -390,6 +461,9 @@ begin // ShiftImages(FBitmap.Canvas, Index, 1); // ShiftImages(FMaskBitmap.Canvas, Index, 1); FCount := fImageList.Count; + {$else} + {$note implement} + {$endif} FChanged := true; Change; end; @@ -406,6 +480,7 @@ destructor TCustomImageList.Destroy; var i: integer; begin + {$ifdef IMGLIST_OLDSTYLE} FBitmap.Free; FBitmap:=nil; FMaskBitmap.Free; @@ -414,6 +489,7 @@ begin for i:=0 to FMaskList.Count-1 do TObject(FMaskList[i]).Free; FreeThenNil(FImageList); FreeThenNil(FMaskList); + {$endif} inherited Destroy; while FChangeLinkList.Count>0 do UnregisterChanges(TChangeLink(FChangeLinkList[0])); @@ -437,8 +513,13 @@ var aBitmap: TBitmap; begin if (FCount = 0) or (Index >= FCount) then Exit; + + {$ifdef IMGLIST_OLDSTYLE} aBitmap := TBitmap(FImageList[Index]); Canvas.Draw(X,Y,aBitmap); + {$else} + {$note implement} + {$endif} end; {------------------------------------------------------------------------------ @@ -456,6 +537,36 @@ begin Change; end; +{------------------------------------------------------------------------------ + Method: TCustomImageList.FillDescription + Params: Desc: the description to fill + Returns: Nothing + + Fills the description with the default info of the imagedata + ------------------------------------------------------------------------------} +procedure TCustomImageList.FillDescription(ADesc: TRawImageDescription); +begin + ADesc.Format := ricfRGBA; + ADesc.HasPalette := False; + ADesc.Depth := 32; + ADesc.Width := FWidth; + ADesc.Height := FHeight; + ADesc.BitOrder := riboBitsInOrder; + ADesc.ByteOrder := riboMSBFirst; + ADesc.LineOrder := riloTopToBottom; + ADesc.BitsPerPixel := 32; + ADesc.LineEnd := rileDWordBoundary; + ADesc.RedPrec := 8; // red precision. bits for red + ADesc.RedShift := 24; + ADesc.GreenPrec := 8; + ADesc.GreenShift := 16; + ADesc.BluePrec := 8; + ADesc.BlueShift := 8; + ADesc.AlphaPrec := 8; + ADesc.AlphaShift := 0; + ADesc.AlphaSeparate := False; +end; + {------------------------------------------------------------------------------ Method: TCustomImageList.GetBitmap Params: Index: the index of the requested image @@ -465,10 +576,27 @@ end; Creates a copy of the index'th image. ------------------------------------------------------------------------------} procedure TCustomImageList.GetBitmap(Index: Integer; Image: TBitmap); +{$ifndef IMGLIST_OLDSTYLE} +var + RawImg: TRawImage; + IntfImg: TLazIntfImage; +{$endif} begin if (FCount = 0) or (Image = nil) then Exit; - //DebugLn('TCustomImageList.GetBitmap Index=',Index,' Image=',DbgS(Image),' Bitmap=',DbgS(FImageList.Items[Index])); + + {$ifdef IMGLIST_OLDSTYLE} Image.Assign(TBitMap(FImageList.Items[Index])); + {$else} + CheckIndex(Index); + FillChar(RawImg, SizeOf(RawImg), 0); + FillDescription(RawImg.Description); + RawImg.DataSize := FWidth * FHeight; + RawImg.Data := @FData[Index * RawImg.DataSize]; + + IntfImg := TLazIntfImage.Create(RawImg); + Image.LoadFromIntfImage(IntfImg); + IntfImg.Free; + {$endif} end; {------------------------------------------------------------------------------ @@ -479,6 +607,7 @@ end; images into one bitmap (plus one mask), therefore ImageRect contains the bounds of the n-th image on the bitmap. ------------------------------------------------------------------------------} +{$ifdef IMGLIST_KEEP_EXTRA} procedure TCustomImageList.GetInternalImage(Index: integer; var Image, Mask: TBitmap; var ImageRect: TRect); begin @@ -486,6 +615,7 @@ begin Mask:=TBitmap(FMaskList[Index]); ImageRect:=Rect(0,0,Image.Width,Image.Height); end; +{$endif} {------------------------------------------------------------------------------ Function: TCustomImageList.GetHotspot @@ -527,6 +657,7 @@ end; ------------------------------------------------------------------------------} procedure TCustomImageList.GetImages(Index: Integer; const Image, Mask: TBitmap); begin +{$ifdef IMGLIST_OLDSTYLE} with Image do FBitmap.Canvas.CopyRect( Rect(0, 0, Width, Height), Canvas, @@ -537,6 +668,9 @@ begin Canvas, Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight) ); +{$else} +{$note implement} +{$endif} end; {------------------------------------------------------------------------------ @@ -546,10 +680,12 @@ end; This function checks if the internal image is allocated ------------------------------------------------------------------------------} +{$ifdef IMGLIST_OLDSTYLE} function TCustomImageList.HandleAllocated: Boolean; begin Result := (FBitmap <> nil); end; +{$endif} {------------------------------------------------------------------------------ Method: TCustomImageList.Initialize @@ -570,6 +706,7 @@ begin if (Height < 1) or (Height > 32768) or (Width < 1) then raise EInvalidOperation.Create(SInvalidImageSize); + {$ifdef IMGLIST_OLDSTYLE} FBitmap := TBitmap.Create; FBitmap.Height := Height; FBitmap.Width := Width; @@ -581,6 +718,7 @@ begin Canvas.Brush.Color := clWhite; Monochrome := True; end; + {$endif} end; procedure TCustomImageList.SetWidthHeight(NewWidth, NewHeight: integer); @@ -588,9 +726,11 @@ begin if (FHeight=NewHeight) and (FWidth=NewWidth) then exit; FHeight := NewHeight; FWidth := NewWidth; + {$ifdef IMGLIST_OLDSTYLE} FBitMap.Width := 0; FBitMap.Height := 0; AllocBitmap(0); + {$endif} Clear; end; @@ -606,11 +746,11 @@ end; ------------------------------------------------------------------------------} procedure TCustomImageList.Insert(Index: Integer; Image, Mask: TBitmap); begin - if (Index > Count) - then raise EInvalidOperation.Create(SInvalidIndex); + CheckIndex(Index, True); if (Index < 0) then Index := 0; + {$ifdef IMGLIST_OLDSTYLE} if (Image <> nil) then begin FImageList.Insert(Index,Image); @@ -619,6 +759,10 @@ begin FChanged := true; Change; end; + {$else} + {$note Implement} + {$endif} + end; {------------------------------------------------------------------------------ @@ -631,13 +775,14 @@ end; ------------------------------------------------------------------------------} procedure TCustomImageList.InsertIcon(Index: Integer; Image: TIcon); begin - if (Index > FCount) - then raise EInvalidOperation.Create(SInvalidIndex); + CheckIndex(Index, True); if (Index < 0) then Index := 0; //No Icon Support yet - + {$ifndef IMGLIST_OLDSTYLE} + {$note implement} + {$endif} end; {------------------------------------------------------------------------------ @@ -664,6 +809,9 @@ begin Mask(MaskColor); end; Insert(Index, Image, Mask); + {$ifndef IMGLIST_OLDSTYLE} + Mask.Free; + {$endif} end; {------------------------------------------------------------------------------ @@ -675,13 +823,40 @@ end; Moves an image from the CurIndex'th location to NewIndex'th location ------------------------------------------------------------------------------} procedure TCustomImageList.Move(CurIndex, NewIndex: Integer); +{$ifndef IMGLIST_OLDSTYLE} +var + ImgSize, DataSize: Cardinal; + p: Pointer; +{$endif} begin - if CurIndex <> NewIndex then begin - FImageList.Move(CurIndex,NewIndex); - FMaskList.Move(CurIndex,NewIndex); - FChanged := true; - Change; - end; + if CurIndex = NewIndex then Exit; + CheckIndex(CurIndex); + CheckIndex(NewIndex); + + if CurIndex < 0 then CurIndex := 0; + if NewIndex < 0 then NewIndex := 0; + + {$ifdef IMGLIST_OLDSTYLE} + FImageList.Move(CurIndex,NewIndex); + FMaskList.Move(CurIndex,NewIndex); + {$else} + + ImgSize := FWidth * FHeight; + DataSize := ImgSize * SizeOf(FData[0]); + p := GetMem(DataSize); + // store current + System.Move(FData[Cardinal(CurIndex) * ImgSize], p^, DataSize); + // move all one up + if CurIndex < NewIndex + then System.Move(FData[(Cardinal(CurIndex) + 1) * ImgSize], FData[Cardinal(CurIndex) * ImgSize], DataSize * Cardinal(NewIndex - CurIndex)) + else System.Move(FData[Cardinal(NewIndex) * ImgSize], FData[(Cardinal(NewIndex) + 1) * ImgSize], DataSize * Cardinal(NewIndex - CurIndex)); + // restore current + System.Move(p^, FData[Cardinal(NewIndex) * ImgSize], DataSize); + FreeMem(p); + {$endif} + + FChanged := true; + Change; end; {------------------------------------------------------------------------------ @@ -715,7 +890,11 @@ var Signature: TImageListSignature; begin //Write signature + {$ifdef IMGLIST_OLDSTYLE} Signature:=SIG_LAZ2; + {$else} + Signature:=SIG_LAZ3; + {$endif} AStream.Write(Signature,SizeOf(Signature)); //Count of image @@ -723,12 +902,17 @@ begin WriteLRSInteger(AStream,Width); WriteLRSInteger(AStream,Height); + //images + {$ifdef IMGLIST_OLDSTYLE} for i:=0 to Count-1 do begin CurImage:=TBitmap(FImageList[i]); //DebugLn('TCustomImageList.WriteData Position=',AStream.Position,' ',CurImage.Width,',',CurImage.Height); CurImage.WriteNativeStream(AStream,true,bnXPixmap); end; + {$else} + AStream.Write(FData[0], FWidth * FHeight * FCount * SizeOf(FData[0])); + {$endif} end; {------------------------------------------------------------------------------ @@ -748,17 +932,20 @@ var i, NewCount, Size: Integer; bmp: TBitmap; begin - //DebugLn('TCustomImageList.ReadData DoReadLaz1'); // provided for compatability for earlier lazarus streams NewCount := AStream.ReadWord; - //DebugLn('TCustomImageList.ReadData DoReadLaz1 NewCount=',NewCount); for i := 0 to NewCount - 1 do begin bmp := TBitMap.Create; Size:=ReadLRSInteger(AStream); bmp.ReadStream(AStream, True, Size); bmp.Transparent := True; + {$ifdef IMGLIST_OLDSTYLE} AddDirect(bmp, nil); + {$else} + Add(bmp, nil); + bmp.Free; + {$endif} end; end; @@ -779,9 +966,31 @@ var Size:=ReadLRSCardinal(AStream); //DebugLn('TCustomImageList.ReadData DoReadLaz2 Size=',Size,' ',AStream.Position); bmp.ReadStream(AStream, True, Size); + {$ifdef IMGLIST_OLDSTYLE} AddDirect(bmp, nil); + {$else} + Add(bmp, nil); + bmp.Free; + {$endif} end; end; + + procedure DoReadLaz3; + begin + FCount := ReadLRSCardinal(AStream); + FWidth := ReadLRSCardinal(AStream); + FHeight := ReadLRSCardinal(AStream); + + {$ifdef IMGLIST_OLDSTYLE} + AStream.Seek(FWidth * FHeight * FCount * 4, soCurrent); + {$else} + AllocData(FCount); + AStream.ReadBuffer(FData[0], FWidth * FHeight * FCount * SizeOf(FData[0])) ; + {$endif} + + FChanged := true; + Change; + end; procedure CreateImagesFromRawImage(IntfImage: TLazIntfImage; NewCount: integer); @@ -817,7 +1026,12 @@ var Img.Handle:=ImgHandle; Img.MaskHandle:=MaskHandle; + {$ifdef IMGLIST_OLDSTYLE} AddDirect(Img, nil); + {$else} + Add(Img, nil); + Img.Free; + {$endif} //DebugLn('CreateImagesFromRawImage B ',Img.Width,',',Img.Height,' ',Count); Img := nil; Dec(NewCount); @@ -887,55 +1101,67 @@ var NewCount: Integer; Size: integer; begin - Clear; + BeginUpdate; // avoid multiple changed calls + try + Clear; - StreamPos := AStream.Position; // check stream signature - AStream.Read(Signature, SizeOf(Signature)); + StreamPos := AStream.Position; // check stream signature + AStream.Read(Signature, SizeOf(Signature)); - if Signature = SIG_LAZ1 - then begin - DoReadLaz1; - Exit; - end; + if Signature = SIG_LAZ3 + then begin + DoReadLaz3; + Exit; + end; - if Signature = SIG_LAZ2 - then begin - DoReadLaz2; - Exit; - end; + if Signature = SIG_LAZ2 + then begin + DoReadLaz2; + Exit; + end; - // Delphi streams + if Signature = SIG_LAZ1 + then begin + DoReadLaz1; + Exit; + end; - {$IFDEF SaveDelphiImgListStream} - SaveImgListStreamToFile; - {$ENDIF} + // Delphi streams - if Signature = SIG_D3 - then begin - AStream.ReadWord; //Skip ? - NewCount := ReadLRSWord(AStream); - //DebugLn('NewCount=',NewCount); - AStream.ReadWord; //Skip Capacity - AStream.ReadWord; //Skip Grow - FWidth := ReadLRSWord(AStream); - //DebugLn('NewWidth=',FWidth); - FHeight := ReadLRSWord(AStream); - //DebugLn('NewHeight=',FHeight); - FBKColor := TColor(ReadLRSInteger(AStream)); - HasMask := (ReadLRSWord(AStream) and 1) = 1; - AStream.ReadDWord; //Skip ? - AStream.ReadDWord; //Skip ? + {$IFDEF SaveDelphiImgListStream} + SaveImgListStreamToFile; + {$ENDIF} - ReadDelphiImageAndMask(HasMask,NewCount); - end - else begin - // D2 has no signature, so restore original position - AStream.Position := StreamPos; - Size:=ReadLRSInteger(AStream); - NewCount:=ReadLRSInteger(AStream); + if Signature = SIG_D3 + then begin + AStream.ReadWord; //Skip ? + NewCount := ReadLRSWord(AStream); + //DebugLn('NewCount=',NewCount); + AStream.ReadWord; //Skip Capacity + AStream.ReadWord; //Skip Grow + FWidth := ReadLRSWord(AStream); + //DebugLn('NewWidth=',FWidth); + FHeight := ReadLRSWord(AStream); + //DebugLn('NewHeight=',FHeight); + FBKColor := TColor(ReadLRSInteger(AStream)); + HasMask := (ReadLRSWord(AStream) and 1) = 1; + AStream.ReadDWord; //Skip ? + AStream.ReadDWord; //Skip ? - ReadDelphiImageAndMask(false,NewCount); - AStream.Position := StreamPos+Size; + ReadDelphiImageAndMask(HasMask,NewCount); + end + else begin + // D2 has no signature, so restore original position + AStream.Position := StreamPos; + Size:=ReadLRSInteger(AStream); + NewCount:=ReadLRSInteger(AStream); + + ReadDelphiImageAndMask(false,NewCount); + AStream.Position := StreamPos+Size; + end; + + finally + EndUpdate; end; end; @@ -977,17 +1203,21 @@ begin DestinationRect := Rect(0, Index * FHeight, FWidth, (Index + 1) * FHeight); SourceRect := Rect(0, 0, FWidth, FHeight); + {$ifdef IMGLIST_OLDSTYLE} CopyImage(FBitmap.Canvas, Image.Canvas, DestinationRect, SourceRect); if Mask <> nil then CopyImage(FMaskBitmap.Canvas, Mask.Canvas, DestinationRect, SourceRect) else FMaskBitmap.Canvas.FillRect(DestinationRect); + {$else} + {$note implement} + {$endif} FChanged := true; Change; end; {------------------------------------------------------------------------------ - Method: TCustomImageList.Replace + Method: TCustomImageList.ReplaceIcon Params: Index: the index of the replaceded image Image: an icon image Returns: Nothing. @@ -1002,6 +1232,9 @@ begin if (Index < 0) then Index := 0; // No Icon suppport yet + {$ifndef IMGLIST_OLDSTYLE} + {$note implement} + {$endif} end; {------------------------------------------------------------------------------ @@ -1021,6 +1254,9 @@ begin if (Index < 0) then Index := 0; + {$ifndef IMGLIST_OLDSTYLE} + {$note implement} + {$endif} end; {------------------------------------------------------------------------------ @@ -1120,6 +1356,22 @@ begin end; end; +procedure TCustomImageList.StretchDraw(Canvas: TCanvas; Index: Integer; ARect: TRect; Enabled: Boolean); +var + bmp, msk: TBitmap; +begin + if (FCount = 0) or (Index >= FCount) then Exit; + + {$ifdef IMGLIST_OLDSTYLE} + bmp := TBitmap(FImageList[Index]); + msk := TBitmap(FMaskList[Index]); + StretchMaskBlt(Canvas.Handle, ARect.Left, ARect.Top, ARect.Right - ARect.Left, + ARect.Bottom - ARect.Top, bmp.Handle, 0, 0, FWidth, FHeight, msk.Handle, 0, 0, SRCCOPY); + {$else} + {$note implement} + {$endif} +end; + {------------------------------------------------------------------------------ Method: TCustomImageList.UnRegisterChanges Params: Value: a reference to changelink object diff --git a/lcl/interfaces/gtk/gtkpagecallback.inc b/lcl/interfaces/gtk/gtkpagecallback.inc index cee05c209d..ac310d3de3 100644 --- a/lcl/interfaces/gtk/gtkpagecallback.inc +++ b/lcl/interfaces/gtk/gtkpagecallback.inc @@ -35,7 +35,11 @@ begin TabWidget:=gtk_notebook_get_tab_label(PGtkNoteBook(NotebookWidget), PageWidget); if TabWidget=nil then exit; + {$ifdef IMGLIST_OLDSTYLE} DrawImageListIconOnWidget(NoteBook.Images,Page.ImageIndex,Widget); + {$else} + {$note implement} + {$endif} end; function PageIconWidgetExposeAfter(Widget: PGtkWidget; Event: PGDKEventExpose; diff --git a/lcl/interfaces/gtk/gtkproc.inc b/lcl/interfaces/gtk/gtkproc.inc index 1ed8e91749..0272eeefa2 100644 --- a/lcl/interfaces/gtk/gtkproc.inc +++ b/lcl/interfaces/gtk/gtkproc.inc @@ -1289,12 +1289,17 @@ begin {$EndIf} end; +{$ifdef IMGLIST_OLDSTYLE} procedure DrawImageListIconOnWidget(ImgList: TCustomImageList; Index: integer; DestWidget: PGTKWidget); begin DrawImageListIconOnWidget(ImgList,Index,DestWidget,true,true,0,0); end; +{$else} +{$note TODO: Remove me} +{$endif} +{$ifdef IMGLIST_OLDSTYLE} procedure DrawImageListIconOnWidget(ImgList: TCustomImageList; Index: integer; DestWidget: PGTKWidget; CenterHorizontally, CenterVertically: boolean; @@ -1335,6 +1340,9 @@ begin SRCCOPY); ReleaseDC(HDC(DestWidget),DestDC); end; +{$else} +{$note TODO: Remove me} +{$endif} function GetPGdkImageBitsPerPixel(Image: PGdkImage): cardinal; begin @@ -5704,8 +5712,12 @@ begin IconImg,0,0,ALeft,ATop,-1,-1); gdk_gc_set_clip_mask(gtk_widget_get_style(Widget)^.Black_gc, nil); end else begin + {$ifdef IMGLIST_OLDSTYLE} DrawImageListIconOnWidget(LCLMenuItem.GetImageList,LCLMenuItem.ImageIndex, Widget,false,false,ALeft,ATop); + {$else} + {$note Implement} + {$endif} end; end; diff --git a/lcl/interfaces/gtk/gtkproc.pp b/lcl/interfaces/gtk/gtkproc.pp index 7319e30d03..ddc212462a 100644 --- a/lcl/interfaces/gtk/gtkproc.pp +++ b/lcl/interfaces/gtk/gtkproc.pp @@ -49,11 +49,20 @@ uses FileUtil, ImgList, GtkFontCache, GTKGlobals, gtkDef, GtkExtra; - const GtkListItemGtkListTag = 'GtkList'; GtkListItemLCLListTag = 'LCLList'; + + {$if Declared(TOldStyleCustomImageList)} + {$define IMGLIST_OLDSTYLE} + {$else} + {$note TODO: remove me} + {$endif} + + + + type PPWaitHandleEventHandler = ^PWaitHandleEventHandler; PWaitHandleEventHandler = ^TWaitHandleEventHandler; @@ -646,12 +655,16 @@ function ScalePixmap(ScaleGC: PGDKGC; SrcColorMap: PGdkColormap; NewWidth, NewHeight: integer; var NewPixmap: PGdkPixmap): Boolean; +{$ifdef IMGLIST_OLDSTYLE} procedure DrawImageListIconOnWidget(ImgList: TCustomImageList; Index: integer; DestWidget: PGTKWidget); procedure DrawImageListIconOnWidget(ImgList: TCustomImageList; Index: integer; DestWidget: PGTKWidget; CenterHorizontally, CenterVertically: boolean; DestLeft, DestTop: integer); +{$else} +{$note TODO: Remove me} +{$endif} function GetPGdkImageBitsPerPixel(Image: PGdkImage): cardinal; function CreateGdkBitmap(Window: PGdkWindow; Width, Height: integer): PGdkBitmap; function ExtractGdkBitmap(Bitmap: PGdkBitmap; const SrcRect: TRect): PGdkBitmap; diff --git a/lcl/interfaces/gtk/gtkwscomctrls.pp b/lcl/interfaces/gtk/gtkwscomctrls.pp index fe49c19491..e52eeb1df4 100644 --- a/lcl/interfaces/gtk/gtkwscomctrls.pp +++ b/lcl/interfaces/gtk/gtkwscomctrls.pp @@ -42,6 +42,11 @@ uses GtkDef, GtkExtra, GtkWSPrivate; type + {$if Declared(TOldStyleCustomImageList)} + {$define IMGLIST_OLDSTYLE} + {$else} + {$note TODO: remove me} + {$endif} { TGtkWSStatusBar } diff --git a/lcl/interfaces/gtk/gtkwscustomlistview.inc b/lcl/interfaces/gtk/gtkwscustomlistview.inc index c9f7d64e76..3d4dbc9cf6 100644 --- a/lcl/interfaces/gtk/gtkwscustomlistview.inc +++ b/lcl/interfaces/gtk/gtkwscustomlistview.inc @@ -501,6 +501,7 @@ begin and (AItem.ImageIndex < TLVHack(ALV).SmallImages.Count) then begin // set image & caption + {$ifdef IMGLIST_OLDSTYLE} TLVHack(ALV).SmallImages.GetInternalImage(AItem.ImageIndex, ImageBitmap, MaskBitmap, ImageRect); if (ImageRect.Left <> 0) or (ImageRect.Top <> 0) @@ -508,6 +509,9 @@ begin Pixmap := PGDIObject(ImageBitmap.Handle)^.GDIPixmapObject; Mask := PGdkBitmap(PGDIObject(ImageBitmap.Handle)^.GDIBitmapMaskObject); gtk_clist_set_pixtext(ACListWidget, AIndex, 0, PChar(AItem.Caption), 3, Pixmap, Mask); + {$else} + {$note implement} + {$endif} end else begin // set caption alone @@ -634,6 +638,7 @@ begin WidgetInfo := GetWidgetInfo(Pointer(ALV.Handle)); CListWidget := PGtkCList(WidgetInfo^.CoreWidget); + {$ifdef IMGLIST_OLDSTYLE} if (TLVHack(ALV).SmallImages <> nil) and (AImageIndex >= 0) and (AImageIndex < TLVHack(ALV).SmallImages.Count) @@ -650,6 +655,11 @@ begin Pixmap := nil; Mask := nil; end; + {$else} + {$note implement} + Pixmap := nil; + Mask := nil; + {$endif} CellType := gtk_clist_get_cell_type(CListWidget, AIndex, ASubIndex); // Sigh. diff --git a/lcl/intfgraphics.pas b/lcl/intfgraphics.pas index 370f23b1d0..06b2c02519 100644 --- a/lcl/intfgraphics.pas +++ b/lcl/intfgraphics.pas @@ -173,6 +173,7 @@ type procedure SetColor_BPP32_R8G8B8_A1_BIO_TTB_RBO(x, y: integer; const Value: TFPColor); public constructor Create(AWidth, AHeight: integer); override; + constructor Create(ARawImage: TRawImage); destructor Destroy; override; procedure BeginUpdate; procedure EndUpdate; @@ -1635,6 +1636,25 @@ begin inherited Create(AWidth, AHeight); end; +constructor TLazIntfImage.Create(ARawImage: TRawImage); +begin + Create(FDataDescription.Width, FDataDescription.Height); + + FDataDescription := ARawImage.Description; + FPixelData := ARawImage.Data; + FPixelDataSize := ARawImage.DataSize; + FMaskData := ARawImage.Mask; + FMaskDataSize := ARawImage.MaskSize; + FCreateAllDataNeeded := False; + + CreateRawImageLineStarts(Width, Height, FDataDescription.BitsPerPixel, + FDataDescription.LineEnd, FLineStarts); + if FMaskData <> nil + then CreateRawImageLineStarts(Width, Height, FDataDescription.AlphaBitsPerPixel, + FDataDescription.AlphaLineEnd, FMaskLineStarts); + ChooseGetSetColorFunctions; +end; + destructor TLazIntfImage.Destroy; begin FreeAllData; diff --git a/lcl/lcltype.pp b/lcl/lcltype.pp index f1e44b2168..6b27e4af9b 100644 --- a/lcl/lcltype.pp +++ b/lcl/lcltype.pp @@ -1053,6 +1053,15 @@ type end; TRGBQuad = tagRGBQUAD; RGBQUAD = tagRGBQUAD; + + TRGBAQuad = record + Blue: Byte; + Green: Byte; + Red: Byte; + Alpha: Byte; + end; + PRGBAQuad = ^TRGBAQuad; + PBitmapInfo = ^TBitmapInfo; tagBITMAPINFO = record