598 lines
21 KiB
Ada
598 lines
21 KiB
Ada
-- 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;
|