File : agpl-bmp.adb


------------------------------------------------------------------------------

--                         ADAGIO - ADALID - AENEA.                         --

--                                                                          --

--                            Copyright (C) 2003                            --

--                                 A. Mosteo.                               --

--                                                                          --

--  Authors: A. Mosteo. (adagio@mosteo.com)                                 --

--                                                                          --

--  If you have any questions in regard to this software, please address    --

--  them to the above email.                                                --

--                                                                          --

--  This program is free software; you can redistribute it and/or modify    --

--  it under the terms of the GNU General Public License as published by    --

--  the Free Software Foundation; either version 2 of the License, or (at   --

--  your option) any later version.                                         --

--                                                                          --

--  This program is distributed in the hope that it will be useful, but     --

--  WITHOUT ANY WARRANTY; without even the implied warranty of              --

--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU       --

--  General Public License for more details.                                --

--                                                                          --

--  You should have received a copy of the GNU General Public License       --

--  along with this library; if not, write to the Free Software Foundation, --

--  Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.          --

--                                                                          --

--  You are not allowed to use any part of this code to develop a program   --

--  whose output would be used to harass or prosecute other users of the    --

--  networks Adagio connects with. All data collected with Adagio or a tool --

--  containing Adagio code about other network users must remain            --

--  confidential and cannot be made public by any mean, nor be used to      --

--  harass or legally prosecute these users.                                --

------------------------------------------------------------------------------

--  $Id: agpl-bmp.adb,v 1.2 2004/02/29 20:36:41 Jano Exp $


--  Packages for work with BMP files


with Agpl.Streams.Memory_arrays;

with Ada.Unchecked_deallocation;
with Interfaces;

