Files
lace/3-mid/opengl/private/gid/gid-decoding_tga.adb
2022-07-31 17:34:54 +10:00

284 lines
8.0 KiB
Ada

with GID.Buffering; use GID.Buffering;
with GID.Color_tables;
package body GID.Decoding_TGA is
----------
-- Load --
----------
procedure Load (image: in out Image_descriptor) is
procedure Row_start(y: Natural) is
begin
if image.flag_1 then -- top first
Set_X_Y(0, image.height-1-y);
else
Set_X_Y(0, y);
end if;
end Row_Start;
-- Run Length Encoding --
RLE_pixels_remaining: Natural:= 0;
is_run_packet: Boolean;
type Pixel is record
color: RGB_Color;
alpha: U8;
end record;
pix, pix_mem: Pixel;
generic
bpp: Positive;
pal: Boolean;
procedure Get_pixel;
pragma Inline(Get_Pixel);
--
procedure Get_pixel is
idx: Natural;
p1, p2, c, d: U8;
begin
if pal then
if image.palette'Length <= 256 then
Get_Byte(image.buffer, p1);
idx:= Natural(p1);
else
Get_Byte(image.buffer, p1);
Get_Byte(image.buffer, p2);
idx:= Natural(p1) + Natural(p2) * 256;
end if;
idx:= idx + image.palette'First;
pix.color:= image.palette(idx);
else
case bpp is
when 32 => -- BGRA
Get_Byte(image.buffer, pix.color.blue);
Get_Byte(image.buffer, pix.color.green);
Get_Byte(image.buffer, pix.color.red);
Get_Byte(image.buffer, pix.alpha);
when 24 => -- BGR
Get_Byte(image.buffer, pix.color.blue);
Get_Byte(image.buffer, pix.color.green);
Get_Byte(image.buffer, pix.color.red);
when 16 | 15 => -- 5 bit per channel
Get_Byte(image.buffer, c);
Get_Byte(image.buffer, d);
Color_tables.Convert(c, d, pix.color);
if bpp=16 then
pix.alpha:= U8((U16(c and 128) * 255)/128);
end if;
when 8 => -- Gray
Get_Byte(image.buffer, pix.color.green);
pix.color.red:= pix.color.green;
pix.color.blue:= pix.color.green;
when others =>
null;
end case;
end if;
end Get_pixel;
generic
bpp: Positive;
pal: Boolean;
procedure RLE_Pixel;
pragma Inline(RLE_Pixel);
--
procedure RLE_Pixel is
tmp: U8;
procedure Get_pixel_for_RLE is new Get_pixel(bpp, pal);
begin
if RLE_pixels_remaining = 0 then -- load RLE code
Get_Byte(image.buffer, tmp );
Get_pixel_for_RLE;
RLE_pixels_remaining:= U8'Pos(tmp and 16#7F#);
is_run_packet:= (tmp and 16#80#) /= 0;
if is_run_packet then
pix_mem:= pix;
end if;
else
if is_run_packet then
pix:= pix_mem;
else
Get_pixel_for_RLE;
end if;
RLE_pixels_remaining:= RLE_pixels_remaining - 1;
end if;
end RLE_Pixel;
procedure RLE_pixel_32 is new RLE_pixel(32, False);
procedure RLE_pixel_24 is new RLE_pixel(24, False);
procedure RLE_pixel_16 is new RLE_pixel(16, False);
procedure RLE_pixel_15 is new RLE_pixel(15, False);
procedure RLE_pixel_8 is new RLE_pixel(8, False);
procedure RLE_pixel_palette is new RLE_pixel(1, True); -- 1: dummy
procedure Output_Pixel is
pragma Inline(Output_Pixel);
begin
case Primary_color_range'Modulus is
when 256 =>
Put_Pixel(
Primary_color_range(pix.color.red),
Primary_color_range(pix.color.green),
Primary_color_range(pix.color.blue),
Primary_color_range(pix.alpha)
);
when 65_536 =>
Put_Pixel(
16#101# * Primary_color_range(pix.color.red),
16#101# * Primary_color_range(pix.color.green),
16#101# * Primary_color_range(pix.color.blue),
16#101# * Primary_color_range(pix.alpha)
-- 16#101# because max intensity FF goes to FFFF
);
when others =>
raise invalid_primary_color_range;
end case;
end Output_Pixel;
procedure Get_RGBA is -- 32 bits
procedure Get_pixel_32 is new Get_pixel(32, False);
begin
for y in 0..image.height-1 loop
Row_start(y);
for x in 0..image.width-1 loop
Get_pixel_32;
Output_Pixel;
end loop;
Feedback(((y+1)*100)/image.height);
end loop;
end Get_RGBA;
procedure Get_RGB is -- 24 bits
procedure Get_pixel_24 is new Get_pixel(24, False);
begin
for y in 0..image.height-1 loop
Row_start(y);
for x in 0..image.width-1 loop
Get_pixel_24;
Output_Pixel;
end loop;
Feedback(((y+1)*100)/image.height);
end loop;
end Get_RGB;
procedure Get_16 is -- 16 bits
procedure Get_pixel_16 is new Get_pixel(16, False);
begin
for y in 0..image.height-1 loop
Row_start(y);
for x in 0..image.width-1 loop
Get_pixel_16;
Output_Pixel;
end loop;
Feedback(((y+1)*100)/image.height);
end loop;
end Get_16;
procedure Get_15 is -- 15 bits
procedure Get_pixel_15 is new Get_pixel(15, False);
begin
for y in 0..image.height-1 loop
Row_start(y);
for x in 0..image.width-1 loop
Get_pixel_15;
Output_Pixel;
end loop;
Feedback(((y+1)*100)/image.height);
end loop;
end Get_15;
procedure Get_Gray is
procedure Get_pixel_8 is new Get_pixel(8, False);
begin
for y in 0..image.height-1 loop
Row_start(y);
for x in 0..image.width-1 loop
Get_pixel_8;
Output_Pixel;
end loop;
Feedback(((y+1)*100)/image.height);
end loop;
end Get_Gray;
procedure Get_with_palette is
procedure Get_pixel_palette is new Get_pixel(1, True); -- 1: dummy
begin
for y in 0..image.height-1 loop
Row_start(y);
for x in 0..image.width-1 loop
Get_pixel_palette;
Output_Pixel;
end loop;
Feedback(((y+1)*100)/image.height);
end loop;
end Get_with_palette;
begin
pix.alpha:= 255; -- opaque is default
Attach_Stream(image.buffer, image.stream);
--
if image.RLE_encoded then
-- One format check per row
RLE_pixels_remaining:= 0;
for y in 0..image.height-1 loop
Row_start(y);
if image.palette /= null then
for x in 0..image.width-1 loop
RLE_pixel_palette;
Output_Pixel;
end loop;
else
case image.bits_per_pixel is
when 32 =>
for x in 0..image.width-1 loop
RLE_Pixel_32;
Output_Pixel;
end loop;
when 24 =>
for x in 0..image.width-1 loop
RLE_Pixel_24;
Output_Pixel;
end loop;
when 16 =>
for x in 0..image.width-1 loop
RLE_Pixel_16;
Output_Pixel;
end loop;
when 15 =>
for x in 0..image.width-1 loop
RLE_Pixel_15;
Output_Pixel;
end loop;
when 8 =>
for x in 0..image.width-1 loop
RLE_Pixel_8;
Output_Pixel;
end loop;
when others => null;
end case;
end if;
Feedback(((y+1)*100)/image.height);
end loop;
elsif image.palette /= null then
Get_with_palette;
else
case image.bits_per_pixel is
when 32 =>
Get_RGBA;
when 24 =>
Get_RGB;
when 16 =>
Get_16;
when 15 =>
Get_15;
when 8 =>
Get_Gray;
when others => null;
end case;
end if;
end Load;
end GID.Decoding_TGA;