* Image tests

src/base/fresnel.images.pas

@@ -5,7 +5,7 @@ unit fresnel.images;
 interface
 
 uses
-  Classes, SysUtils, fresnel.classes, fpImage;
+  Classes, SysUtils, Contnrs, fresnel.classes, fpImage;
 
 Const
   DefaultImageExtension = '.png';
@@ -52,9 +52,9 @@ Type
 
   { TCustomImageList }
 
-  { TImageListResolution }
+  { TResolution }
 
-  TImageListResolution = class(TCollectionItem)
+  TResolution = class(TCollectionItem)
   private
     FDefault: Boolean;
     FResolution: Word;
@@ -65,37 +65,55 @@ Type
     Property Default : Boolean Read FDefault Write SetDefault;
   end;
 
-  { TImageListResolution }
 
-  { TImageListResolutionList }
+  { TResolutionList }
 
-  TImageListResolutionList = class(TOwnedCollection)
+  TResolutionList = class(TOwnedCollection)
   private
-    function GetR(aIndex : Integer): TImageListResolution;
-    procedure SetR(aIndex : Integer; AValue: TImageListResolution);
+    function GetR(aIndex : Integer): TResolution;
+    procedure SetR(aIndex : Integer; AValue: TResolution);
   Public
-    Function FindDefaultResolution : TImageListResolution;
+    Function FindDefaultResolution : TResolution;
     Function IndexOfResolution(aResolution :  Word) : Integer;
-    Function AddResolution(aResolution : Word) : TImageListResolution;
-    Property Resolutions [aIndex : Integer] : TImageListResolution Read GetR Write SetR; default;
+    Function AddResolution(aResolution : Word) : TResolution;
+    Property Resolutions [aIndex : Integer] : TResolution Read GetR Write SetR; default;
+  end;
+
+  { TFPImageList }
+
+  TFPImageList = Class(TObject)
+  Private
+    FList : TFPObjectList;
+    function GetCount: Integer;
+    function GetImage(Index: Integer): TFPCustomImage;
+    procedure SetImage(Index: Integer; AValue: TFPCustomImage);
+  Public
+    Constructor Create(aOwnsImages : Boolean);
+    Destructor Destroy; override;
+    Property Count : Integer Read GetCount;
+    Property Images[Index: Integer] : TFPCustomImage Read GetImage Write SetImage; default;
   end;
 
   TCustomImageList = Class(TComponent)
   Private
     FAutoCreateMissingResolution: Boolean;
     FHeight: Word;
-    FResolutions: TImageListResolutionList;
+    FResolutions: TResolutionList;
     FWidth: Word;
+    FImageStores : Array of TFPImageList;
+    function GetImageCount: Integer;
     procedure SetDefaultResolution(AValue: Word);
     procedure SetHeight(AValue: Word);
-    procedure SetResolutions(AValue: TImageListResolutionList);
+    procedure SetResolutions(AValue: TResolutionList);
     procedure SetWidth(AValue: Word);
     procedure SetWidthHeight(aWidth, aHeight: Word);
   Protected
-    function CreateResolutions: TImageListResolutionList; virtual;
+    function CreateResolutions: TResolutionList; virtual;
     function DetermineApplicationResolution : Word; virtual;
     Function GetDefaultResolution : Word;
+    Function GetIndexOfResolution (aResolution : Word) : Integer;
     Function CreateImage : TFPCustomImage;
+    Function GetResolutionList(aResolution : Word) : TFPImageList;
   Public
     Constructor Create(aOwner : TComponent); override;
     Destructor Destroy; override;
@@ -105,8 +123,9 @@ Type
     Procedure GetImage(aIndex : Integer; aImage : TFPCustomImage);
     Function GetImage(aIndex : Integer; aResolution : Word) : TFPCustomImage;
     Procedure GetImage(aIndex : Integer; aResolution : Word; aImage : TFPCustomImage);
+    Property ImageCount : Integer Read GetImageCount;
     Property DefaultResolution : Word Read GetDefaultResolution Write SetDefaultResolution;
-    Property Resolutions : TImageListResolutionList Read FResolutions Write SetResolutions;
+    Property Resolutions : TResolutionList Read FResolutions Write SetResolutions;
     Property Width : Word Read FWidth Write SetWidth;
     Property Height : Word Read FHeight Write SetHeight;
     Property AutoCreateMissingResolution : Boolean Read FAutoCreateMissingResolution Write FAutoCreateMissingResolution default true;