package body Agpl.Bmp is

   package ADS renames Ada.Streams;
   package AGS renames Agpl.Streams;

   use type ADS.Stream_element_array;
   use type ADS.Stream_element_offset;

   ------------------------------------------------------------------------

   -- Create                                                             --

   ------------------------------------------------------------------------

   procedure Create (
      This : in out Object; Width : in Positive; Height : in Positive)
   is
   begin
      Finalize (This);
      This.Data   := 
         new Ada.Streams.Stream_element_array (
            1 .. Ada.Streams.Stream_element_offset (Width * Height * 3));
      This.Width  := Width;
      This.Height := Height;
   end Create;

   ------------------------------------------------------------------------

   -- Check_coordinates                                                  --

   ------------------------------------------------------------------------

   -- Return true if inside bounds, false if outside, exception if checking

   function Check_coordinates (This : in Object; Row, Column : in Integer)
      return Boolean;
   pragma Inline (Check_coordinates);
   function Check_coordinates (This : in Object; Row, Column : in Integer)
      return Boolean is 
   begin
      if Row < 1 or else Column < 1 or else 
         Row > This.Height or else Column > This.Width
      then
         if not This.Checking then
            return false;
         else
            raise Coordinates_out_of_bounds;
         end if;
      else
         return true;
      end if;
   end Check_coordinates;
   ------------------------------------------------------------------------

   -- Index_of                                                          --

   ------------------------------------------------------------------------

   function Index_of (This : in Object; Row, Column : in Positive) 
      return Ada.Streams.Stream_element_offset;
   pragma Inline (Index_of);
   function Index_of (This : in Object; Row, Column : in Positive) 
      return Ada.Streams.Stream_element_offset is
   begin
      return ADS.Stream_element_offset (
         (This.Height - Row) * This.Width * 3 + (Column - 1) * 3 + 1);
   end Index_of;

   ------------------------------------------------------------------------

   -- Get_pixel                                                          --

   ------------------------------------------------------------------------

   function Get_pixel (
      This   : in Object;
      Row,
      Column : in Integer) return Types.Rgb_triplet 
   is
      Pos : ADS.Stream_element_offset;
   begin
      if not Check_coordinates (This, Row, Column) then
         raise Coordinates_out_of_bounds;
      end if;
      Pos := Index_of (This, Row, Column);
      return (
         B => Types.Unsigned_8 (This.Data (Pos)),
         G => Types.Unsigned_8 (This.Data (Pos + 1)),
         R => Types.Unsigned_8 (This.Data (Pos + 2)));
   end Get_pixel;

   ------------------------------------------------------------------------

   -- Set_pixel                                                          --

   ------------------------------------------------------------------------

   procedure Set_pixel (
      This   : in out Object; 
      Row, 
      Column : in     Integer; 
      Rgb    : in     Types.Rgb_triplet)
   is
      Pos : ADS.Stream_element_offset;
   begin
      if not Check_coordinates (This, Row, Column) then
         return;
      end if;

      Pos := Index_of (This, Row, Column);
      This.Data (Pos)     := ADS.Stream_element (Rgb.B);
      This.Data (Pos + 1) := ADS.Stream_element (Rgb.G);
      This.Data (Pos + 2) := ADS.Stream_element (Rgb.R);
   end Set_pixel;

   ------------------------------------------------------------------------

   -- Set_checking                                                       --

   ------------------------------------------------------------------------

   -- If drawing outbounds, we can get an error or silent discarding:

   procedure Set_checking (This : in out Object; Check : in Boolean := true) 
   is
   begin
      This.Checking := Check;
   end Set_checking;

   ------------------------------------------------------------------------

   -- Get_stream                                                         --

   ------------------------------------------------------------------------

   -- Returns a stream with a valid BMP representation (not the pixel matrix).

   function Get_stream (This : in Object) 
      return Ada.Streams.Stream_element_array 
   is
      Headers : aliased ADS.Stream_element_array := (1 .. 54 => 0);
      Stream  : aliased AGS.Memory_arrays.Stream_type (Headers'Access);
      Str     : AGS.Stream_access := Stream'Unchecked_Access;

      use Interfaces;
   begin
      -- HEADER

      -- Magic

      String'Write (Str, "BM");
      -- File size

      Unsigned_32'Write (Str, Unsigned_32(Headers'Length + This.Data'Length));
      -- Reserved

      Unsigned_32'Write (Str, 0);
      -- Offset of image data

      Unsigned_32'Write (Str, Unsigned_32 (Headers'Length));
      
      -- INFOHEADER

      -- Size of infoheader?

      Unsigned_32'Write (
         Str,
         Unsigned_32 (Headers'Length - AGS.Memory_arrays.Index (Stream)));
      -- Width

      Unsigned_32'Write (Str, Unsigned_32 (This.Width));
      -- Height

      Unsigned_32'Write (Str, Unsigned_32 (This.Height));
      -- Color planes

      Unsigned_16'Write (Str, 1);
      -- bpp

      Unsigned_16'Write (Str, 24);
      -- No compression

      Unsigned_32'Write (Str, 0);
      -- Data size

      Unsigned_32'Write (Str, Unsigned_32 (This.Data'Length));
      -- Pixels per meter, horizontal and vertical

      Unsigned_32'Write (Str, 0);
      Unsigned_32'Write (Str, 0);
      -- Palette colors

      Unsigned_32'Write (Str, 0);
      -- Important colors

      Unsigned_32'Write (Str, 0);

      if AGS.Memory_arrays.Index (Stream) /= Headers'Last then
         raise Constraint_error;
      end if;

      return Headers & This.Data.all;
   end Get_stream;

   procedure Free is new Ada.Unchecked_deallocation (
      Ada.Streams.Stream_element_array, 
      Agpl.Streams.Stream_element_array_access);

   procedure Initialize (This : in out Object) is
      pragma Unreferenced (This);
   begin
      null;
   end Initialize;

   procedure Adjust     (This : in out Object) is
   begin
      This.Data := new ADS.Stream_element_array'(This.Data.all);
   end Adjust;

   procedure Finalize   (This : in out Object) is
   begin
      Free (This.Data);
   end Finalize;

end Agpl.Bmp;