|
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: 26400 (0x6720)
Types: TextFile
Names: »B«
└─⟦85b835f43⟧ Bits:30000549 8mm tape, Rational 1000, Xlib rev 6.00
└─⟦0c20f784e⟧ »DATA«
└─⟦1abbe589f⟧
└─⟦306851c02⟧
└─⟦this⟧
with Calendar;
with Text_Io;
with Unchecked_Deallocation;
with Ran1_Package;
use Ran1_Package;
with Trig;
use Trig;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Color;
use Xlbt_Color;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Event2;
use Xlbt_Event2;
with Xlbt_Hint;
use Xlbt_Hint;
with Xlbt_Gc;
use Xlbt_Gc;
with Xlbt_Geometry;
use Xlbt_Geometry;
with Xlbt_Misc;
use Xlbt_Misc;
with Xlbt_Pointer;
use Xlbt_Pointer;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Visual;
use Xlbt_Visual;
with Xlbt_Window;
use Xlbt_Window;
with Xlbp_Atom;
use Xlbp_Atom;
with Xlbp_Color;
use Xlbp_Color;
with Xlbp_Display;
use Xlbp_Display;
with Xlbp_Event;
use Xlbp_Event;
with Xlbp_Gc;
use Xlbp_Gc;
with Xlbp_Geometry;
use Xlbp_Geometry;
with Xlbp_Graphics;
use Xlbp_Graphics;
with Xlbp_Hint;
use Xlbp_Hint;
with Xlbp_Key;
use Xlbp_Key;
with Xlbp_Sync;
use Xlbp_Sync;
with Xlbp_Visual;
use Xlbp_Visual;
with Xlbp_Window;
use Xlbp_Window;
with Xlbmp_Environment;
use Xlbmp_Environment;
package body Worm_Main is
--
-- worm.c: draw wiggly worms.
--
-- Adapted from a concept in the Dec 87 issue of Scientific American.
-- Makes a nice lockscreen via "lockscreen nice worm".
--
-- compile: cc worm.c -o worm -lm -lsuntool -lsunwindow -lpixrect
--
-- usage: worm [-l length] [-s size] [-n number]
-- where "length" is length of each worm in segments (default 50)
-- "size" is size of each segment (default 2)
-- "number" is number of worms to draw (default 64)
--
-- This program looks best on a color monitor. Try these options:
-- worm -n 1 Just one really fast worm
-- worm -l 2 Paramecia
-- worm -s 500 Mondrian painting (actually enormous worms)
-- worm -l -1 Jackson Pollack painting (actually infinite length worms)
--
-- -- Thu Dec 17 09:58:48 PST 1987
-- -- Brad Taylor (brad@sun)
--
-- hacked to use X11 by Dave Lemke (lemke@sun.com)
-- Wed Dec 23 09:57:32 PST 1987
--
-- additional options:
-- -S -R -C [-g geometry] [-d display]
--
-- -S screen saver mode - covers screen
-- -R rotate colormap while running
-- -C chromocolor worms - colors change as they crawl
-- ***********************************************************
-- Copyright 1988 by Sun Microsystems, Inc. Mountain View, CA.
--
-- 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 appear in all copies and that
-- both that copyright notice and this permission notice appear in
-- supporting documentation, and that the names of Sun or MIT not be
-- used in advertising or publicity pertaining to distribution of the
-- software without specific prior written permission. Sun and M.I.T.
-- make no representations about the suitability of this software for
-- any purpose. It is provided "as is" without any express or implied warranty.
--
-- SUN DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
-- ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
-- PURPOSE. IN NO EVENT SHALL SUN 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.
-- **********************************************************
Num_Colors : constant := 256;
Min_Colors : constant := 16;
Segments : constant := 36;
Pi : constant := 3.14159265358979323844;
Ran_Data : Ran1_Data;
type Worm_Stuff_Rec is
record
X_Circ : S_Long_List;
Y_Circ : S_Long_List;
Dir : S_Long;
Tail : S_Long;
X : S_Long;
Y : S_Long;
end record;
type Worm_Stuff is access Worm_Stuff_Rec;
type Worm_Stuff_Array is array (S_Natural range <>) of Worm_Stuff;
type Worm_Stuff_List is access Worm_Stuff_Array;
procedure Free_Worm_Stuff is new Unchecked_Deallocation (Worm_Stuff_Rec,
Worm_Stuff);
function Worm_Init (Xsize : S_Long;
Ysize : S_Long;
Worm_Length : S_Long) return Worm_Stuff;
Worm_Length : S_Long := 50;
Circ_Size : S_Long := 2;
Nworms : S_Long := 64;
Sin_Tab : S_Long_Array (0 .. Segments - 1);
Cos_Tab : S_Long_Array (0 .. Segments - 1);
Ncolors : S_Long;
Xwmh : X_Wm_Hints := ((Input_Hint | State_Hint => True, others => False),
True, Normal_State, None_X_Pixmap, None_X_Window,
0, 0, None_X_Pixmap, None_X_Window);
Dpy : X_Display;
W : X_Window;
Screen : X_Screen_Number;
Gc : X_Gc;
Wgc : X_Gc;
Cmap : X_Colormap;
Is_Color : Boolean := True;
Is_Dynamic : Boolean := False;
Screen_Saver : Boolean := False;
Rotate : Boolean := False;
Chromo_Color : Boolean := False;
Colors : X_Color_Array (0 .. Num_Colors - 1);
Worm : Worm_Stuff_List;
Def_Geo : constant X_String := "500x500+10+10";
Visual : X_Visual;
Depth : U_Char := 1;
Backpixel : X_Pixel;
Protocol_Atom : X_Atom;
Kill_Atom : X_Atom;
--\f
function Ran2 return S_Long is
I : S_Long;
F : Float;
begin
F := Ran1 (Ran_Data);
if Float'Mantissa < 32 then
I := S_Long ((2.0 ** (Float'Mantissa - 1) - 1.0) * F);
else
I := S_Long (Float (S_Long'Last / 2) * F);
end if;
return I;
if Float'Mantissa < 32 then
return S_Long ((2.0 ** (Float'Mantissa - 1) - 1.0) *
Ran1 (Ran_Data));
else
return S_Long (Float (S_Long'Last / 2) * Ran1 (Ran_Data));
end if;
end Ran2;
--\f
procedure Do_Rotate_Colors is
Temp : X_Pixel;
begin
Temp := Colors (1).Pixel; -- start at 1 - don't want the black
for I in 1 .. Ncolors - 2 loop
Colors (I).Pixel := Colors (I + 1).Pixel;
end loop;
Colors (Ncolors - 1).Pixel := Temp;
X_Store_Colors (Dpy, Cmap, Colors);
end Do_Rotate_Colors;
--\f
function Worm_Init (Xsize : S_Long;
Ysize : S_Long;
Worm_Length : S_Long) return Worm_Stuff is
Ws : Worm_Stuff := new Worm_Stuff_Rec;
begin
if Worm_Length > 0 then
Ws.X_Circ := new S_Long_Array (0 .. Worm_Length - 1);
Ws.Y_Circ := new S_Long_Array (0 .. Worm_Length - 1);
for I in Ws.X_Circ'Range loop
Ws.X_Circ (I) := Xsize / 2;
Ws.Y_Circ (I) := Ysize / 2;
end loop;
end if;
Ws.Dir := Ran2 rem Segments;
Ws.Tail := 0;
Ws.X := Xsize / 2;
Ws.Y := Ysize / 2;
return Ws;
end Worm_Init;
--\f
procedure Draw_Seg (X : S_Long;
Y : S_Long;
C : X_Pixel) is
begin
X_Set_Foreground (Dpy, Gc, C);
X_Fill_Rectangle (Dpy, W.Drawable, Gc, S_Short (X), S_Short (Y),
U_Short (Circ_Size), U_Short (Circ_Size));
end Draw_Seg;
--\f
procedure Worm_Doit (Ws : Worm_Stuff;
Xsize : S_Long;
Ysize : S_Long;
Color : X_Pixel) is
X : S_Long;
Y : S_Long;
begin
if Worm_Length > 0 then
Ws.Tail := (Ws.Tail + 1) rem Worm_Length;
X := Ws.X_Circ (Ws.Tail);
Y := Ws.Y_Circ (Ws.Tail);
X_Clear_Area (Dpy, W, S_Short (X), S_Short (Y),
U_Short (Circ_Size), U_Short (Circ_Size), False);
end if;
if Ran2 rem 2 /= 0 then
Ws.Dir := (Ws.Dir + 1) rem Segments;
else
Ws.Dir := (Ws.Dir + Segments - 1) rem Segments;
end if;
X := (Ws.X + Cos_Tab (Ws.Dir) + Xsize) rem Xsize;
Y := (Ws.Y + Sin_Tab (Ws.Dir) + Ysize) rem Ysize;
if Worm_Length > 0 then
Ws.X_Circ (Ws.Tail) := X;
Ws.Y_Circ (Ws.Tail) := Y;
end if;
if Is_Color then
Draw_Seg (X, Y, Color);
else
X_Fill_Rectangle (Dpy, W.Drawable, Wgc, S_Short (X), S_Short (Y),
U_Short (Circ_Size), U_Short (Circ_Size));
end if;
Ws.X := X;
Ws.Y := Y;
end Worm_Doit;
--\f
function Floor (X : Float) return S_Long is
I : S_Long := S_Long (X);
begin
if Float (I) > X then
return I - 1;
else
return I;
end if;
end Floor;
--\f
procedure Hsb2_Rgb (Hp : Float;
S : Float;
I : Float;
R : in out Float;
G : in out Float;
B : in out Float) is
H : Float := Hp;
F : Float;
P : Float;
Q : Float;
T : Float;
J : S_Long;
begin
if S = 0.0 then
R := I;
G := I;
B := I;
else
H := H - Float (Floor (H)); -- remove anything over 1
H := H * 6.0;
J := Floor (H);
F := H - Float (J);
P := I * (1.0 - S);
Q := I * (1.0 - S * F);
T := I * (1.0 - (S * (1.0 - F)));
case J is
when 0 =>
R := I;
G := T;
B := P;
when 1 =>
R := Q;
G := I;
B := P;
when 2 =>
R := P;
G := I;
B := T;
when 3 =>
R := P;
G := Q;
B := I;
when 4 =>
R := T;
G := P;
B := I;
when 5 =>
R := I;
G := P;
B := Q;
when others =>
raise Constraint_Error;
end case;
end if;
end Hsb2_Rgb;
--\f
procedure Cmap_Init (Win : X_Window) is
Pixels : X_Pixel_Array (0 .. Num_Colors - 1);
Pmask : X_Plane_Mask_Array (1 .. 0);
Vinfo : X_Visual_Info;
Num_Vis : S_Long;
Vmask : S_Long;
Stat_Colors : X_Color_Array (0 .. Num_Colors - 1);
Planes : U_Char;
Status : X_Status;
Defvalues : constant := 256;
Defrandom : constant Boolean := False; -- use an random colormap - messy
Hsb : constant Boolean :=
True; -- use an HSB colormap - makes colorwheel look neat
begin
Planes := X_Display_Planes (Dpy, Screen);
-- see what kind of visual we're dealing with
X_Match_Visual_Info (Dpy, Screen, Planes, Pseudo_Color, Vinfo, Status);
if Status = Successful then
goto Read_Write_Map;
end if;
X_Match_Visual_Info (Dpy, Screen, Planes, Grayscale, Vinfo, Status);
if Status = Successful then
goto Read_Write_Map;
end if;
X_Match_Visual_Info (Dpy, Screen, Planes, Direct_Color, Vinfo, Status);
if Status = Successful then
goto Read_Write_Map;
else
goto Read_Only_Map;
end if;
<<Read_Write_Map>> null;
Visual := Vinfo.Visual;
Depth := Vinfo.Depth;
Cmap := X_Create_Colormap
(Dpy, X_Root_Window (Dpy, Screen), Visual, Alloc_None);
Ncolors := S_Long (Vinfo.Colormap_Size);
-- grab as many color cells as we can
for I in reverse Min_Colors .. Ncolors loop
X_Alloc_Color_Cells (Dpy, Cmap, False, Pmask,
Pixels (0 .. I - 1), Status);
if Status = Successful then
Ncolors := I;
exit;
end if;
end loop;
if Ncolors = Min_Colors then
Text_Io.Put_Line ("Couldn't allocate even" &
S_Long'Image (Min_Colors) & " colors - exiting");
raise Program_Error;
end if;
if Defrandom then
-- make the black for background
Backpixel := Pixels (0);
Colors (0).Pixel := Pixels (0);
Colors (0).Red := 0;
Colors (0).Green := 0;
Colors (0).Blue := 0;
Colors (0).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
for I in 1 .. Ncolors - 1 loop
Colors (I).Pixel := Pixels (I);
Colors (I).Red := U_Short (Ran2 rem Defvalues * 2 ** 8);
Colors (I).Green := U_Short (Ran2 rem Defvalues * 2 ** 8);
Colors (I).Blue := U_Short (Ran2 rem Defvalues * 2 ** 8);
Colors (I).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
end loop;
X_Store_Colors (Dpy, Cmap, Colors);
elsif Hsb then
-- this colormap makes things look a lot nicer when worms goes
-- into freeze mode.
declare
Hue : Float;
Sat : Float;
Bright : Float;
R : Float;
G : Float;
B : Float;
begin
Sat := 0.9;
Bright := 1.0;
-- make the black for background
Backpixel := Pixels (0);
Colors (0).Pixel := Pixels (0);
Colors (0).Red := 0;
Colors (0).Green := 0;
Colors (0).Blue := 0;
Colors (0).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
for I in 1 .. Ncolors - 1 loop
Hue := Float (I) / Float (Ncolors);
Hsb2_Rgb (Hue, Sat, Bright, R, G, B);
Colors (I).Pixel := Pixels (I);
Colors (I).Red := U_Short (S_Long (R * 255.0) * 2 ** 8);
Colors (I).Green := U_Short (S_Long (G * 255.0) * 2 ** 8);
Colors (I).Blue := U_Short (S_Long (B * 255.0) * 2 ** 8);
Colors (I).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
end loop;
X_Store_Colors (Dpy, Cmap, Colors);
end;
else
for I in Stat_Colors'Range loop
Stat_Colors (I).Pixel := X_Pixel (I);
end loop;
X_Query_Colors (Dpy, X_Default_Colormap (Dpy, Screen), Stat_Colors);
X_Store_Colors (Dpy, Cmap, Stat_Colors);
Colors := Stat_Colors;
end if;
Is_Dynamic := True;
return;
<<Read_Only_Map>> null;
Is_Dynamic := False;
Visual := Vinfo.Visual;
Depth := Vinfo.Depth;
-- for a Static colormap, just make each worm a random pixel
for I in Colors'Range loop
Colors (I).Pixel := X_Pixel (Ran2);
end loop;
end Cmap_Init;
--\f
procedure Main (Display : X_String := "";
Geometry : X_String := "";
Length : S_Natural := 50;
Size : S_Positive := 2;
Number : S_Positive := 64;
Screen_Saver : Boolean := False;
Rotate_Colors : Boolean := False;
Chromo_Colors : Boolean := False) is
Disp : X_String_Pointer;
Geo : X_String_Pointer;
Xsize : S_Long := 500;
Ysize : S_Long := 500;
X : S_Long := 0;
Y : S_Long := 0;
Status : X_Status;
Xsh : X_Size_Hints;
Xwa : X_Window_Attributes;
Vmask : X_New_Window_Attributes;
Values : X_Set_Window_Attributes;
Freeze : Boolean := False;
Is_Visible : Boolean := False;
Error : X_Error_String;
Env : constant X_String :=
X_Display_Name (Display);
E : X_Event;
Wcolor : S_Long;
Chromo : S_Long := 0; -- chromo looks best with HSB
begin
Worm_Length := Length;
Nworms := Number;
Circ_Size := Size;
Disp := new X_String'(Display);
Geo := new X_String'(Geometry);
Worm_Main.Screen_Saver := Screen_Saver;
Rotate := Rotate_Colors;
Chromo_Color := Chromo_Colors;
for I in Sin_Tab'Range loop
Sin_Tab (I) := S_Long (Float (Circ_Size) *
Sin (Float (I) * 2.0 * Pi /
Float (Sin_Tab'Length)));
Cos_Tab (I) := S_Long (Float (Circ_Size) *
Cos (Float (I) * 2.0 * Pi /
Float (Sin_Tab'Length)));
end loop;
X_Open_Display (Env, Dpy, Error);
if "=" (Dpy, None_X_Display) then
Text_Io.Put_Line ("Cannot open display: " &
To_String (Err (Error)));
raise Program_Error;
end if;
Screen := X_Default_Screen (Dpy);
Ncolors := Num_Colors;
if Screen_Saver then
Xsize := S_Long (X_Display_Width (Dpy, Screen));
Ysize := S_Long (X_Display_Height (Dpy, Screen));
X := 0;
Y := 0;
else
declare
Flags : X_Parse_Geometry_Flags;
begin
if Geo = null then
Geo := new X_String'(Def_Geo);
end if;
X_Parse_Geometry (Geo.all, S_Short (X), S_Short (Y),
U_Short (Xsize), U_Short (Ysize), Flags);
if (Flags (X_Value) and then Flags (X_Negative)) then
X := X + S_Long (X_Display_Width (Dpy, Screen)) - Xsize;
end if;
if Flags (Y_Value) and then Flags (Y_Negative) then
Y := Y + S_Long (X_Display_Height (Dpy, Screen)) - Ysize;
end if;
end;
end if;
Visual := X_Default_Visual (Dpy, Screen);
Depth := X_Default_Depth (Dpy, Screen);
Cmap := X_Default_Colormap (Dpy, Screen);
-- set up the color map
if X_Display_Cells (Dpy, Screen) > 2 then
Cmap_Init (W);
else
Is_Color := False;
Backpixel := X_Black_Pixel (Dpy, Screen);
end if;
Vmask := X_New_Window_Attributes'
(Cw_Background_Pixel | Cw_Colormap => True,
others => False);
Values.Background_Pixel := Backpixel;
Values.Colormap := Cmap;
W := X_Create_Window (Dpy, X_Root_Window (Dpy, Screen), S_Short (X),
S_Short (Y), U_Short (Xsize), U_Short (Ysize),
0, Depth, Input_Output, Visual, Vmask, Values);
Xsh.Flags := X_Size_Hints_Flags'(P_Position | P_Size => True,
others => False);
Xsh.X := X;
Xsh.Y := Y;
Xsh.Width := Xsize;
Xsh.Height := Ysize;
X_Set_Wm_Properties (Dpy, W, "Worms", "Worms",
(1 .. 0 => None_X_String_Pointer), Xsh, Xwmh,
None_X_Class_Hint, Status);
Protocol_Atom := X_Intern_Atom (Dpy, "WM_PROTOCOLS", False);
Kill_Atom := X_Intern_Atom (Dpy, "WM_DELETE_WINDOW", False);
X_Set_Wm_Protocols (Dpy, W, (1 => Kill_Atom), Status);
X_Map_Raised (Dpy, W);
X_Select_Input
(Dpy, W,
(Exposure_Mask | Structure_Notify_Mask |
-- #ifdef DUMB_WM
-- Enter_Window_Mask or Leave_Window_Mask or
-- #endif
Button_Press_Mask | Key_Press_Mask | Visibility_Change_Mask =>
True,
others => False));
Gc := X_Create_Gc (Dpy, W.Drawable, None_X_Gc_Components,
None_X_Gc_Values);
Wgc := X_Create_Gc
(Dpy, W.Drawable, None_X_Gc_Components, None_X_Gc_Values);
X_Set_Foreground (Dpy, Wgc, X_White_Pixel (Dpy, Screen));
Worm := new Worm_Stuff_Array (0 .. Nworms - 1);
for I in Worm'Range loop
Worm (I) := Worm_Init (Xsize, Ysize, Worm_Length);
end loop;
loop
if X_Pending (Dpy) /= 0 or else
Freeze or else
not Is_Visible then
X_Next_Event (Dpy, E);
if E.Kind = Visibility_Notify then
if E.Visibility.State = Visibility_Fully_Obscured then
Is_Visible := False;
else
Is_Visible := True;
end if;
elsif E.Kind = Button_Press then
if E.Button.Button = Button_2 then
return;
end if;
elsif E.Kind = Key_Press then
if not X_Is_Modifier_Key
(X_Key_Code_To_Key_Sym (Dpy,
E.Key.Key_Code,
0)) then
Freeze := not Freeze;
end if;
elsif E.Kind = Configure_Notify then
Xsize := S_Long (E.Configure.Width);
Ysize := S_Long (E.Configure.Height);
for I in Worm'Range loop
Free_S_Long_List (Worm (I).X_Circ);
Free_S_Long_List (Worm (I).Y_Circ);
Free_Worm_Stuff (Worm (I));
Worm (I) := Worm_Init (Xsize, Ysize, Worm_Length);
end loop;
X_Clear_Window (Dpy, W);
-- really want to remove all the pending graphics requests - can't figure out
-- how...
-- attempted to use GraphicsExposure, but it put so much crap into the
-- queue that the configure was never found...
X_Flush (Dpy);
elsif E.Kind = Client_Message then
if E.Client.Message_Type = Protocol_Atom and then
X_Client_Message_S_Long (E.Client.Data, 0) =
Kill_Atom.Number then
return;
end if;
elsif E.Kind = Enter_Notify then
X_Install_Colormap (Dpy, Cmap);
elsif E.Kind = Leave_Notify then
X_Uninstall_Colormap (Dpy, Cmap);
-- since visibility notify doesn't allow for
-- the totally obscured -> partially obscured
-- case, we have to depend on exposure instead.
elsif E.Kind = Expose then
Is_Visible := True;
end if;
end if;
if Rotate and then
Is_Color and then
Is_Dynamic then
Do_Rotate_Colors;
end if;
for I in Worm'Range loop
Wcolor := (((I * Ncolors) / Nworms) + Chromo) rem Ncolors;
Worm_Doit (Worm (I), Xsize, Ysize, Colors (Wcolor).Pixel);
end loop;
-- note that there is a little jump in the worms
-- if they are frozen and no rotation exists.
-- doesn't seem to be possible to (easily) get away
-- from this
if Chromo_Color then
if Chromo = S_Long'Last then
Chromo := 0;
else
Chromo := Chromo + 1;
end if;
end if;
end loop;
end Main;
--\f
begin
declare
Clk : Calendar.Day_Duration := Calendar.Seconds (Calendar.Clock);
I : Natural;
begin
I := Natural (Clk / Duration (100.0));
Clk := Calendar.Day_Duration
(Clk - Duration (Duration (I) * Duration (100.00)));
----Clk is now in the 0..99.9999 range.
Ran_Data := Ran1_Initialize (S_Natural
(Clk * Duration (Natural'Last / 101)));
end;
end Worm_Main;