|
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: 25863 (0x6507)
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_Font;
use Xlbt_Font;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbt_Request;
use Xlbt_Request;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Text;
use Xlbt_Text;
with Xlbp_Font;
use Xlbp_Font;
with Xlbp_Gc;
use Xlbp_Gc;
with Xlbt_Reply;
use Xlbt_Reply;
with Xlbip_Get_Reply;
use Xlbip_Get_Reply;
with Xlbip_Internal;
use Xlbip_Internal;
with Xlbip_Put_Request;
use Xlbip_Put_Request;
package body Xlbp_Text is
------------------------------------------------------------------------------
-- X Library Text - 8-bit characters
--
-- Xlbp_Text - Handle drawing of 8-bit characters
------------------------------------------------------------------------------
-- 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
procedure X_Draw_String (Display : X_Display;
Drawable : X_Drawable;
Gc : X_Gc;
X : S_Short;
Y : S_Short;
Text : X_String) is
------------------------------------------------------------------------------
-- X_Draw_String
------------------------------------------------------------------------------
Str_Length : S_Natural := Text'Length;
Datalength : S_Natural;
Partial_N_Chars : S_Natural := Str_Length;
Elt : X_Text_Elt;
Character_Offset : S_Natural := Text'First;
begin
----Do nothing for an empty string.
if Str_Length = 0 then
return;
end if;
----Lock the display and flush changes to the GC we are about to use.
Lock_Display (Display);
begin
Private_X_Flush_Gc (Display, Gc);
----Send the request header; figure out the actual request length. The length
-- is that of the header plus the text plus the number of sub-headers we need
-- to describe all of the up-to 254 character sub-blocks we are sending.
Datalength :=
(X_Text_Elt'Size / 8) * ((Str_Length + 253) / 254) + Str_Length;
Put_X_Poly_Text8_Request
(Display,
(Kind => Poly_Text8,
Length => X_Poly_Text8_Request'Size / 32 +
U_Short ((Datalength + 3) / 4),
Pad => 0,
Drawable => Drawable,
Gc => Gc.Gid,
X => X,
Y => Y),
Datalength);
----Send as many full 254 character blocks as we can.
Elt := (Deltaa => 0,
Length => 254);
while Partial_N_Chars > 254 loop
Put_X_Text_Elt_Unaligned (Display, Elt);
Put_X_String_Unaligned
(Display,
Text (Character_Offset .. Character_Offset + 253));
Partial_N_Chars := Partial_N_Chars - 254;
Character_Offset := Character_Offset + 254;
end loop;
----Send the last not-full character block if there is one.
if Partial_N_Chars /= 0 then
Elt := (Deltaa => 0,
Length => U_Char (Partial_N_Chars));
Put_X_Text_Elt_Unaligned (Display, Elt);
Put_X_String_Unaligned (Display,
Text (Character_Offset .. Text'Last));
----Pad request out to a 32-bit boundary if necessary
if Datalength rem 4 /= 0 then
Put_U_Char_Array_Unaligned
(Display, (1 .. 4 - Datalength rem 4 => 0));
end if;
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Draw_String;
--\f
procedure X_Draw_Image_String (Display : X_Display;
Drawable : X_Drawable;
Gc : X_Gc;
X : S_Short;
Y : S_Short;
Text : X_String) is
------------------------------------------------------------------------------
-- X_Draw_Image_String
------------------------------------------------------------------------------
Character_Offset : S_Natural := Text'First;
First_Time_Through : Boolean := True;
Cur_X : S_Short := X;
Cur_Length : S_Natural := Text'Length;
Last_X : S_Short := 0;
Unit : S_Natural;
begin
----Lock the display and flush changes to the GC we are about to use.
Lock_Display (Display);
begin
Private_X_Flush_Gc (Display, Gc);
----Loop until all of the characters are done.
while Cur_Length > 0 loop
----Figure out how many characters to do this pass.
if Cur_Length > 255 then
Unit := 255;
else
Unit := Cur_Length;
end if;
----If we just did a group then we must figure out how wide it was before we
-- can do the next group.
if First_Time_Through then
First_Time_Through := False;
else
declare
Direction : X_Font_Direction;
Ascent : S_Short;
Descent : S_Short;
Overall : X_Char_Struct;
Font : X_Font_Struct;
begin
----Unlock; get the font we're using; check the extent of the last 255
-- characters; and lock up again.
Unlock_Display (Display);
Font := X_Query_Font (Display, (Id => Gc.Gid.Id));
if Font = None_X_Font_Struct then
return;
end if;
X_Text_Extents (Font,
Text (Character_Offset - 255 ..
Character_Offset - 1),
Direction,
Ascent,
Descent,
Overall);
Free_X_Font_Struct (Font);
Lock_Display (Display);
Cur_X := Last_X + S_Short (Overall.Width);
end;
end if;
----Send out a request for this group of characters.
Last_X := Cur_X;
Put_X_Image_Text8_Request
(Display,
(Kind => Image_Text8,
Length => X_Image_Text8_Request'Size / 32 +
U_Short ((Unit + 3) / 4),
N_Chars => U_Char (Unit),
Drawable => Drawable,
Gc => Gc.Gid,
X => Cur_X,
Y => Y),
Unit);
----Put out the characters for this group.
Put_X_String
(Display,
Text (Character_Offset .. Character_Offset + Unit - 1));
Character_Offset := Character_Offset + Unit;
Cur_Length := Cur_Length - Unit;
end loop;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Draw_Image_String;
--\f
procedure X_Draw_Text (Display : X_Display;
Drawable : X_Drawable;
Gc : X_Gc;
X : S_Short;
Y : S_Short;
Items : X_Text_Item_Array) is
------------------------------------------------------------------------------
-- X_Draw_Text
------------------------------------------------------------------------------
Length : S_Natural := 0;
Font : U_Char_Array (1 .. 5);
Partial_N_Chars : S_Natural;
Partial_Delta : S_Short;
Elt : X_Text_Elt;
First_Time_Through : Boolean;
Character_Offset : S_Natural;
Chars : X_String_Pointer;
begin
----Lock the display and flush changes to the GC we are about to use.
Lock_Display (Display);
begin
Private_X_Flush_Gc (Display, Gc);
----Process each of the Items in turn. Calculate the total size of the extra
-- data in this request.
for I in Items'Range loop
----Font changes are 5 bytes; a 255 byte, plus size of Font id.
if Items (I).Font /= None_X_Font then
Length := Length + 1 + X_Font'Size / 8;
end if;
----If there's a Delta then we will send one Text_Elt for each 128 of the
-- Delta amount.
if Items (I).Deltaa /= 0 then
if Items (I).Deltaa > 0 then
Length :=
Length + X_Text_Elt'Size / 8 *
S_Natural
((Items (I).Deltaa + 126) / 127);
else
Length :=
Length +
X_Text_Elt'Size / 8 *
S_Natural
((abs (Items (I).Deltaa) + 127) / 128);
end if;
end if;
----If there are characters then they will be sent in 254 character chunks with
-- a Text_Elt header for each chunk.
Chars := Items (I).Chars;
if Chars'Length > 0 then
Length := Length +
X_Text_Elt'Size / 8 *
S_Natural ((Chars'Length + 253) / 254 - 1);
if Items (I).Deltaa = 0 then
----We share with the last Delta if possible.
Length := Length + X_Text_Elt'Size / 8;
end if;
Length := Length + Chars'Length;
end if;
end loop;
----Send the request header.
Put_X_Poly_Text8_Request
(Display,
(Kind => Poly_Text8,
Length =>
X_Poly_Text8_Request'Size / 32 + U_Short (Length + 3) / 4,
Pad => 0,
Drawable => Drawable,
Gc => Gc.Gid,
X => X,
Y => Y),
Length);
----Process each of the Items in turn. Put them into the Display buffer.
for I in Items'Range loop
----If this guy is doing a font change then put him out. To mark a font shift,
-- write a 255 byte followed by the 4 bytes of font ID, big-end (most
-- significant bits) first. Update our local GC with the new font.
if Items (I).Font /= None_X_Font then
Font (1) := 255;
Font (2) := U_Char (Items (I).Font.Id.Number / 2 ** 24);
Font (3) := U_Char (Items (I).Font.Id.Number /
2 ** 16 rem 16#100#);
Font (4) := U_Char (Items (I).Font.Id.Number /
2 ** 8 rem 16#100#);
Font (5) := U_Char (Items (I).Font.Id.Number rem 16#100#);
Put_U_Char_Array_Unaligned (Display, Font);
Gc.Values.Font := Items (I).Font;
end if;
----If there's a Delta then process that.
Partial_Delta := Items (I).Deltaa;
if Partial_Delta /= 0 then
while Partial_Delta < -128 or else Partial_Delta > 127 loop
if Partial_Delta > 0 then
Elt := (Deltaa => 127,
Length => 0);
Partial_Delta := Partial_Delta - 127;
else
Elt := (Deltaa => -128,
Length => 0);
Partial_Delta := Partial_Delta + 128;
end if;
Put_X_Text_Elt_Unaligned (Display, Elt);
end loop;
if Partial_Delta /= 0 and then
Items (I).Chars'Length = 0 then
Elt := (Deltaa => S_Char (Partial_Delta),
Length => 0);
Put_X_Text_Elt_Unaligned (Display, Elt);
end if;
end if;
----If there are characters then process them.
Chars := Items (I).Chars;
Partial_N_Chars := Chars'Last;
First_Time_Through := True;
Character_Offset := Chars'First;
----Do them in lumps of 254 at a time to begin with.
while Partial_N_Chars > 254 loop
if First_Time_Through then
First_Time_Through := False;
Elt := (Deltaa => S_Char (Partial_Delta),
Length => 254);
Put_X_Text_Elt_Unaligned (Display, Elt);
Partial_Delta := 0;
else
Elt := (Deltaa => 0,
Length => 254);
Put_X_Text_Elt_Unaligned (Display, Elt);
end if;
Put_X_String_Unaligned
(Display,
Chars (Character_Offset .. Character_Offset + 253));
Partial_N_Chars := Partial_N_Chars - 254;
Character_Offset := Character_Offset + 254;
end loop;
----Finish off the last few characters; if any.
if Partial_N_Chars /= 0 then
Elt := (Deltaa => S_Char (Partial_Delta),
Length => U_Char (Partial_N_Chars));
Put_X_Text_Elt_Unaligned (Display, Elt);
Put_X_String_Unaligned
(Display,
Chars (Character_Offset .. Chars'Last));
end if;
end loop;
----Pad request out to a 32-bit (4 byte) boundary.
Length := Length rem 4;
if Length /= 0 then
Put_U_Char_Array_Unaligned (Display, (1 .. 4 - Length => 0));
end if;
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return;
Unlock_Display (Display);
Sync_Handle (Display);
return;
end X_Draw_Text;
--\f
procedure X_Query_Text_Extents (Display : X_Display;
Font : X_Font;
Text : X_String;
Direction : out X_Font_Direction;
Font_Ascent : out S_Short;
Font_Descent : out S_Short;
Overall : out X_Char_Struct) is
------------------------------------------------------------------------------
-- X_Query_Text_Extents
------------------------------------------------------------------------------
Str_Length : constant S_Natural := Text'Length;
Rep : X_Reply_Contents;
Succ : X_Status;
begin
----Lock the display and flush changes to the GC we are about to use.
Lock_Display (Display);
begin
----Send the request.
Put_X_Query_Text_Extents_Request
(Display, (Kind => Query_Text_Extents,
Length => X_Query_Text_Extents_Request'Size / 32 +
U_Short (Str_Length + 3) /
2, -- Yes, 2; not 4.
Font => Font,
Odd_Length =>
From_Boolean ((Str_Length rem 2) /= 0)));
----Send the string; each character is sent as 2 bytes.
declare
Buf : U_Char_Array (1 .. S_Natural (Str_Length * 2));
begin
for I in reverse 0 .. Str_Length - 1 loop
Buf (I * 2 + 1) := 0;
Buf (I * 2 + 2) := X_Character'Pos (Text (Text'First + I));
end loop;
Put_U_Char_Array (Display, Buf);
end;
----Read the reply.
Get_Reply (Display => Display,
Code => Query_Text_Extents,
Reply => Rep,
Extra => 0,
Discard => True,
Status => Succ);
----If we got failure then return that.
if Succ = Failed then
Direction := Font_Left_To_Right;
Font_Ascent := 0;
Font_Descent := 0;
Overall := None_X_Char_Struct;
return;
end if;
----Return the results.
Direction := Rep.Query_Text_Extents.Draw_Direction;
Font_Ascent := Rep.Query_Text_Extents.Font_Ascent;
Font_Descent := Rep.Query_Text_Extents.Font_Descent;
Overall :=
(Ascent => Rep.Query_Text_Extents.Overall_Ascent,
Descent => Rep.Query_Text_Extents.Overall_Descent,
Width => S_Short (Rep.Query_Text_Extents.Overall_Width),
Lbearing => S_Short (Rep.Query_Text_Extents.Overall_Left),
Rbearing => S_Short (Rep.Query_Text_Extents.Overall_Right),
Attributes => (others => False));
----Catch unexpected exceptions.
exception
when others =>
Unlock_Display (Display);
raise;
end;
----Unlock; sync; and return;
Unlock_Display (Display);
Sync_Handle (Display);
end X_Query_Text_Extents;
--\f
procedure Ci_Get_Char_Info_1d (Fs : X_Font_Struct;
Char : U_Char;
Cs : in out X_Char_Struct;
Found : out Boolean) is
begin
if Fs.Per_Char = None_X_Char_Struct_List_2d then
Cs := Fs.Min_Bounds;
Found := True;
elsif 0 in Fs.Per_Char'Range (1) and then
Char in Fs.Per_Char'Range (2) then
Cs := Fs.Per_Char (0, Char);
if Ci_Non_Exist_Char (Cs) then
Found := False;
else
Found := True;
end if;
else
Found := False;
end if;
end Ci_Get_Char_Info_1d;
--\f
procedure Ci_Get_Default_Info_1d (Fs : X_Font_Struct;
Cs : in out X_Char_Struct;
Found : out Boolean) is
begin
Ci_Get_Char_Info_1d (Fs,
Fs.Default_Char.Char2,
Cs,
Found);
end Ci_Get_Default_Info_1d;
--\f
procedure X_Text_Extents (Font : X_Font_Struct;
Text : X_String;
Direction : out X_Font_Direction;
Font_Ascent : out S_Short;
Font_Descent : out S_Short;
Overall : out X_Char_Struct) is
------------------------------------------------------------------------------
-- X_Text_Extents
------------------------------------------------------------------------------
N_Found : S_Natural := 0; -- number of characters found
Def : X_Char_Struct; -- info about default char
Cs : X_Char_Struct;
Have_Def : Boolean;
Found : Boolean;
Ovrall : X_Char_Struct;
begin
Ci_Get_Default_Info_1d (Font, Def, Have_Def);
Direction := Font.Direction;
Font_Ascent := Font.Ascent;
Font_Descent := Font.Descent;
-- Iterate over the input string getting the appropriate * char struct.
-- The default (which may be null if there is no def_char) will be returned
-- if the character doesn't exist. On the first time * through the loop,
-- assign the values to overall; otherwise, compute * the new values.
for I in Text'Range loop
Ci_Get_Char_Info_1d
(Font, U_Char (X_Character'Pos (Text (I))), Cs, Found);
if not Found then
if Have_Def then
Cs := Def;
else
goto Continue;
end if;
end if;
if N_Found = 0 then
Overall := Cs;
else
Ovrall.Ascent := Max (Ovrall.Ascent, Cs.Ascent);
Ovrall.Descent := Max (Ovrall.Descent, Cs.Descent);
Ovrall.Lbearing := Min (Ovrall.Lbearing,
Ovrall.Width + Cs.Lbearing);
Ovrall.Rbearing := Max (Ovrall.Rbearing,
Ovrall.Width + Cs.Rbearing);
Ovrall.Width := Ovrall.Width + Cs.Width;
end if;
N_Found := N_Found + 1;
<<Continue>> null;
end loop;
----If there were no characters, then set everything to 0.
if N_Found = 0 then
Overall := None_X_Char_Struct;
else
Overall := Ovrall;
end if;
end X_Text_Extents;
--\f
function X_Text_Width (Font : X_Font_Struct;
Text : X_String) return S_Long is
------------------------------------------------------------------------------
-- X_Text_Width
------------------------------------------------------------------------------
Def : X_Char_Struct; -- info about default char
Cs : X_Char_Struct;
Have_Def : Boolean;
Found : Boolean;
Width : S_Long;
begin
Ci_Get_Default_Info_1d (Font, Def, Have_Def);
-- Iterate over the input string getting the appropriate * char struct.
-- The default (which may be null if there is no def_char) will be returned
-- if the character doesn't exist. On the first time * through the loop,
-- assign the values to overall; otherwise, compute * the new values.
Width := 0;
for I in Text'Range loop
Ci_Get_Char_Info_1d
(Font, U_Char (X_Character'Pos (Text (I))), Cs, Found);
if not Found then
if Have_Def then
Width := Width + S_Long (Def.Width);
end if;
else
Width := Width + S_Long (Cs.Width);
end if;
end loop;
return Width;
end X_Text_Width;
--\f
end Xlbp_Text;