@@ -114,7 +133,11 @@ Type
 
   TImageList = class(TCustomImageList)
   Published
+    Property DefaultResolution;
     Property Resolutions;
+    Property Width;
+    Property Height;
+    Property AutoCreateMissingResolution;
   end;
 
   { TCustomImageStore }
@@ -217,17 +240,17 @@ resourceString
   SErrDuplicateResolution = 'Duplicate resolution: %d';
 
 
-function TImageListResolutionList.GetR(aIndex : Integer): TImageListResolution;
+function TResolutionList.GetR(aIndex : Integer): TResolution;
 begin
-  Result:=TImageListResolution(Items[aIndex])
+  Result:=TResolution(Items[aIndex])
 end;
 
-procedure TImageListResolutionList.SetR(aIndex : Integer; AValue: TImageListResolution);
+procedure TResolutionList.SetR(aIndex : Integer; AValue: TResolution);
 begin
   Items[aIndex]:=aValue
 end;
 
-function TImageListResolutionList.FindDefaultResolution: TImageListResolution;
+function TResolutionList.FindDefaultResolution: TResolution;
 
 var
   I : Integer;
@@ -243,21 +266,49 @@ begin
     end;
 end;
 
-function TImageListResolutionList.IndexOfResolution(aResolution: Word): Integer;
+function TResolutionList.IndexOfResolution(aResolution: Word): Integer;
 begin
   Result:=Count-1;
   While (Result>=0) and (GetR(Result).Resolution<>aResolution) do
     Dec(result);
 end;
 
-function TImageListResolutionList.AddResolution(aResolution: Word): TImageListResolution;
+function TResolutionList.AddResolution(aResolution: Word): TResolution;
 begin
   If IndexOfResolution(aResolution)<>-1 then
     Raise EImageData.CreateFmt(SErrDuplicateResolution,[aResolution]);
-  Result:=Add as TImageListResolution;
+  Result:=Add as TResolution;
   Result.Resolution:=aResolution;
 end;
 
+{ TFPImageList }
+
+function TFPImageList.GetCount: Integer;
+begin
+  Result:=FList.Count;
+end;
+
+function TFPImageList.GetImage(Index: Integer): TFPCustomImage;
+begin
+  Result:=TFPCustomImage(FList[Index]);
+end;
+
+procedure TFPImageList.SetImage(Index: Integer; AValue: TFPCustomImage);
+begin
+ FList.Items[Index]:=aValue;
+end;
+
+constructor TFPImageList.Create(aOwnsImages: Boolean);
+begin
+  FList:=TFPObjectList.Create(aOwnsImages);
+end;
+
+destructor TFPImageList.Destroy;
+begin
+  FreeAndNil(FList);
+  inherited Destroy;
+end;
+
 { TImagesConfig }
 
 procedure TImagesConfig.SetImageDir(AValue: String);
@@ -397,26 +448,26 @@ begin
   Result:=Result+LowerCase(ImageExtension);
 end;
 
-{ TImageListResolution }
+{ TResolution }
 
 
-procedure TImageListResolution.SetDefault(AValue: Boolean);
+procedure TResolution.SetDefault(AValue: Boolean);
 
 var
-  Res : TImageListResolution;
+  Res : TResolution;
 
 begin
   if FDefault=AValue then Exit;
-  if aValue and (Collection is TImageListResolutionList) then
+  if aValue and (Collection is TResolutionList) then
     begin
-    Res:=TImageListResolutionList(Collection).FindDefaultResolution;
+    Res:=TResolutionList(Collection).FindDefaultResolution;
     if Assigned(Res) then
       Res.Default:=False;
     end;
   FDefault:=AValue;
 end;
 
-procedure TImageListResolution.SetResolution(AValue: Word);
+procedure TResolution.SetResolution(AValue: Word);
 begin
   if FResolution=AValue then Exit;
   FResolution:=AValue;
@@ -426,7 +477,7 @@ end;
 { TCustomImageList }
 
 
-procedure TCustomImageList.SetResolutions(AValue: TImageListResolutionList);
+procedure TCustomImageList.SetResolutions(AValue: TResolutionList);
 begin
   if FResolutions=AValue then Exit;
   FResolutions.Assign(AValue);
