Vovanium/Video_library
2
0
Fork 0
Code Issues Pull requests Projects Releases Wiki Activity

>refactor< unbounded images

Browse source
This commit is contained in:
Vovanium 2023-02-13 03:25:22 +03:00
parent 3dbffac503
commit 82450aaff2
5 changed files with 124 additions and 129 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

50
source/base/video-images-raster-generic_unbounded.adb Normal file
View file

@ -0,0 +1,50 @@
package body Video.Images.Raster.Generic_Unbounded is
overriding function Bounding_Box (Source : Image) return Box
is
Data : Raster_Holders.Constant_Reference_Type := Source.Pixels.Constant_Reference;
R : Raster_Images.Raster_Type renames Data.Element.all;
begin
return (X => (R'First (2), R'Last (2)),
Y => (R'First (1), R'Last (1)));
end;
overriding function Pixel (
Source : Image;
A : Point)
return Raster_Images.Pixel_Type
is
Data : Raster_Holders.Constant_Reference_Type := Source.Pixels.Constant_Reference;
begin
return Data.Element.all (A.Y, A.X);
end Pixel;
overriding function Pixel (
Source : Image;
A : Point)
return Color
is
Data : Raster_Holders.Constant_Reference_Type := Source.Pixels.Constant_Reference;
begin
return Map_Color (Parent (Source), Data.Element.all (A.Y, A.X));
end Pixel;
overriding procedure Query_Raster (
Source : in Image;
Query : not null access procedure (R : in Raster_Images.Raster_Type))
is
Data : Raster_Holders.Constant_Reference_Type := Source.Pixels.Constant_Reference;
begin
Query (Data.Element.all);
end Query_Raster;
overriding procedure Process_Raster (
Target : in out Image;
Process : not null access procedure (R : in out Raster_Images.Raster_Type))
is
Data : Raster_Holders.Reference_Type := Target.Pixels.Reference;
begin
Process (Data.Element.all);
end Process_Raster;
end Video.Images.Raster.Generic_Unbounded;

41
source/base/video-images-raster-generic_unbounded.ads Normal file
View file

@ -0,0 +1,41 @@
with Ada.Containers.Indefinite_Holders;
--
-- Images with raster that can be changed in runtime
--
generic
with package Raster_Images is new Generic_Raster_Images (<>);
type Parent is abstract tagged private;
with function Map_Color (Map : Parent; Pixel : Raster_Images.Pixel_Type) return Color is <>;
package Video.Images.Raster.Generic_Unbounded is
type Image is abstract new Parent and Raster_Images.Image with private;
overriding function Bounding_Box (Source : Image) return Box;
overriding function Pixel (
Source : Image;
A : Point)
return Raster_Images.Pixel_Type;
overriding function Pixel (
Source : Image;
A : Point)
return Color;
overriding procedure Query_Raster (
Source : in Image;
Query : not null access procedure (R : in Raster_Images.Raster_Type));
overriding procedure Process_Raster (
Target : in out Image;
Process : not null access procedure (R : in out Raster_Images.Raster_Type));
private
use type Raster_Images.Raster_Type;
package Raster_Holders is new Ada.Containers.Indefinite_Holders (Raster_Images.Raster_Type);
type Image is abstract new Parent and Raster_Images.Image with record
Pixels : Raster_Holders.Holder;
end record;
end Video.Images.Raster.Generic_Unbounded;

1
source/base/video-images-raster-indexed-generic_fixed.ads
View file

@ -42,7 +42,6 @@ package Video.Images.Raster.Indexed.Generic_Fixed is
--
package Fixed_Color_Maps is new Colors.Maps.Generic_Fixed (0, Last_Color_Index);
package With_Own_Palette is new Images_with_Color_Map (Fixed_Color_Maps.Fixed_Color_Map);

80
source/base/video-images-raster-indexed-generic_unbounded.adb
View file

