|
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: 84274 (0x14932)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─ ⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Color;
use Xlbt_Color;
with Xlbt_Display2;
use Xlbt_Display2;
with Xlbt_Image;
use Xlbt_Image;
with Xlbt_Image2;
use Xlbt_Image2;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Visual;
use Xlbt_Visual;
with Xlbp_Gc;
use Xlbp_Gc;
with Xlbp_Proc_Var;
use Xlbp_Proc_Var;
with Xlbip_Get_Reply;
use Xlbip_Get_Reply;
with Xlbip_Image_Internal;
use Xlbip_Image_Internal;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
with Xlbmt_Network_Types;
use Xlbmt_Network_Types;
package body Xlbp_Image is
------------------------------------------------------------------------------
-- X Library Images
--
-- Xlbp_Image - Used to create and manipulate images.
------------------------------------------------------------------------------
-- Copyright 1989 - 1991 by Rational, Santa Clara, California.
-- Copyright 1987 - 1989 by Digital Equipment Corporation, Maynard, Mass.
-- Copyright 1987 - 1989 by Massachusetts Institute of Technology,
-- Cambridge, Massachusetts.
--
-- 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 Digital, MIT, or Rational
-- not be used in advertising or publicity pertaining to distribution of
-- the software without specific, written prior permission.
--
-- Digital, MIT, and Rational disclaim all warranties with regard to this
-- software, including all implied warranties of merchantability and fitness,
-- in no event shall Digital, 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
------------------------------------------------------------------------------
-- The following table gives the bit ordering within bytes (when accessed
-- sequentially) for a scanline containing 32 bits, with bits numbered 0 to
-- 31, where bit 0 should be leftmost on the display. For a given byte
-- labeled A-B, A is for the most significant bit of the byte, and B is
-- for the least significant bit.
--
-- legend:
-- 1 scanline-unit = 8
-- 2 scanline-unit = 16
-- 4 scanline-unit = 32
-- M byte-order = MostSignificant
-- L byte-order = LeastSignificant
-- m bit-order = MostSignificant
-- l bit-order = LeastSignificant
--
--
-- format ordering
--
-- 1Mm 00-07 08-15 16-23 24-31
-- 2Mm 00-07 08-15 16-23 24-31
-- 4Mm 00-07 08-15 16-23 24-31
-- 1Ml 07-00 15-08 23-16 31-24
-- 2Ml 15-08 07-00 31-24 23-16
-- 4Ml 31-24 23-16 15-08 07-00
-- 1Lm 00-07 08-15 16-23 24-31
-- 2Lm 08-15 00-07 24-31 16-23
-- 4Lm 24-31 16-23 08-15 00-07
-- 1Ll 07-00 15-08 23-16 31-24
-- 2Ll 07-00 15-08 23-16 31-24
-- 4Ll 07-00 15-08 23-16 31-24
--
--
-- The following table gives the required conversion between any two
-- formats. It is based strictly on the table above. If you believe one,
-- you should believe the other.
--
-- legend:
-- n no changes
-- s reverse 8-bit units within 16-bit units
-- l reverse 8-bit units within 32-bit units
-- w reverse 16-bit units within 32-bit units
-- R reverse bits within 8-bit units
-- S s+R
-- L l+R
-- W w+R
------------------------------------------------------------------------------
type Swap_Function_Types is
(Do_No_Swap, Do_Swap_Two_Bytes, Do_Swap_Four_Bytes,
Do_Swap_Words, Do_Swap_Bits, Do_Swap_Bits_And_Two_Bytes,
Do_Swap_Bits_And_Four_Bytes, Do_Swap_Bits_And_Words);
Ln : constant Swap_Function_Types := Do_No_Swap;
Ls : constant Swap_Function_Types := Do_Swap_Two_Bytes;
Ll : constant Swap_Function_Types := Do_Swap_Four_Bytes;
Lw : constant Swap_Function_Types := Do_Swap_Words;
Br : constant Swap_Function_Types := Do_Swap_Bits;
Bs : constant Swap_Function_Types := Do_Swap_Bits_And_Two_Bytes;
Bl : constant Swap_Function_Types := Do_Swap_Bits_And_Four_Bytes;
Bw : constant Swap_Function_Types := Do_Swap_Bits_And_Words;
type Swap_Function_Array is
array (S_Natural range 0 .. 11, S_Natural range 0 .. 11) of
Swap_Function_Types;
Swap_Function : constant Swap_Function_Array :=
(
-- 1Mm 2Mm 4Mm 1Ml 2Ml 4Ml 1Lm 2Lm 4Lm 1Ll 2Ll 4Ll
(Ln, Ln, Ln, Br, Bs, Bl, Ln, Ls, Ll, Br, Br, Br), -- 1Mm
(Ln, Ln, Ln, Br, Bs, Bl, Ln, Ls, Ll, Br, Br, Br), -- 2Mm
(Ln, Ln, Ln, Br, Bs, Bl, Ln, Ls, Ll, Br, Br, Br), -- 4Mm
(Br, Br, Br, Ln, Ls, Ll, Br, Bs, Bl, Ln, Ln, Ln), -- 1Ml
(Bs, Bs, Bs, Ls, Ln, Lw, Bs, Br, Bw, Ls, Ll, Ls), -- 2Ml
(Bl, Bl, Bl, Ll, Lw, Ln, Bl, Bw, Br, Ll, Ll, Ll), -- 4Ml
(Ln, Ln, Ln, Br, Bs, Bl, Ln, Ls, Ll, Br, Br, Br), -- 1Lm
(Ls, Ls, Ls, Bs, Br, Bw, Ls, Ln, Lw, Bs, Bs, Bs), -- 2Lm
(Ll, Ll, Ll, Bl, Bw, Br, Ll, Lw, Ln, Bl, Bl, Bl), -- 4Lm
(Br, Br, Br, Ln, Ls, Ll, Br, Bs, Bl, Ln, Ln, Ln), -- 1Ll
(Br, Br, Br, Ln, Ls, Ll, Br, Bs, Bl, Ln, Ln, Ln), -- 2Ll
(Br, Br, Br, Ln, Ls, Ll, Br, Bs, Bl, Ln, Ln, Ln) -- 4Ll
);
-- -- Of course the table above is a lie. We also need to factor in the
-- -- order of the source data to cope with swapping half of a unit at the
-- -- end of a scanline, since we are trying to avoid de-ref'ing off the
-- -- end of the source.
-- --
-- -- Defines whether the first half of a unit has the first half of the data
-- --
--
-- type X_Byte_Bit_Order_Array is
-- array (S_Natural range 0 .. 11) of X_Byte_Bit_Order;
--
-- Half_Order : constant X_Byte_Bit_Order_Array :=
-- (Lsb_First, -- 1Mm
-- Lsb_First, -- 2Mm
-- Lsb_First, -- 4Mm
-- Lsb_First, -- 1Ml
-- Msb_First, -- 2Ml
-- Msb_First, -- 4Ml
-- Lsb_First, -- 1Lm
-- Msb_First, -- 2Lm
-- Msb_First, -- 4Lm
-- Lsb_First, -- 1Ll
-- Lsb_First, -- 2Ll
-- Lsb_First -- 4Ll
-- );
Private_Reverse_Nibs : constant U_Char_Array (0 .. 16#FF#) :=
(16#00#, 16#10#, 16#20#, 16#30#, 16#40#, 16#50#, 16#60#, 16#70#,
16#80#, 16#90#, 16#A0#, 16#B0#, 16#C0#, 16#D0#, 16#E0#, 16#F0#,
16#01#, 16#11#, 16#21#, 16#31#, 16#41#, 16#51#, 16#61#, 16#71#,
16#81#, 16#91#, 16#A1#, 16#B1#, 16#C1#, 16#D1#, 16#E1#, 16#F1#,
16#02#, 16#12#, 16#22#, 16#32#, 16#42#, 16#52#, 16#62#, 16#72#,
16#82#, 16#92#, 16#A2#, 16#B2#, 16#C2#, 16#D2#, 16#E2#, 16#F2#,
16#03#, 16#13#, 16#23#, 16#33#, 16#43#, 16#53#, 16#63#, 16#73#,
16#83#, 16#93#, 16#A3#, 16#B3#, 16#C3#, 16#D3#, 16#E3#, 16#F3#,
16#04#, 16#14#, 16#24#, 16#34#, 16#44#, 16#54#, 16#64#, 16#74#,
16#84#, 16#94#, 16#A4#, 16#B4#, 16#C4#, 16#D4#, 16#E4#, 16#F4#,
16#05#, 16#15#, 16#25#, 16#35#, 16#45#, 16#55#, 16#65#, 16#75#,
16#85#, 16#95#, 16#A5#, 16#B5#, 16#C5#, 16#D5#, 16#E5#, 16#F5#,
16#06#, 16#16#, 16#26#, 16#36#, 16#46#, 16#56#, 16#66#, 16#76#,
16#86#, 16#96#, 16#A6#, 16#B6#, 16#C6#, 16#D6#, 16#E6#, 16#F6#,
16#07#, 16#17#, 16#27#, 16#37#, 16#47#, 16#57#, 16#67#, 16#77#,
16#87#, 16#97#, 16#A7#, 16#B7#, 16#C7#, 16#D7#, 16#E7#, 16#F7#,
16#08#, 16#18#, 16#28#, 16#38#, 16#48#, 16#58#, 16#68#, 16#78#,
16#88#, 16#98#, 16#A8#, 16#B8#, 16#C8#, 16#D8#, 16#E8#, 16#F8#,
16#09#, 16#19#, 16#29#, 16#39#, 16#49#, 16#59#, 16#69#, 16#79#,
16#89#, 16#99#, 16#A9#, 16#B9#, 16#C9#, 16#D9#, 16#E9#, 16#F9#,
16#0A#, 16#1A#, 16#2A#, 16#3A#, 16#4A#, 16#5A#, 16#6A#, 16#7A#,
16#8A#, 16#9A#, 16#AA#, 16#BA#, 16#CA#, 16#DA#, 16#EA#, 16#FA#,
16#0B#, 16#1B#, 16#2B#, 16#3B#, 16#4B#, 16#5B#, 16#6B#, 16#7B#,
16#8B#, 16#9B#, 16#AB#, 16#BB#, 16#CB#, 16#DB#, 16#EB#, 16#FB#,
16#0C#, 16#1C#, 16#2C#, 16#3C#, 16#4C#, 16#5C#, 16#6C#, 16#7C#,
16#8C#, 16#9C#, 16#AC#, 16#BC#, 16#CC#, 16#DC#, 16#EC#, 16#FC#,
16#0D#, 16#1D#, 16#2D#, 16#3D#, 16#4D#, 16#5D#, 16#6D#, 16#7D#,
16#8D#, 16#9D#, 16#AD#, 16#BD#, 16#CD#, 16#DD#, 16#ED#, 16#FD#,
16#0E#, 16#1E#, 16#2E#, 16#3E#, 16#4E#, 16#5E#, 16#6E#, 16#7E#,
16#8E#, 16#9E#, 16#AE#, 16#BE#, 16#CE#, 16#DE#, 16#EE#, 16#FE#,
16#0F#, 16#1F#, 16#2F#, 16#3F#, 16#4F#, 16#5F#, 16#6F#, 16#7F#,
16#8F#, 16#9F#, 16#AF#, 16#BF#, 16#CF#, 16#DF#, 16#EF#, 16#FF#);
--\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;
------------------------------------------------------------------------------
function Round_Up (N_Bytes : S_Natural;
Pad : S_Natural) return S_Natural is
begin
return ((N_Bytes + Pad - 1) / Pad) * Pad;
end Round_Up;
------------------------------------------------------------------------------
--\f
------------------------------------------------------------------------------
procedure X_Destroy_Image (Image : in out X_Image) is
use Proc_Var_X_Destroy_Image;
begin
if Image /= None_X_Image then
Call (To_Pv (Image.F.Destroy_Image), Image);
end if;
end X_Destroy_Image;
------------------------------------------------------------------------------
function X_Get_Pixel (Image : X_Image;
X : S_Short;
Y : S_Short) return X_Pixel is
use Proc_Var_X_Get_Pixel;
begin
return Call (To_Pv (Image.F.Get_Pixel), Image, X, Y);
end X_Get_Pixel;
------------------------------------------------------------------------------
procedure X_Put_Pixel (Image : X_Image;
X : S_Short;
Y : S_Short;
Pixel : X_Pixel) is
use Proc_Var_X_Put_Pixel;
begin
Call (To_Pv (Image.F.Put_Pixel), Image, X, Y, Pixel);
end X_Put_Pixel;
------------------------------------------------------------------------------
function X_Sub_Image (Image : X_Image;
X : S_Short;
Y : S_Short;
Width : U_Short;
Height : U_Short) return X_Image is
use Proc_Var_X_Sub_Image;
begin
return Call (To_Pv (Image.F.Sub_Image), Image, X, Y, Width, Height);
end X_Sub_Image;
------------------------------------------------------------------------------
procedure X_Add_Pixel (Image : X_Image;
Value : X_Pixel) is
use Proc_Var_X_Add_Pixel;
begin
Call (To_Pv (Image.F.Add_Pixel), Image, Value);
end X_Add_Pixel;
--\f
------------------------------------------------------------------------------
function Ones (Msk : X_Plane_Mask) return U_Char is -- HACK_MEM 169
-- geb, god knows what this is doing.
Z : X_Plane_Mask := Msk;
Y : X_Plane_Mask;
begin
-- y := (msk >> 1) & 033333333333;
Y := Shift (Z, -1) and -8#4444444445#;
-- y := msk - y - ((y >>1) & 033333333333);
Y := Z - Y - (Shift (Y, -1) and -8#4444444445#);
-- return (((y + (y >> 3)) & 030707070707) % 077);
Y := ((Y + Shift (Y, -3)) and -8#7070707071#) rem 8#77#;
return U_Char (Y rem X_Plane_Mask (U_Char'Last + 1));
end Ones;
--\f
------------------------------------------------------------------------------
-- These two convenience routines return the scan_line_pad and bits_per_pixel
-- associated with a specific depth of Z_Pixmap format image for a
-- display.
function Private_X_Get_Scanline_Pad (Display : X_Display;
Depth : U_Char) return U_Char is
begin
for I in Display.Pixmap_Format'Range loop
if Display.Pixmap_Format (I).Depth = Depth then
return Display.Pixmap_Format (I).Scan_Line_Pad;
end if;
end loop;
return Display.Bitmap_Pad;
end Private_X_Get_Scanline_Pad;
--\f
function Private_X_Get_Bits_Per_Pixel (Display : X_Display;
Depth : U_Char) return U_Char is
begin
for I in Display.Pixmap_Format'Range loop
if Display.Pixmap_Format (I).Depth = Depth then
return Display.Pixmap_Format (I).Bits_Per_Pixel;
end if;
end loop;
return Depth;
end Private_X_Get_Bits_Per_Pixel;
--\f
------------------------------------------------------------------------------
-- Set_Image
--
-- Overwrites a section of one image with all of the data from another.
-- If the two images are not of the same format (i.e. X_Y_Pixmap and Z_Pixmap),
-- the image data is converted to the destination format. The following
-- restrictions apply:
--
-- 1. The depths of the source and destination images must be equal.
--
-- 2. If the height of the source image is too large to fit between
-- the specified y starting point and the bottom of the image,
-- then scan_lines are truncated on the bottom.
--
-- 3. If the width of the source image is too large to fit between
-- the specified x starting point and the end of the scan_line,
-- then pixels are truncated on the right.
--
-- The images need not have the same bitmap_bit_order, byte_order,
-- bitmap_unit, bits_per_pixel, bitmap_pad, or x_offset.
------------------------------------------------------------------------------
procedure Private_X_Set_Image (Src_Img : X_Image;
Dst_Img : X_Image;
X : S_Short;
Y : S_Short) is
Pixel : X_Pixel;
Width : U_Short;
Height : U_Short;
Start_Row : S_Short;
Start_Col : S_Short;
Xx : S_Short := X;
Yy : S_Short := Y;
begin
if (Src_Img.Depth /= Dst_Img.Depth) then
Private_X_Report_Bad_Image
("depth", U_Char'Image (Dst_Img.Depth), "private_X_Set_Image");
end if;
if Xx < 0 then
Start_Col := -Xx;
Xx := 0;
else
Start_Col := 0;
end if;
if Yy < 0 then
Start_Row := -Y;
Yy := 0;
else
Start_Row := 0;
end if;
Width := Dst_Img.Width - U_Short (Xx);
if Src_Img.Width < Width then
Width := Src_Img.Width;
end if;
Height := Dst_Img.Height - U_Short (Yy);
if Src_Img.Height < Height then
Height := Src_Img.Height;
end if;
----This is slow, will do better later.
for Row in Start_Row .. S_Short (Height - 1) loop
for Col in Start_Col .. S_Short (Width - 1) loop
Pixel := X_Get_Pixel (Src_Img, Col, Row);
X_Put_Pixel (Dst_Img, Xx + Col, Yy + Row, Pixel);
end loop;
end loop;
end Private_X_Set_Image;
--\f
procedure No_Swap (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Bound : S_Natural;
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
begin
if Srcinc = Destinc then
Bound := Srcinc * (Height - 1) + Srclen - 1;
Dest (Dest_I .. Dest_I + Bound) := Src (Src_I .. Src_I + Bound);
else
Bound := Srclen - 1;
for H in reverse 0 .. Height - 1 loop
Dest (Dest_I .. Dest_I + Bound) := Src (Src_I .. Src_I + Bound);
Src_I := Src_I + Srcinc;
Dest_I := Dest_I + Destinc;
end loop;
end if;
end No_Swap;
--\f
procedure Swap_Two_Bytes (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 2;
Odd : S_Natural := Srclen rem 2;
begin
for H in reverse 1 .. Height loop
for E in 1 .. Even loop
Dest (Dest_I) := Src (Src_I + 1);
Dest (Dest_I + 1) := Src (Src_I);
Dest_I := Dest_I + 2;
Src_I := Src_I + 2;
end loop;
if Odd = 1 then
Dest (Dest_I + 1) := Src (Src_I);
Dest_I := Dest_I + 2;
Src_I := Src_I + Odd;
end if;
end loop;
-- N : S_Natural;
-- Length : S_Natural := Round_Up (Srclen, 2);
-- Lsrcinc : S_Long := Srcinc - Length;
-- Ldestinc : S_Long := Destinc - Length;
-- begin
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and then Srclen /= Length then
-- Length := Length - 2;
-- if Half_Order = Msb_First then
-- Dest (Dest_I + Length) := Src (Src_I + Length + 1);
-- else
-- Dest (Dest_I + Length + 1) := Src (Src_I + Length);
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Src (Src_I + 1);
-- Dest (Dest_I + 1) := Src (Src_I);
-- N := N - 2;
-- Src_I := Src_I + 2;
-- Dest_I := Dest_I + 2;
-- end loop;
-- Src_I := Src_I + Lsrcinc;
-- Dest_I := Dest_I + Ldestinc;
-- end loop;
--
end Swap_Two_Bytes;
--\f
procedure Swap_Three_Bytes (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural;
Byte_Order : X_Byte_Bit_Order) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 3;
Odd : S_Natural := Srclen rem 3;
begin
for H in reverse 0 .. Height - 1 loop
for E in 1 .. Even loop
Dest (Dest_I) := Src (Src_I + 2);
Dest (Dest_I + 1) := Src (Src_I + 1);
Dest (Dest_I + 2) := Src (Src_I);
Src_I := Src_I + 3;
Dest_I := Dest_I + 3;
end loop;
if Odd = 1 then
Dest (Dest_I + 2) := Src (Src_I);
Dest_I := Dest_I + 3;
Src_I := Src_I + Odd;
elsif Odd = 2 then
Dest (Dest_I + 2) := Src (Src_I);
Dest (Dest_I + 1) := Src (Src_I + 1);
Dest_I := Dest_I + 3;
Src_I := Src_I + Odd;
end if;
end loop;
-- N : S_Natural;
-- Length : S_Natural := ((Srclen + 2) / 3) * 3;
-- Lsrcinc : S_Long := Srcinc - Length;
-- Ldestinc : S_Long := Destinc - Length;
-- begin
--
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and then Srclen /= Length then
-- Length := Length - 3;
-- if Srclen - Length = 2 then
-- Dest (Dest_I + Length + 1) := Src (Src_I + Length + 1);
-- end if;
-- if Byte_Order = Msb_First then
-- Dest (Dest_I + Length) := Src (Src_I + Length + 2);
-- else
-- Dest (Dest_I + Length + 2) := Src (Src_I + Length);
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Src (Src_I + 2);
-- Dest (Dest_I + 1) := Src (Src_I + 1);
-- Dest (Dest_I + 2) := Src (Src_I);
-- N := N - 3;
-- Src_I := Src_I + 3;
-- Dest_I := Dest_I + 3;
-- end loop;
-- Src_I := Src_I + Lsrcinc;
-- Dest_I := Dest_I + Ldestinc;
-- end loop;
end Swap_Three_Bytes;
--\f
procedure Swap_Four_Bytes (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 4;
Odd : S_Natural := Srclen rem 4;
begin
for H in reverse 0 .. Height - 1 loop
for E in 1 .. Even loop
Dest (Dest_I) := Src (Src_I + 3);
Dest (Dest_I + 1) := Src (Src_I + 2);
Dest (Dest_I + 2) := Src (Src_I + 1);
Dest (Dest_I + 3) := Src (Src_I);
Src_I := Src_I + 4;
Dest_I := Dest_I + 4;
end loop;
if Odd = 1 then
Dest (Dest_I + 3) := Src (Src_I);
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 2 then
Dest (Dest_I + 3) := Src (Src_I);
Dest (Dest_I + 2) := Src (Src_I + 1);
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 3 then
Dest (Dest_I + 3) := Src (Src_I);
Dest (Dest_I + 2) := Src (Src_I + 1);
Dest (Dest_I + 1) := Src (Src_I + 2);
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
end if;
end loop;
-- N : S_Natural;
-- Length : S_Natural := Round_Up (Srclen, 4);
-- Lsrcinc : S_Long := Srcinc - Length;
-- Ldestinc : S_Long := Destinc - Length;
-- begin
--
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and Srclen /= Length then
-- Length := Length - 4;
-- if Half_Order = Msb_First then
-- Dest (Dest_I + Length) := Src (Src_I + Length + 3);
-- end if;
-- if (Half_Order = Lsb_First and then Srclen - Length = 3) or else
-- (Half_Order = Msb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length + 1) := Src (Src_I + Length + 2);
-- end if;
-- if (Half_Order = Msb_First and then Srclen - Length = 3) or else
-- (Half_Order = Lsb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length + 2) := Src (Src_I + Length + 1);
-- end if;
-- if Half_Order = Lsb_First then
-- Dest (Dest_I + Length + 3) := Src (Src_I + Length);
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Src (Src_I + 3);
-- Dest (Dest_I + 1) := Src (Src_I + 2);
-- Dest (Dest_I + 2) := Src (Src_I + 1);
-- Dest (Dest_I + 3) := Src (Src_I);
-- N := N - 4;
-- Src_I := Src_I + 4;
-- Dest_I := Dest_I + 4;
-- end loop;
-- Src_I := Src_I + Lsrcinc;
-- Dest_I := Dest_I + Ldestinc;
-- end loop;
end Swap_Four_Bytes;
--\f
procedure Swap_Words (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
--Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 4;
Odd : S_Natural := Srclen rem 4;
begin
for H in reverse 0 .. Height - 1 loop
for E in 1 .. Even loop
Dest (Dest_I) := Src (Src_I + 2);
Dest (Dest_I + 1) := Src (Src_I + 3);
Dest (Dest_I + 2) := Src (Src_I);
Dest (Dest_I + 3) := Src (Src_I + 1);
Src_I := Src_I + 4;
Dest_I := Dest_I + 4;
end loop;
if Odd = 1 then
Dest (Dest_I + 2) := Src (Src_I);
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 2 then
Dest (Dest_I + 2) := Src (Src_I);
Dest (Dest_I + 3) := Src (Src_I + 1);
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 3 then
Dest (Dest_I + 2) := Src (Src_I);
Dest (Dest_I + 3) := Src (Src_I + 1);
Dest (Dest_I) := Src (Src_I + 2);
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
end if;
end loop;
-- Length : S_Natural := Round_Up (Srclen, 4);
-- N : S_Natural;
-- Lsrcinc : S_Long := Srcinc - Length;
-- Ldestinc : S_Long := Destinc - Length;
-- begin
--
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and Srclen /= Length then
-- Length := Length - 4;
-- if Half_Order = Msb_First then
-- Dest (Dest_I + Length + 1) := Src (Src_I + Length + 3);
-- end if;
-- if (Half_Order = Lsb_First and then Srclen - Length = 3) or else
-- (Half_Order = Msb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length) := Src (Src_I + Length + 2);
-- end if;
-- if (Half_Order = Msb_First and then Srclen - Length = 3) or else
-- (Half_Order = Lsb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length + 3) := Src (Src_I + Length + 1);
-- end if;
-- if Half_Order = Lsb_First then
-- Dest (Dest_I + Length + 2) := Src (Src_I + Length);
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Src (Src_I + 2);
-- Dest (Dest_I + 1) := Src (Src_I + 3);
-- Dest (Dest_I + 2) := Src (Src_I);
-- Dest (Dest_I + 3) := Src (Src_I + 1);
-- N := N - 4;
-- Src_I := Src_I + 4;
-- Dest_I := Dest_I + 4;
-- end loop;
-- Src_I := Src_I + Lsrcinc;
-- Dest_I := Dest_I + Ldestinc;
-- end loop;
--
end Swap_Words;
--\f
procedure Swap_Nibbles (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
begin
for H in reverse 0 .. Height - 1 loop
for N in reverse 0 .. Srclen - 1 loop
Dest (Dest_I + N) := Private_Reverse_Nibs
(S_Natural (Src (Src_I + N)));
end loop;
Src_I := Src_I + Srcinc + Srclen;
Dest_I := Dest_I + Destinc + Srclen;
end loop;
end Swap_Nibbles;
--\f
procedure Shift_Nibbles_Left (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Lsrcinc : S_Long := Srcinc - Srclen;
Ldestinc : S_Long := Destinc - Srclen;
C1 : U_Char;
C2 : U_Char;
begin
for H in 1 .. Height loop
for N in 1 .. Srclen loop
C1 := Src (Src_I);
Src_I := Src_I + 1;
C2 := Src (Src_I);
Dest (Dest_I) := U_Char
(((S_Natural (C1) rem 2 ** 4) * 2 ** 4) +
(S_Natural (C2) / 2 ** 4));
Dest_I := Dest_I + 1;
end loop;
Src_I := Src_I + Lsrcinc;
Dest_I := Dest_I + Ldestinc;
end loop;
end Shift_Nibbles_Left;
--\f
procedure Swap_Bits (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Lsrcinc : S_Long := Srcinc - Srclen;
Ldestinc : S_Long := Destinc - Srclen;
begin
for H in reverse 0 .. Height - 1 loop
for N in reverse S_Natural range 0 .. Srclen - 1 loop
Dest (Dest_I) := Private_Reverse_Byte (S_Natural (Src (Src_I)));
Src_I := Src_I + 1;
Dest_I := Dest_I + 1;
end loop;
Src_I := Src_I + Lsrcinc;
Dest_I := Dest_I + Ldestinc;
end loop;
end Swap_Bits;
--\f
procedure Swap_Bits_And_Two_Bytes (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 2;
Odd : S_Natural := Srclen rem 2;
begin
for H in reverse 1 .. Height loop
for E in 1 .. Even loop
Dest (Dest_I) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Dest (Dest_I + 1) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest_I := Dest_I + 2;
Src_I := Src_I + 2;
end loop;
if Odd = 1 then
Dest (Dest_I + 1) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest_I := Dest_I + 2;
Src_I := Src_I + Odd;
end if;
end loop;
-- Length : S_Natural := Round_Up (Srclen, 2);
-- N : S_Natural;
-- Lsrcinc : S_Long := Srcinc - Length;
-- Ldestinc : S_Long := Destinc - Length;
-- begin
--
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and Srclen /= Length then
-- Length := Length - 2;
-- if Half_Order = Msb_First then
-- Dest (Dest_I + Length) :=
-- Private_Reverse_Byte
-- (S_Natural (Src (Src_I + Length + 1)));
-- else
-- Dest (Dest_I + Length + 1) :=
-- Private_Reverse_Byte
-- (S_Natural (Src (Src_I + Length)));
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 1)));
-- Dest (Dest_I + 1) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I)));
-- N := N - 2;
-- Src_I := Src_I + 2;
-- Dest_I := Dest_I + 2;
-- end loop;
-- Src_I := Src_I + Lsrcinc;
-- Dest_I := Dest_I + Ldestinc;
-- end loop;
end Swap_Bits_And_Two_Bytes;
--\f
procedure Swap_Bits_And_Four_Bytes (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 4;
Odd : S_Natural := Srclen rem 4;
begin
for H in reverse 0 .. Height - 1 loop
for E in 1 .. Even loop
Dest (Dest_I) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 3)));
Dest (Dest_I + 1) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 2)));
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Src_I := Src_I + 4;
Dest_I := Dest_I + 4;
end loop;
if Odd = 1 then
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 2 then
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 3 then
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Dest (Dest_I + 1) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 2)));
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
end if;
end loop;
-- Length : S_Natural := Round_Up (Srclen, 4);
-- N : S_Natural;
-- begin
--
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and Srclen /= Length then
-- Length := Length - 4;
-- if Half_Order = Msb_First then
-- Dest (Dest_I + Length) :=
-- Private_Reverse_Byte (S_Natural
-- (Src (Src_I + Length + 3)));
-- end if;
-- if (Half_Order = Lsb_First and then Srclen - Length = 3) or else
-- (Half_Order = Msb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length + 1) :=
-- Private_Reverse_Byte (S_Natural
-- (Src (Src_I + Length + 2)));
-- end if;
-- if (Half_Order = Msb_First and then Srclen - Length = 3) or else
-- (Half_Order = Lsb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length + 2) :=
-- Private_Reverse_Byte (S_Natural
-- (Src (Src_I + Length + 1)));
-- end if;
-- if Half_Order = Lsb_First then
-- Dest (Dest_I + Length + 3) :=
-- Private_Reverse_Byte (S_Natural (Src (Src_I + Length)));
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 3)));
-- Dest (Dest_I + 1) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 2)));
-- Dest (Dest_I + 2) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 1)));
-- Dest (Dest_I + 3) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I)));
-- N := N - 4;
-- Src_I := Src_I + 4;
-- Dest_I := Dest_I + 4;
-- end loop;
-- Src_I := Src_I + Srcinc;
-- Dest_I := Dest_I + Destinc;
-- end loop;
--
end Swap_Bits_And_Four_Bytes;
--\f
procedure Swap_Bits_And_Words (Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
Src_I : S_Natural := Src'First;
Dest_I : S_Natural := Dest'First;
Even : S_Natural := Srclen / 4;
Odd : S_Natural := Srclen rem 4;
begin
for H in reverse 0 .. Height - 1 loop
for E in 1 .. Even loop
Dest (Dest_I) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 2)));
Dest (Dest_I + 1) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 3)));
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Src_I := Src_I + 4;
Dest_I := Dest_I + 4;
end loop;
if Odd = 1 then
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 2 then
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
elsif Odd = 3 then
Dest (Dest_I + 2) := Private_Reverse_Byte
(S_Natural (Src (Src_I)));
Dest (Dest_I + 3) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 1)));
Dest (Dest_I) := Private_Reverse_Byte
(S_Natural (Src (Src_I + 2)));
Dest_I := Dest_I + 4;
Src_I := Src_I + Odd;
end if;
end loop;
-- Length : S_Natural := Round_Up (Srclen, 4);
-- N : S_Natural;
-- Lsrcinc : S_Long := Srcinc - Length;
-- Ldestinc : S_Long := Destinc - Length;
-- begin
--
-- for H in reverse 0 .. Height - 1 loop
-- if H = 0 and Srclen /= Length then
-- Length := Length - 4;
-- if Half_Order = Msb_First then
-- Dest (Dest_I + Length + 1) :=
-- Private_Reverse_Byte (S_Natural
-- (Src (Src_I + Length + 3)));
-- end if;
-- if (Half_Order = Lsb_First and then Srclen - Length = 3) or else
-- (Half_Order = Msb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length) :=
-- Private_Reverse_Byte (S_Natural
-- (Src (Src_I + Length + 2)));
-- end if;
-- if (Half_Order = Msb_First and then Srclen - Length = 3) or else
-- (Half_Order = Msb_First and then Srclen rem 4 / 2 = 1) then
-- Dest (Dest_I + Length + 3) :=
-- Private_Reverse_Byte (S_Natural
-- (Src (Src_I + Length + 1)));
-- end if;
-- if Half_Order = Lsb_First then
-- Dest (Dest_I + Length + 2) :=
-- Private_Reverse_Byte (S_Natural (Src (Src_I + Length)));
-- end if;
-- end if;
-- N := Length;
-- while N > 0 loop
-- Dest (Dest_I) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 2)));
-- Dest (Dest_I + 1) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 3)));
-- Dest (Dest_I + 2) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I)));
-- Dest (Dest_I + 3) := Private_Reverse_Byte
-- (S_Natural (Src (Src_I + 1)));
-- N := N - 4;
-- Src_I := Src_I + 4;
-- Dest_I := Dest_I + 4;
-- end loop;
-- Src_I := Src_I + Lsrcinc;
-- Dest_I := Dest_I + Ldestinc;
-- end loop;
end Swap_Bits_And_Words;
--\f
-- This macro creates a value from 0 to 11 suitable for indexing
-- into the Swap_Functions table above.
function Compose_Index (Bitmap_Unit : U_Char;
Bitmap_Bit_Order : X_Byte_Bit_Order;
Byte_Order : X_Byte_Bit_Order) return S_Natural is
Ret : S_Natural;
begin
if Bitmap_Unit = 32 then
Ret := 2;
elsif Bitmap_Unit = 16 then
Ret := 1;
else
Ret := 0;
end if;
if Bitmap_Bit_Order = Msb_First then
Ret := Ret + 0;
else
Ret := Ret + 3;
end if;
if Byte_Order = Msb_First then
Ret := Ret + 0;
else
Ret := Ret + 6;
end if;
return Ret;
end Compose_Index;
--\f
procedure Do_Swap_Func (Func : Swap_Function_Types;
Src : U_Char_Array;
Dest : in out U_Char_Array;
Srclen : S_Natural;
Srcinc : S_Natural;
Destinc : S_Natural;
Height : S_Natural
-- Half_Order : X_Byte_Bit_Order
) is
begin
case Func is
when Do_No_Swap =>
No_Swap (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Two_Bytes =>
Swap_Two_Bytes (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Four_Bytes =>
Swap_Four_Bytes (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Words =>
Swap_Words (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Bits =>
Swap_Bits (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Bits_And_Two_Bytes =>
Swap_Bits_And_Two_Bytes (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Bits_And_Four_Bytes =>
Swap_Bits_And_Four_Bytes (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
when Do_Swap_Bits_And_Words =>
Swap_Bits_And_Words (Src, Dest, Srclen, Srcinc,
Destinc, Height); --, Half_Order);
end case;
end Do_Swap_Func;
--\f
procedure Send_X_Y_Image (Display : X_Display;
Req : in out X_Put_Image_Request;
Image : X_Image;
Req_Xoffset : U_Short;
Req_Yoffset : U_Short) is
Total_Xoffset : U_Short;
Bytes_Per_Src : S_Natural;
Bytes_Per_Dest : S_Natural;
Length : S_Natural;
Bytes_Per_Line : S_Natural;
Bytes_Per_Src_Plane : S_Natural;
Bytes_Per_Dest_Plane : S_Natural;
Bytes_Per_Temp_Plane : S_Natural;
Temp_Length : S_Natural;
Src : S_Natural;
Dest : S_Natural;
Swapfunc : Swap_Function_Types;
-- H_Order : X_Byte_Bit_Order;
begin
Total_Xoffset := U_Short (Image.X_Offset + S_Short (Req_Xoffset));
Req.Left_Pad := U_Char (S_Long (Total_Xoffset) and
S_Long (Display.Bitmap_Unit - 1));
Total_Xoffset := (Total_Xoffset - U_Short (Req.Left_Pad)) / 2 ** 3;
-- The protocol requires left-pad of zero on all ZPixmap, even
-- though the 1-bit case is identical to bitmap format. This is a
-- bug in the protocol, caused because 1-bit ZPixmap was added late
-- in the game. Hairy shifting code compensation isn't worth it,
-- just use XYPixmap format instead.
if Req.Left_Pad /= 0 and Req.Format = Z_Pixmap then
Req.Format := X_Y_Pixmap;
end if;
Bytes_Per_Dest :=
Round_Up (Req.Width + U_Short (Req.Left_Pad), Display.Bitmap_Pad) /
8;
Bytes_Per_Dest_Plane := Bytes_Per_Dest * S_Natural (Req.Height);
Length := Bytes_Per_Dest_Plane * S_Natural (Image.Depth);
Req.Length := Req.Length + U_Short (Length + 3) / 4;
Swapfunc := Swap_Function (Compose_Index (Image.Bitmap_Unit,
Image.Bitmap_Bit_Order,
Image.Byte_Order),
Compose_Index (Display.Bitmap_Unit,
Display.Bitmap_Bit_Order,
Display.Byte_Order));
-- H_Order := Half_Order (Compose_Index (Image.Bitmap_Unit,
-- Image.Bitmap_Bit_Order,
-- Image.Byte_Order));
Src := Image.Data'First +
S_Natural (Image.Bytes_Per_Line * Req_Yoffset +
Total_Xoffset);
-- when total_xoffset > 0, we have to worry about stepping off the
-- end of image.data.
--/
if Swapfunc = Do_No_Swap and then
S_Natural (Image.Bytes_Per_Line) = Bytes_Per_Dest and then
((Total_Xoffset = 0 and then (Image.Depth = 1 or else
Image.Height = Req.Height)) or else
(Image.Depth = 1 and then
Req_Yoffset + Req.Height < Image.Height)) then
Put_X_Put_Image_Request (Display, Req, Length);
Put_U_Char_Array (Display, Image.Data (Src .. Src - 1 + Length));
return;
end if;
declare
Buf : U_Char_Array (1 .. Length);
begin
Length := Round_Up (Length, 4);
Bytes_Per_Src := S_Natural
(Req.Width + U_Short (Req.Left_Pad) + 7) / 8;
Bytes_Per_Line := S_Natural (Image.Bytes_Per_Line);
Bytes_Per_Src_Plane := Bytes_Per_Line * S_Natural (Image.Height);
Total_Xoffset := U_Short (S_Long (Total_Xoffset) and
S_Long ((Image.Bitmap_Unit - 1) / 8));
if Total_Xoffset > 0 and then
Image.Byte_Order /= Image.Bitmap_Bit_Order then
Bytes_Per_Line := Bytes_Per_Src + S_Natural (Total_Xoffset);
Src := Src - S_Natural (Total_Xoffset);
Bytes_Per_Temp_Plane := Bytes_Per_Line * S_Natural (Req.Height);
Temp_Length := Round_Up (Bytes_Per_Temp_Plane *
S_Natural (Image.Depth), 4);
declare
Temp : U_Char_Array (1 .. Temp_Length);
begin
Swapfunc := Swap_Function
(Compose_Index (Image.Bitmap_Unit,
Image.Bitmap_Bit_Order,
Image.Byte_Order),
Compose_Index (Image.Bitmap_Unit,
Display.Byte_Order,
Display.Byte_Order));
Dest := Temp'First;
for J in reverse 0 .. Image.Depth - 1 loop
Do_Swap_Func (Swapfunc,
Image.Data (Src .. Image.Data'Last),
Temp (Dest .. Temp'Last),
Bytes_Per_Line,
S_Natural (Image.Bytes_Per_Line),
Bytes_Per_Line,
S_Natural (Req.Height)); --, H_Order);
Src := Src + Bytes_Per_Src_Plane;
Dest := Dest + Bytes_Per_Temp_Plane;
end loop;
Swapfunc := Swap_Function
(Compose_Index (Image.Bitmap_Unit,
Display.Byte_Order,
Display.Byte_Order),
Compose_Index (Display.Bitmap_Unit,
Display.Bitmap_Bit_Order,
Display.Byte_Order));
-- H_Order := Half_Order (Compose_Index (Image.Bitmap_Unit,
-- Display.Byte_Order,
-- Display.Byte_Order));
Src := Temp'First + S_Natural (Total_Xoffset);
Bytes_Per_Src_Plane := Bytes_Per_Temp_Plane;
Dest := Buf'First;
for J in reverse 0 .. Image.Depth - 1 loop
Do_Swap_Func (Swapfunc,
Temp (Src .. Image.Data'Last),
Buf (Dest .. Buf'Last),
S_Natural (Bytes_Per_Src),
S_Natural (Bytes_Per_Line),
S_Natural (Bytes_Per_Dest),
S_Natural (Req.Height));--, H_Order);
Src := Src + Bytes_Per_Src_Plane;
Dest := Dest + Bytes_Per_Dest_Plane;
end loop;
end;
else
Dest := Buf'First;
for J in reverse 0 .. Image.Depth - 1 loop
Do_Swap_Func (Swapfunc,
Image.Data (Src .. Image.Data'Last),
Buf (Dest .. Buf'Last),
S_Natural (Bytes_Per_Src),
S_Natural (Bytes_Per_Line),
S_Natural (Bytes_Per_Dest),
S_Natural (Req.Height)); --, H_Order);
Src := Src + Bytes_Per_Src_Plane;
Dest := Dest + Bytes_Per_Dest_Plane;
end loop;
end if;
Put_X_Put_Image_Request (Display, Req, Length);
Put_U_Char_Array (Display,
Buf (Buf'First .. Buf'First - 1 + Length));
end;
end Send_X_Y_Image;
--\f
-- XXX assumes image->bits_per_pixel == dest_bits_per_pixel
procedure Send_Z_Image (Display : X_Display;
Req : in out X_Put_Image_Request;
Image : X_Image;
Req_Xoffset : U_Short;
Req_Yoffset : U_Short;
Dest_Bits_Per_Pixel : U_Char;
Dest_Scanline_Pad : U_Char) is
Bytes_Per_Src : S_Natural;
Bytes_Per_Dest : S_Natural;
Length : S_Natural;
Shifted_Src : U_Char_List := Image.Data;
Src : S_Natural;
Dest : S_Natural;
begin
Req.Left_Pad := 0;
Bytes_Per_Src :=
Round_Up (Req.Width * U_Short (Image.Bits_Per_Pixel), U_Short (8)) /
8;
Bytes_Per_Dest :=
Round_Up
(Req.Width * U_Short (Dest_Bits_Per_Pixel), Dest_Scanline_Pad) /
8;
Length := Bytes_Per_Dest * S_Natural (Req.Height);
Req.Length := Req.Length + U_Short (Length + 3) / 4;
Src := Image.Data'First +
S_Natural (Req_Yoffset * Image.Bytes_Per_Line +
Req_Xoffset * U_Short (Image.Bits_Per_Pixel) / 8);
if (Image.Bits_Per_Pixel = 4 and then
Req_Xoffset mod 2 = 1) then
Shifted_Src :=
new U_Char_Array
(0 .. S_Natural (Req.Height * Image.Bytes_Per_Line));
Shift_Nibbles_Left (Image.Data (Src .. Src - 1 + Length),
Shifted_Src.all, Bytes_Per_Src,
S_Natural (Image.Bytes_Per_Line),
S_Natural (Image.Bytes_Per_Line),
S_Natural (Req.Height));
Src := Src - Image.Data'First;
end if;
-- when req_xoffset > 0, we have to worry about stepping off the
-- end of image.data.
if ((Image.Byte_Order = Display.Byte_Order or else
Image.Bits_Per_Pixel = 8) and then
S_Natural (Image.Bytes_Per_Line) = Bytes_Per_Dest and then
(Req_Xoffset = 0 or else
Req_Yoffset + Req.Height < Image.Height)) then
Put_X_Put_Image_Request (Display, Req, Length);
Put_U_Char_Array (Display, Shifted_Src (Src .. Src - 1 + Length));
if Shifted_Src /= Image.Data then
Free_U_Char_List (Shifted_Src);
end if;
return;
end if;
Length := Round_Up (Length, 4);
declare
Temp : U_Char_Array (1 .. Length);
begin
Dest := Temp'First;
if Image.Byte_Order = Display.Byte_Order or else
Image.Bits_Per_Pixel = 8 then
No_Swap (Shifted_Src (Src .. Shifted_Src'Last),
Temp, Bytes_Per_Src,
S_Natural (Image.Bytes_Per_Line), Bytes_Per_Dest,
S_Natural (Req.Height)); --, Image.Byte_Order);
elsif Image.Bits_Per_Pixel = 32 then
Swap_Four_Bytes (Shifted_Src (Src .. Shifted_Src'Last),
Temp, Bytes_Per_Src,
S_Natural (Image.Bytes_Per_Line),
Bytes_Per_Dest, S_Natural (Req.Height)); --,
-- Image.Byte_Order);
elsif Image.Bits_Per_Pixel = 24 then
Swap_Three_Bytes (Shifted_Src (Src .. Shifted_Src'Last),
Temp, Bytes_Per_Src,
S_Natural (Image.Bytes_Per_Line),
Bytes_Per_Dest, S_Natural (Req.Height),
Image.Byte_Order);
elsif Image.Bits_Per_Pixel = 16 then
Swap_Two_Bytes (Shifted_Src (Src .. Shifted_Src'Last), Temp,
Bytes_Per_Src, S_Natural (Image.Bytes_Per_Line),
Bytes_Per_Dest, S_Natural (Req.Height));--,
--Image.Byte_Order);
else
Swap_Nibbles (Shifted_Src (Src .. Shifted_Src'Last), Temp,
Bytes_Per_Src, S_Natural (Image.Bytes_Per_Line),
Bytes_Per_Dest, S_Natural (Req.Height));
end if;
Put_X_Put_Image_Request (Display, Req, Length);
Put_U_Char_Array (Display,
Temp (Temp'First .. Temp'First - 1 + Length));
end;
if Shifted_Src /= Image.Data then
Free_U_Char_List (Shifted_Src);
end if;
end Send_Z_Image;
--\f
procedure Put_Image_Request
(Display : X_Display;
D : X_Drawable;
Gc : X_Gc;
Image : X_Image;
Req_Xoffset : U_Short;
Req_Yoffset : U_Short;
X : S_Short;
Y : S_Short;
Req_Width : U_Short;
Req_Height : U_Short;
Dest_Bits_Per_Pixel : U_Char;
Dest_Scan_Line_Pad : U_Char) is
Req : X_Put_Image_Request;
begin
----Begin preparing the request.
Req := (Kind => Put_Image,
Length => X_Put_Image_Request'Size / 32,
Pad => 0,
Left_Pad => 0,
Drawable => D,
Gc => Gc.Gid,
Dst_X => X,
Dst_Y => Y,
Width => Req_Width,
Height => Req_Height,
Format => Image.Format,
Depth => Image.Depth);
----Send the request the correct way.
if Image.Depth = 1 or else Image.Format /= Z_Pixmap then
Send_X_Y_Image (Display, Req, Image, Req_Xoffset, Req_Yoffset);
else
Send_Z_Image (Display, Req, Image, Req_Xoffset, Req_Yoffset,
Dest_Bits_Per_Pixel, Dest_Scan_Line_Pad);
end if;
end Put_Image_Request;
--\f
procedure Put_Sub_Image
(Display : X_Display;
D : X_Drawable;
Gc : X_Gc;
Image : X_Image;
Req_Xoffset : U_Short;
Req_Yoffset : U_Short;
X : S_Short;
Y : S_Short;
Req_Width : U_Short;
Req_Height : U_Short;
Dest_Bits_Per_Pixel : U_Char;
Dest_Scanline_Pad : U_Char) is
Left_Pad : S_Natural;
Bytes_Per_Row : S_Natural;
Available : S_Natural;
begin
if Req_Width = 0 or else Req_Height = 0 then
return;
end if;
if 65536 < Display.Max_Request_Size then
Available := 65536 / 4;
else
Available := S_Natural (Display.Max_Request_Size / 4);
end if;
Available := Available - S_Natural (X_Put_Image_Request'Size / 32);
if Image.Depth = 1 or else Image.Format /= Z_Pixmap then
Left_Pad := S_Natural
(S_Long (Image.X_Offset + S_Short (Req_Xoffset)) and
S_Long (Display.Bitmap_Unit - 1));
Bytes_Per_Row := (Round_Up (S_Natural (Req_Width) + Left_Pad,
S_Natural (Display.Bitmap_Pad)) / 8) *
S_Natural (Image.Depth);
else
Left_Pad := 0;
Bytes_Per_Row := Round_Up
(Req_Width * U_Short (Dest_Bits_Per_Pixel),
Dest_Scanline_Pad) / 8;
end if;
if Bytes_Per_Row * S_Natural (Req_Height) <= Available then
Put_Image_Request (Display, D, Gc, Image, Req_Xoffset,
Req_Yoffset, X, Y, Req_Width, Req_Height,
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
elsif Req_Height > 1 then
declare
Sub_Image_Height : U_Short :=
U_Short (Available / Bytes_Per_Row);
begin
if Sub_Image_Height = 0 then
Sub_Image_Height := 1;
end if;
Put_Sub_Image (Display, D, Gc, Image, Req_Xoffset,
Req_Yoffset, X, Y, Req_Width, Sub_Image_Height,
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
Put_Sub_Image (Display, D, Gc, Image, Req_Xoffset,
Req_Yoffset + Sub_Image_Height, X,
Y + S_Short (Sub_Image_Height),
Req_Width, Req_Height - Sub_Image_Height,
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
end;
else
declare
Sub_Image_Width : U_Short :=
U_Short (((Available * 8) / S_Natural (Dest_Scanline_Pad)) *
S_Natural (Dest_Scanline_Pad) - Left_Pad);
begin
Put_Sub_Image (Display, D, Gc, Image, Req_Xoffset,
Req_Yoffset, X, Y, Sub_Image_Width, 1,
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
Put_Sub_Image (Display, D, Gc, Image,
Req_Xoffset + Sub_Image_Width, Req_Yoffset,
X + S_Short (Sub_Image_Width), Y,
Req_Width - Sub_Image_Width, 1,
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
end;
end if;
end Put_Sub_Image;
--\f
function X_Create_Image (Display : X_Display;
Visual : X_Visual;
Depth : U_Char;
Format : X_Image_Format;
Offset : U_Short;
Data : U_Char_Array;
Width : U_Short;
Height : U_Short;
Bitmap_Pad : U_Char;
Image_Bytes_Per_Line : U_Short) return X_Image is
Datap : U_Char_List := new U_Char_Array (1 .. Data'Length);
begin
Datap.all := Data;
return X_Create_Image (Display => Display,
Visual => Visual,
Depth => Depth,
Format => Format,
Offset => Offset,
Data => Datap,
Data_Is_Shared => False,
Width => Width,
Height => Height,
Bitmap_Pad => Bitmap_Pad,
Image_Bytes_Per_Line => Image_Bytes_Per_Line);
exception
when others =>
Free_U_Char_List (Datap);
raise;
end X_Create_Image;
--\f
------------------------------------------------------------------------------
-- Create_Image
--
-- Allocates the memory necessary for an X_Image data structure.
-- Initializes the structure with "default" values and returns X_Image.
------------------------------------------------------------------------------
function X_Create_Image (Display : X_Display;
Visual : X_Visual;
Depth : U_Char;
Format : X_Image_Format;
Offset : U_Short;
Data : U_Char_List;
Data_Is_Shared : Boolean;
Width : U_Short;
Height : U_Short;
Bitmap_Pad : U_Char;
Image_Bytes_Per_Line : U_Short) return X_Image is
Image : X_Image;
Imagei : X_Image;
Bits_Per_Pixel : U_Char := 1;
begin
Imagei := new X_Image_Rec;
Image := Imagei;
Imagei.Width := Width;
Imagei.Height := Height;
Imagei.Format := Format;
Imagei.Byte_Order := Display.Byte_Order;
Imagei.Bitmap_Unit := Display.Bitmap_Unit;
Imagei.Bitmap_Bit_Order := Display.Bitmap_Bit_Order;
if Visual /= None_X_Visual then
Imagei.Red_Mask := Visual.Red_Mask;
Imagei.Green_Mask := Visual.Green_Mask;
Imagei.Blue_Mask := Visual.Blue_Mask;
else
Imagei.Red_Mask := None_X_Color_Mask;
Imagei.Green_Mask := None_X_Color_Mask;
Imagei.Blue_Mask := None_X_Color_Mask;
end if;
if Format = Z_Pixmap then
Bits_Per_Pixel := Private_X_Get_Bits_Per_Pixel (Display, Depth);
end if;
Imagei.X_Offset := S_Short (Offset);
Imagei.Bitmap_Pad := Bitmap_Pad;
Imagei.Depth := Depth;
Imagei.Data := Data;
Imagei.Data_Is_Shared := Data_Is_Shared;
--
-- compute per line accelerator.
--
if Image_Bytes_Per_Line = 0 then
if Format = Z_Pixmap then
Imagei.Bytes_Per_Line :=
U_Short
(Round_Up (S_Natural (Bits_Per_Pixel) * S_Natural (Width),
S_Natural (Imagei.Bitmap_Pad)) /
8);
else
Imagei.Bytes_Per_Line :=
U_Short (Round_Up (Width + Offset, Imagei.Bitmap_Pad) / 8);
end if;
else
Imagei.Bytes_Per_Line := Image_Bytes_Per_Line;
end if;
Imagei.Bits_Per_Pixel := Bits_Per_Pixel;
Imagei.Obdata := null;
Private_X_Init_Image_Func_Ptrs (Image);
return Image;
exception
when others =>
if Imagei /= None_X_Image then
Imagei.Data := None_U_Char_List; -- Not ours to free.
Free_X_Image (Imagei);
end if;
raise;
end X_Create_Image;
--\f
function X_Get_Image (Display : X_Display;
Drawable : X_Drawable;
X : S_Short;
Y : S_Short;
Width : U_Short;
Height : U_Short;
Plane_Mask : X_Plane_Mask;
Format : X_Image_Format) return X_Image is
Rep : X_Reply_Contents;
Image : X_Image;
Succ : X_Status;
begin
----Lock the display.
Lock_Display (Display);
begin
----Send the request.
Put_X_Get_Image_Request
(Display, (Kind => Get_Image,
Length => X_Get_Image_Request'Size / 32,
Drawable => Drawable,
X => X,
Y => Y,
Width => Width,
Height => Height,
Plane_Mask => Plane_Mask,
Format => Format));
----Get the reply header.
Get_Reply (Display => Display,
Code => Get_Image,
Reply => Rep,
Extra => 0,
Discard => False,
Status => Succ);
----If we failed then return null.
if Succ = Failed then
Unlock_Display (Display);
Sync_Handle (Display);
return None_X_Image;
end if;
----Read the data that came with the reply.
declare
Data : U_Char_List;
Vis : X_Visual;
Void : X_Status;
begin
begin
Data := new U_Char_Array
(1 .. S_Natural (Rep.Get_Image.Length) * 4);
exception
when others =>
Eat_Raw_Data
(Display,
S_Natural (Rep.Get_Image.Length) * (32 / 8));
raise;
end;
Get_U_Char_Array (Display, Data.all);
Internal_X_Vid_To_Visual
(Display, Rep.Get_Image.Visual, Vis, Void);
if (Format = X_Y_Pixmap) then
Image :=
X_Create_Image
(Display => Display,
Visual => Vis,
Depth =>
Ones (Plane_Mask and
(Shift (1, Integer (Rep.Get_Image.Depth)) -
1)),
Format => Format,
Offset => 0,
Data => Data,
Data_Is_Shared => False,
Width => Width,
Height => Height,
Bitmap_Pad => Display.Bitmap_Pad,
Image_Bytes_Per_Line => 0);
else -- format = Z_Pixmap
Image :=
X_Create_Image
(Display => Display,
Visual => Vis,
Depth => Rep.Get_Image.Depth,
Format => Z_Pixmap,
Offset => 0,
Data => Data,
Data_Is_Shared => False,
Width => Width,
Height => Height,
Bitmap_Pad =>
Private_X_Get_Scanline_Pad
(Display, Rep.Get_Image.Depth),
Image_Bytes_Per_Line => 0);
end if;
exception
when others =>
Free_U_Char_List (Data);
raise;
end;
----Catch exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return the image.
Unlock_Display (Display);
Sync_Handle (Display);
return Image;
end X_Get_Image;
--\f
procedure X_Get_Sub_Image (Display : X_Display;
Drawable : X_Drawable;
X : S_Short;
Y : S_Short;
Width : U_Short;
Height : U_Short;
Plane_Mask : X_Plane_Mask;
Format : X_Image_Format;
Image : X_Image;
Image_X : S_Short;
Image_Y : S_Short) is
Temp_Image : X_Image;
begin
Temp_Image := X_Get_Image (Display, Drawable, X, Y, Width,
Height, Plane_Mask, Format);
if Temp_Image /= None_X_Image then
Private_X_Set_Image (Temp_Image, Image, Image_X, Image_Y);
Free_X_Image (Temp_Image);
end if;
end X_Get_Sub_Image;
--\f
procedure X_Put_Image (Display : X_Display;
Drawable : X_Drawable;
Gc : X_Gc;
Image : X_Image;
Image_X : U_Short;
Image_Y : U_Short;
X : S_Short;
Y : S_Short;
Width : U_Short;
Height : U_Short) is
Lwidth : S_Short := S_Short (Width);
Lheight : S_Short := S_Short (Height);
Limage_X : S_Short := S_Short (Image_X);
Limage_Y : S_Short := S_Short (Image_Y);
Dest_Bits_Per_Pixel : U_Char;
Dest_Scanline_Pad : U_Char;
begin
if Limage_X < 0 then
Lwidth := Lwidth + Limage_X;
Limage_X := 0;
end if;
if Limage_Y < 0 then
Lheight := Lheight + Limage_Y;
Limage_Y := 0;
end if;
if Limage_X + Lwidth > S_Short (Image.Width) then
Lwidth := S_Short (Image.Width) - Limage_X;
end if;
if Limage_Y + Lheight > S_Short (Image.Height) then
Lheight := S_Short (Image.Height) - Limage_Y;
end if;
if Lwidth <= 0 or else Lheight <= 0 then
return;
end if;
if Image.Depth = 1 or else Image.Format /= Z_Pixmap then
Dest_Bits_Per_Pixel := 1;
Dest_Scanline_Pad := Display.Bitmap_Pad;
else
declare
Format : X_Screen_Format_List;
begin
Dest_Bits_Per_Pixel := Image.Bits_Per_Pixel;
Dest_Scanline_Pad := Image.Bitmap_Pad;
Format := Display.Pixmap_Format;
for N in Format'Range loop
if Format (N).Depth = Image.Depth then
Dest_Bits_Per_Pixel := Format (N).Bits_Per_Pixel;
Dest_Scanline_Pad := Format (N).Scan_Line_Pad;
end if;
end loop;
if Dest_Bits_Per_Pixel /= Image.Bits_Per_Pixel then
declare
Img : X_Image := new X_Image_Rec;
begin
-- XXX slow, but works
Img.Width := U_Short (Lwidth);
Img.Height := U_Short (Lheight);
Img.X_Offset := 0;
Img.Format := Z_Pixmap;
Img.Byte_Order := Display.Byte_Order;
Img.Bitmap_Pad := Dest_Scanline_Pad;
Img.Depth := Image.Depth;
Img.Bits_Per_Pixel := Dest_Bits_Per_Pixel;
Img.Bytes_Per_Line :=
U_Short (Round_Up (U_Short (Dest_Bits_Per_Pixel) *
U_Short (Lwidth),
Dest_Scanline_Pad) / 8);
Img.Data :=
new U_Char_Array
(0 .. S_Natural
(S_Short (Img.Bytes_Per_Line) *
Lheight - 1));
Private_X_Init_Image_Func_Ptrs (Img);
for J in reverse S_Short range 0 .. Lheight - 1 loop
for I in reverse S_Short range 0 .. Lwidth - 1 loop
X_Put_Pixel (Img, I, J,
X_Get_Pixel (Image, Limage_X + I,
Limage_Y + J));
end loop;
end loop;
Lock_Display (Display);
Private_X_Flush_Gc (Display, Gc);
Put_Sub_Image (Display, Drawable, Gc, Img, 0, 0, X, Y,
U_Short (Lwidth), U_Short (Lheight),
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
Unlock_Display (Display);
Sync_Handle (Display);
Free_U_Char_List (Img.Data);
return;
exception
when others =>
Free_X_Image (Img);
raise;
end;
end if;
end;
end if;
Lock_Display (Display);
begin
Private_X_Flush_Gc (Display, Gc);
Put_Sub_Image (Display, Drawable, Gc, Image, Image_X, Image_Y,
X, Y, U_Short (Lwidth), U_Short (Lheight),
Dest_Bits_Per_Pixel, Dest_Scanline_Pad);
exception
when others =>
Unlock_Display (Display);
raise;
end;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Put_Image;
--\f
end Xlbp_Image;