-
-
Notifications
You must be signed in to change notification settings - Fork 3
/
gid-decoding_tga.adb
288 lines (269 loc) · 8.56 KB
/
gid-decoding_tga.adb
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
with GID.Buffering,
GID.Color_tables;
package body GID.Decoding_TGA is
use Buffering, Interfaces;
----------
-- Load --
----------
procedure Load (image : in out Image_Descriptor) is
procedure Row_start (y : Natural) is
begin
if image.top_first then
Set_X_Y (0, Integer (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_8_Bit;
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
rle_bpp : Positive;
rle_pal : Boolean;
procedure RLE_Pixel;
pragma Inline (RLE_Pixel);
--
procedure RLE_Pixel is
tmp : U8;
procedure Get_pixel_for_RLE is new Get_pixel (rle_bpp, rle_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);
function Times_257 (x : Primary_Color_Range) return Primary_Color_Range
is
(16 * (16 * x) + x) with Inline; -- This is 257 * x, = 16#0101# * x
-- Numbers are 8-bit -> no OA warning at instantiation.
-- Returns x if type Primary_Color_Range is mod 2**8.
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
(Times_257 (Primary_Color_Range (pix.color.red)),
Times_257 (Primary_Color_Range (pix.color.green)),
Times_257 (Primary_Color_Range (pix.color.blue)),
Times_257 (Primary_Color_Range (pix.alpha)));
-- Times_257 makes max intensity FF go to FFFF
when others =>
raise invalid_primary_color_range
with "TGA: color range not supported";
end case;
end Output_Pixel;
procedure Get_RGBA is -- 32 bits : R, G, B, A use 8 bits each.
procedure Get_pixel_32 is new Get_pixel (32, False);
begin
for y in 0 .. Integer (image.height) - 1 loop
Row_start (y);
for x in 0 .. Integer (image.width) - 1 loop
Get_pixel_32;
Output_Pixel;
end loop;
Feedback (((y + 1) * 100) / Integer (image.height));
end loop;
end Get_RGBA;
procedure Get_RGB is -- 24 bits : R, G, B use 8 bits each.
procedure Get_pixel_24 is new Get_pixel (24, False);
begin
for y in 0 .. Integer (image.height) - 1 loop
Row_start (y);
for x in 0 .. Integer (image.width) - 1 loop
Get_pixel_24;
Output_Pixel;
end loop;
Feedback (((y + 1) * 100) / Integer (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 .. Integer (image.height) - 1 loop
Row_start (y);
for x in 0 .. Integer (image.width) - 1 loop
Get_pixel_16;
Output_Pixel;
end loop;
Feedback (((y + 1) * 100) / Integer (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 .. Integer (image.height) - 1 loop
Row_start (y);
for x in 0 .. Integer (image.width) - 1 loop
Get_pixel_15;
Output_Pixel;
end loop;
Feedback (((y + 1) * 100) / Integer (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 .. Integer (image.height) - 1 loop
Row_start (y);
for x in 0 .. Integer (image.width) - 1 loop
Get_pixel_8;
Output_Pixel;
end loop;
Feedback (((y + 1) * 100) / Integer (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 .. Integer (image.height) - 1 loop
Row_start (y);
for x in 0 .. Integer (image.width) - 1 loop
Get_pixel_palette;
Output_Pixel;
end loop;
Feedback (((y + 1) * 100) / Integer (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 .. Integer (image.height) - 1 loop
Row_start (y);
if image.palette /= null then
for x in 0 .. Integer (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) / Integer (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;