@ -1,80 +0,0 @@
with Ada.Unchecked_Deallocation;
package body Video.Images.Raster.Indexed.Generic_Unbounded is
procedure Deallocate is new Ada.Unchecked_Deallocation (
Object => Raster_Type,
Name => Raster_Access);
procedure Deallocate is new Ada.Unchecked_Deallocation (
Object => Colormap_Type,
Name => Colormap_Access);
overriding function Bounding_Box (Source : Image_with_Own_Palette) return Box
is (
(Source.Pixels'First (2), Source.Pixels'Last (2)),
(Source.Pixels'First (1), Source.Pixels'Last (1)));
overriding function Pixel (
Source : Image_with_Own_Palette;
A : Point)
return Pixel_Type
is (Source.Pixels (A.Y, A.X));
overriding function Pixel (
Source : Image_with_Own_Palette;
A : Point)
return Color
is (Source.Colormap (Integer (Source.Pixels (A.Y, A.X))));
overriding function Pixel_Index (
Source : Image_with_Own_Palette;
A : Point)
return Natural
is (Integer (Source.Pixels (A.Y, A.X)));
overriding procedure Query_Raster (
Source : in Image_with_Own_Palette;
Query : not null access procedure (R : in Raster_Type))
is
begin
Query (Source.Pixels.all);
end Query_Raster;
overriding procedure Process_Raster (
Target : in out Image_with_Own_Palette;
Process : not null access procedure (R : in out Raster_Type))
is
begin
Process (Target.Pixels.all);
end Process_Raster;
overriding function Map_Color (Source : Image_with_Own_Palette; Index : Natural) return Color
is (Source.Colormap (Index));
overriding function To_Palette (Source : Image_with_Own_Palette) return Palette
is (Source.Colormap.all);
overriding procedure Finalize (Object : in out Image_with_Own_Palette) is
P : Raster_Access := Object.Pixels; -- Exception workaround
C : Colormap_Access := Object.Colormap;
begin
Deallocate (P); -- if Object.Pixels is freed directly it's nullified so exception occurs
Deallocate (C); -- Same
end;
package body Make is
function By (
Bounds : Integer_Geometry.Box)
return Image_with_Own_Palette
is
begin
return (Limited_Controlled with
Pixels => new Raster_Type (
Bounds.Y.First .. Bounds.Y.Last,
Bounds.X.First .. Bounds.Y.Last),
Colormap => new Colormap_Type);
end By;
end Make;
end Video.Images.Raster.Indexed.Generic_Unbounded;

81
source/base/video-images-raster-indexed-generic_unbounded.ads
View file

@ -1,5 +1,8 @@
with Ada.Finalization;
use Ada.Finalization;
with Video.Colors.Maps.Generic_Fixed;
with Video.Colors.Maps.Shared_Palettes;
with Video.Images.Raster.Generic_Unbounded;
generic
type Pixel_Type is mod <>;
@ -13,62 +16,44 @@ package Video.Images.Raster.Indexed.Generic_Unbounded is
Last_Color_Index : constant Color_Index := Color_Index (Pixel_Type'Modulus - 1);
-- Last color index. Used for palette bounds
generic
type Parent_Color_Map is new Colors.Maps.Constant_Color_Map with private;
package Images_with_Color_Map is
type Base_Color_Map is abstract new Parent_Color_Map with null record;
function Map_Color (Map : Base_Color_Map; Pixel : Pixel_Type) return Color
is (Map.Map_Color (Color_Index (Pixel))) with Inline;
package Image_Base is new Raster.Generic_Unbounded (
Raster_Images => Raster_Images,
Parent => Base_Color_Map);
type Image is new Image_Base.Image with null record;
-- An actual type
overriding function Pixel_Index (
Source : Image;
A : Point)
return Natural
is (Integer (Pixel_Type'(Source.Pixel (A))));
end Images_with_Color_Map;
--
type Image_with_Own_Palette is limited new Limited_Controlled and Raster_Images.Image with private;
package Fixed_Color_Maps is new Colors.Maps.Generic_Fixed (0, Last_Color_Index);
overriding function Bounding_Box (Source : Image_with_Own_Palette) return Box;
package With_Own_Palette is new Images_with_Color_Map (Fixed_Color_Maps.Fixed_Color_Map);
overriding function Pixel (
Source : Image_with_Own_Palette;
A : Point)
return Pixel_Type;
subtype Image_with_Own_Palette is With_Own_Palette.Image;
overriding function Pixel (
Source : Image_with_Own_Palette;
A : Point)
return Color;
--
overriding function Pixel_Index (
Source : Image_with_Own_Palette;
A : Point)
return Natural;
package With_Shared_Palette is new Images_with_Color_Map (
Colors.Maps.Shared_Palettes.Constant_Shared_Palette);
overriding procedure Query_Raster (
Source : in Image_with_Own_Palette;
Query : not null access procedure (R : in Raster_Type));
overriding procedure Process_Raster (
Target : in out Image_with_Own_Palette;
Process : not null access procedure (R : in out Raster_Type));
overriding function First_Color (Source : Image_with_Own_Palette) return Color_Index
is (0);
overriding function Last_Color (Source : Image_with_Own_Palette) return Color_Index
is (Last_Color_Index);
overriding function Map_Color (Source : Image_with_Own_Palette; Index : Natural) return Color;
overriding function To_Palette (Source : Image_with_Own_Palette) return Palette;
overriding procedure Finalize (Object : in out Image_with_Own_Palette);
package Make is
function By (
Bounds : Integer_Geometry.Box)
return Image_with_Own_Palette;
end Make;
subtype Image_with_Shared_Palette is With_Shared_Palette.Image;
private
type Raster_Access is access Raster_Type;
subtype Colormap_Type is Palette (0 .. Last_Color_Index);
type Colormap_Access is access Colormap_Type;
type Image_with_Own_Palette is limited new Limited_Controlled and Raster_Images.Image with record
Pixels : not null Raster_Access;
Colormap : not null Colormap_Access;
end record;
end Video.Images.Raster.Indexed.Generic_Unbounded;