@@ -449,10 +500,20 @@ begin
 
 end;
 
-procedure TCustomImageList.SetWidthHeight(aWidth,aHeight: Word);
+function TCustomImageList.GetImageCount: Integer;
 
 begin
+  if Length(FImageStores)=0 then
+    Result:=0
+  else
+    Result:=GetResolutionList(DefaultResolution).Count;
+end;
+
+procedure TCustomImageList.SetWidthHeight(aWidth,aHeight: Word);
 
+begin
+  FWidth:=aWidth;
+  FHeight:=aHeight;
 end;
 
 procedure TCustomImageList.SetHeight(AValue: Word);
@@ -466,7 +527,7 @@ constructor TCustomImageList.Create(aOwner: TComponent);
 begin
   inherited Create(aOwner);
   FResolutions:=CreateResolutions;
-  FResolutions.AddResolution(DetermineApplicationResolution);
+  FResolutions.AddResolution(DetermineApplicationResolution).Default:=True;
 end;
 
 destructor TCustomImageList.Destroy;
@@ -475,10 +536,10 @@ begin
   inherited Destroy;
 end;
 
-function TCustomImageList.CreateResolutions: TImageListResolutionList;
+function TCustomImageList.CreateResolutions: TResolutionList;
 
 begin
-  Result:=TImageListResolutionList.Create(Self,TImageListResolution);
+  Result:=TResolutionList.Create(Self,TResolution);
 end;
 
 function TCustomImageList.DetermineApplicationResolution: Word;
@@ -492,14 +553,22 @@ begin
 end;
 
 function TCustomImageList.IsValidImageIndex(aIndex: Integer; aResolution: Word): Boolean;
-begin
 
+var
+  aList : TFPImageList;
+
+begin
+  aList:=GetResolutionList(aResolution);
+  if Assigned(aList) then
+    Result:=(aIndex>=0) and (aIndex<aList.Count)
+  else
+    Result:=False;
 end;
 
 function TCustomImageList.GetDefaultResolution: Word;
 
 var
-  Res : TImageListResolution;
+  Res : TResolution;
 
 begin
   Res:=Resolutions.FindDefaultResolution;
@@ -509,11 +578,34 @@ begin
     Result:=DetermineApplicationResolution;
 end;
 
+function TCustomImageList.GetIndexOfResolution(aResolution: Word): Integer;
+begin
+  Result:=FResolutions.IndexOfResolution(aResolution);
+end;
+
 function TCustomImageList.CreateImage: TFPCustomImage;
 begin
   Result:=TImageData.CreateData(Width,Height);
 end;
 
+function TCustomImageList.GetResolutionList(aResolution: Word): TFPImageList;
+var
+  Idx : Integer;
+
+begin
+  Idx:=GetIndexOfResolution(aResolution);
+  if Idx=-1 then
+    Result:=Nil
+  else
+    begin
+    if Idx>=Length(FImageStores) then
+      SetLength(FImageStores,Idx+1);
+    if FImageStores[Idx]=Nil then
+      FimageStores[Idx]:=TFPImageList.Create(True);
+    Result:=FimageStores[Idx];
+    end;
+end;
+
 function TCustomImageList.GetImage(aIndex: Integer): TFPCustomIMage;
 begin
   Result:=GetImage(aIndex,GetDefaultResolution)
@@ -536,8 +628,13 @@ begin
 end;
 
 procedure TCustomImageList.GetImage(aIndex: Integer; aResolution: Word; aImage: TFPCustomImage);
-begin
 
+var
+  aList : TFPImageList;
+
+begin
+  aList:=GetResolutionList(aResolution);
+  aImage.Assign(aList[aIndex]);
 end;
 
 { TCustomImageStore }

tests/base/TestFresnelBase.lpi

@@ -60,6 +60,11 @@
       <IncludeFiles Value="$(ProjOutDir)"/>
       <UnitOutputDirectory Value="lib/$(TargetCPU)-$(TargetOS)"/>
     </SearchPaths>
+    <Linking>
+      <Debugging>
+        <DebugInfoType Value="dsDwarf3"/>
+      </Debugging>
+    </Linking>
   </CompilerOptions>
   <Debugging>
     <Exceptions>

tests/base/tcfresnelimages.pas

