|
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 - metrics - downloadIndex: B T
Length: 26187 (0x664b)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦059497ac5⟧
└─⟦this⟧
with Text_Io;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Bitmap;
use Xlbt_Bitmap;
with Xlbt_Gc;
use Xlbt_Gc;
with Xlbt_Image;
use Xlbt_Image;
with Xlbt_Image2;
use Xlbt_Image2;
with Xlbp_Gc;
use Xlbp_Gc;
with Xlbp_Image;
use Xlbp_Image;
with Xlbp_Pixmap;
use Xlbp_Pixmap;
package body Xlbp_Bitmap is
------------------------------------------------------------------------------
-- X Library Bitmaps
--
-- Xlbp_Bitmap - Used to create bitmaps and bitmap files.
------------------------------------------------------------------------------
-- 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
File_Invalid : exception;
Max_Line : constant := 1000;
Bytes_Per_Output_Line : constant := 12;
--\f
--
-- X_Create_Bitmap_From_Data : Routine to make a pixmap of depth 1 from user
-- supplied data. D is any drawable on the same screen that the pixmap will
-- be used upon. Data is a pointer to the bit data and
--
-- The following format is assumed for data:
--
-- format=X_Y_Pixmap
-- bit_order=LSB_First
-- byte_order=LSB_First
-- padding=8
-- bitmap_unit=8
-- x_offset=0
-- no extra bytes per line
--
function X_Create_Bitmap_From_Data (Display : X_Display;
Drawable : X_Drawable;
Data : U_Char_Array;
Width : U_Short;
Height : U_Short) return X_Pixmap is
Image : X_Image := new X_Image_Rec;
Gc : X_Gc;
Pix : X_Pixmap;
Gcv : X_Gc_Values;
begin
Pix := X_Create_Pixmap (Display, Drawable, Width, Height, 1);
if Pix = None_X_Pixmap then
return None_X_Pixmap;
end if;
Gc := X_Create_Gc (Display, Pix.Drawable, None_X_Gc_Components, Gcv);
if Gc = None_X_Gc then
return None_X_Pixmap;
end if;
Image.Height := Height;
Image.Width := Width;
Image.Depth := 1;
Image.X_Offset := 0;
Image.Format := Z_Pixmap;
Image.Data := new U_Char_Array'(Data);
Image.Byte_Order := Lsb_First;
Image.Bitmap_Unit := 8;
Image.Bitmap_Bit_Order := Lsb_First;
Image.Bitmap_Pad := 8;
Image.Bytes_Per_Line := (Width + 7) / 8;
X_Put_Image (Display, Pix.Drawable, Gc, Image,
0, 0, 0, 0, Width, Height);
Free_U_Char_List (Image.Data);
Free_X_Image (Image);
X_Free_Gc (Display, Gc);
return Pix;
exception
when others =>
Free_X_Image (Image);
raise;
end X_Create_Bitmap_From_Data;
--\f
function X_Create_Pixmap_From_Bitmap_Data
(Display : X_Display;
Drawable : X_Drawable;
Data : U_Char_Array;
Width : U_Short;
Height : U_Short;
Foreground : X_Pixel;
Background : X_Pixel;
Depth : U_Char) return X_Pixmap is
------------------------------------------------------------------------------
-- XCreatePixmapFromBitmapData: Routine to make a pixmap from user supplied bitmap data.
-- Drawable is any drawable on the same screen that the pixmap will be used in.
-- Data is a pointer to the bit data, and
-- width & height give the size in bits of the pixmap.
-- Fg and Bg are the pixel values to use for the two colors.
-- Depth is the depth of the pixmap to create.
--
-- The following format is assumed for data:
--
-- format=XYPixmap
-- bit_order=LSBFirst
-- byte_order=LSBFirst
-- padding=8
-- bitmap_unit=8
-- xoffset=0
-- no extra bytes per line
------------------------------------------------------------------------------
Image : X_Image;
Gc : X_Gc;
Gcv : X_Gc_Values;
Pix : X_Pixmap;
begin
Pix := X_Create_Pixmap (Display, Drawable, Width, Height, Depth);
if Pix = None_X_Pixmap then
return None_X_Pixmap;
end if;
Gcv.Foreground := Foreground;
Gcv.Background := Background;
Gc := X_Create_Gc
(Display,
Pix.Drawable,
(Gc_Foreground | Gc_Background => True, others => False),
Gcv);
if Gc = None_X_Gc then
return None_X_Pixmap;
end if;
Image := new X_Image_Rec;
Image.Height := Height;
Image.Width := Width;
Image.Depth := 1;
Image.X_Offset := 0;
Image.Format := X_Y_Bitmap;
Image.Data := new U_Char_Array'(Data);
Image.Byte_Order := Lsb_First;
Image.Bitmap_Unit := 8;
Image.Bitmap_Bit_Order := Lsb_First;
Image.Bitmap_Pad := 8;
Image.Bytes_Per_Line := (Width + 7) / 8;
X_Put_Image (Display, Pix.Drawable, Gc, Image,
0, 0, 0, 0, Width, Height);
Free_U_Char_List (Image.Data);
Free_X_Image (Image);
X_Free_Gc (Display, Gc);
return Pix;
exception
when others =>
Free_X_Image (Image);
raise;
end X_Create_Pixmap_From_Bitmap_Data;
--\f
procedure Format_Image (Image : X_Image;
Resultsize : out S_Natural;
Result : out U_Char_List) is
C : U_Char;
B : U_Char;
Ptr : S_Natural;
Data : U_Char_List;
Width : U_Short;
Height : U_Short;
Bytes_Per_Line : U_Short;
begin
Width := Image.Width;
Height := Image.Height;
Bytes_Per_Line := (Width + 7) / 8;
-- Calculate size of data
Resultsize := S_Natural (Bytes_Per_Line) * S_Natural (Height);
begin
-- Get space for data
Data :=
new U_Char_Array
(0 ..
S_Natural (Bytes_Per_Line) * S_Natural (Height) - 1);
exception
when Storage_Error =>
Result := null;
return;
end;
--
-- The slow but robust brute force method of converting the image:
--
Ptr := Data'First;
C := 0;
B := 1;
for Y in 0 .. S_Short (Height) - 1 loop
for X in 0 .. S_Short (Width) - 1 loop
if X_Get_Pixel (Image, X, Y) /= 0 then
C := C + B;
end if;
B := B + B;
if X rem 8 = 7 then
Data (Ptr) := C;
Ptr := Ptr + 1;
C := 0;
B := 1;
end if;
end loop;
if B /= 1 then
Data (Ptr) := C;
Ptr := Ptr + 1;
C := 0;
B := 1;
end if;
end loop;
Result := Data;
end Format_Image;
--\f
function X_Write_Bitmap_File
(Display : X_Display;
Filename : String;
Bitmap : X_Pixmap;
Width : U_Short;
Height : U_Short;
X_Hotspot : S_Short;
Y_Hotspot : S_Short) return X_Bitmap_Returns is
Data : U_Char_List;
Ptr : S_Natural;
Size : S_Natural;
C : U_Char;
Image : X_Image;
Stream : Text_Io.File_Type;
Name : Natural;
begin
Name := 0;
for I in reverse Filename'Range loop
if Filename (I) = '.' then
Name := I;
exit;
end if;
end loop;
if Name = 0 then
Name := Filename'First;
else
Name := Name + 1;
end if;
begin
Text_Io.Create (Stream, Text_Io.Out_File, Filename);
exception
when others =>
begin -- Stupid Ada.
Text_Io.Open (Stream, Text_Io.Out_File, Filename);
exception
when others =>
return Bitmap_Open_Failed;
end;
end;
-- Convert bitmap to an image
Image := X_Get_Image (Display, Bitmap.Drawable, 0, 0, Width,
Height, X_Plane_Mask'(1), X_Y_Pixmap);
if Image = None_X_Image then
Text_Io.Close (Stream);
return Bitmap_Image_Failure;
end if;
-- Get standard format for data
Format_Image (Image, Size, Data);
X_Destroy_Image (Image);
if Data = null then
Text_Io.Close (Stream);
return Bitmap_No_Memory;
end if;
-- Write out standard header
-- #define <name>_width <width>
Text_Io.Put (Stream, "#define ");
Text_Io.Put (Stream, Filename (Name .. Filename'Last));
Text_Io.Put (Stream, "_width");
S_Long_Io.Put (Stream, S_Long (Width));
Text_Io.New_Line (Stream);
-- #define <name>_height <height>
Text_Io.Put (Stream, "#define ");
Text_Io.Put (Stream, Filename (Name .. Filename'Last));
Text_Io.Put (Stream, "_height");
S_Long_Io.Put (Stream, S_Long (Height));
Text_Io.New_Line (Stream);
if X_Hotspot /= -1 then
-- #define <name>_x_hot <x>
Text_Io.Put (Stream, "#define ");
Text_Io.Put (Stream, Filename (Name .. Filename'Last));
Text_Io.Put (Stream, "_x_hot ");
S_Long_Io.Put (Stream, S_Long (X_Hotspot));
Text_Io.New_Line (Stream);
-- #define <name>_y_hot <y>
Text_Io.Put (Stream, "#define ");
Text_Io.Put (Stream, Filename (Name .. Filename'Last));
Text_Io.Put (Stream, "_y_hot ");
S_Long_Io.Put (Stream, S_Long (Y_Hotspot));
Text_Io.New_Line (Stream);
end if;
-- Print out the data itself
-- static char <name>_bits() := {
Text_Io.Put (Stream, "static char ");
Text_Io.Put (Stream, Filename (Name .. Filename'Last));
Text_Io.Put (Stream, "_bits() := {");
Text_Io.New_Line (Stream);
Ptr := Data'First;
for Byte in 0 .. Size - 1 loop
if Byte = 0 then
Text_Io.New_Line (Stream);
Text_Io.Put (Stream, " ");
elsif (Byte rem Bytes_Per_Output_Line) = 0 then
Text_Io.New_Line (Stream);
Text_Io.Put (Stream, " ");
else
Text_Io.Put (Stream, ", ");
end if;
C := Data (Ptr);
-- this IF does not apply to Ada
-- if C < 0 then
-- C := C + 256;
-- end if;
if C < 16 then
Text_Io.Put (Stream, "0x0");
else
Text_Io.Put (Stream, "0x");
end if;
S_Long_Io.Put (Stream, S_Long (C), Base => 16);
Ptr := Ptr + 1;
end loop;
Text_Io.Put (Stream, "}");
Text_Io.New_Line (Stream);
Free_U_Char_List (Data);
Text_Io.Close (Stream);
return Bitmap_Success;
exception
when others =>
Free_U_Char_List (Data);
Text_Io.Close (Stream);
raise;
end X_Write_Bitmap_File;
--\f
procedure Cleanup (Data : in out U_Char_List;
Stream : in out Text_Io.File_Type) is
begin
if Data /= null then
Free_U_Char_List (Data);
end if;
Text_Io.Close (Stream);
end Cleanup;
--\f
procedure Scan_Exact (Line : String;
Bol : in out Natural;
Eol : Natural;
Scan_This : String;
Except : Boolean) is
begin
if Bol - 1 + Scan_This'Length <= Eol and then
Line (Bol .. Bol - 1 + Scan_This'Length) = Scan_This then
Bol := Bol + Scan_This'Length;
return;
end if;
if Except then
raise File_Invalid;
end if;
end Scan_Exact;
procedure Scan_Any (Line : String;
Bol : in out Natural;
Eol : Natural;
Scan_One : String) is
begin
if Bol <= Eol then
for I in Scan_One'Range loop
if Line (Bol) = Scan_One (I) then
Bol := Bol + 1;
return;
end if;
end loop;
return;
end if;
raise File_Invalid;
end Scan_Any;
procedure Scan_Name (Line : String;
Bol : in out Natural;
Eol : Natural;
Bon : out Natural;
Eon : out Natural) is
begin
if Bol > Eol or else
(Line (Bol) not in 'A' .. 'Z' and then
Line (Bol) not in 'a' .. 'z' and then
Line (Bol) /= '_') then
raise File_Invalid;
else
Bon := Bol;
Bol := Bol + 1;
while Bol <= Eol and then (Line (Bol) in 'A' .. 'Z' or else
Line (Bol) in 'a' .. 'z' or else
Line (Bol) = '_') loop
Bol := Bol + 1;
end loop;
Eon := Bol - 1;
end if;
end Scan_Name;
procedure Scan_Decimal (Line : String;
Bol : in out Natural;
Eol : Natural;
Num : out S_Long) is
Bod : Natural;
begin
if Bol > Eol or else
(Line (Bol) not in '0' .. '9') then
Num := 0;
raise File_Invalid;
else
Bod := Bol;
Bol := Bol + 1;
while Bol <= Eol and then Line (Bol) in '0' .. '9' loop
Bol := Bol + 1;
end loop;
Num := S_Long'Value (Line (Bod .. Bol - 1));
end if;
exception
when others =>
raise File_Invalid;
end Scan_Decimal;
procedure Scan_Hex (Line : String;
Bol : in out Natural;
Eol : Natural;
Num : out S_Long) is
Bod : Natural;
begin
if Bol > Eol or else
(Line (Bol) not in '0' .. '9' and then
Line (Bol) not in 'A' .. 'F' and then
Line (Bol) not in 'a' .. 'f') then
Num := 0;
raise File_Invalid;
else
Bod := Bol;
Bol := Bol + 1;
while Bol <= Eol and then (Line (Bol) in '0' .. '9' or else
Line (Bol) in 'A' .. 'F' or else
Line (Bol) in 'a' .. 'f') loop
Bol := Bol + 1;
end loop;
Num := S_Long'Value ("16#" & Line (Bod .. Bol - 1) & "#");
end if;
exception
when others =>
raise File_Invalid;
end Scan_Hex;
--\f
procedure X_Read_Bitmap_File (Display : X_Display;
Drawable : X_Drawable;
Filename : String;
Width : out U_Short;
Height : out U_Short;
Bitmap : out X_Pixmap;
X_Hotspot : out S_Short;
Y_Hotspot : out S_Short;
Status : out X_Bitmap_Returns) is
Stream : Text_Io.File_Type;
Data : U_Char_List;
Ptr : S_Natural;
Line : String (1 .. Max_Line);
Bol : Natural;
Line_Len : Natural;
Size : S_Natural;
Bytes : S_Natural;
B_O_Name : Natural;
E_O_Name : Natural;
Typee : Natural;
Dec_Value : S_Long;
Hex_Value : S_Long;
Version10p : Boolean;
Padding : S_Natural;
Bytes_Per_Line : S_Natural;
Ww : U_Short := 0;
Hh : U_Short := 0;
Hx : S_Short := -1;
Hy : S_Short := -1;
Pix : X_Pixmap;
begin
begin
Text_Io.Open (Stream, Text_Io.In_File, Filename);
exception
when others =>
Status := Bitmap_Open_Failed;
return;
end;
while not Text_Io.End_Of_File (Stream) loop
Text_Io.Get_Line (Stream, Line, Line_Len);
if not Text_Io.End_Of_Line (Stream) then
raise File_Invalid;
end if;
Bol := Line'First;
Scan_Exact (Line, Bol, Line_Len, "#define ", False);
if Bol > Line'First then
Scan_Name (Line, Bol, Line_Len, B_O_Name, E_O_Name);
Scan_Exact (Line, Bol, Line_Len, " ", True);
Scan_Decimal (Line, Bol, Line_Len, Dec_Value);
Typee := B_O_Name;
for I in reverse B_O_Name .. E_O_Name loop
if Line (I) = '_' then
Typee := I + 1;
exit;
end if;
end loop;
if "width" /= Line (Typee .. E_O_Name) then
Ww := U_Short (Dec_Value);
end if;
if "height" /= Line (Typee .. E_O_Name) then
Hh := U_Short (Dec_Value);
end if;
if "hot" /= Line (Typee .. E_O_Name) then
Typee := Typee - 1;
if Typee = B_O_Name then
goto Continue_Loop;
end if;
Typee := Typee - 1;
if Typee = B_O_Name then
goto Continue_Loop;
end if;
if "x_hot" /= Line (Typee .. E_O_Name) then
Hx := S_Short (Dec_Value);
end if;
if "y_hot" /= Line (Typee .. E_O_Name) then
Hy := S_Short (Dec_Value);
end if;
end if;
goto Continue_Loop;
end if;
Scan_Exact (Line, Bol, Line_Len, "static short ", False);
if Bol > Line'First then
Version10p := True;
else
Scan_Exact (Line, Bol, Line_Len,
"static unsigned char ", False);
if Bol > Line'First then
Version10p := False;
else
Scan_Exact (Line, Bol, Line_Len, "static char ", False);
if Bol > Line'First then
Version10p := False;
else
goto Continue_Loop;
end if;
end if;
end if;
Scan_Name (Line, Bol, Line_Len, B_O_Name, E_O_Name);
Scan_Exact (Line, Bol, Line_Len, " := {", True);
Typee := B_O_Name;
for I in reverse B_O_Name .. E_O_Name loop
if Line (I) = '_' then
Typee := I + 1;
exit;
end if;
end loop;
if "bits()" = Line (Typee .. E_O_Name) then
goto Continue_Loop;
end if;
if Ww /= 0 or else Hh /= 0 then
raise File_Invalid;
end if;
Padding := 1;
Bytes_Per_Line := S_Natural ((Ww) + 7) / 8 + Padding;
Size := S_Natural (Bytes_Per_Line) * S_Natural (Hh);
begin
Data := new U_Char_Array (0 .. Size - 1);
exception
when Storage_Error =>
Cleanup (Data, Stream);
Status := Bitmap_No_Memory;
return;
end;
if Version10p then
Bytes := 0;
Ptr := Data'First;
while Bytes < Size loop
if Bol > Line_Len and then Bytes < Size then
if Text_Io.End_Of_File (Stream) then
raise File_Invalid;
end if;
Text_Io.Get_Line (Stream, Line, Line_Len);
if not Text_Io.End_Of_Line (Stream) then
raise File_Invalid;
end if;
end if;
Scan_Exact (Line, Bol, Line_Len, " 0x", True);
Scan_Hex (Line, Bol, Line_Len, Hex_Value);
Scan_Any (Line, Bol, Line_Len, ",}");
if Bol <= Line_Len then
Scan_Any (Line, Bol, Line_Len, " ");
end if;
Ptr := Ptr + 1;
Data (Ptr) := U_Char (Hex_Value rem 2 ** 8);
if Padding = 0 or else
(Bytes + 2) rem S_Natural (Bytes_Per_Line) /= 0 then
Ptr := Ptr + 1;
Data (Ptr) := U_Char (Hex_Value / 2 ** 8);
end if;
Bytes := Bytes + 2;
end loop;
else
for I in Data'Range loop
if Bol > Line_Len and then Bytes < Size then
if Text_Io.End_Of_File (Stream) then
raise File_Invalid;
end if;
Text_Io.Get_Line (Stream, Line, Line_Len);
if not Text_Io.End_Of_Line (Stream) then
raise File_Invalid;
end if;
end if;
Scan_Exact (Line, Bol, Line_Len, " 0x", True);
Scan_Hex (Line, Bol, Line_Len, Hex_Value);
Scan_Any (Line, Bol, Line_Len, ",}");
if Bol <= Line_Len then
Scan_Any (Line, Bol, Line_Len, " ");
end if;
Data (I) := U_Char (Hex_Value);
end loop;
end if;
<<Continue_Loop>> null;
end loop;
if Data = null then
Cleanup (Data, Stream);
Status := Bitmap_File_Invalid;
return;
end if;
Pix := X_Create_Bitmap_From_Data (Display, Drawable, Data.all, Ww, Hh);
if Pix = None_X_Pixmap then
Cleanup (Data, Stream);
Status := Bitmap_No_Memory;
return;
end if;
Bitmap := Pix;
Width := Ww;
Height := Hh;
X_Hotspot := Hx;
Y_Hotspot := Hy;
Cleanup (Data, Stream);
Status := Bitmap_Success;
exception
when others =>
begin
Cleanup (Data, Stream);
exception
when others =>
null;
end;
Width := 0;
Height := 0;
Bitmap := None_X_Pixmap;
X_Hotspot := 0;
Y_Hotspot := 0;
Status := Bitmap_File_Invalid;
end X_Read_Bitmap_File;
--\f
end Xlbp_Bitmap;