nichkara/lace
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add initial prototype.

Browse Source
This commit is contained in:
Rod Kay
2022-07-31 17:34:54 +10:00
commit 54a53b2ac0
1421 changed files with 358874 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1372
3-mid/opengl/private/gid/crypt/gid-decoding_png.alt_inflate.adb Normal file
View File

File diff suppressed because it is too large Load Diff

1349
3-mid/opengl/private/gid/crypt/gid-decoding_png.alt_slide_copy.adb Normal file
View File

File diff suppressed because it is too large Load Diff

3
3-mid/opengl/private/gid/debug.pra Normal file
View File

@@ -0,0 +1,3 @@
pragma Initialize_Scalars;
-- pragma Normalize_Scalars; -- For all units!

79
3-mid/opengl/private/gid/gid-buffering.adb Normal file
View File

@@ -0,0 +1,79 @@
with Ada.IO_Exceptions;
package body GID.Buffering is
procedure Fill_Buffer(b: in out Input_buffer);
-- ^ Spec here to avoid warning by 'Get_Byte' below (GNAT 2009):
-- warning: call to subprogram with no separate spec prevents inlining
procedure Fill_Buffer(b: in out Input_buffer)
is
--
procedure BlockRead(
buffer : out Byte_Array;
actually_read: out Natural
)
is
use Ada.Streams;
Last_Read: Stream_Element_Offset;
begin
if is_mapping_possible then
declare
SE_Buffer_mapped: Stream_Element_Array (1 .. buffer'Length);
-- direct mapping: buffer = SE_Buffer_mapped
for SE_Buffer_mapped'Address use buffer'Address;
pragma Import (Ada, SE_Buffer_mapped);
begin
Read(b.stream.all, SE_Buffer_mapped, Last_Read);
end;
else
declare
SE_Buffer: Stream_Element_Array (1 .. buffer'Length);
-- need to copy array (slightly slower)
begin
Read(b.stream.all, SE_Buffer, Last_Read);
for i in buffer'Range loop
buffer(i):= U8(SE_Buffer(Stream_Element_Offset(i-buffer'First)+SE_buffer'First));
end loop;
end;
end if;
actually_read:= Natural(Last_Read);
end BlockRead;
--
begin
BlockRead(
buffer => b.data,
actually_read => b.MaxInBufIdx
);
b.InputEoF:= b.MaxInBufIdx = 0;
b.InBufIdx := 1;
end Fill_Buffer;
procedure Attach_Stream(
b : out Input_buffer;
stm : in Stream_Access
)
is
begin
b.stream:= stm;
-- Fill_Buffer(b) will be performed on first call of Get_Byte
end Attach_Stream;
function Is_stream_attached(b: Input_buffer) return Boolean is
begin
return b.stream /= null;
end Is_stream_attached;
procedure Get_Byte(b: in out Input_buffer; byte: out U8) is
begin
if b.InBufIdx > b.MaxInBufIdx then
Fill_Buffer(b);
if b.InputEoF then
raise Ada.IO_Exceptions.End_Error;
end if;
end if;
byte:= b.data(b.InBufIdx);
b.InBufIdx:= b.InBufIdx + 1;
end Get_Byte;
end GID.Buffering;

28
3-mid/opengl/private/gid/gid-buffering.ads Normal file
View File

@@ -0,0 +1,28 @@
private package GID.Buffering is
-- Attach a buffer to a stream.
procedure Attach_Stream(
b : out Input_buffer;
stm : in Stream_Access
);
function Is_stream_attached(b: Input_buffer) return Boolean;
-- From the first call to Get_Byte, subsequent bytes must be read
-- through Get_Byte as well since the stream is partly read in advance
procedure Get_Byte(b: in out Input_buffer; byte: out U8);
pragma Inline(Get_Byte);
private
subtype Size_test_a is Byte_Array(1..19);
subtype Size_test_b is Ada.Streams.Stream_Element_Array(1..19);
-- is_mapping_possible: Compile-time test for checking if
-- a Byte_Array is equivalemnt to a Ada.Streams.Stream_Element_Array.
--
is_mapping_possible: constant Boolean:=
Size_test_a'Size = Size_test_b'Size and
Size_test_a'Alignment = Size_test_b'Alignment;
end GID.Buffering;

71
3-mid/opengl/private/gid/gid-color_tables.adb Normal file
View File

@@ -0,0 +1,71 @@
with GID.Buffering;
with Ada.Exceptions;
package body GID.Color_tables is
procedure Convert(c, d: in U8; rgb: out RGB_Color) is
begin
rgb.red := (d and 127) / 4;
rgb.green:= (d and 3) * 8 + c / 32;
rgb.blue := c and 31;
--
rgb.red := U8((U16(rgb.red ) * 255) / 31);
rgb.green:= U8((U16(rgb.green) * 255) / 31);
rgb.blue := U8((U16(rgb.blue ) * 255) / 31);
end Convert;
procedure Load_palette (image: in out Image_descriptor) is
c, d: U8;
use GID.Buffering;
begin
if image.palette = null then
return;
end if;
declare
palette: Color_Table renames image.palette.all;
begin
for i in palette'Range loop
case image.format is
when BMP =>
-- order is BGRx
U8'Read(image.stream, Palette(i).blue);
U8'Read(image.stream, Palette(i).green);
U8'Read(image.stream, Palette(i).red);
U8'Read(image.stream, c);
-- x discarded
when GIF | PNG =>
-- buffered; order is RGB
Get_Byte(image.buffer, Palette(i).red);
Get_Byte(image.buffer, Palette(i).green);
Get_Byte(image.buffer, Palette(i).blue);
when TGA =>
case image.subformat_id is -- = palette's bit depth
when 8 => -- Grey
U8'Read(image.stream, c);
Palette(i).Red := c;
Palette(i).Green:= c;
Palette(i).Blue := c;
when 15 | 16 => -- RGB, 5 bit per channel
U8'Read(image.stream, c);
U8'Read(image.stream, d);
Convert(c, d, Palette(i));
when 24 | 32 => -- RGB | RGBA, 8 bit per channel
U8'Read(image.stream, Palette(i).blue);
U8'Read(image.stream, Palette(i).green);
U8'Read(image.stream, Palette(i).red);
when others =>
null;
end case;
when others =>
Ada.Exceptions.Raise_exception(
unsupported_image_subformat'Identity,
"Palette loading not implemented for " &
Image_format_type'Image(image.format)
);
end case;
end loop;
end;
end Load_palette;
end GID.Color_tables;

18
3-mid/opengl/private/gid/gid-color_tables.ads Normal file
View File

@@ -0,0 +1,18 @@
--
-- Color tables, known as "palettes"
--
private package GID.Color_tables is
-- Load a palette on its defined range, according to
-- the format and subformats loaded by initial
-- steps in GID.Load_image_header
procedure Load_palette (image: in out Image_descriptor);
-- if image.palette = null, nothing happens.
-- Convert a RGB value packed in 2 bytes
-- (15 bit, 5 bit each channel) into a RGB_Color
-- This is for the TGA format.
procedure Convert(c, d: in U8; rgb: out RGB_Color);
end GID.Color_tables;

122
3-mid/opengl/private/gid/gid-decoding_bmp.adb Normal file
View File

@@ -0,0 +1,122 @@
with GID.Buffering; use GID.Buffering;
package body GID.Decoding_BMP is
procedure Load (image: in out Image_descriptor) is
b01, b, br, bg, bb: U8:= 0;
x, x_max, y: Natural;
--
procedure Pixel_with_palette is
pragma Inline(Pixel_with_palette);
begin
case Primary_color_range'Modulus is
when 256 =>
Put_Pixel(
Primary_color_range(image.palette(Integer(b)).red),
Primary_color_range(image.palette(Integer(b)).green),
Primary_color_range(image.palette(Integer(b)).blue),
255
);
when 65_536 =>
Put_Pixel(
16#101# * Primary_color_range(image.palette(Integer(b)).red),
16#101# * Primary_color_range(image.palette(Integer(b)).green),
16#101# * Primary_color_range(image.palette(Integer(b)).blue),
65_535
-- 16#101# because max intensity FF goes to FFFF
);
when others =>
raise invalid_primary_color_range;
end case;
end Pixel_with_palette;
--
pair: Boolean;
bit: Natural range 0..7;
--
line_bits: constant Float:= Float(image.width * image.bits_per_pixel);
padded_line_size: constant Positive:= 4 * Integer(Float'Ceiling(line_bits / 32.0));
unpadded_line_size: constant Positive:= Integer(Float'Ceiling(line_bits / 8.0));
-- (in bytes)
begin
Attach_Stream(image.buffer, image.stream);
y:= 0;
while y <= image.height-1 loop
x:= 0;
x_max:= image.width-1;
case image.bits_per_pixel is
when 1 => -- B/W
bit:= 0;
Set_X_Y(x,y);
while x <= x_max loop
if bit=0 then
Get_Byte(image.buffer, b01);
end if;
b:= (b01 and 16#80#) / 16#80#;
Pixel_with_palette;
b01:= b01 * 2; -- cannot overflow.
if bit=7 then
bit:= 0;
else
bit:= bit + 1;
end if;
x:= x + 1;
end loop;
when 4 => -- 16 colour image
pair:= True;
Set_X_Y(x,y);
while x <= x_max loop
if pair then
Get_Byte(image.buffer, b01);
b:= (b01 and 16#F0#) / 16#10#;
else
b:= (b01 and 16#0F#);
end if;
pair:= not pair;
Pixel_with_palette;
x:= x + 1;
end loop;
when 8 => -- 256 colour image
Set_X_Y(x,y);
while x <= x_max loop
Get_Byte(image.buffer, b);
Pixel_with_palette;
x:= x + 1;
end loop;
when 24 => -- RGB, 256 colour per primary colour
Set_X_Y(x,y);
while x <= x_max loop
Get_Byte(image.buffer, bb);
Get_Byte(image.buffer, bg);
Get_Byte(image.buffer, br);
case Primary_color_range'Modulus is
when 256 =>
Put_Pixel(
Primary_color_range(br),
Primary_color_range(bg),
Primary_color_range(bb),
255
);
when 65_536 =>
Put_Pixel(
256 * Primary_color_range(br),
256 * Primary_color_range(bg),
256 * Primary_color_range(bb),
65_535
);
when others =>
raise invalid_primary_color_range;
end case;
x:= x + 1;
end loop;
when others =>
null;
end case;
for i in unpadded_line_size + 1 .. padded_line_size loop
Get_Byte(image.buffer, b);
end loop;
y:= y + 1;
Feedback((y*100)/image.height);
end loop;
end Load;
end GID.Decoding_BMP;

18
3-mid/opengl/private/gid/gid-decoding_bmp.ads Normal file
View File

@@ -0,0 +1,18 @@
private package GID.Decoding_BMP is
--------------------
-- Image decoding --
--------------------
generic
type Primary_color_range is mod <>;
with procedure Set_X_Y (x, y: Natural);
with procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
);
with procedure Feedback (percents: Natural);
--
procedure Load (image: in out Image_descriptor);
end GID.Decoding_BMP;

597
3-mid/opengl/private/gid/gid-decoding_gif.adb Normal file
View File

@@ -0,0 +1,597 @@
-- A GIF stream is made of several "blocks".
-- The image itself is contained in an Image Descriptor block.
--
with GID.Buffering, GID.Color_tables;
with Ada.Exceptions, Ada.Text_IO;
package body GID.Decoding_GIF is
generic
type Number is mod <>;
procedure Read_Intel_x86_number(
from : in out Input_buffer;
n : out Number
);
pragma Inline(Read_Intel_x86_number);
procedure Read_Intel_x86_number(
from : in out Input_buffer;
n : out Number
)
is
b: U8;
m: Number:= 1;
begin
n:= 0;
for i in 1..Number'Size/8 loop
GID.Buffering.Get_Byte(from, b);
n:= n + m * Number(b);
m:= m * 256;
end loop;
end Read_Intel_x86_number;
procedure Read_Intel is new Read_Intel_x86_number( U16 );
----------
-- Load --
----------
procedure Load (
image : in out Image_descriptor;
next_frame: out Ada.Calendar.Day_Duration
)
is
local: Image_descriptor;
-- With GIF, each frame is a local image with an eventual
-- palette, different dimensions, etc. ...
use GID.Buffering, Ada.Exceptions;
type GIFDescriptor is record
ImageLeft,
ImageTop,
ImageWidth,
ImageHeight : U16;
Depth : U8;
end record;
-- For loading from the GIF file
Descriptor : GIFDescriptor;
-- Coordinates
X, tlX, brX : Natural;
Y, tlY, brY : Natural;
-- Code information
subtype Code_size_range is Natural range 2..12;
CurrSize : Code_size_range;
subtype Color_type is U8;
Transp_color : Color_type:= 0;
-- GIF data is stored in blocks and sub-blocks.
-- We initialize block_read and block_size to force
-- reading and buffering the next sub-block
block_size : Natural:= 0;
block_read : Natural:= 0;
function Read_Byte return U8 is
pragma Inline(Read_Byte);
b: U8;
use Ada.Streams;
begin
if block_read >= block_size then
Get_Byte(image.buffer, b);
block_size:= Natural(b);
block_read:= 0;
end if;
Get_Byte(image.buffer, b);
block_read:= block_read + 1;
return b;
end Read_Byte;
-- Used while reading the codes
bits_in : U8:= 8;
bits_buf: U8;
-- Local procedure to read the next code from the file
function Read_Code return Natural is
bit_mask: Natural:= 1;
code: Natural:= 0;
begin
-- Read the code, bit by bit
for Counter in reverse 0..CurrSize - 1 loop
-- Next bit
bits_in:= bits_in + 1;
-- Maybe, a new byte needs to be loaded with a further 8 bits
if bits_in = 9 then
bits_buf:= Read_Byte;
bits_in := 1;
end if;
-- Add the current bit to the code
if (bits_buf and 1) > 0 then
code:= code + bit_mask;
end if;
bit_mask := bit_mask * 2;
bits_buf := bits_buf / 2;
end loop;
return code;
end Read_Code;
generic
-- Parameter(s) that are constant through
-- the whole image. Macro-expanded generics and
-- some optimization will trim corresponding "if's"
interlaced : Boolean;
transparency : Boolean;
pixel_mask : U32;
--
procedure GIF_Decode;
procedure GIF_Decode is
procedure Pixel_with_palette(b: U8) is
pragma Inline(Pixel_with_palette);
begin
if transparency and then b = Transp_color then
Put_Pixel(0,0,0, 0);
return;
end if;
case Primary_color_range'Modulus is
when 256 =>
Put_Pixel(
Primary_color_range(local.palette(Integer(b)).red),
Primary_color_range(local.palette(Integer(b)).green),
Primary_color_range(local.palette(Integer(b)).blue),
255
);
when 65_536 =>
Put_Pixel(
16#101# * Primary_color_range(local.palette(Integer(b)).red),
16#101# * Primary_color_range(local.palette(Integer(b)).green),
16#101# * Primary_color_range(local.palette(Integer(b)).blue),
-- 16#101# because max intensity FF goes to FFFF
65_535
);
when others =>
raise invalid_primary_color_range;
end case;
end Pixel_with_palette;
-- Interlacing
Interlace_pass : Natural range 1..4:= 1;
Span : Natural:= 7;
-- Local procedure to draw a pixel
procedure Next_Pixel(code: Natural) is
pragma Inline(Next_Pixel);
c : constant Color_Type:= Color_type(U32(code) and pixel_mask);
begin
-- Actually draw the pixel on screen buffer
if X < image.width then
if interlaced and mode = nice then
for i in reverse 0..Span loop
if Y+i < image.height then
Set_X_Y(X, image.height - (Y+i) - 1);
Pixel_with_palette(c);
end if;
end loop;
elsif Y < image.height then
Pixel_with_palette(c);
end if;
end if;
-- Move on to next pixel
X:= X + 1;
-- Or next row, if necessary
if X = brX then
X:= tlX;
if interlaced then
case Interlace_pass is
when 1 =>
Y:= Y + 8;
if Y >= brY then
Y:= 4;
Interlace_pass:= 2;
Span:= 3;
Feedback((Interlace_pass*100)/4);
end if;
when 2 =>
Y:= Y + 8;
if Y >= brY then
Y:= 2;
Interlace_pass:= 3;
Span:= 1;
Feedback((Interlace_pass*100)/4);
end if;
when 3 =>
Y:= Y + 4;
if Y >= brY then
Y:= 1;
Interlace_pass:= 4;
Span:= 0;
Feedback((Interlace_pass*100)/4);
end if;
when 4 =>
Y:= Y + 2;
end case;
if mode = fast and then Y < image.height then
Set_X_Y(X, image.height - Y - 1);
end if;
else -- not interlaced
Y:= Y + 1;
if Y < image.height then
Set_X_Y(X, image.height - Y - 1);
end if;
if Y mod 32 = 0 then
Feedback((Y*100)/image.height);
end if;
end if;
end if;
end Next_Pixel;
-- The string table
Prefix : array ( 0..4096 ) of Natural:= (others => 0);
Suffix : array ( 0..4096 ) of Natural:= (others => 0);
Stack : array ( 0..1024 ) of Natural;
-- Special codes (specific to GIF's flavour of LZW)
ClearCode : constant Natural:= 2 ** CurrSize; -- Reset code
EndingCode: constant Natural:= ClearCode + 1; -- End of file
FirstFree : constant Natural:= ClearCode + 2; -- Strings start here
Slot : Natural:= FirstFree; -- Last read code
InitCodeSize : constant Code_size_range:= CurrSize + 1;
TopSlot : Natural:= 2 ** InitCodeSize; -- Highest code for current size
Code : Natural;
StackPtr : Integer:= 0;
Fc : Integer:= 0;
Oc : Integer:= 0;
C : Integer;
BadCodeCount : Natural:= 0; -- the number of bad codes found
begin -- GIF_Decode
-- The decoder source and the cool comments are kindly donated by
-- André van Splunter.
--
CurrSize:= InitCodeSize;
-- This is the main loop. For each code we get we pass through the
-- linked list of prefix codes, pushing the corresponding "character"
-- for each code onto the stack. When the list reaches a single
-- "character" we push that on the stack too, and then start unstacking
-- each character for output in the correct order. Special handling is
-- included for the clear code, and the whole thing ends when we get
-- an ending code.
C := Read_Code;
while C /= EndingCode loop
-- If the code is a clear code, reinitialize all necessary items.
if C = ClearCode then
CurrSize := InitCodeSize;
Slot := FirstFree;
TopSlot := 2 ** CurrSize;
-- Continue reading codes until we get a non-clear code
-- (Another unlikely, but possible case...)
C := Read_Code;
while C = ClearCode loop
C := Read_Code;
end loop;
-- If we get an ending code immediately after a clear code
-- (Yet another unlikely case), then break out of the loop.
exit when C = EndingCode;
-- Finally, if the code is beyond the range of already set codes,
-- (This one had better NOT happen... I have no idea what will
-- result from this, but I doubt it will look good...) then set
-- it to color zero.
if C >= Slot then
C := 0;
end if;
Oc := C;
Fc := C;
-- And let us not forget to output the char...
Next_Pixel(C);
else -- C /= ClearCode
-- In this case, it's not a clear code or an ending code, so
-- it must be a code code... So we can now decode the code into
-- a stack of character codes. (Clear as mud, right?)
Code := C;
-- Here we go again with one of those off chances... If, on the
-- off chance, the code we got is beyond the range of those
-- already set up (Another thing which had better NOT happen...)
-- we trick the decoder into thinking it actually got the last
-- code read. (Hmmn... I'm not sure why this works...
-- But it does...)
if Code >= Slot then
if Code > Slot then
BadCodeCount := BadCodeCount + 1;
end if;
Code := Oc;
Stack (StackPtr) := Fc rem 256;
StackPtr := StackPtr + 1;
end if;
-- Here we scan back along the linked list of prefixes, pushing
-- helpless characters (ie. suffixes) onto the stack as we do so.
while Code >= FirstFree loop
Stack (StackPtr) := Suffix (Code);
StackPtr := StackPtr + 1;
Code := Prefix (Code);
end loop;
-- Push the last character on the stack, and set up the new
-- prefix and suffix, and if the required slot number is greater
-- than that allowed by the current bit size, increase the bit
-- size. (NOTE - If we are all full, we *don't* save the new
-- suffix and prefix... I'm not certain if this is correct...
-- it might be more proper to overwrite the last code...
Stack (StackPtr) := Code rem 256;
if Slot < TopSlot then
Suffix (Slot) := Code rem 256;
Fc := Code;
Prefix (Slot) := Oc;
Slot := Slot + 1;
Oc := C;
end if;
if Slot >= TopSlot then
if CurrSize < 12 then
TopSlot := TopSlot * 2;
CurrSize := CurrSize + 1;
end if;
end if;
-- Now that we've pushed the decoded string (in reverse order)
-- onto the stack, lets pop it off and output it...
loop
Next_Pixel(Stack (StackPtr));
exit when StackPtr = 0;
StackPtr := StackPtr - 1;
end loop;
end if;
C := Read_Code;
end loop;
if full_trace and then BadCodeCount > 0 then
Ada.Text_IO.Put_Line(
"Found" & Integer'Image(BadCodeCount) &
" bad codes"
);
end if;
end GIF_Decode;
-- Here we have several specialized instances of GIF_Decode,
-- with parameters known at compile-time -> optimizing compilers
-- will skip expensive tests about interlacing, transparency.
--
procedure GIF_Decode_interlaced_transparent_8 is
new GIF_Decode(True, True, 255);
procedure GIF_Decode_straight_transparent_8 is
new GIF_Decode(False, True, 255);
procedure GIF_Decode_interlaced_opaque_8 is
new GIF_Decode(True, False, 255);
procedure GIF_Decode_straight_opaque_8 is
new GIF_Decode(False, False, 255);
--
procedure Skip_sub_blocks is
temp: U8;
begin
sub_blocks_sequence:
loop
Get_Byte(image.buffer, temp ); -- load sub-block length byte
exit sub_blocks_sequence when temp = 0;
-- null sub-block = end of sub-block sequence
for i in 1..temp loop
Get_Byte(image.buffer, temp ); -- load sub-block byte
end loop;
end loop sub_blocks_sequence;
end Skip_sub_blocks;
temp, temp2, label: U8;
delay_frame: U16;
c: Character;
frame_interlaced: Boolean;
frame_transparency: Boolean:= False;
local_palette : Boolean;
--
separator : Character ;
-- Colour information
new_num_of_colours : Natural;
pixel_mask : U32;
BitsPerPixel : Natural;
begin -- Load
next_frame:= 0.0;
-- Scan various GIF blocks, until finding an image
loop
Get_Byte(image.buffer, temp);
separator:= Character'Val(temp);
if full_trace then
Ada.Text_IO.Put(
"GIF separator [" & separator &
"][" & U8'Image(temp) & ']'
);
end if;
case separator is
when ',' => -- 16#2C#
exit;
-- Image descriptor will begin
-- See: 20. Image Descriptor
when ';' => -- 16#3B#
if full_trace then
Ada.Text_IO.Put(" - End of GIF");
end if;
image.next_frame:= 0.0;
next_frame:= image.next_frame;
return; -- End of GIF image
when '!' => -- 16#21# Extensions
if full_trace then
Ada.Text_IO.Put(" - Extension");
end if;
Get_Byte(image.buffer, label );
case label is
when 16#F9# => -- See: 23. Graphic Control Extension
if full_trace then
Ada.Text_IO.Put_Line(" - Graphic Control Extension");
end if;
Get_Byte(image.buffer, temp );
if temp /= 4 then
Raise_Exception(
error_in_image_data'Identity,
"GIF: error in Graphic Control Extension"
);
end if;
Get_Byte(image.buffer, temp );
-- Reserved 3 Bits
-- Disposal Method 3 Bits
-- User Input Flag 1 Bit
-- Transparent Color Flag 1 Bit
frame_transparency:= (temp and 1) = 1;
Read_Intel(image.buffer, delay_frame);
image.next_frame:=
image.next_frame + Ada.Calendar.Day_Duration(delay_frame) / 100.0;
next_frame:= image.next_frame;
Get_Byte(image.buffer, temp );
Transp_color:= Color_Type(temp);
-- zero sub-block:
Get_Byte(image.buffer, temp );
when 16#FE# => -- See: 24. Comment Extension
if full_trace then
Ada.Text_IO.Put_Line(" - Comment Extension");
sub_blocks_sequence:
loop
Get_Byte(image.buffer, temp ); -- load sub-block length byte
exit sub_blocks_sequence when temp = 0;
-- null sub-block = end of sub-block sequence
for i in 1..temp loop
Get_Byte(image.buffer, temp2);
c:= Character'Val(temp2);
Ada.Text_IO.Put(c);
end loop;
end loop sub_blocks_sequence;
Ada.Text_IO.New_Line;
else
Skip_sub_blocks;
end if;
when 16#01# => -- See: 25. Plain Text Extension
if full_trace then
Ada.Text_IO.Put_Line(" - Plain Text Extension");
end if;
Skip_sub_blocks;
when 16#FF# => -- See: 26. Application Extension
if full_trace then
Ada.Text_IO.Put_Line(" - Application Extension");
end if;
Skip_sub_blocks;
when others =>
if full_trace then
Ada.Text_IO.Put_Line(" - Unused:" & U8'Image(label));
end if;
Skip_sub_blocks;
end case;
when others =>
Raise_Exception(
error_in_image_data'Identity,
"Unknown GIF separator: " & separator
);
end case;
end loop;
-- Load the image descriptor
Read_Intel(image.buffer, Descriptor.ImageLeft);
Read_Intel(image.buffer, Descriptor.ImageTop);
Read_Intel(image.buffer, Descriptor.ImageWidth);
Read_Intel(image.buffer, Descriptor.ImageHeight);
Get_Byte(image.buffer, Descriptor.Depth);
-- Get image corner coordinates
tlX := Natural(Descriptor.ImageLeft);
tlY := Natural(Descriptor.ImageTop);
brX := tlX + Natural(Descriptor.ImageWidth);
brY := tlY + Natural(Descriptor.ImageHeight);
-- Local Color Table Flag 1 Bit
-- Interlace Flag 1 Bit
-- Sort Flag 1 Bit
-- Reserved 2 Bits
-- Size of Local Color Table 3 Bits
--
frame_interlaced:= (Descriptor.Depth and 64) = 64;
local_palette:= (Descriptor.Depth and 128) = 128;
local.format:= GIF;
local.stream:= image.stream;
local.buffer:= image.buffer;
if local_palette then
-- Get amount of colours in image
BitsPerPixel := 1 + Natural(Descriptor.Depth and 7);
New_num_of_colours:= 2 ** BitsPerPixel;
-- 21. Local Color Table
local.palette:= new Color_table(0..New_num_of_colours-1);
Color_tables.Load_palette(local);
image.buffer:= local.buffer;
elsif image.palette = null then
Raise_Exception(
error_in_image_data'Identity,
"GIF: neither local, nor global palette"
);
else
-- Use global palette
New_num_of_colours:= 2 ** image.subformat_id;
-- usually <= 2** image.bits_per_pixel
-- Just copy main palette
local.palette:= new Color_table'(image.palette.all);
end if;
Pixel_mask:= U32(New_num_of_colours - 1);
if full_trace then
Ada.Text_IO.Put_Line(
" - Image, interlaced: " & Boolean'Image(frame_interlaced) &
"; local palette: " & Boolean'Image(local_palette) &
"; transparency: " & Boolean'Image(frame_transparency) &
"; transparency index:" & Color_type'Image(Transp_color)
);
end if;
-- Get initial code size
Get_Byte(image.buffer, temp );
if Natural(temp) not in Code_size_range then
Raise_Exception(
error_in_image_data'Identity,
"GIF: wrong LZW code size (must be in 2..12), is" &
U8'Image(temp)
);
end if;
CurrSize := Natural(temp);
-- Start at top left of image
X := Natural(Descriptor.ImageLeft);
Y := Natural(Descriptor.ImageTop);
Set_X_Y(X, image.height - Y - 1);
--
if new_num_of_colours < 256 then
-- "Rare" formats -> no need of best speed
declare
-- We create an instance with dynamic parameters
procedure GIF_Decode_general is
new GIF_Decode(frame_interlaced, frame_transparency, pixel_mask);
begin
GIF_Decode_general;
end;
else
-- 8 bit, usual format: we try to make things
-- faster with specialized instanciations...
if frame_interlaced then
if frame_transparency then
GIF_Decode_interlaced_transparent_8;
else
GIF_Decode_interlaced_opaque_8;
end if;
else -- straight (non-interlaced)
if frame_transparency then
GIF_Decode_straight_transparent_8;
else
GIF_Decode_straight_opaque_8;
end if;
end if;
end if;
Feedback(100);
--
Get_Byte(image.buffer, temp ); -- zero-size sub-block
end Load;
end GID.Decoding_GIF;

22
3-mid/opengl/private/gid/gid-decoding_gif.ads Normal file
View File

@@ -0,0 +1,22 @@
private package GID.Decoding_GIF is
--------------------
-- Image decoding --
--------------------
generic
type Primary_color_range is mod <>;
with procedure Set_X_Y (x, y: Natural);
with procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
);
with procedure Feedback (percents: Natural);
mode: Display_mode;
--
procedure Load (
image : in out Image_descriptor;
next_frame: out Ada.Calendar.Day_Duration
);
end GID.Decoding_GIF;

1032
3-mid/opengl/private/gid/gid-decoding_jpg.adb Normal file
View File

File diff suppressed because it is too large Load Diff

89
3-mid/opengl/private/gid/gid-decoding_jpg.ads Normal file
View File

@@ -0,0 +1,89 @@
private package GID.Decoding_JPG is
use JPEG_defs;
type JPEG_marker is
(
SOI , -- Start Of Image
--
SOF_0 , -- Start Of Frame - Baseline DCT
SOF_1 , -- Extended sequential DCT
SOF_2 , -- Progressive DCT
SOF_3 , -- Lossless (sequential)
SOF_5 , -- Differential sequential DCT
SOF_6 , -- Differential progressive DCT
SOF_7 , -- Differential lossless (sequential)
SOF_8 , -- Reserved for JPEG extensions
SOF_9 , -- Extended sequential DCT
SOF_10 , -- Progressive DCT
SOF_11 , -- Lossless (sequential)
SOF_13 , -- Differential sequential DCT
SOF_14 , -- Differential progressive DCT
SOF_15 , -- Differential lossless (sequential)
--
DHT , -- Define Huffman Table
DAC , -- Define Arithmetic Coding
DQT , -- Define Quantization Table
DRI , -- Define Restart Interval
--
APP_0 , -- JFIF - JFIF JPEG image - AVI1 - Motion JPEG (MJPG)
APP_1 , -- EXIF Metadata, TIFF IFD format, JPEG Thumbnail (160x120)
APP_2 , -- ICC color profile, FlashPix
APP_3 ,
APP_4 ,
APP_5 ,
APP_6 ,
APP_7 ,
APP_8 ,
APP_9 ,
APP_10 ,
APP_11 ,
APP_12 , -- Picture Info
APP_13 , -- Photoshop Save As: IRB, 8BIM, IPTC
APP_14 , -- Copyright Entries
--
COM , -- Comments
SOS , -- Start of Scan
EOI -- End of Image
);
YCbCr_set : constant Compo_set:= (Y|Cb|Cr => True, others => False);
Y_Grey_set: constant Compo_set:= (Y => True, others => False);
CMYK_set : constant Compo_set:= (Y|Cb|Cr|I => True, others => False);
type Segment_head is record
length : U16;
kind : JPEG_marker;
end record;
procedure Read(image: in out Image_descriptor; sh: out Segment_head);
-- SOF - Start Of Frame (the real header)
procedure Read_SOF(image: in out Image_descriptor; sh: Segment_head);
procedure Read_DHT(image: in out Image_descriptor; data_length: Natural);
procedure Read_DQT(image: in out Image_descriptor; data_length: Natural);
procedure Read_DRI(image: in out Image_descriptor);
procedure Read_EXIF(image: in out Image_descriptor; data_length: Natural);
--------------------
-- Image decoding --
--------------------
generic
type Primary_color_range is mod <>;
with procedure Set_X_Y (x, y: Natural);
with procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
);
with procedure Feedback (percents: Natural);
-- mode: Display_mode; -- nice -> progressive nicely displayed
--
procedure Load (
image : in out Image_descriptor;
next_frame: out Ada.Calendar.Day_Duration
);
end GID.Decoding_JPG;

367
3-mid/opengl/private/gid/gid-decoding_png-huffman.adb Normal file
View File

@@ -0,0 +1,367 @@
with Ada.Text_IO;
with Ada.Unchecked_Deallocation;
package body GID.Decoding_PNG.Huffman is
procedure Build(t: out Huff_tree; descr: in Huff_descriptor) is
curr, alloc: Natural;
code, mask: Unsigned_32;
begin
alloc:= root;
for i in descr'Range loop
if descr(i).length > 0 then
curr:= root;
code:= Unsigned_32(descr(i).code);
mask:= Shift_Left(Unsigned_32'(1), descr(i).length-1);
for j in 0..descr(i).length-1 loop
if (code and mask) /= 0 then
if t.node(curr).one = nil then
alloc:= alloc + 1;
t.node(curr).one:= alloc;
end if;
curr:= t.node(curr).one;
else
if t.node(curr).zero = nil then
alloc:= alloc + 1;
t.node(curr).zero:= alloc;
end if;
curr:= t.node(curr).zero;
end if;
mask:= Shift_Right(mask, 1);
end loop;
t.node(curr).n:= i;
end if;
end loop;
t.last:= alloc;
end Build;
-- Free huffman tables starting with table where t points to
procedure HufT_free ( tl: in out p_Table_list ) is
procedure Dispose is new
Ada.Unchecked_Deallocation( HufT_table, p_HufT_table );
procedure Dispose is new
Ada.Unchecked_Deallocation( Table_list, p_Table_list );
current: p_Table_list;
tcount : Natural; -- just a stat. Idea: replace table_list with an array
tot_length: Natural;
begin
if full_trace then
Ada.Text_IO.Put("[HufT_Free... ");
tcount:= 0;
tot_length:= 0;
end if;
while tl /= null loop
if full_trace then
tcount:= tcount+1;
tot_length:= tot_length + tl.table'Length;
end if;
Dispose( tl.table ); -- destroy the Huffman table
current:= tl;
tl := tl.next;
Dispose( current ); -- destroy the current node
end loop;
if full_trace then
Ada.Text_IO.Put_Line(
Integer'Image(tcount)& " tables, of" &
Integer'Image(tot_length)& " tot. length]"
);
end if;
end HufT_free;
-- Build huffman table from code lengths given by array b
procedure HufT_build ( b : Length_array;
s : Integer;
d, e : Length_array;
tl : out p_Table_list;
m : in out Integer;
huft_incomplete : out Boolean)
is
b_max : constant:= 16;
b_maxp1: constant:= b_max + 1;
-- bit length count table
count : array( 0 .. b_maxp1 ) of Integer:= (others=> 0);
f : Integer; -- i repeats in table every f entries
g : Integer; -- max. code length
i, -- counter, current code
j : Integer; -- counter
kcc : Integer; -- number of bits in current code
c_idx, v_idx: Natural; -- array indices
current_table_ptr : p_HufT_table:= null;
current_node_ptr : p_Table_list:= null; -- curr. node for the curr. table
new_node_ptr : p_Table_list; -- new node for the new table
new_entry: HufT; -- table entry for structure assignment
u : array( 0..b_max ) of p_HufT_table; -- table stack
n_max : constant:= 288;
-- values in order of bit length
v : array( 0..n_max ) of Integer:= (others=> 0);
el_v, el_v_m_s: Integer;
w : Natural:= 0; -- bits before this table
offset, code_stack : array( 0..b_maxp1 ) of Integer;
table_level : Integer:= -1;
bits : array( Integer'(-1)..b_maxp1 ) of Integer;
-- ^bits(table_level) = # bits in table of level table_level
y : Integer; -- number of dummy codes added
z : Natural:= 0; -- number of entries in current table
el : Integer; -- length of eob code=code 256
no_copy_length_array: constant Boolean:= d'Length=0 or e'Length=0;
begin
if full_trace then
Ada.Text_IO.Put("[HufT_Build...");
end if;
tl:= null;
if b'Length > 256 then -- set length of EOB code, if any
el := b(256);
else
el := b_max;
end if;
-- Generate counts for each bit length
for k in b'Range loop
if b(k) > b_max then
-- m := 0; -- GNAT 2005 doesn't like it (warning).
raise huft_error;
end if;
count( b(k) ):= count( b(k) ) + 1;
end loop;
if count(0) = b'Length then
m := 0;
huft_incomplete:= False; -- spotted by Tucker Taft, 19-Aug-2004
return; -- complete
end if;
-- Find minimum and maximum length, bound m by those
j := 1;
while j <= b_max and then count(j) = 0 loop
j:= j + 1;
end loop;
kcc := j;
if m < j then
m := j;
end if;
i := b_max;
while i > 0 and then count(i) = 0 loop
i:= i - 1;
end loop;
g := i;
if m > i then
m := i;
end if;
-- Adjust last length count to fill out codes, if needed
y := Integer( Shift_Left(Unsigned_32'(1), j) ); -- y:= 2 ** j;
while j < i loop
y := y - count(j);
if y < 0 then
raise huft_error;
end if;
y:= y * 2;
j:= j + 1;
end loop;
y:= y - count(i);
if y < 0 then
raise huft_error;
end if;
count(i):= count(i) + y;
-- Generate starting offsets into the value table for each length
offset(1) := 0;
j:= 0;
for idx in 2..i loop
j:= j + count( idx-1 );
offset( idx ) := j;
end loop;
-- Make table of values in order of bit length
for idx in b'Range loop
j := b(idx);
if j /= 0 then
v( offset(j) ) := idx-b'First;
offset(j):= offset(j) + 1;
end if;
end loop;
-- Generate huffman codes and for each, make the table entries
code_stack(0) := 0;
i := 0;
v_idx:= v'First;
bits(-1) := 0;
-- go through the bit lengths (kcc already is bits in shortest code)
for k in kcc .. g loop
for am1 in reverse 0 .. count(k)-1 loop -- a counts codes of length k
-- here i is the huffman code of length k bits for value v(v_idx)
while k > w + bits(table_level) loop
w:= w + bits(table_level); -- Length of tables to this position
table_level:= table_level+ 1;
z:= g - w; -- Compute min size table <= m bits
if z > m then
z := m;
end if;
j := k - w;
f := Integer(Shift_Left(Unsigned_32'(1), j)); -- f:= 2 ** j;
if f > am1 + 2 then -- Try a k-w bit table
f:= f - (am1 + 2);
c_idx:= k;
loop -- Try smaller tables up to z bits
j:= j + 1;
exit when j >= z;
f := f * 2;
c_idx:= c_idx + 1;
exit when f - count(c_idx) <= 0;
f:= f - count(c_idx);
end loop;
end if;
if w + j > el and then w < el then
j:= el - w; -- Make EOB code end at table
end if;
if w = 0 then
j := m; -- Fix: main table always m bits!
end if;
z:= Integer(Shift_Left(Unsigned_32'(1), j)); -- z:= 2 ** j;
bits(table_level) := j;
-- Allocate and link new table
begin
current_table_ptr := new HufT_table ( 0..z );
new_node_ptr := new Table_list'( current_table_ptr, null );
exception
when Storage_Error =>
raise huft_out_of_memory;
end;
if current_node_ptr = null then -- first table
tl:= new_node_ptr;
else
current_node_ptr.next:= new_node_ptr; -- not my first...
end if;
current_node_ptr:= new_node_ptr; -- always non-Null from there
u( table_level ):= current_table_ptr;
-- Connect to last table, if there is one
if table_level > 0 then
code_stack(table_level) := i;
new_entry.bits := bits(table_level-1);
new_entry.extra_bits := 16 + j;
new_entry.next_table := current_table_ptr;
j := Integer(
Shift_Right( Unsigned_32(i) and
(Shift_Left(Unsigned_32'(1), w) - 1 ),
w - bits(table_level-1) )
);
-- Test against bad input!
if j > u( table_level - 1 )'Last then
raise huft_error;
end if;
u( table_level - 1 ) (j) := new_entry;
end if;
end loop;
-- Set up table entry in new_entry
new_entry.bits := k - w;
new_entry.next_table:= null; -- Unused
if v_idx >= b'Length then
new_entry.extra_bits := invalid;
else
el_v:= v(v_idx);
el_v_m_s:= el_v - s;
if el_v_m_s < 0 then -- Simple code, raw value
if el_v < 256 then
new_entry.extra_bits:= 16;
else
new_entry.extra_bits:= 15;
end if;
new_entry.n := el_v;
else -- Non-simple -> lookup in lists
if no_copy_length_array then
raise huft_error;
end if;
new_entry.extra_bits := e( el_v_m_s );
new_entry.n := d( el_v_m_s );
end if;
v_idx:= v_idx + 1;
end if;
-- fill code-like entries with new_entry
f := Integer( Shift_Left( Unsigned_32'(1) , k - w ));
-- i.e. f := 2 ** (k-w);
j := Integer( Shift_Right( Unsigned_32(i), w ) );
while j < z loop
current_table_ptr(j) := new_entry;
j:= j + f;
end loop;
-- backwards increment the k-bit code i
j := Integer( Shift_Left( Unsigned_32'(1) , k - 1 ));
-- i.e.: j:= 2 ** (k-1)
while ( Unsigned_32(i) and Unsigned_32(j) ) /= 0 loop
i := Integer( Unsigned_32(i) xor Unsigned_32(j) );
j := j / 2;
end loop;
i := Integer( Unsigned_32(i) xor Unsigned_32(j) );
-- backup over finished tables
while
Integer(Unsigned_32(i) and (Shift_Left(1, w)-1)) /=
code_stack(table_level)
loop
table_level:= table_level - 1;
w:= w - bits(table_level); -- Size of previous table!
end loop;
end loop; -- am1
end loop; -- k
if full_trace then
Ada.Text_IO.Put_Line("finished]");
end if;
huft_incomplete:= y /= 0 and g /= 1;
exception
when others =>
HufT_free( tl );
raise;
end HufT_build;
end GID.Decoding_PNG.Huffman;

88
3-mid/opengl/private/gid/gid-decoding_png-huffman.ads Normal file
View File

@@ -0,0 +1,88 @@
-- GID.Decoding_PNG.Huffman
---------------------------
-- Huffman tree generation and deletion.
-- Copy of UnZip.Decompress.Huffman
private package GID.Decoding_PNG.Huffman is
-- Variants A and B.
-- A/ Simplistic huffman trees, pointerless
type Length_code_pair is record
length: Natural;
code : Natural;
end record;
type Huff_descriptor is array(Natural range <>) of Length_code_pair;
nil: constant:= 0;
root: constant:= 1;
type Huff_node is record
n: Natural; -- value
zero, one: Natural:= nil; -- index of next node, if any
end record;
max_size: constant:= 800;
type Huff_node_list is array(1..max_size) of Huff_node;
type Huff_tree is record
last: Natural:= nil;
node: Huff_node_list;
end record;
procedure Build(t: out Huff_tree; descr: in Huff_descriptor);
-- B/ Huffman tables: several steps in the binary tree
-- in one jump.
-- Pro: probably faster
-- Contra: complicated, relies on pointers, large data.
type HufT_table;
type p_HufT_table is access HufT_table;
invalid: constant:= 99; -- invalid value for extra bits
type HufT is record
extra_bits : Natural:= invalid;
bits : Natural;
n : Natural;
next_table : p_HufT_table:= null;
end record;
type HufT_table is array( Integer range <> ) of aliased HufT;
type p_HufT is access all HufT;
-- Linked list just for destroying Huffman tables
type Table_list;
type p_Table_list is access Table_list;
type Table_list is record
table: p_HufT_table;
next : p_Table_list;
end record;
type Length_array is array(Integer range <>) of Natural;
empty : constant Length_array( 1..0 ):= ( others=> 0 );
-- Free huffman tables starting with table where t points to
procedure HufT_free ( tl: in out p_Table_list );
-- Build huffman table from code lengths given by array b.all
procedure HufT_build ( b : Length_array;
s : Integer;
d, e : Length_array;
tl : out p_Table_list;
m : in out Integer;
huft_incomplete : out Boolean);
-- Possible exceptions occuring in huft_build
huft_error, -- bad tree constructed
huft_out_of_memory: exception; -- not enough memory
end GID.Decoding_PNG.Huffman;

1537
3-mid/opengl/private/gid/gid-decoding_png.adb Normal file
View File

File diff suppressed because it is too large Load Diff

77
3-mid/opengl/private/gid/gid-decoding_png.ads Normal file
View File

@@ -0,0 +1,77 @@
private package GID.Decoding_PNG is
type PNG_Chunk_tag is (
--
-- Critical chunks
--
IHDR, -- must be the first chunk; it contains the header.
PLTE, -- contains the palette; list of colors.
IDAT, -- contains the image, which may be split among multiple IDAT chunks.
IEND, -- marks the image end.
--
-- Ancillary chunks
--
bKGD, -- gives the default background color.
cHRM, -- gives the chromaticity coordinates of the display primaries and white point.
gAMA, -- specifies gamma.
hIST, -- can store the histogram, or total amount of each color in the image.
iCCP, -- is an ICC color profile.
iTXt, -- contains UTF-8 text, compressed or not, with an optional language tag.
pHYs, -- holds the intended pixel size and/or aspect ratio of the image.
sBIT, -- (significant bits) indicates the color-accuracy of the source data.
sPLT, -- suggests a palette to use if the full range of colors is unavailable.
sRGB, -- indicates that the standard sRGB color space is used.
tEXt, -- can store text that can be represented in ISO/IEC 8859-1.
tIME, -- stores the time that the image was last changed.
tRNS, -- contains transparency information.
zTXt, -- contains compressed text with the same limits as tEXt.
--
-- Public extentions
-- PNG Extensions and Register of Public Chunks and Keywords
--
oFFs, -- image offset from frame or page origin
pCAL, -- physical calibration of pixel values
sCAL, -- physical scale of image subject
sTER, -- stereographic subimage layout
gIFg, -- GIF Graphic Control Extension
gIFx, -- GIF Application Extension
fRAc, -- fractal image parameters
--
-- Private chunks (not defined in the ISO standard)
--
vpAg, -- used in ImageMagick to store "virtual page" size
spAL,
prVW,
cmOD,
cmPP,
cpIp,
mkBF,
mkBS,
mkBT,
mkTS,
pcLb
);
type Chunk_head is record
length: U32;
kind : PNG_Chunk_tag;
end record;
procedure Read( image: in out image_descriptor; ch: out Chunk_head);
--------------------
-- Image decoding --
--------------------
generic
type Primary_color_range is mod <>;
with procedure Set_X_Y (x, y: Natural);
with procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
);
with procedure Feedback (percents: Natural);
--
procedure Load (image: in out Image_descriptor);
end GID.Decoding_PNG;

283
3-mid/opengl/private/gid/gid-decoding_tga.adb Normal file
View File

@@ -0,0 +1,283 @@
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;

18
3-mid/opengl/private/gid/gid-decoding_tga.ads Normal file
View File

@@ -0,0 +1,18 @@
private package GID.Decoding_TGA is
--------------------
-- Image decoding --
--------------------
generic
type Primary_color_range is mod <>;
with procedure Set_X_Y (x, y: Natural);
with procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
);
with procedure Feedback (percents: Natural);
--
procedure Load (image: in out Image_descriptor);
end GID.Decoding_TGA;

584
3-mid/opengl/private/gid/gid-headers.adb Normal file
View File

@@ -0,0 +1,584 @@
---------------------------------
-- GID - Generic Image Decoder --
---------------------------------
--
-- Private child of GID, with helpers for identifying
-- image formats and reading header informations.
--
with GID.Buffering,
GID.Color_tables,
GID.Decoding_JPG,
GID.Decoding_PNG;
with Ada.Exceptions, Ada.Unchecked_Deallocation;
package body GID.Headers is
use Ada.Exceptions;
-------------------------------------------------------
-- The very first: read signature to identify format --
-------------------------------------------------------
procedure Load_signature (
image : in out Image_descriptor;
try_tga : Boolean:= False
)
is
use Bounded_255;
c, d: Character;
FITS_challenge: String(1..5); -- without the initial
GIF_challenge : String(1..5); -- without the initial
PNG_challenge : String(1..7); -- without the initial
PNG_signature: constant String:=
"PNG" & ASCII.CR & ASCII.LF & ASCII.SUB & ASCII.LF;
procedure Dispose is
new Ada.Unchecked_Deallocation(Color_table, p_Color_table);
begin
-- Some cleanup
Dispose(image.palette);
image.next_frame:= 0.0;
image.display_orientation:= Unchanged;
--
Character'Read(image.stream, c);
image.first_byte:= Character'Pos(c);
case c is
when 'B' =>
Character'Read(image.stream, c);
if c='M' then
image.detailed_format:= To_Bounded_String("BMP");
image.format:= BMP;
return;
end if;
when 'S' =>
String'Read(image.stream, FITS_challenge);
if FITS_challenge = "IMPLE" then
image.detailed_format:= To_Bounded_String("FITS");
image.format:= FITS;
return;
end if;
when 'G' =>
String'Read(image.stream, GIF_challenge);
if GIF_challenge = "IF87a" or GIF_challenge = "IF89a" then
image.detailed_format:= To_Bounded_String('G' & GIF_challenge & ", ");
image.format:= GIF;
return;
end if;
when 'I' | 'M' =>
Character'Read(image.stream, d);
if c=d then
if c = 'I' then
image.detailed_format:= To_Bounded_String("TIFF, little-endian");
else
image.detailed_format:= To_Bounded_String("TIFF, big-endian");
end if;
image.format:= TIFF;
return;
end if;
when Character'Val(16#FF#) =>
Character'Read(image.stream, c);
if c=Character'Val(16#D8#) then
-- SOI (Start of Image) segment marker (FFD8)
image.detailed_format:= To_Bounded_String("JPEG");
image.format:= JPEG;
return;
end if;
when Character'Val(16#89#) =>
String'Read(image.stream, PNG_challenge);
if PNG_challenge = PNG_signature then
image.detailed_format:= To_Bounded_String("PNG");
image.format:= PNG;
return;
end if;
when others =>
if try_tga then
image.detailed_format:= To_Bounded_String("TGA");
image.format:= TGA;
return;
else
raise unknown_image_format;
end if;
end case;
raise unknown_image_format;
end Load_signature;
generic
type Number is mod <>;
procedure Read_Intel_x86_number(
from : in Stream_Access;
n : out Number
);
pragma Inline(Read_Intel_x86_number);
generic
type Number is mod <>;
procedure Big_endian_number(
from : in out Input_buffer;
n : out Number
);
pragma Inline(Big_endian_number);
procedure Read_Intel_x86_number(
from : in Stream_Access;
n : out Number
)
is
b: U8;
m: Number:= 1;
begin
n:= 0;
for i in 1..Number'Size/8 loop
U8'Read(from, b);
n:= n + m * Number(b);
m:= m * 256;
end loop;
end Read_Intel_x86_number;
procedure Big_endian_number(
from : in out Input_buffer;
n : out Number
)
is
b: U8;
begin
n:= 0;
for i in 1..Number'Size/8 loop
Buffering.Get_Byte(from, b);
n:= n * 256 + Number(b);
end loop;
end Big_endian_number;
procedure Read_Intel is new Read_Intel_x86_number( U16 );
procedure Read_Intel is new Read_Intel_x86_number( U32 );
procedure Big_endian is new Big_endian_number( U32 );
----------------------------------------------------------
-- Loading of various format's headers (past signature) --
----------------------------------------------------------
----------------
-- BMP header --
----------------
procedure Load_BMP_header (image: in out Image_descriptor) is
n, dummy: U32;
pragma Warnings(off, dummy);
w, dummy16: U16;
pragma Warnings(off, dummy16);
begin
-- Pos= 3, read the file size
Read_Intel(image.stream, dummy);
-- Pos= 7, read four bytes, unknown
Read_Intel(image.stream, dummy);
-- Pos= 11, read four bytes offset, file top to bitmap data.
-- For 256 colors, this is usually 36 04 00 00
Read_Intel(image.stream, dummy);
-- Pos= 15. The beginning of Bitmap information header.
-- Data expected: 28H, denoting 40 byte header
Read_Intel(image.stream, dummy);
-- Pos= 19. Bitmap width, in pixels. Four bytes
Read_Intel(image.stream, n);
image.width:= Natural(n);
-- Pos= 23. Bitmap height, in pixels. Four bytes
Read_Intel(image.stream, n);
image.height:= Natural(n);
-- Pos= 27, skip two bytes. Data is number of Bitmap planes.
Read_Intel(image.stream, dummy16); -- perform the skip
-- Pos= 29, Number of bits per pixel
-- Value 8, denoting 256 color, is expected
Read_Intel(image.stream, w);
case w is
when 1 | 4 | 8 | 24 =>
null;
when others =>
Raise_exception(
unsupported_image_subformat'Identity,
"bit depth =" & U16'Image(w)
);
end case;
image.bits_per_pixel:= Integer(w);
-- Pos= 31, read four bytes
Read_Intel(image.stream, n); -- Type of compression used
-- BI_RLE8 = 1
-- BI_RLE4 = 2
if n /= 0 then
Raise_exception(
unsupported_image_subformat'Identity,
"RLE compression"
);
end if;
--
Read_Intel(image.stream, dummy); -- Pos= 35, image size
Read_Intel(image.stream, dummy); -- Pos= 39, horizontal resolution
Read_Intel(image.stream, dummy); -- Pos= 43, vertical resolution
Read_Intel(image.stream, n); -- Pos= 47, number of palette colors
if image.bits_per_pixel <= 8 then
if n = 0 then
image.palette:= new Color_Table(0..2**image.bits_per_pixel-1);
else
image.palette:= new Color_Table(0..Natural(n)-1);
end if;
end if;
Read_Intel(image.stream, dummy); -- Pos= 51, number of important colors
-- Pos= 55 (36H), - start of palette
Color_tables.Load_palette(image);
end Load_BMP_header;
procedure Load_FITS_header (image: in out Image_descriptor) is
begin
raise known_but_unsupported_image_format;
end Load_FITS_header;
----------------
-- GIF header --
----------------
procedure Load_GIF_header (image: in out Image_descriptor) is
-- GIF - logical screen descriptor
screen_width, screen_height : U16;
packed, background, aspect_ratio_code : U8;
global_palette: Boolean;
begin
Read_Intel(image.stream, screen_width);
Read_Intel(image.stream, screen_height);
image.width:= Natural(screen_width);
image.height:= Natural(screen_height);
image.transparency:= True; -- cannot exclude transparency at this level.
U8'Read(image.stream, packed);
-- Global Color Table Flag 1 Bit
-- Color Resolution 3 Bits
-- Sort Flag 1 Bit
-- Size of Global Color Table 3 Bits
global_palette:= (packed and 16#80#) /= 0;
image.bits_per_pixel:= Natural((packed and 16#7F#)/16#10#) + 1;
-- Indicative:
-- iv) [...] This value should be set to indicate the
-- richness of the original palette
U8'Read(image.stream, background);
U8'Read(image.stream, aspect_ratio_code);
Buffering.Attach_stream(image.buffer, image.stream);
if global_palette then
image.subformat_id:= 1+(Natural(packed and 16#07#));
-- palette's bits per pixels, usually <= image's
--
-- if image.subformat_id > image.bits_per_pixel then
-- Raise_exception(
-- error_in_image_data'Identity,
-- "GIF: global palette has more colors than the image" &
-- image.subformat_id'img & image.bits_per_pixel'img
-- );
-- end if;
image.palette:= new Color_Table(0..2**(image.subformat_id)-1);
Color_tables.Load_palette(image);
end if;
end Load_GIF_header;
-----------------
-- JPEG header --
-----------------
procedure Load_JPEG_header (image: in out Image_descriptor) is
-- http://en.wikipedia.org/wiki/JPEG
use GID.Decoding_JPG, GID.Buffering, Bounded_255;
sh: Segment_head;
b: U8;
begin
-- We have already passed the SOI (Start of Image) segment marker (FFD8).
image.JPEG_stuff.restart_interval:= 0;
Attach_stream(image.buffer, image.stream);
loop
Read(image, sh);
case sh.kind is
when DHT => -- Huffman Table
Read_DHT(image, Natural(sh.length));
when DQT =>
Read_DQT(image, Natural(sh.length));
when DRI => -- Restart Interval
Read_DRI(image);
when SOF_0 .. SOF_15 =>
Read_SOF(image, sh);
exit; -- we've got header-style informations, then it's time to quit
when APP_1 =>
Read_EXIF(image, Natural(sh.length));
when others =>
-- Skip segment data
for i in 1..sh.length loop
Get_Byte(image.buffer, b);
end loop;
end case;
end loop;
end Load_JPEG_header;
----------------
-- PNG header --
----------------
procedure Load_PNG_header (image: in out Image_descriptor) is
use Decoding_PNG, Buffering;
ch: Chunk_head;
n, dummy: U32;
pragma Warnings(off, dummy);
b, color_type: U8;
palette: Boolean:= False;
begin
Buffering.Attach_stream(image.buffer, image.stream);
Read(image, ch);
if ch.kind /= IHDR then
Raise_exception(
error_in_image_data'Identity,
"Expected 'IHDR' chunk as first chunk in PNG stream"
);
end if;
Big_endian(image.buffer, n);
if n = 0 then
Raise_exception(
error_in_image_data'Identity,
"PNG image with zero width"
);
end if;
image.width:= Natural(n);
Big_endian(image.buffer, n);
if n = 0 then
Raise_exception(
error_in_image_data'Identity,
"PNG image with zero height"
);
end if;
image.height:= Natural(n);
Get_Byte(image.buffer, b);
image.bits_per_pixel:= Integer(b);
Get_Byte(image.buffer, color_type);
image.subformat_id:= Integer(color_type);
case color_type is
when 0 => -- Greyscale
image.greyscale:= True;
case image.bits_per_pixel is
when 1 | 2 | 4 | 8 | 16 =>
null;
when others =>
Raise_exception(
error_in_image_data'Identity,
"PNG, type 0 (greyscale): wrong bit-per-channel depth"
);
end case;
when 2 => -- RGB TrueColor
case image.bits_per_pixel is
when 8 | 16 =>
image.bits_per_pixel:= 3 * image.bits_per_pixel;
when others =>
Raise_exception(
error_in_image_data'Identity,
"PNG, type 2 (RGB): wrong bit-per-channel depth"
);
end case;
when 3 => -- RGB with palette
palette:= True;
case image.bits_per_pixel is
when 1 | 2 | 4 | 8 =>
null;
when others =>
Raise_exception(
error_in_image_data'Identity,
"PNG, type 3: wrong bit-per-channel depth"
);
end case;
when 4 => -- Grey & Alpha
image.greyscale:= True;
image.transparency:= True;
case image.bits_per_pixel is
when 8 | 16 =>
image.bits_per_pixel:= 2 * image.bits_per_pixel;
when others =>
Raise_exception(
error_in_image_data'Identity,
"PNG, type 4 (Greyscale & Alpha): wrong bit-per-channel depth"
);
end case;
when 6 => -- RGBA
image.transparency:= True;
case image.bits_per_pixel is
when 8 | 16 =>
image.bits_per_pixel:= 4 * image.bits_per_pixel;
when others =>
Raise_exception(
error_in_image_data'Identity,
"PNG, type 6 (RGBA): wrong bit-per-channel depth"
);
end case;
when others =>
Raise_exception(
error_in_image_data'Identity,
"Unknown PNG color type"
);
end case;
Get_Byte(image.buffer, b);
if b /= 0 then
Raise_exception(
error_in_image_data'Identity,
"Unknown PNG compression; ISO/IEC 15948:2003" &
" knows only 'method 0' (deflate)"
);
end if;
Get_Byte(image.buffer, b);
if b /= 0 then
Raise_exception(
error_in_image_data'Identity,
"Unknown PNG filtering; ISO/IEC 15948:2003 knows only 'method 0'"
);
end if;
Get_Byte(image.buffer, b);
image.interlaced:= b = 1; -- Adam7
Big_endian(image.buffer, dummy); -- Chunk's CRC
if palette then
loop
Read(image, ch);
case ch.kind is
when IEND =>
Raise_exception(
error_in_image_data'Identity,
"PNG: there must be a palette, found IEND"
);
when PLTE =>
if ch.length rem 3 /= 0 then
Raise_exception(
error_in_image_data'Identity,
"PNG: palette chunk byte length must be a multiple of 3"
);
end if;
image.palette:= new Color_Table(0..Integer(ch.length/3)-1);
Color_tables.Load_palette(image);
Big_endian(image.buffer, dummy); -- Chunk's CRC
exit;
when others =>
-- skip chunk data and CRC
for i in 1..ch.length + 4 loop
Get_Byte(image.buffer, b);
end loop;
end case;
end loop;
end if;
end Load_PNG_header;
------------------------
-- TGA (Targa) header --
------------------------
procedure Load_TGA_header (image: in out Image_descriptor) is
-- TGA FILE HEADER, p.6
--
image_ID_length: U8; -- Field 1
color_map_type : U8; -- Field 2
image_type : U8; -- Field 3
-- Color Map Specification - Field 4
first_entry_index : U16; -- Field 4.1
color_map_length : U16; -- Field 4.2
color_map_entry_size: U8; -- Field 4.3
-- Image Specification - Field 5
x_origin: U16;
y_origin: U16;
image_width: U16;
image_height: U16;
pixel_depth: U8;
tga_image_descriptor: U8;
--
dummy: U8;
base_image_type: Integer;
begin
-- Read the header
image_ID_length:= image.first_byte;
U8'Read(image.stream, color_map_type);
U8'Read(image.stream, image_type);
-- Color Map Specification - Field 4
Read_Intel(image.stream, first_entry_index);
Read_Intel(image.stream, color_map_length);
U8'Read(image.stream, color_map_entry_size);
-- Image Specification - Field 5
Read_Intel(image.stream, x_origin);
Read_Intel(image.stream, y_origin);
Read_Intel(image.stream, image_width);
Read_Intel(image.stream, image_height);
U8'Read(image.stream, pixel_depth);
U8'Read(image.stream, tga_image_descriptor);
-- Done.
--
-- Image type:
-- 1 = 8-bit palette style
-- 2 = Direct [A]RGB image
-- 3 = grayscale
-- 9 = RLE version of Type 1
-- 10 = RLE version of Type 2
-- 11 = RLE version of Type 3
--
base_image_type:= U8'Pos(image_type and 7);
image.RLE_encoded:= (image_type and 8) /= 0;
--
if color_map_type /= 0 then
image.palette:= new Color_Table(
Integer(first_entry_index)..
Integer(first_entry_index)+Integer(color_map_length)-1
);
image.subformat_id:= Integer(color_map_entry_size);
case image.subformat_id is -- = palette's bit depth
when 8 => -- Grey
null;
when 15 | 16 => -- RGB 3*5 bit | RGBA 3*3+1 bit
null;
when 24 | 32 => -- RGB 3*8 bit | RGBA 4*8 bit
null;
when others =>
Raise_exception(
error_in_image_data'Identity,
"TGA color map (palette): wrong bit depth:" &
Integer'Image(image.subformat_id)
);
end case;
end if;
--
image.greyscale:= False; -- ev. overridden later
case base_image_type is
when 1 =>
image.greyscale:= color_map_entry_size = 8;
when 2 =>
null;
when 3 =>
image.greyscale:= True;
when others =>
Raise_exception(
unsupported_image_subformat'Identity,
"TGA type =" & Integer'Image(base_image_type)
);
end case;
image.width := U16'Pos(image_width);
image.height := U16'Pos(image_height);
image.bits_per_pixel := U8'Pos(pixel_depth);
-- Make sure we are loading a supported TGA_type
case image.bits_per_pixel is
when 32 | 24 | 16 | 15 | 8 =>
null;
when others =>
Raise_exception(
unsupported_image_subformat'Identity,
"TGA bits per pixels =" & Integer'Image(image.bits_per_pixel)
);
end case;
image.flag_1:= (tga_image_descriptor and 32) /= 0; -- top first
-- *** Image and color map data
-- * Image ID
for i in 1..image_ID_length loop
U8'Read( image.stream, dummy );
end loop;
-- * Color map data (palette)
Color_tables.Load_palette(image);
-- * Image data: Read by Load_image_contents.
end Load_TGA_header;
procedure Load_TIFF_header (image: in out Image_descriptor) is
begin
raise known_but_unsupported_image_format;
end Load_TIFF_header;
end;

31
3-mid/opengl/private/gid/gid-headers.ads Normal file
View File

@@ -0,0 +1,31 @@
---------------------------------
-- GID - Generic Image Decoder --
---------------------------------
--
-- Private child of GID, with helpers for identifying
-- image formats and reading header informations.
--
private package GID.Headers is
--
-- Crude image signature detection
--
procedure Load_signature (
image : in out Image_descriptor;
try_tga : Boolean:= False
);
--
-- Loading of various format's headers (past signature)
--
procedure Load_BMP_header (image: in out Image_descriptor);
procedure Load_FITS_header (image: in out Image_descriptor);
procedure Load_GIF_header (image: in out Image_descriptor);
procedure Load_JPEG_header (image: in out Image_descriptor);
procedure Load_PNG_header (image: in out Image_descriptor);
procedure Load_TGA_header (image: in out Image_descriptor);
procedure Load_TIFF_header (image: in out Image_descriptor);
end;

210
3-mid/opengl/private/gid/gid.adb Normal file
View File

@@ -0,0 +1,210 @@
---------------------------------
-- GID - Generic Image Decoder --
---------------------------------
--
-- Copyright (c) Gautier de Montmollin 2010
--
-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-- THE SOFTWARE.
--
-- NB: this is the MIT License, as found 2-May-2010 on the site
-- http://www.opensource.org/licenses/mit-license.php
with GID.Headers,
GID.Decoding_BMP,
GID.Decoding_GIF,
GID.Decoding_JPG,
GID.Decoding_PNG,
GID.Decoding_TGA;
with Ada.Unchecked_Deallocation;
package body GID is
-----------------------
-- Load_image_header --
-----------------------
procedure Load_image_header (
image : out Image_descriptor;
from : in out Ada.Streams.Root_Stream_Type'Class;
try_tga : Boolean:= False
)
is
begin
image.stream:= from'Unchecked_Access;
Headers.Load_signature(image, try_tga);
case image.format is
when BMP =>
Headers.Load_BMP_header(image);
when FITS =>
Headers.Load_FITS_header(image);
when GIF =>
Headers.Load_GIF_header(image);
when JPEG =>
Headers.Load_JPEG_header(image);
when PNG =>
Headers.Load_PNG_header(image);
when TGA =>
Headers.Load_TGA_header(image);
when TIFF =>
Headers.Load_TIFF_header(image);
end case;
end Load_image_header;
-----------------
-- Pixel_width --
-----------------
function Pixel_width (image: Image_descriptor) return Positive is
begin
return image.width;
end Pixel_width;
------------------
-- Pixel_height --
------------------
function Pixel_height (image: Image_descriptor) return Positive is
begin
return image.height;
end Pixel_height;
function Display_orientation (image: Image_descriptor) return Orientation is
begin
return image.display_orientation;
end Display_orientation;
-------------------------
-- Load_image_contents --
-------------------------
procedure Load_image_contents (
image : in out Image_descriptor;
next_frame: out Ada.Calendar.Day_Duration
)
is
procedure BMP_Load is
new Decoding_BMP.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
procedure GIF_Load is
new Decoding_GIF.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback, mode );
procedure JPG_Load is
new Decoding_JPG.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
procedure PNG_Load is
new Decoding_PNG.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
procedure TGA_Load is
new Decoding_TGA.Load( Primary_color_range, Set_X_Y, Put_Pixel, Feedback );
begin
next_frame:= 0.0;
-- ^ value updated in case of animation and when
-- current frame is not the last frame
case image.format is
when BMP =>
BMP_Load(image);
when GIF =>
GIF_Load(image, next_frame);
when JPEG =>
JPG_Load(image, next_frame);
when PNG =>
PNG_Load(image);
when TGA =>
TGA_Load(image);
when others =>
raise known_but_unsupported_image_format;
end case;
end Load_image_contents;
---------------------------------------
-- Some informations about the image --
---------------------------------------
function Format (image: Image_descriptor) return Image_format_type is
begin
return image.format;
end Format;
function Detailed_format (image: Image_descriptor) return String is
begin
return Bounded_255.To_String(image.detailed_format);
end Detailed_format;
function Subformat (image: Image_descriptor) return Integer is
begin
return image.subformat_id;
end Subformat;
function Bits_per_pixel (image: Image_descriptor) return Positive is
begin
return image.bits_per_pixel;
end Bits_per_pixel;
function RLE_encoded (image: Image_descriptor) return Boolean is
begin
return image.RLE_encoded;
end RLE_encoded;
function Interlaced (image: Image_descriptor) return Boolean is
begin
return image.interlaced;
end Interlaced;
function Greyscale (image: Image_descriptor) return Boolean is
begin
return image.greyscale;
end Greyscale;
function Has_palette (image: Image_descriptor) return Boolean is
begin
return image.palette /= null;
end Has_palette;
function Expect_transparency (image: Image_descriptor) return Boolean is
begin
return image.transparency;
end Expect_transparency;
procedure Adjust (Object : in out Image_descriptor) is
begin
-- Clone the palette
Object.palette:= new Color_table'(Object.palette.all);
end Adjust;
procedure Finalize (Object : in out Image_descriptor) is
procedure Dispose is
new Ada.Unchecked_Deallocation(Color_table, p_Color_table);
procedure Dispose is
new Ada.Unchecked_Deallocation(
JPEG_defs.VLC_table,
JPEG_defs.p_VLC_table
);
begin
-- Deterministic garbage collection
Dispose(Object.palette);
for ad in JPEG_defs.VLC_defs_type'Range(1) loop
for idx in JPEG_defs.VLC_defs_type'Range(2) loop
Dispose(Object.JPEG_stuff.vlc_defs(ad, idx));
end loop;
end loop;
end Finalize;
end GID;

304
3-mid/opengl/private/gid/gid.ads Normal file
View File

@@ -0,0 +1,304 @@
---------------------------------
-- GID - Generic Image Decoder --
---------------------------------
--
-- Purpose:
--
-- The Generic Image Decoder is a package for decoding a broad
-- variety of image formats, from any data stream, to any kind
-- of medium, be it an in-memory bitmap, a GUI object,
-- some other stream, arrays of floating-point initial data
-- for scientific calculations, a browser element, a device,...
-- Animations are supported.
--
-- The code is unconditionally portable, independent of the
-- choice of operating system, processor, endianess and compiler.
--
-- Image types currently supported:
--
-- BMP, GIF, JPEG, PNG, TGA
--
-- Credits:
--
-- - André van Splunter: GIF's LZW decoder
-- - Martin J. Fiedler: most of the JPEG decoder (from NanoJPEG)
--
-- More credits in gid_work.xls, sheet "credits".
--
-- Copyright (c) Gautier de Montmollin 2010..2012
--
-- Permission is hereby granted, free of charge, to any person obtaining a copy
-- of this software and associated documentation files (the "Software"), to deal
-- in the Software without restriction, including without limitation the rights
-- to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
-- copies of the Software, and to permit persons to whom the Software is
-- furnished to do so, subject to the following conditions:
--
-- The above copyright notice and this permission notice shall be included in
-- all copies or substantial portions of the Software.
--
-- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
-- IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
-- FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
-- AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
-- LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
-- OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
-- THE SOFTWARE.
--
-- NB: this is the MIT License, as found 2-May-2010 on the site
-- http://www.opensource.org/licenses/mit-license.php
with Ada.Calendar, Ada.Streams, Ada.Strings.Bounded, Ada.Finalization;
with Interfaces;
package GID is
type Image_descriptor is private;
---------------------------------------------------
-- 1) Load the image header from the data stream --
---------------------------------------------------
procedure Load_image_header (
image : out Image_descriptor;
from : in out Ada.Streams.Root_Stream_Type'Class;
try_tga : Boolean:= False
);
-- try_tga: if no known signature is found, assume it might be
-- the TGA format (which hasn't a signature) and try to load an
-- image of this format
unknown_image_format,
known_but_unsupported_image_format,
unsupported_image_subformat,
error_in_image_data,
invalid_primary_color_range: exception;
----------------------------------------------------------------------
-- 2) If needed, use dimensions to prepare the retrieval of the --
-- image, for instance: reserving an in-memory bitmap, sizing a --
-- GUI object, defining a browser element, setting up a device --
----------------------------------------------------------------------
function Pixel_width (image: Image_descriptor) return Positive;
function Pixel_height (image: Image_descriptor) return Positive;
-- "Unchanged" orientation has origin at top left
type Orientation is (
Unchanged,
Rotation_90, Rotation_180, Rotation_270
);
function Display_orientation (image: Image_descriptor) return Orientation;
--------------------------------------------------------------------
-- 3) Load and decode the image itself. If the image is animated, --
-- call Load_image_contents until next_frame is 0.0 --
--------------------------------------------------------------------
type Display_mode is (fast, nice);
-- For bitmap pictures, the result is exactly the same, but
-- interlaced images' larger pixels are drawn in full during decoding.
generic
type Primary_color_range is mod <>;
-- Coding of primary colors (red, green or blue)
-- and of opacity (also known as alpha channel), on the target "device".
-- Currently, only 8-bit and 16-bit are admitted.
-- 8-bit coding is usual: TrueColor, PC graphics, etc.;
-- 16-bit coding is seen in some high-end apps/devices/formats.
--
with procedure Set_X_Y (x, y: Natural);
-- After Set_X_Y, next pixel is meant to be displayed at position (x,y)
with procedure Put_Pixel (
red, green, blue : Primary_color_range;
alpha : Primary_color_range
);
-- When Put_Pixel is called twice without a Set_X_Y inbetween,
-- the pixel must be displayed on the next X position after the last one.
-- [ Rationale: if the image lands into an array with contiguous pixels
-- on the X axis, this approach allows full address calculation to be
-- made only at the beginning of each row, which is much faster ]
--
with procedure Feedback (percents: Natural);
--
mode: Display_mode;
--
procedure Load_image_contents (
image : in out Image_descriptor;
next_frame: out Ada.Calendar.Day_Duration
-- ^ animation: real time lapse foreseen between the first image
-- and the image right after this one; 0.0 if no next frame
);
-------------------------------------------------------------------
-- Some informations about the image, not necessary for decoding --
-------------------------------------------------------------------
type Image_format_type is
( -- Bitmap formats
BMP, FITS, GIF, JPEG, PNG, TGA, TIFF
);
function Format (image: Image_descriptor) return Image_format_type;
function Detailed_format (image: Image_descriptor) return String;
-- example: "GIF89a, interlaced"
function Subformat (image: Image_descriptor) return Integer;
-- example the 'color type' in PNG
function Bits_per_pixel (image: Image_descriptor) return Positive;
function RLE_encoded (image: Image_descriptor) return Boolean;
function Interlaced (image: Image_descriptor) return Boolean;
function Greyscale (image: Image_descriptor) return Boolean;
function Has_palette (image: Image_descriptor) return Boolean;
function Expect_transparency (image: Image_descriptor) return Boolean;
--------------------------------------------------------------
-- Information about this package - e.g. for an "about" box --
--------------------------------------------------------------
version : constant String:= "02";
reference : constant String:= "8-Sep-2012";
web: constant String:= "http://sf.net/projects/gen-img-dec/";
-- Hopefully the latest version is at that URL...
private
use Interfaces;
subtype U8 is Unsigned_8;
subtype U16 is Unsigned_16;
subtype U32 is Unsigned_32;
package Bounded_255 is
new Ada.Strings.Bounded.Generic_Bounded_Length(255);
type Stream_Access is access all Ada.Streams.Root_Stream_Type'Class;
type RGB_color is record
red, green, blue : U8;
end record;
type Color_table is array (Integer range <>) of RGB_color;
type p_Color_table is access Color_table;
type Byte_array is array(Integer range <>) of U8;
type Input_buffer is record
data : Byte_array(1..1024);
stream : Stream_Access:= null;
InBufIdx : Positive:= 1; -- Points to next char in buffer to be read
MaxInBufIdx: Natural := 0; -- Count of valid chars in input buffer
InputEoF : Boolean; -- End of file indicator
end record;
-- Initial values ensure call to Fill_Buffer on first Get_Byte
-- JPEG may store data _before_ any image header (SOF), then we have
-- to make the image descriptor store that information, alas...
package JPEG_defs is
type Component is
(Y, -- brightness
Cb, -- hue
Cr, -- saturation
I, -- ??
Q -- ??
);
type QT is array(0..63) of Natural;
type QT_list is array(0..7) of QT;
type Compo_set is array(Component) of Boolean;
type Info_per_component_A is record -- B is defined inside the decoder
qt_assoc : Natural;
samples_hor : Natural;
samples_ver : Natural;
up_factor_x : Natural; -- how much we must repeat horizontally
up_factor_y : Natural; -- how much we must repeat vertically
shift_x : Natural; -- shift for repeating pixels horizontally
shift_y : Natural; -- shift for repeating pixels vertically
end record;
type Component_info_A is array(Component) of Info_per_component_A;
type Supported_color_space is (
YCbCr, -- 3-dim color space
Y_Grey, -- 1-dim greyscale
CMYK -- 4-dim Cyan, Magenta, Yellow, blacK
);
type AC_DC is (AC, DC);
type VLC_code is record
bits, code: U8;
end record;
type VLC_table is array(0..65_535) of VLC_code;
type p_VLC_table is access VLC_table;
type VLC_defs_type is array(AC_DC, 0..7) of p_VLC_table;
end JPEG_defs;
type JPEG_stuff_type is record
components : JPEG_defs.Compo_set:= (others => False);
color_space : JPEG_defs.Supported_color_space;
info : JPEG_defs.Component_info_A;
max_samples_hor : Natural;
max_samples_ver : Natural;
qt_list : JPEG_defs.QT_list;
vlc_defs : JPEG_defs.VLC_defs_type:= (others => (others => null));
restart_interval : Natural; -- predictor restarts every... (0: never)
end record;
type Image_descriptor is new Ada.Finalization.Controlled with record
format : Image_format_type;
detailed_format : Bounded_255.Bounded_String; -- for humans only!
subformat_id : Integer:= 0;
width, height : Positive;
display_orientation: Orientation;
bits_per_pixel : Positive;
RLE_encoded : Boolean:= False;
transparency : Boolean:= False;
greyscale : Boolean:= False;
interlaced : Boolean:= False;
flag_1 : Boolean; -- format-specific information
JPEG_stuff : JPEG_stuff_type;
stream : Stream_Access;
buffer : Input_buffer;
palette : p_Color_table:= null;
first_byte : U8;
next_frame : Ada.Calendar.Day_Duration;
end record;
procedure Adjust (Object : in out Image_descriptor);
procedure Finalize (Object : in out Image_descriptor);
to_be_done: exception;
-- this exception should not happen, even with malformed files
-- its role is to pop up when a feature is set as implemented
-- but one aspect (e.g. palette) was forgotten.
--
-- Primitive tracing using Ada.Text_IO, for debugging,
-- or explaining internals.
--
type Trace_type is (
none, -- No trace at all, no use of console from the library
some_t, -- Image / frame technical informations
full -- Byte / pixel / compressed block details
);
trace: constant Trace_type:= none; -- <== Choice here
no_trace : constant Boolean:= trace=none;
full_trace: constant Boolean:= trace=full;
some_trace: constant Boolean:= trace>=some_t;
end GID;

12
3-mid/opengl/private/gid/gid.gpr Normal file
View File

@@ -0,0 +1,12 @@
-- This is a GNAT, GCC or GNAT Programming Studio (GPS) project file
-- for the Generic Image Decoder ( http://sf.net/projects/gen-img-dec/ )
-- Build me with "gnatmake -P gid.gpr", or open me with GPS
--
project GID is
for Source_Dirs use (".");
-- for Exec_Dir use "test";
-- for Main use ("tb.ads", "to_bmp.adb", "mini.adb");
for Object_Dir use "obj_debug";
end GID;

162
3-mid/opengl/private/gid/gid.txt Normal file
View File

@@ -0,0 +1,162 @@
Generic Image Decoder
---------------------
The Generic Image Decoder (GID) is an Ada package for decoding a
broad variety of image formats, from any data stream, to any kind
of medium, be it an in-memory bitmap, a GUI object,
some other stream, arrays of floating-point initial data
for scientific calculations, a browser element, a device,...
Animations are supported.
Some features:
- Standalone (no dependency on other libraires, bindings,...)
- Unconditionally portable code: OS-, CPU-, compiler- independent code.
- Multi-platform, but native code
- Task safe
- Endian-neutral
- Free, open-source
- pure Ada 95 (compiled by Ada 95, Ada 2005, and later compilers)
Some possible applications:
- image processing (interactive or not)
- image analysis, text recognition
- a drawing program
- a web browser
- use of images as data for simulations
- thumbnail generation for a file manager
Through the genericity and the use of the Inline pragma at multiple
nesting levels (see it like macros inside macros), the package is
able to deliver a decent decoding performance, keep a reasonably
compact and readable source code, and avoid tediously copied
pieces of code with almost the same contents corresponding to
different subformats.
Licensing, warranty, copyright, supported formats, authors, credits, history
----------------------------------------------------------------------------
Please read the top comments in gid.ads, and further details in gid_work.xls.
Files
-----
gid.ads GID package specification
gid.adb GID package body
gid-*.ad* private packages for decoding specific
formats, reading headers,...
To summarize, the gid*.ad* files are the whole GID source files.
For example, you can have a copy of those in a gid/ subdirectory
in your project.
gid.gpr GNAT/GCC project file - to be opened with GPS or used
with the command: gnatmake -P gid
gid_objectada.prj ObjectAda (7.2.2+) project file
gid_work.xls this workbook contains GID's history, a list of open
bugs, technical informations about formats, etc.
test/to_bmp.adb middle-size command-line demo which converts all image
files given as arguments (also works from a GUI file
explorer with drag & drop) into BMP image files with
the .dib extension. Typically, you put plenty of
images into the test folder and launch "to_bmp *" to
convert them all.
test/mini.adb small-size version of to_bmp; writes PPM files.
test/tb*.ad* wrappers for to_bmp, for obtaining trace-back
How to use GID in your programs
-------------------------------
Hopefully the package specification (in the file gid.ads) is self
explanatory enough. There are three steps needed:
1) Load the image header from a data stream
2) If needed, use dimensions to prepare the retrieval of the image
3) Load and decode the image itself. If the image is animated,
call Load_image_contents until next_frame is 0.0
The subprograms corresponding to these steps are
1) Load_image_header
2) Pixel_width and Pixel_height
3) Load_image_contents
Load_image_contents is generic. You provide the following:
* Primary_color_range: the type of primary colors.
Usually it is a byte (E.g. Unsigned_8)
* procedure Set_X_Y: setting a "cursor" (an array index, for instance)
* procedure Put_Pixel: set a color (and transparency) on
the "cursor" place; the cursor is meant to move one pixel
to te right, then
* procedure Feedback: display progress (if you want it, otherwise
you can always provide an empty procedure)
* mode: Display_mode: here you tell if you want the decoding rather
nicer or faster, when the decoder is processing "progressive"
(JPEG) or "interlaced" (GIF, PNG) pictures. Note: the end
result is exactly the same.
This generic construction allows you a total freedom on where and
how to use GID in your programs. In addition, your Set_X_Y and
Put_Pixel procedures are inserted at compile-time, (no call instruction),
right in the heart of the decoding procedures, for each image format,
which should deliver a decent performance as soon as you set the right
compiler options (optimization, inlined or macro-expanded generics,
suppression of all checks, loop unrolling).
How to build GID
----------------
- From GPS, press F4 - that's it. The executable is in the /test folder.
- From ObjectAda, press F7 - that's it. The .exe is in the folder created
by ObjectAda upon first project opening.
- From AdaGIDE, press F3. There will be .o and .ali files at unexpected
places, so it's better to build first with GPS or the command line
- From the command line, with GNAT:
- default build mode: gnatmake -P gid
- other build mode (e.g. Small): gnatmake -P gid -XBuild_Mode=Small
We assume here you consider GID unpacked "out of the box", with directories.
Memory requirements and usage
-----------------------------
GID uses only memory for decoding purposes (e.g. decompression
structures, color tables) and doesn't store the image itself.
As a result, memory will be reserved for only one copy of the output
bitmap, and this under the format you want or need to have.
As an example, the to_bmp demo stores the image as a packed
RBG byte array with a 4-byte padding which is the appropriate
format for dumping a BMP file in the end. But there are many
other possible storage formats, and GID lets you the total
freedom about it. It can be even the case that the bitmap
storage is more appropriate through an operating system or
a specific library; in such a case you would not store the
bitmap within the Ada progam at all and Put_Pixel would be used
to transmit the pixels further.
All memory used by GID is taken on the stack, with the exception
of palettes and JPEG's DHT tables. Those are dynamically allocated
on the heap and deallocated upon scope end of a variable of the
Image_descriptor type. It means there is no memory leak possible.
The use of heap allocation is justified there because of the
relatively large size of those objects. They could very well
be also part of the descriptor record, with a maximal size for
palette (2**16, for the TGA format).
Where to find the latest version
--------------------------------
Please check the "web" constant in gid.ads.
Note on the construction of GID.
--------------------------------
All image formats decoded by GID have similarities in their structure.
- Most streams begin with a signature, followed by a header
containing dimensions and the color depth. Then the image contents
follow. This is obvious to have such a data organisation,
since the header details are needed to calibrate the recipient
of the image.
- Streams are structured in blocks of data which are given different
names depending on the format:
- PNG : chunks
- GIF : blocks
- JPEG: segments
- TGA : areas
- TIFF: tags
etc.