@@ -30,13 +30,46 @@ Type
     Procedure TestImageSizedFileNameResolutionAndSizeDir;
   end;
 
+  { TTestResolutionList }
+
+  TTestResolutionList = class(TTestCase)
+  private
+    FList: TResolutionList;
+  Public
+    Procedure SetUp; override;
+    Procedure TearDown; override;
+    Property List : TResolutionList Read FList;
+  Published
+    Procedure TestHookup;
+    Procedure TestAddResolution;
+    Procedure TestFindDefaultResolution;
+    Procedure TestIndexOfResolution;
+  end;
+
+  { TTestImageList }
+
+  TTestImageList = Class(TTestCase)
+  private
+    FImageList: TImageList;
+  Public
+    Procedure Setup; override;
+    Procedure TearDown; override;
+    Property List : TImageList Read FImageList;
+  Published
+    Procedure TestHookup;
+  end;
+
   { TTestFresnelImageData }
 
   TTestFresnelImageData = Class(TTestCase)
   private
     FData: TImageData;
   Public
+    Procedure Setup; override;
+    Procedure TearDown; override;
     Property Data : TImageData Read FData Write FData;
+  Published
+    Procedure TestHookup;
   end;
 
 implementation
@@ -130,8 +163,108 @@ begin
   AssertEquals('Default filename (resolution, size first)',Config.ImageDir+'48x48/96/so'+DefaultImageExtension,Config.GetSizedImageFileName('so',48,96));
 end;
 
+{ TTestResolutionList }
+
+procedure TTestResolutionList.SetUp;
+begin
+  inherited SetUp;
+  FList:=TResolutionList.Create(Nil,TResolution);
+end;
+
+procedure TTestResolutionList.TearDown;
+begin
+  inherited TearDown;
+  FreeAndNil(FList);
+end;
+
+procedure TTestResolutionList.TestHookup;
+begin
+  AssertNotNull('Have list',List);
+  AssertEquals('No resolutions',0,List.Count);
+end;
+
+procedure TTestResolutionList.TestAddResolution;
+
+  procedure AddData;
+
+  begin
+    List.AddResolution(96);
+  end;
+
+var
+  R : TResolution;
+
+begin
+  R:=List.AddResolution(96);
+  AssertNotNull('Have result',R);
+  AssertEquals('Correct resolution',96,R.Resolution);
+  AssertFalse('Default',R.Default);
+  AssertException('No second resolution',EImageData,@AddData);
+end;
+
+procedure TTestResolutionList.TestFindDefaultResolution;
+var
+  R : TResolution;
+
+begin
+  R:=List.AddResolution(96);
+  R.Default:=True;
+  List.AddResolution(72);
+  AssertSame('Correct default',R,List.FindDefaultResolution);
+end;
+
+procedure TTestResolutionList.TestIndexOfResolution;
+begin
+  List.AddResolution(96);
+  List.AddResolution(72);
+  List.AddResolution(128);
+  List.AddResolution(224);
+  AssertEquals('Index of 72',1,List.IndexOfResolution(72));
+
+end;
+
+{ TTestImageList }
+
+procedure TTestImageList.Setup;
+begin
+  inherited Setup;
+  FImageList:=TImageList.Create(NIl);
+end;
+
+procedure TTestImageList.TearDown;
+begin
+  FreeandNil(FImageList);
+  inherited TearDown;
+end;
+
+procedure TTestImageList.TestHookup;
+begin
+  AssertNotNull('Have list',List);
+  AssertEquals('Empty',0,List.ImageCount);
+  AssertEquals('Resolution',1,List.Resolutions.Count);
+end;
+
+{ TTestFresnelImageData }
+
+procedure TTestFresnelImageData.Setup;
+begin
+  inherited Setup;
+  FData:=TImageData.Create(Nil);
+end;
+
+procedure TTestFresnelImageData.TearDown;
+begin
+  FreeAndNil(FData);
+  inherited TearDown;
+end;
+
+procedure TTestFresnelImageData.TestHookup;
+begin
+  AssertNotNull('Have data',Data)
+end;
+
 
 initialization
-  RegisterTests([TTestImageConfig,TTestFresnelImageData])
+  RegisterTests([TTestImageConfig,TTestFresnelImageData,TTestResolutionList,TTestImageList])
 end.