gid_10.0.0_ea4b473f/test/to_bmp.adb

--
--  Convert any image or animation file to BMP file(s).
--
--  Middle-size test/demo for the GID (Generic Image Decoder) package.
--
--  Supports:
--  - Transparency (blends transparent or partially opaque areas with a
--      background image, gid.gif, or a fixed, predefined colour)
--  - Display orientation (JPEG EXIF informations from digital cameras)
--
--  For a smaller and simpler example, look for mini.adb .
--

with GID;

with Ada.Calendar;
with Ada.Characters.Handling;           use Ada.Characters.Handling;
with Ada.Command_Line;                  use Ada.Command_Line;
with Ada.Streams.Stream_IO;             use Ada.Streams.Stream_IO;
with Ada.Strings.Fixed;
with Ada.Strings.Unbounded;             use Ada.Strings.Unbounded;
with Ada.Text_IO;                       use Ada.Text_IO;
with Ada.Unchecked_Deallocation;

with Interfaces;

procedure To_BMP is

  default_bkg_name : constant String := "gid.gif";

  procedure Blurb is
  begin
    Put_Line (Standard_Error, "To_BMP * Converts any image file to a BMP file");
    Put_Line (Standard_Error, "Simple test for the GID (Generic Image Decoder) package");
    Put_Line (Standard_Error, "Package version " & GID.version & " dated " & GID.reference);
    Put_Line (Standard_Error, "URL: " & GID.web);
    New_Line (Standard_Error);
    Put_Line (Standard_Error, "Syntax:");
    Put_Line (Standard_Error, "to_bmp [-] [-<background_image_name>] <image_1> [<image_2>...]");
    New_Line (Standard_Error);
    Put_Line (Standard_Error, "Options:");
    Put_Line (Standard_Error, "  '-': don't output image (testing only)");
    Put_Line (Standard_Error, "  '-<background_image_name>':");
    Put_Line (Standard_Error, "      use specifed background to mix with transparent images");
    Put_Line (Standard_Error, "      (otherwise, trying with '" & default_bkg_name & "' or single color)");
    New_Line (Standard_Error);
    Put_Line (Standard_Error, "Output: "".dib"" is added the full input name(s)");
    Put_Line (Standard_Error, "  Reason of "".dib"": unknown synonym of "".bmp"";");
    Put_Line (Standard_Error, "  just do ""del *.dib"" for cleanup");
    New_Line (Standard_Error);
  end Blurb;

  --  Image used as background for displaying images having transparency
  background_image_name : Unbounded_String := Null_Unbounded_String;

  use Interfaces;

  type Byte_Array is array (Integer range <>) of Unsigned_8;
  type p_Byte_Array is access Byte_Array;
  procedure Dispose is new Ada.Unchecked_Deallocation (Byte_Array, p_Byte_Array);

  forgive_errors : constant Boolean := False;
  error : Boolean;

  img_buf, bkg_buf : p_Byte_Array := null;
  bkg : GID.Image_descriptor;

  generic
    correct_orientation : GID.Orientation;
  --  Load image into a 24-bit truecolor BGR raw bitmap (for a BMP output)
  procedure Load_raw_image (
    image : in out GID.Image_descriptor;
    buffer : in out p_Byte_Array;
    next_frame : out Ada.Calendar.Day_Duration
  );
  --
  procedure Load_raw_image (
    image : in out GID.Image_descriptor;
    buffer : in out p_Byte_Array;
    next_frame : out Ada.Calendar.Day_Duration
  )
  is
    subtype Primary_color_range is Unsigned_8;
    subtype U16 is Unsigned_16;
    image_width : constant Positive := GID.Pixel_width (image);
    image_height : constant Positive := GID.Pixel_height (image);
    padded_line_size_x : constant Positive :=
      4 * Integer (Float'Ceiling (Float (image_width) * 3.0 / 4.0));
    padded_line_size_y : constant Positive :=
      4 * Integer (Float'Ceiling (Float (image_height) * 3.0 / 4.0));
    --  (in bytes)
    idx : Integer;
    mem_x, mem_y : Natural;
    bkg_padded_line_size : Positive;
    bkg_width, bkg_height : Natural;
    --
    procedure Set_X_Y (x, y : Natural) is
    pragma Inline (Set_X_Y);
      use GID;
      rev_x : constant Natural := image_width - (x + 1);
      rev_y : constant Natural := image_height - (y + 1);
    begin
      case correct_orientation is
        when Unchanged =>
          idx := 3 * x + padded_line_size_x * y;
        when Rotation_90 =>
          idx := 3 * rev_y + padded_line_size_y * x;
        when Rotation_180 =>
          idx := 3 * rev_x + padded_line_size_x * rev_y;
        when Rotation_270 =>
          idx := 3 * y + padded_line_size_y * rev_x;
      end case;
      mem_x := x;
      mem_y := y;
    end Set_X_Y;
    --
    --  No background version of Put_Pixel
    --
    procedure Put_Pixel_without_bkg (
      red, green, blue : Primary_color_range;
      alpha            : Primary_color_range
    )
    is
    pragma Inline (Put_Pixel_without_bkg);
    pragma Warnings (off, alpha); -- alpha is just ignored
      use GID;
    begin
      buffer (idx .. idx + 2) := (blue, green, red);
      --  GID requires us to look to next pixel for next time:
      case correct_orientation is
        when Unchanged =>
          idx := idx + 3;
        when Rotation_90 =>
          idx := idx + padded_line_size_y;
        when Rotation_180 =>
          idx := idx - 3;
        when Rotation_270 =>
          idx := idx - padded_line_size_y;
      end case;
    end Put_Pixel_without_bkg;
    --
    --  Unicolor background version of Put_Pixel
    --
    procedure Put_Pixel_with_unicolor_bkg (
      red, green, blue : Primary_color_range;
      alpha            : Primary_color_range
    )
    is
    pragma Inline (Put_Pixel_with_unicolor_bkg);
      u_red  : constant := 200;
      u_green : constant := 133;
      u_blue : constant := 32;
    begin
      if alpha = 255 then
        buffer (idx .. idx + 2) := (blue, green, red);
      else -- blend with bckground color
        buffer (idx)  := Primary_color_range ((U16 (alpha) * U16 (blue)  + U16 (255 - alpha) * u_blue) / 255);
        buffer (idx + 1) := Primary_color_range ((U16 (alpha) * U16 (green) + U16 (255 - alpha) * u_green) / 255);
        buffer (idx + 2) := Primary_color_range ((U16 (alpha) * U16 (red)   + U16 (255 - alpha) * u_red) / 255);
      end if;
      idx := idx + 3;
      --  ^ GID requires us to look to next pixel on the right for next time.
    end Put_Pixel_with_unicolor_bkg;
    --
    --  Background image version of Put_Pixel
    --
    procedure Put_Pixel_with_image_bkg (
      red, green, blue : Primary_color_range;
      alpha            : Primary_color_range
    )
    is
    pragma Inline (Put_Pixel_with_image_bkg);
      b_red,
      b_green,
      b_blue : Primary_color_range;
      bkg_idx : Natural;
    begin
      if alpha = 255 then
        buffer (idx .. idx + 2) := (blue, green, red);
      else -- blend with background image
        bkg_idx := 3 * (mem_x mod bkg_width) + bkg_padded_line_size * (mem_y mod bkg_height);
        b_blue := bkg_buf (bkg_idx);
        b_green := bkg_buf (bkg_idx + 1);
        b_red  := bkg_buf (bkg_idx + 2);
        buffer (idx)  := Primary_color_range ((U16 (alpha) * U16 (blue)  + U16 (255 - alpha) * U16 (b_blue)) / 255);
        buffer (idx + 1) := Primary_color_range ((U16 (alpha) * U16 (green) + U16 (255 - alpha) * U16 (b_green)) / 255);
        buffer (idx + 2) := Primary_color_range ((U16 (alpha) * U16 (red)   + U16 (255 - alpha) * U16 (b_red)) / 255);
      end if;
      idx := idx + 3;
      --  ^ GID requires us to look to next pixel on the right for next time.
      mem_x := mem_x + 1;
    end Put_Pixel_with_image_bkg;

    stars : Natural := 0;
    procedure Feedback (percents : Natural) is
      so_far : constant Natural := percents / 5;
    begin
      for i in stars + 1 .. so_far loop
        Put (Standard_Error, '*');
      end loop;
      stars := so_far;
    end Feedback;

    --  Here, the exciting thing: the instanciation of
    --  GID.Load_image_contents. In our case, we load the image
    --  into a 24-bit bitmap (because we provide a Put_Pixel
    --  that does that with the pixels), but we could do plenty
    --  of other things instead, like display the image live on a GUI.

    --  More exciting: for tuning performance, we have 3 different
    --  instances of GID.Load_image_contents (each of them with the full
    --  decoders for all formats, own specialized generic instances, inlines,
    --  etc.) depending on the transparency features.

    procedure BMP24_Load_without_bkg is
      new GID.Load_image_contents (
        Primary_color_range,
        Set_X_Y,
        Put_Pixel_without_bkg,
        Feedback,
        GID.fast
      );

    procedure BMP24_Load_with_unicolor_bkg is
      new GID.Load_image_contents (
        Primary_color_range,
        Set_X_Y,
        Put_Pixel_with_unicolor_bkg,
        Feedback,
        GID.fast
      );

    procedure BMP24_Load_with_image_bkg is
      new GID.Load_image_contents (
        Primary_color_range,
        Set_X_Y,
        Put_Pixel_with_image_bkg,
        Feedback,
        GID.fast
      );

  begin
    error := False;
    Dispose (buffer);
    case correct_orientation is
      when GID.Unchanged | GID.Rotation_180 =>
        buffer := new Byte_Array (0 .. padded_line_size_x * GID.Pixel_height (image) - 1);
      when GID.Rotation_90 | GID.Rotation_270 =>
        buffer := new Byte_Array (0 .. padded_line_size_y * GID.Pixel_width (image) - 1);
    end case;
    if GID.Expect_transparency (image) then
      if background_image_name = Null_Unbounded_String then
        BMP24_Load_with_unicolor_bkg (image, next_frame);
      else
        bkg_width := GID.Pixel_width (bkg);
        bkg_height := GID.Pixel_height (bkg);
        bkg_padded_line_size :=
          4 * Integer (Float'Ceiling (Float (bkg_width) * 3.0 / 4.0));
        BMP24_Load_with_image_bkg (image, next_frame);
      end if;
    else
      BMP24_Load_without_bkg (image, next_frame);
    end if;
    --  -- For testing: white rectangle with a red half-frame.
    --  buffer.all:= (others => 255);
    --  for x in 0..GID.Pixel_width(image)-1 loop
    --    Put_Pixel_with_unicolor_bkg(x,0,255,0,0,255);
    --  end loop;
    --  for y in 0..GID.Pixel_height(image)-1 loop
    --    Put_Pixel_with_unicolor_bkg(0,y,255,0,0,255);
    --  end loop;
  exception
    when others =>
      if forgive_errors then
        error := True;
        next_frame := 0.0;
      else
        raise;
      end if;
  end Load_raw_image;

  procedure Load_raw_image_0 is new Load_raw_image (GID.Unchanged);
  procedure Load_raw_image_90 is new Load_raw_image (GID.Rotation_90);
  procedure Load_raw_image_180 is new Load_raw_image (GID.Rotation_180);
  procedure Load_raw_image_270 is new Load_raw_image (GID.Rotation_270);

  procedure Dump_BMP_24 (name : String; i : GID.Image_descriptor) is
    f : Ada.Streams.Stream_IO.File_Type;
    type BITMAPFILEHEADER is record
      bfType     : Unsigned_16;
      bfSize     : Unsigned_32;
      bfReserved1 : Unsigned_16 := 0;
      bfReserved2 : Unsigned_16 := 0;
      bfOffBits  : Unsigned_32;
    end record;
    --  ^ No packing needed
    BITMAPFILEHEADER_Bytes : constant := 14;

    type BITMAPINFOHEADER is record
      biSize         : Unsigned_32;
      biWidth        : Unsigned_32;
      biHeight       : Unsigned_32;
      biPlanes       : Unsigned_16 := 1;
      biBitCount     : Unsigned_16;
      biCompression  : Unsigned_32 := 0;
      biSizeImage    : Unsigned_32;
      biXPelsPerMeter : Unsigned_32 := 0;
      biYPelsPerMeter : Unsigned_32 := 0;
      biClrUsed      : Unsigned_32 := 0;
      biClrImportant : Unsigned_32 := 0;
    end record;
    --  ^ No packing needed
    BITMAPINFOHEADER_Bytes : constant := 40;

    FileInfo  : BITMAPINFOHEADER;
    FileHeader : BITMAPFILEHEADER;
    --
    generic
      type Number is mod <>;
    procedure Write_Intel_x86_number (n : in Number);

    procedure Write_Intel_x86_number (n : in Number) is
      m : Number := n;
      bytes : constant Integer := Number'Size / 8;
    begin
      for i in 1 .. bytes loop
        Unsigned_8'Write (Stream (f), Unsigned_8 (m and 255));
        m := m / 256;
      end loop;
    end Write_Intel_x86_number;
    procedure Write_Intel is new Write_Intel_x86_number (Unsigned_16);
    procedure Write_Intel is new Write_Intel_x86_number (Unsigned_32);
  begin
    FileHeader.bfType := 16#4D42#; -- 'BM'
    FileHeader.bfOffBits := BITMAPINFOHEADER_Bytes + BITMAPFILEHEADER_Bytes;
    FileInfo.biSize       := BITMAPINFOHEADER_Bytes;
    case GID.Display_orientation (i) is
      when GID.Unchanged | GID.Rotation_180 =>
        FileInfo.biWidth  := Unsigned_32 (GID.Pixel_width (i));
        FileInfo.biHeight := Unsigned_32 (GID.Pixel_height (i));
      when GID.Rotation_90 | GID.Rotation_270 =>
        FileInfo.biWidth  := Unsigned_32 (GID.Pixel_height (i));
        FileInfo.biHeight := Unsigned_32 (GID.Pixel_width (i));
    end case;
    FileInfo.biBitCount   := 24;
    FileInfo.biSizeImage  := Unsigned_32 (img_buf.all'Length);

    FileHeader.bfSize := FileHeader.bfOffBits + FileInfo.biSizeImage;

    Create (f, Out_File, name & ".dib");
    --  BMP Header, endian-safe:
    Write_Intel (FileHeader.bfType);
    Write_Intel (FileHeader.bfSize);
    Write_Intel (FileHeader.bfReserved1);
    Write_Intel (FileHeader.bfReserved2);
    Write_Intel (FileHeader.bfOffBits);
    --
    Write_Intel (FileInfo.biSize);
    Write_Intel (FileInfo.biWidth);
    Write_Intel (FileInfo.biHeight);
    Write_Intel (FileInfo.biPlanes);
    Write_Intel (FileInfo.biBitCount);
    Write_Intel (FileInfo.biCompression);
    Write_Intel (FileInfo.biSizeImage);
    Write_Intel (FileInfo.biXPelsPerMeter);
    Write_Intel (FileInfo.biYPelsPerMeter);
    Write_Intel (FileInfo.biClrUsed);
    Write_Intel (FileInfo.biClrImportant);
    --  BMP raw BGR image:
    declare
      --  Workaround for the severe xxx'Read xxx'Write performance
      --  problems in the GNAT and ObjectAda compilers (as in 2009)
      --  This is possible if and only if Byte = Stream_Element and
      --  arrays types are both packed the same way.
      --
      subtype Size_test_a is Byte_Array (1 .. 19);
      subtype Size_test_b is Ada.Streams.Stream_Element_Array (1 .. 19);
      workaround_possible : constant Boolean :=
        Size_test_a'Size = Size_test_b'Size and then
        Size_test_a'Alignment = Size_test_b'Alignment;
      --
    begin
      if workaround_possible then
        declare
          use Ada.Streams;
          SE_Buffer   : Stream_Element_Array (0 .. Stream_Element_Offset (img_buf'Length - 1));
          for SE_Buffer'Address use img_buf.all'Address;
          pragma Import (Ada, SE_Buffer);
        begin
          Ada.Streams.Write (Stream (f).all, SE_Buffer (0 .. Stream_Element_Offset (img_buf'Length - 1)));
        end;
      else
        Byte_Array'Write (Stream (f), img_buf.all); -- the workaround is about this line...
      end if;
    end;
    Close (f);
  end Dump_BMP_24;

  procedure Process (name : String; as_background, test_only : Boolean) is
    f : Ada.Streams.Stream_IO.File_Type;
    i : GID.Image_descriptor;
    up_name : constant String := To_Upper (name);
    --
    next_frame, current_frame : Ada.Calendar.Day_Duration := 0.0;
    use Ada.Strings, Ada.Strings.Fixed;
  begin
    --
    --  Load the image in its original format
    --
    Open (f, In_File, name);
    Put_Line (Standard_Error, "Processing " & name & "...");
    --
    GID.Load_image_header (
      i,
      Stream (f).all,
      try_tga =>
        name'Length >= 4 and then
        up_name (up_name'Last - 3 .. up_name'Last) = ".TGA"
    );
    Put_Line (Standard_Error,
      "  Image format: " & GID.Image_format_type'Image (GID.Format (i))
    );
    Put_Line (Standard_Error,
      "  Image detailed format: " & GID.Detailed_format (i)
    );
    Put_Line (Standard_Error,
      "  Image sub-format ID (if any): " & Integer'Image (GID.Subformat (i))
    );
    Put_Line (Standard_Error,
      "  Dimensions in pixels: " &
      Integer'Image (GID.Pixel_width (i)) & " x" &
      Integer'Image (GID.Pixel_height (i))
    );
    Put_Line (Standard_Error,
      "  Display orientation: " &
      GID.Orientation'Image (GID.Display_orientation (i))
    );
    Put (Standard_Error,
      "  Color depth: " &
      Integer'Image (GID.Bits_per_pixel (i)) & " bits"
    );
    if GID.Bits_per_pixel (i) <= 24 then
      Put_Line (Standard_Error,
        ',' &
        Integer'Image (2**GID.Bits_per_pixel (i)) & " colors"
      );
    else
      New_Line (Standard_Error);
    end if;
    Put_Line (Standard_Error,
      "  Palette: " & Boolean'Image (GID.Has_palette (i))
    );
    Put_Line (Standard_Error,
      "  Greyscale: " & Boolean'Image (GID.Greyscale (i))
    );
    Put_Line (Standard_Error,
      "  RLE encoding (if any): " & Boolean'Image (GID.Is_RLE_encoded (i))
    );
    Put_Line (Standard_Error,
      "  Interlaced (GIF: each frame's choice): " & Boolean'Image (GID.Is_Interlaced (i))
    );
    Put_Line (Standard_Error,
      "  Expect transparency: " & Boolean'Image (GID.Expect_transparency (i))
    );
    Put_Line (Standard_Error, "1........10........20");
    Put_Line (Standard_Error, "         |         | ");
    --
    if as_background then
      case GID.Display_orientation (i) is
        when GID.Unchanged =>
          Load_raw_image_0 (i, bkg_buf, next_frame);
        when GID.Rotation_90 =>
          Load_raw_image_90 (i, bkg_buf, next_frame);
        when GID.Rotation_180 =>
          Load_raw_image_180 (i, bkg_buf, next_frame);
        when GID.Rotation_270 =>
          Load_raw_image_270 (i, bkg_buf, next_frame);
      end case;
      bkg := i;
      New_Line (Standard_Error);
      Close (f);
      return;
    end if;
    loop
      case GID.Display_orientation (i) is
        when GID.Unchanged =>
          Load_raw_image_0 (i, img_buf, next_frame);
        when GID.Rotation_90 =>
          Load_raw_image_90 (i, img_buf, next_frame);
        when GID.Rotation_180 =>
          Load_raw_image_180 (i, img_buf, next_frame);
        when GID.Rotation_270 =>
          Load_raw_image_270 (i, img_buf, next_frame);
      end case;
      if not test_only then
        Dump_BMP_24 (name & '_' & Trim (Duration'Image (current_frame), Left), i);
      end if;
      New_Line (Standard_Error);
      if error then
        Put_Line (Standard_Error, "Error!");
      end if;
      exit when next_frame = 0.0;
      current_frame := next_frame;
    end loop;
    Close (f);
  exception
    when GID.unknown_image_format =>
      Put_Line (Standard_Error, "  Image format is unknown!");
      if Is_Open (f) then
        Close (f);
      end if;
  end Process;

  test_only : Boolean := False;

begin
  if Argument_Count = 0 then
    Blurb;
    return;
  end if;
  Put_Line (Standard_Error, "To_BMP, using GID version " & GID.version & " dated " & GID.reference);
  begin
    Process (default_bkg_name, True, False);
    --  if success:
    background_image_name := To_Unbounded_String (default_bkg_name);
  exception
    when Ada.Text_IO.Name_Error =>
      null; -- nothing bad, just couldn't find default background
  end;
  for i in 1 .. Argument_Count loop
    declare
      arg : constant String := Argument (i);
    begin
      if arg /= "" and then arg (arg'First) = '-' then
        declare
          opt : constant String := arg (arg'First + 1 .. arg'Last);
        begin
          if opt = "" then
            test_only := True;
          else
            Put_Line (Standard_Error, "Background image is " & opt);
            Process (opt, True, False);
            --  define this only after processing, otherwise
            --  a transparent background will try to use
            --  an undefined background
            background_image_name := To_Unbounded_String (opt);
          end if;
        end;
      else
        Process (arg, False, test_only);
      end if;
    end;
  end loop;
end To_BMP;