-- 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;