|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 Tapes |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Tapes Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - downloadIndex: ┃ B T ┃
Length: 38810 (0x979a)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Unchecked_Conversion;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic3;
use Xlbt_Basic3;
with Xlbt_Exceptions;
use Xlbt_Exceptions;
with Xlbt_Image3;
use Xlbt_Image3;
with Xlbt_String;
use Xlbt_String;
with Xlbp_Image;
use Xlbp_Image;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbit_Library4;
use Xlbit_Library4;
with Xlbmp_Error_Log;
use Xlbmp_Error_Log;
package body Xlbip_Image_Internal is
------------------------------------------------------------------------------
-- X Library Internal Image Operations
--
-- Xlbip_Image_Internal - Operations for images.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1985 - 1989 by the Massachusetts Institute of Technology
--
-- All Rights Reserved.
--
-- Permission to use, copy, modify, and distribute this software and its
-- documentation for any purpose and without fee is hereby granted,
-- provided that the above copyright notice(s) appear in all copies and that
-- both that copyright notice(s) and this permission notice appear in
-- supporting documentation, and that the names of MIT or Rational not be
-- used in advertising or publicity pertaining to distribution of the software
-- without specific, written prior permission.
--
-- MIT and Rational disclaim all warranties with regard to this software,
-- including all implied warranties of merchantability and fitness, in no
-- event shall MIT or Rational be liable for any special, indirect or
-- consequential damages or any damages whatsoever resulting from loss of use,
-- data or profits, whether in an action of contract, negligence or other
-- tortious action, arising out of or in connection with the use or performance
-- of this software.
------------------------------------------------------------------------------
--\f
subtype U_Char_4_Array is U_Char_Array (0 .. 3);
function To_U_Char is new Unchecked_Conversion (X_Pixel,
U_Char_4_Array);
function From_U_Char is new Unchecked_Conversion (U_Char_4_Array,
X_Pixel);
subtype U_Char_0_31 is U_Char range 0 .. 31;
Private_Lo_Mask : constant U_Char_Array (0 .. 16#09# - 1) :=
(16#00#, 16#01#, 16#03#, 16#07#, 16#0F#, 16#1F#, 16#3F#, 16#7F#, 16#FF#);
Private_Hi_Mask : constant U_Char_Array (0 .. 16#09# - 1) :=
(16#FF#, 16#FE#, 16#FC#, 16#F8#, 16#F0#, 16#E0#, 16#C0#, 16#80#, 16#00#);
Low_Bits_Table : constant X_Pixel_Array (0 .. 32) :=
(16#00000000#, 16#00000001#, 16#00000003#, 16#00000007#,
16#0000000F#, 16#0000001F#, 16#0000003F#, 16#0000007F#,
16#000000FF#, 16#000001FF#, 16#000003FF#, 16#000007FF#,
16#00000FFF#, 16#00001FFF#, 16#00003FFF#, 16#00007FFF#,
16#0000FFFF#, 16#0001FFFF#, 16#0003FFFF#, 16#0007FFFF#,
16#000FFFFF#, 16#001FFFFF#, 16#003FFFFF#, 16#007FFFFF#,
16#00FFFFFF#, 16#01FFFFFF#, 16#03FFFFFF#, 16#07FFFFFF#,
16#0FFFFFFF#, 16#1FFFFFFF#, 16#3FFFFFFF#, 16#7FFFFFFF#,
-1);
--\f
procedure Private_X_Report_Bad_Image (Errtype : X_String;
Error : String;
Routine : X_String) is
begin
X_Report_Error ("XlibError", "BadImage",
"Xlib; Bad image %1 {%2} found in routine %3.",
Errtype,
To_X_String (Error),
Routine);
raise X_Library_Confusion;
end Private_X_Report_Bad_Image;
--\f
procedure Private_Reverse_Bytes (Bp : in out U_Char_Array) is
begin
for I in Bp'Range loop
Bp (I) := Private_Reverse_Byte (S_Natural (Bp (I)));
end loop;
end Private_Reverse_Bytes;
--\f
------------------------------------------------------------------------------
-- This module provides rudimentary manipulation routines for image data
-- structures. The functions provided are:
--
-- X_Create_Image Creates a default X_Image data structure
-- private_X_Destroy_Image Deletes an X_Image data structure
-- private_X_Get_Pixel Reads a pixel from an image data structure
-- private_X_Get_Pixel_8 Reads a pixel from an 8-bit Z image data structure
-- private_X_Get_Pixel_1 Reads a pixel from a 1-bit image data structure
-- private_X_Put_Pixel Writes a pixel into an image data structure
-- private_X_Put_Pixel_8 Writes a pixel into an 8-bit Z image data structure
-- private_X_Put_Pixel_1 Writes a pixel into a 1-bit image data structure
-- private_X_Sub_Image Clones a new (sub)image from an existing one
-- private_X_Set_Image Writes an image data pattern into another image
-- private_X_Add_Pixel Adds a constant value to every pixel in an image
--
-- The logic contained in these routines makes several assumptions about
-- the image data structures, and at least for current implementations
-- these assumptions are believed to be true. They are:
--
-- For all formats, bits_per_pixel is less than or equal to 32.
-- For X_Y formats, bitmap_unit is 8, 16, 24, or 32 bits.
-- For Z format, bits_per_pixel is 4, 8, 12, 16, 20, 24, 28 or 32 bits.
------------------------------------------------------------------------------
procedure Private_Normalize_Image_Bits
(Bpt : in out U_Char_Array;
Nb : S_Natural; -- # bytes to normalize
Byte_Order : X_Byte_Bit_Order;
Unit_Size : U_Char; -- size of bitmap_unit or Z_pixel
Bit_Order : X_Byte_Bit_Order) is
begin
if Byte_Order = Msb_First and Byte_Order /= Bit_Order then
case Unit_Size is
when 4 =>
for Bpi in Bpt'First .. Bpt'First + Nb - 1 loop
-- swap nibble
Bpt (Bpi) := Bpt (Bpi) / 16 + Bpt (Bpi) rem 16 * 16;
end loop;
when 16 =>
Private_Swap_Short (Bpt (Bpt'First .. Bpt'First + Nb - 1));
when 24 =>
Private_Swap_Three (Bpt (Bpt'First .. Bpt'First + Nb - 1));
when 32 =>
Private_Swap_Long (Bpt (Bpt'First .. Bpt'First + Nb - 1));
when others =>
raise X_Library_Confusion;
end case;
end if;
if Bit_Order = Msb_First then
Private_Reverse_Bytes (Bpt (Bpt'First .. Bpt'First + Nb - 1));
end if;
end Private_Normalize_Image_Bits;
--\f
------------------------------------------------------------------------------
function Round_Up (N_Bytes : U_Short;
Pad : U_Short) return S_Natural is
begin
return ((S_Natural (N_Bytes) + S_Natural (Pad) - 1) / S_Natural (Pad)) *
S_Natural (Pad);
end Round_Up;
------------------------------------------------------------------------------
function Round_Up (N_Bytes : U_Short;
Pad : U_Char) return S_Natural is
begin
return ((S_Natural (N_Bytes) + S_Natural (Pad) - 1) / S_Natural (Pad)) *
S_Natural (Pad);
end Round_Up;
--\f
------------------------------------------------------------------------------
-- Macros
--
-- The ROUND_UP macro rounds up a quantity to the specified boundary.
--
-- The X_Y_NORMALIZE macro determines whether X_Y format data requires
-- normalization and calls a routine to do so if needed. The logic in
-- this module is designed for LSB_First byte and bit order, so
-- normalization is done as required to present the data in this order.
--
-- The Z_NORMALIZE macro performs byte and nibble order normalization if
-- required for Z format data.
--
-- The X_Y_INDEX macro computes the index to the starting byte (char) boundary
-- for a bitmap_unit containing a pixel with coordinates x and y for image
-- data in X_Y format.
--
-- The Z_INDEX macro computes the index to the starting byte (char) boundary
-- for a pixel with coordinates x and y for image data in Z_Pixmap format.
--
------------------------------------------------------------------------------
--\f
procedure X_Y_Normalize (Bp : in out U_Char_Array;
N_Bytes : S_Natural;
Image : X_Image) is
begin
if ((Image.Byte_Order = Msb_First) or else
(Image.Bitmap_Bit_Order = Msb_First)) then
Private_Normalize_Image_Bits
(Bp, N_Bytes, Image.Byte_Order,
Image.Bitmap_Unit, Image.Bitmap_Bit_Order);
end if;
end X_Y_Normalize;
--\f
procedure Z_Normalize (Bp : in out U_Char_Array;
N_Bytes : S_Natural;
Image : X_Image) is
begin
if (Image.Byte_Order = Msb_First) then
Private_Normalize_Image_Bits (Bp, N_Bytes, Msb_First,
Image.Bits_Per_Pixel, Lsb_First);
end if;
end Z_Normalize;
--\f
function X_Y_Index (X : S_Short;
Y : S_Short;
Image : X_Image) return S_Natural is
begin
return Image.Data'First +
S_Natural (Y) * S_Natural (Image.Bytes_Per_Line) +
((S_Natural (X) + S_Natural (Image.X_Offset)) /
S_Natural (Image.Bitmap_Unit)) *
S_Natural (Image.Bitmap_Unit / 8);
end X_Y_Index;
--\f
function Z_Index (X : S_Short;
Y : S_Short;
Image : X_Image) return S_Natural is
begin
return Image.Data'First +
S_Natural (Y) * S_Natural (Image.Bytes_Per_Line) +
S_Natural (X) * S_Natural (Image.Bits_Per_Pixel) / 8;
end Z_Index;
--\f
procedure Private_Put_Bits
(Src : U_Char_Array;-- source bit string
Dst_Offset : U_Char_0_31; -- bit offset into destination
Num_Bits : S_Natural; -- number of bits to copy to dest.
Dst : in out -- destination bit string
U_Char_Array)
is
Chlo : U_Char;
Chhi : U_Char;
Hibits : S_Natural;
Srci : S_Natural := Src'First;
Dsti : S_Natural := Dst'First;
L_Dst_Offset : S_Natural := S_Natural (Dst_Offset);
L_Num_Bits : S_Natural := S_Natural (Num_Bits);
begin
Dsti := Dsti + L_Dst_Offset / 8;
L_Dst_Offset := L_Dst_Offset rem 8;
Hibits := 8 - L_Dst_Offset;
Chlo := Dst (Dsti) and Private_Lo_Mask (L_Dst_Offset);
loop
Chhi := Shift (Src (Srci), Integer (L_Dst_Offset)) and
Private_Hi_Mask (L_Dst_Offset);
if L_Num_Bits <= Hibits then
Chhi := Chhi and Private_Lo_Mask (L_Dst_Offset + L_Num_Bits);
Dst (Dsti) := (Dst (Dsti) and
Private_Hi_Mask (L_Dst_Offset + L_Num_Bits))
or Chlo or Chhi;
exit;
end if;
Dst (Dsti) := Chhi or Chlo;
Dsti := Dsti + 1;
L_Num_Bits := L_Num_Bits - Hibits;
Chlo := Shift (Src (Srci) and Private_Hi_Mask (Hibits),
-Integer (Hibits));
Srci := Srci + 1;
if L_Num_Bits <= L_Dst_Offset then
Chlo := Chlo and Private_Lo_Mask (L_Num_Bits);
Dst (Dsti) :=
(Dst (Dsti) and Private_Hi_Mask (L_Num_Bits)) or Chlo;
exit;
end if;
L_Num_Bits := L_Num_Bits - L_Dst_Offset;
end loop;
end Private_Put_Bits;
--\f
------------------------------------------------------------------------------
-- Add_Pixel
--
-- Adds a constant value to every pixel in a pixmap.
------------------------------------------------------------------------------
procedure Private_X_Add_Pixel (Image : X_Image;
Value : X_Pixel) is
Pixel : X_Pixel;
Pixes : U_Char_4_Array;
Src : S_Natural;
N_Bytes : S_Natural;
begin
if Value = 0 then
return;
end if;
if Image.Depth = 1 then
-- The only value that we can add here to an X_Y_Bitmap
-- is one. Since 1 + value := ~value for one bit wide
-- data, we do this quickly by taking the ones complement
-- of the entire bitmap data (offset and pad included!).
-- Note that we don't need to be concerned with bit or
-- byte order at all.
--
for I in Image.Data'Range loop
-- Believe it or not; this is logical negation in Ada.
Image.Data (I) := U_Char ((-Integer (Image.Data (I))) - 1);
end loop;
elsif Image.Format = X_Y_Pixmap then
-- this is slow, may do better later
for Y in S_Short range 0 .. S_Short (Image.Height) - 1 loop
for X in S_Short range 0 .. S_Short (Image.Width) - 1 loop
Pixel := X_Get_Pixel (Image, X, Y);
Pixel := Pixel + Value;
X_Put_Pixel (Image, X, Y, Pixel);
end loop;
end loop;
elsif Image.Format = Z_Pixmap then
-- If the bits_per_pixel makes the alignment occur on even
-- byte boundaries, perform the addition by stepping thru
-- the data one pixel at a time. Otherwise, do it the slow
-- way by calling get and put pixel.
--
if Image.Bits_Per_Pixel rem 8 = 0 then
N_Bytes := Round_Up
(U_Short (Image.Bits_Per_Pixel), U_Short (8)) / 8;
for Y in S_Short range 0 .. S_Short (Image.Height) - 1 loop
Src := Z_Index (0, Y, Image);
for X in S_Short range 0 .. S_Short (Image.Width) - 1 loop
Pixes := (others => 0);
Pixes (0 .. N_Bytes - 1) :=
Image.Data (Src .. Src + N_Bytes - 1);
Z_Normalize (Pixes, N_Bytes, Image);
Pixel := From_U_Char (Pixes);
Pixel := Pixel + Value;
Pixes := To_U_Char (Pixel);
Z_Normalize (Pixes, N_Bytes, Image);
Image.Data (Src .. Src + N_Bytes - 1) :=
Pixes (0 .. N_Bytes - 1);
Src := Src + N_Bytes;
end loop;
end loop;
else
for Y in S_Short range 0 .. S_Short (Image.Height) - 1 loop
for X in S_Short range 0 .. S_Short (Image.Width) - 1 loop
Pixel := X_Get_Pixel (Image, X, Y);
Pixel := Pixel + Value;
X_Put_Pixel (Image, X, Y, Pixel);
end loop;
end loop;
end if;
else -- should never get here
Private_X_Report_Bad_Image
("format", X_Image_Format'Image (Image.Format),
"private_X_Add_Pixel");
end if;
end Private_X_Add_Pixel;
--\f
------------------------------------------------------------------------------
-- Get_Pixel
--
-- Returns the specified pixel. The X and Y coordinates are relative to
-- the origin (upper left [0,0]) of the image. The pixel value is returned
-- in normalized format, i.e. the LSB of the long is the LSB of the pixel.
-- The algorithm used is:
--
-- copy the source bitmap_unit or Z_pixel into temp
-- normalize temp if needed
-- extract the pixel bits into return value
------------------------------------------------------------------------------
function Private_X_Get_Pixel (Image : X_Image;
X : S_Short;
Y : S_Short) return X_Pixel is
Pixel : X_Pixel;
Pixes : U_Char_4_Array;
Src : S_Natural;
Plane : S_Natural;
N_Bytes : S_Natural;
Bits : S_Natural;
begin
if Image.Depth = 1 then
Src := X_Y_Index (X, Y, Image);
Pixes := (others => 0);
N_Bytes := S_Natural (Image.Bitmap_Unit) / 8;
Pixes (0 .. N_Bytes - 1) := Image.Data (Src .. Src + N_Bytes - 1);
X_Y_Normalize (Pixes, N_Bytes, Image);
Bits := S_Natural (X + Image.X_Offset) rem
S_Natural (Image.Bitmap_Unit);
Pixel :=
X_Pixel
(Shift (S_Long (Pixes (Bits / 8)), -Integer (Bits mod 8)) and
1);
elsif Image.Format = X_Y_Pixmap then
Pixel := 0;
Plane := 0;
N_Bytes := S_Natural (Image.Bitmap_Unit) / 8;
for I in 0 .. Image.Depth - 1 loop
Src := X_Y_Index (X, Y, Image) + Plane;
Pixes := (others => 0);
Pixes (0 .. N_Bytes - 1) :=
Image.Data (Src .. Src + N_Bytes - 1);
X_Y_Normalize (Pixes, N_Bytes, Image);
Bits := S_Natural (X + Image.X_Offset) rem
S_Natural (Image.Bitmap_Unit);
Pixel :=
Shift (Pixel, 1) or
(Shift (X_Pixel (Pixes (Bits / 8)),
-Integer (Bits rem 8)) and 1);
Plane := Plane + S_Natural
(Image.Bytes_Per_Line * Image.Height);
end loop;
elsif Image.Format = Z_Pixmap then
Src := Z_Index (X, Y, Image);
Pixes := (others => 0);
N_Bytes :=
Round_Up (U_Short (Image.Bits_Per_Pixel), U_Short (8)) / 8;
Pixes (0 .. N_Bytes - 1) := Image.Data (Src .. Src + N_Bytes - 1);
Z_Normalize (Pixes, N_Bytes, Image);
Pixel := 0;
for I in reverse Pixes'Range loop
Pixel := Shift (Pixel, 8) or X_Pixel (Pixes (I));
end loop;
if Image.Bits_Per_Pixel = 4 then
if X rem 2 /= 0 then
Pixel := Shift (Pixel, -4);
else
Pixel := Pixel and 16#0F#;
end if;
end if;
else -- should never get here
Private_X_Report_Bad_Image
("format", X_Image_Format'Image (Image.Format),
"private_X_Get_Pixel");
end if;
if Image.Bits_Per_Pixel = Image.Depth then
return Pixel;
else
return Pixel and Low_Bits_Table (S_Natural (Image.Depth));
end if;
end Private_X_Get_Pixel;
--\f
function Private_X_Get_Pixel_8 (Image : X_Image;
X : S_Short;
Y : S_Short) return X_Pixel is
Pixel : X_Pixel;
begin
if Image.Format = Z_Pixmap and then
Image.Bits_Per_Pixel = 8 then
Pixel :=
X_Pixel
(Image.Data
(Image.Data'First +
S_Natural (Y * S_Short (Image.Bytes_Per_Line) + X)));
if Image.Depth /= 8 then
Pixel := Pixel and Low_Bits_Table (S_Natural (Image.Depth));
end if;
return Pixel;
else
Private_X_Init_Image_Func_Ptrs (Image);
return X_Get_Pixel (Image, X, Y);
end if;
end Private_X_Get_Pixel_8;
--\f
function Private_X_Get_Pixel_1 (Image : X_Image;
X : S_Short;
Y : S_Short) return X_Pixel is
Bit : U_Char;
Xoff : S_Natural;
Yoff : S_Natural;
begin
if Image.Depth = 1 and then
Image.Byte_Order = Image.Bitmap_Bit_Order then
Xoff := S_Natural (X + Image.X_Offset);
Yoff := S_Natural (Y * S_Short (Image.Bytes_Per_Line)) +
(Xoff / 2 ** 3);
Xoff := Xoff rem 8;
if Image.Bitmap_Bit_Order = Msb_First then
Bit := 2 ** Natural (7 - Xoff);
else
Bit := 2 ** Natural (Xoff);
end if;
if (Image.Data (Image.Data'First + Yoff) and Bit) /= 0 then
return 1;
else
return 0;
end if;
else
Private_X_Init_Image_Func_Ptrs (Image);
return X_Get_Pixel (Image, X, Y);
end if;
end Private_X_Get_Pixel_1;
--\f
------------------------------------------------------------------------------
-- Put_Pixel
--
-- Overwrites the specified pixel. The X and Y coordinates are relative to
-- the origin (upper left [0,0]) of the image. The input pixel value must be
-- in normalized format, i.e. the LSB of the long is the LSB of the pixel.
-- The algorithm used is:
--
-- copy the destination bitmap_unit or Z_pixel to temp
-- normalize temp if needed
-- copy the pixel bits into the temp
-- renormalize temp if needed
-- copy the temp back into the destination image data
------------------------------------------------------------------------------
procedure Private_X_Put_Pixel (Image : X_Image;
X : S_Short;
Y : S_Short;
Pixel : X_Pixel) is
Px : X_Pixel;
Lpixel : X_Pixel := Pixel;
Npixel : X_Pixel;
Pixes : U_Char_4_Array;
Raw : U_Char_4_Array;
Src : S_Natural;
Plane : S_Natural;
N_Bytes : S_Natural;
I : U_Char;
begin
if Image.Depth = 4 then
Lpixel := Lpixel and 16#F#;
end if;
Npixel := Lpixel;
for I in Pixes'Range loop
Pixes (I) := U_Char (Lpixel and 16#FF#);
Lpixel := Lpixel / X_Pixel (2 ** 8);
end loop;
if Image.Depth = 1 then
Src := X_Y_Index (X, Y, Image);
Pixes := (others => 0);
N_Bytes := S_Natural (Image.Bitmap_Unit) / 8;
Pixes (0 .. N_Bytes - 1) := Image.Data (Src .. Src + N_Bytes - 1);
X_Y_Normalize (Pixes, N_Bytes, Image);
I := U_Char (X + Image.X_Offset) rem Image.Bitmap_Unit;
Raw := To_U_Char (Lpixel);
Private_Put_Bits (Raw, I, 1, Pixes);
X_Y_Normalize (Pixes, N_Bytes, Image);
Image.Data (Src .. Src + N_Bytes - 1) := Pixes (0 .. N_Bytes - 1);
elsif Image.Format = X_Y_Pixmap then
Plane := S_Natural (Image.Bytes_Per_Line * Image.Height) *
S_Natural (Image.Depth -
1); -- do least signif plane 1st
N_Bytes := S_Natural (Image.Bitmap_Unit) / 8;
for J in 0 .. Image.Depth - 1 loop
Src := X_Y_Index (X, Y, Image) + Plane;
Pixes := (others => 0);
Pixes (0 .. N_Bytes - 1) :=
Image.Data (Src .. Src + N_Bytes - 1);
X_Y_Normalize (Pixes, N_Bytes, Image);
I := U_Char (X + Image.X_Offset) rem Image.Bitmap_Unit;
Raw := To_U_Char (Px);
Private_Put_Bits (Raw, I, 1, Pixes);
X_Y_Normalize (Pixes, N_Bytes, Image);
Image.Data (Src .. Src + N_Bytes - 1) :=
Pixes (0 .. N_Bytes - 1);
Npixel := Npixel / 2;
Px := Npixel;
for I in Pixes'Range loop
Pixes (I) := U_Char (Npixel and 16#FF#);
Npixel := Npixel / X_Pixel (2 ** 8);
end loop;
Plane := Plane - S_Natural
(Image.Bytes_Per_Line * Image.Height);
end loop;
elsif Image.Format = Z_Pixmap then
Src := Z_Index (X, Y, Image);
Pixes := (others => 0);
N_Bytes :=
Round_Up (U_Short (Image.Bits_Per_Pixel), U_Short (8)) / 8;
Pixes (0 .. N_Bytes - 1) := Image.Data (Src .. Src + N_Bytes - 1);
Z_Normalize (Pixes, N_Bytes, Image);
Raw := To_U_Char (Lpixel);
Private_Put_Bits
(Raw, U_Char ((X * S_Short (Image.Bits_Per_Pixel)) rem 8),
S_Long (Image.Bits_Per_Pixel), Pixes);
Z_Normalize (Pixes, N_Bytes, Image);
Image.Data (Src .. Src + N_Bytes - 1) := Pixes (0 .. N_Bytes - 1);
else -- should never get here
Private_X_Report_Bad_Image
("format", X_Image_Format'Image (Image.Format),
"private_X_Put_Pixel");
end if;
end Private_X_Put_Pixel;
--\f
procedure Private_X_Put_Pixel_8 (Image : X_Image;
X : S_Short;
Y : S_Short;
Pixel : X_Pixel) is
begin
if Image.Format = Z_Pixmap and then
Image.Bits_Per_Pixel = 8 then
Image.Data (Image.Data'First +
S_Natural (Y * S_Short (Image.Bytes_Per_Line) + X)) :=
U_Char (Pixel);
else
Private_X_Init_Image_Func_Ptrs (Image);
X_Put_Pixel (Image, X, Y, Pixel);
end if;
end Private_X_Put_Pixel_8;
--\f
procedure Private_X_Put_Pixel_1 (Image : X_Image;
X : S_Short;
Y : S_Short;
Pixel : X_Pixel) is
Bit : U_Char;
Xoff : S_Natural;
Yoff : S_Natural;
begin
if Image.Depth = 1 and then
Image.Byte_Order = Image.Bitmap_Bit_Order then
Xoff := S_Natural (X + Image.X_Offset);
Yoff := S_Natural (Y * S_Short (Image.Bytes_Per_Line)) +
(Xoff / 2 ** 3);
Xoff := Xoff rem 8;
if Image.Bitmap_Bit_Order = Msb_First then
Bit := 2 ** Natural (7 - Xoff);
else
Bit := 2 ** Natural (Xoff);
end if;
Yoff := Yoff + Image.Data'First;
if Pixel rem 1 /= 0 then
Image.Data (Yoff) := Image.Data (Yoff) or Bit;
else
Image.Data (Yoff) := Image.Data (Yoff) and not Bit;
end if;
else
Private_X_Init_Image_Func_Ptrs (Image);
X_Put_Pixel (Image, X, Y, Pixel);
end if;
end Private_X_Put_Pixel_1;
--\f
------------------------------------------------------------------------------
-- Sub_Image
--
-- Creates a new image that is a subsection of an existing one.
-- Allocates the memory necessary for the neww image data structure.
-- Pointer to new image is returned. The algorithm used is repetitive
-- calls to get and put pixel.
------------------------------------------------------------------------------
function Private_X_Sub_Image
(Image : X_Image;
X : S_Short; -- starting x coordinate in Image
Y : S_Short; -- starting y coordinate in Image
Width : U_Short; -- width in pixels of new subimage
Height : U_Short -- height in pixels of new subimage
) return X_Image is
Subimage : X_Image;
Dsize : S_Natural;
Pixel : X_Pixel;
begin
Subimage := new X_Image_Rec;
Subimage.Width := Width;
Subimage.Height := Height;
Subimage.X_Offset := 0;
Subimage.Format := Image.Format;
Subimage.Byte_Order := Image.Byte_Order;
Subimage.Bitmap_Unit := Image.Bitmap_Unit;
Subimage.Bitmap_Bit_Order := Image.Bitmap_Bit_Order;
Subimage.Bitmap_Pad := Image.Bitmap_Pad;
Subimage.Bits_Per_Pixel := Image.Bits_Per_Pixel;
Subimage.Depth := Image.Depth;
--
-- compute per line accelerator.
--
if (Subimage.Format = Z_Pixmap) then
Subimage.Bytes_Per_Line :=
U_Short (Round_Up (U_Short (Subimage.Bits_Per_Pixel) * Width,
Subimage.Bitmap_Pad / 8));
else
Subimage.Bytes_Per_Line :=
U_Short (Round_Up (Width,
Subimage.Bitmap_Pad / 8));
end if;
Subimage.Obdata := null;
Private_X_Init_Image_Func_Ptrs (Subimage);
Dsize := S_Natural (Subimage.Bytes_Per_Line) * S_Natural (Height);
if Subimage.Format = X_Y_Pixmap then
Dsize := Dsize * S_Natural (Subimage.Depth);
end if;
Subimage.Data := new U_Char_Array (1 .. Dsize);
--
-- Test for cases where the new subimage is larger than the region
-- that we are copying from the existing data. In those cases,
-- copy the area of the existing image, and allow the "uncovered"
-- area of new subimage to remain with zero filled pixels.
--
declare
L_Height : S_Short := S_Short (Height);
L_Width : S_Short := S_Short (Width);
begin
if L_Height > S_Short (Image.Height) - Y then
L_Height := S_Short (Image.Height) - Y;
end if;
if L_Width > S_Short (Image.Width) - X then
L_Width := S_Short (Image.Width) - X;
end if;
for Row in Y .. Y + L_Height - 1 loop
for Col in X .. X + L_Width - 1 loop
Pixel := X_Get_Pixel (Image, Col, Row);
X_Put_Pixel (Subimage, (Col - X), (Row - Y), Pixel);
end loop;
end loop;
end;
return Subimage;
exception
when others =>
Free_X_Image (Subimage);
raise;
end Private_X_Sub_Image;
--\f
function Default_X_Add_Pixel_Type is
new Proc_Var_X_Add_Pixel.Value (Private_X_Add_Pixel);
function Default_X_Create_Image_Type is
new Proc_Var_X_Create_Image.Value (X_Create_Image);
function Default_X_Destroy_Image_Type is
new Proc_Var_X_Destroy_Image.Value (Free_X_Image);
function Default_X_Get_Pixel_Type is
new Proc_Var_X_Get_Pixel.Value (Private_X_Get_Pixel);
function Default_X_Get_Pixel_8_Type is
new Proc_Var_X_Get_Pixel.Value (Private_X_Get_Pixel_8);
function Default_X_Get_Pixel_1_Type is
new Proc_Var_X_Get_Pixel.Value (Private_X_Get_Pixel_1);
function Default_X_Put_Pixel_Type is
new Proc_Var_X_Put_Pixel.Value (Private_X_Put_Pixel);
function Default_X_Put_Pixel_8_Type is
new Proc_Var_X_Put_Pixel.Value (Private_X_Put_Pixel_8);
function Default_X_Put_Pixel_1_Type is
new Proc_Var_X_Put_Pixel.Value (Private_X_Put_Pixel_1);
function Default_X_Sub_Image_Type is
new Proc_Var_X_Sub_Image.Value (Private_X_Sub_Image);
--\f
-- This routine initializes the image object function pointers. The
-- intent is to provide native (i.e. fast) routines for native format images
-- only using the generic (i.e. slow) routines when fast ones don't exist.
-- However, with the current rather botched external interface, clients may
-- have to mung image attributes after the image gets created, so the fast
-- routines always have to check to make sure the optimization is still
-- valid, and reinitialize the functions if not.
procedure Private_X_Init_Image_Func_Ptrs (Image : X_Image) is
begin
Image.F.Create_Image := Proc_Var_X_Create_Image.From_Pv
(Default_X_Create_Image_Type);
Image.F.Destroy_Image := Proc_Var_X_Destroy_Image.From_Pv
(Default_X_Destroy_Image_Type);
if Image.Format = Z_Pixmap and then Image.Bits_Per_Pixel = 8 then
Image.F.Get_Pixel := Proc_Var_X_Get_Pixel.From_Pv
(Default_X_Get_Pixel_8_Type);
Image.F.Put_Pixel := Proc_Var_X_Put_Pixel.From_Pv
(Default_X_Put_Pixel_8_Type);
elsif Image.Depth = 1 and then
Image.Byte_Order = Image.Bitmap_Bit_Order then
Image.F.Get_Pixel := Proc_Var_X_Get_Pixel.From_Pv
(Default_X_Get_Pixel_1_Type);
Image.F.Put_Pixel := Proc_Var_X_Put_Pixel.From_Pv
(Default_X_Put_Pixel_1_Type);
else
Image.F.Get_Pixel := Proc_Var_X_Get_Pixel.From_Pv
(Default_X_Get_Pixel_Type);
Image.F.Put_Pixel := Proc_Var_X_Put_Pixel.From_Pv
(Default_X_Put_Pixel_Type);
end if;
Image.F.Sub_Image := Proc_Var_X_Sub_Image.From_Pv
(Default_X_Sub_Image_Type);
Image.F.Add_Pixel := Proc_Var_X_Add_Pixel.From_Pv
(Default_X_Add_Pixel_Type);
-- Image.F.Set_Image :=
-- proc_var_X_Set_Image_Type.from_pv(
-- Default_X_Set_Image_Type);
end Private_X_Init_Image_Func_Ptrs;
--\f
procedure Private_Swap_Bits (B : in out U_Char_Array) is
------------------------------------------------------------------------------
-- For each byte in the buffer; swap the bits within each byte so that they
-- run in the opposite direction. Bit 0 becomes bit 7; bit 7 becomes bit 0;
-- bit 1 becomes bit 6; etc.
------------------------------------------------------------------------------
begin
for I in B'Range loop
B (I) := Private_Reverse_Byte (S_Natural (B (I)));
end loop;
end Private_Swap_Bits;
--\f
procedure Private_Swap_Short (P : in out U_Char_Array) is
------------------------------------------------------------------------------
-- For each half-word in the buffer, swap the byte pairs.
------------------------------------------------------------------------------
I : S_Natural := P'First;
C : U_Char;
begin
for J in reverse P'First .. P'First + P'Length / 2 - 1 loop
C := P (I);
P (I) := P (I + 1);
P (I + 1) := C;
I := I + 2;
end loop;
end Private_Swap_Short;
--\f
procedure Private_Swap_Long (P : in out U_Char_Array) is
------------------------------------------------------------------------------
-- For each full-word in the buffer; reverse the order of the 4 bytes.
-- We expect the buffer'Length to be a multiple of 4; if it isn't then the
-- last 1, 2, or 3 bytes ('Length rem 4) are not touched.
------------------------------------------------------------------------------
I : S_Natural := P'First;
C : U_Char;
begin
for J in P'First .. P'First + P'Length / 4 - 1 loop
C := P (I);
P (I) := P (I + 3);
P (I + 3) := C;
C := P (I + 2);
P (I + 2) := P (I + 1);
P (I + 1) := C;
I := I + 4;
end loop;
end Private_Swap_Long;
--\f
procedure Private_Swap_Three (P : in out U_Char_Array) is
------------------------------------------------------------------------------
-- We have groups of 24-bits (presumably we have a group of 3-byte colormap
-- values) and we need to swap them from big to little (or little to big)
-- endian.
------------------------------------------------------------------------------
I : S_Natural := P'First;
C : U_Char;
begin
for J in P'First .. P'First + P'Length / 3 - 1 loop
C := P (I);
P (I) := P (I + 2);
P (I + 2) := C;
I := I + 3;
end loop;
end Private_Swap_Three;
--\f
begin
X_Lib_Default_X_Add_Pixel :=
Proc_Var_X_Add_Pixel.From_Pv (Default_X_Add_Pixel_Type);
X_Lib_Default_X_Create_Image :=
Proc_Var_X_Create_Image.From_Pv (Default_X_Create_Image_Type);
X_Lib_Default_X_Destroy_Image :=
Proc_Var_X_Destroy_Image.From_Pv (Default_X_Destroy_Image_Type);
X_Lib_Default_X_Get_Pixel :=
Proc_Var_X_Get_Pixel.From_Pv (Default_X_Get_Pixel_Type);
X_Lib_Default_X_Get_Pixel_8 :=
Proc_Var_X_Get_Pixel.From_Pv (Default_X_Get_Pixel_8_Type);
X_Lib_Default_X_Get_Pixel_1 :=
Proc_Var_X_Get_Pixel.From_Pv (Default_X_Get_Pixel_1_Type);
X_Lib_Default_X_Put_Pixel :=
Proc_Var_X_Put_Pixel.From_Pv (Default_X_Put_Pixel_Type);
X_Lib_Default_X_Put_Pixel_8 :=
Proc_Var_X_Put_Pixel.From_Pv (Default_X_Put_Pixel_8_Type);
X_Lib_Default_X_Put_Pixel_1 :=
Proc_Var_X_Put_Pixel.From_Pv (Default_X_Put_Pixel_1_Type);
X_Lib_Default_X_Sub_Image :=
Proc_Var_X_Sub_Image.From_Pv (Default_X_Sub_Image_Type);
end Xlbip_Image_Internal;