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

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;