|
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: 43935 (0xab9f)
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 Ico_Objcube;
use Ico_Objcube;
with Ico_Objico;
use Ico_Objico;
with Ico_Objtetra;
use Ico_Objtetra;
with Ico_Polyinfo;
use Ico_Polyinfo;
with Ran1_Package;
use Ran1_Package;
with Trig;
with Xlbt_Arithmetic;
use Xlbt_Arithmetic;
with Xlbt_Atom_Defs;
use Xlbt_Atom_Defs;
with Xlbt_Basic;
use Xlbt_Basic;
with Xlbt_Color;
use Xlbt_Color;
with Xlbt_Event;
use Xlbt_Event;
with Xlbt_Gc;
use Xlbt_Gc;
with Xlbt_Geometry;
use Xlbt_Geometry;
with Xlbt_Graphics;
use Xlbt_Graphics;
with Xlbt_Pointer;
use Xlbt_Pointer;
with Xlbt_String;
use Xlbt_String;
with Xlbt_Window;
use Xlbt_Window;
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_Sync;
use Xlbp_Sync;
with Xlbp_Window;
use Xlbp_Window;
with Xlbp_Window_Information;
use Xlbp_Window_Information;
with Xlbp_Window_Property;
use Xlbp_Window_Property;
package body Ico_Main is
------------------------------------------------------------------------------
-- Derived from: ico.c
------------------------------------------------------------------------------
-- $Header: ico.c,v 1.4 88/02/09 13:15:08 jim Exp $
------------------------------------------------------------------------------
-- Copyright 1987 by Digital Equipment Corporation, Maynard, Massachusetts,
-- and the 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 appear in all copies and that
-- both that copyright notice and this permission notice appear in
-- supporting documentation, and that the names of Digital or MIT not be
-- used in advertising or publicity pertaining to distribution of the
-- software without specific, written prior permission.
--
-- DIGITAL DISCLAIMS ALL WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING
-- ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, IN NO EVENT SHALL
-- DIGITAL 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.
--
------------------------------------------------------------------------------
--
-- Description
-- Display a wire-frame rotating icosahedron, with hidden lines removed
--
-- Arguments:
-- -r display on root window instead of creating a new one
-- =wxh+x+y X geometry for new window (default 600x600 centered)
-- host:display X display on which to run
-- (plus a host of others, try -help)
------------------------------------------------------------------------------
-- Additions by jimmc@sci:
-- faces and colors
-- double buffering on the display
-- additional polyhedra
-- sleep switch
------------------------------------------------------------------------------
Ico_Fatal_Error : exception;
Ran_Data : Ran1_Data;
type Transform_3d is array (0 .. 3, 0 .. 3) of Float;
----Now include all the files which define the actual polyhedra
type Poly_Info_Pointer is access Poly_Info;
type Poly_Info_Array is array (Natural range <>) of Poly_Info_Pointer;
Polys : constant Poly_Info_Array := (1 => new Poly_Info'(Obj_Cube),
2 => new Poly_Info'(Obj_Ico),
3 => new Poly_Info'(Obj_Tetra));
type Xx_Color_List is access X_Color_Array;
type Xx_Pixel_List is access X_Pixel_Array;
type Xx_Plane_Mask_List is access X_Plane_Mask_Array;
type Xx_String_Pointer_List is access X_String_Pointer_Array;
type Dbuf_Info is
record
Prev_X : S_Short;
Prev_Y : S_Short;
Plane_Masks : S_Natural; -- points into dbpain.plane_masks
En_Plane_Mask : X_Plane_Mask; -- what we enable for drawing
Colors : Xx_Color_List; -- size = 2 ** totalplanes
Pixels : Xx_Pixel_List; -- size = 2 ** planesperbuf
end record;
type Dbuf_Info_Array is array (S_Natural range <>) of Dbuf_Info;
type Dbuf_Pair is
record
Planes_Per_Buf : S_Natural;
Pixels_Per_Buf : S_Natural; -- = 1<<planesperbuf
Total_Planes : S_Natural; -- = 2*planesperbuf
Total_Pixels : S_Natural; -- = 1<<totalplanes
Plane_Masks : Xx_Plane_Mask_List; -- size = totalplanes
Pixels : X_Pixel_Array (0 .. 0);
Dbuf_Num : S_Natural;
Bufs : Dbuf_Info_Array (0 .. 1);
Draw_Buf : S_Natural;
Dpy_Buf : S_Natural;
end record;
Dbpair : Dbuf_Pair;
type S_Char_Array_2d is
array (S_Natural range <>, S_Natural range <>) of S_Char;
Drawn : S_Char_Array_2d (0 .. Max_Nv - 1, 0 .. Max_Nv - 1);
Zero : constant S_Char_Array_2d (0 .. Max_Nv - 1, 0 .. Max_Nv - 1) :=
(others => (others => 0));
Bg_Color : X_Color;
Fg_Color : X_Color;
Dpy : X_Display;
Win : X_Window;
Win_Width : U_Short;
Win_Height : U_Short;
Cmap : X_Colormap;
Gc : X_Gc;
Initialized : Boolean := False;
Dsync : Boolean := False;-- call X_Sync to keep things debuggable
Dblbuf : Boolean := False;-- do double buffering
Sleepcount : Duration; -- how long to sleep between draws
Isleepcount : Duration := 5.0; -- heuristic sleep period
Numcolors : S_Natural := 0; -- Number of colors user asked for
Colornames : Xx_String_Pointer_List;
Dofaces : Boolean := False;-- draw faces on screen?
Doedges : Boolean := True; -- draw edges on screen?
Xform : Transform_3d;
Xv : Point_3d_Array_2d;
Buffer : Boolean;
Wo2 : Float;
Ho2 : Float;
--\f
------------------------------------------------------------------------------
-- Forward Declarations
------------------------------------------------------------------------------
procedure Concat_Mat (L : Transform_3d;
R : Transform_3d;
M : in out Transform_3d);
procedure Draw_Poly (Poly : Poly_Info_Pointer;
Win : X_Window;
Gc : X_Gc;
Icox : S_Short;
Icoy : S_Short;
Icow : U_Short;
Icoh : U_Short;
Prevx : S_Short;
Prevy : S_Short);
function Find_Poly (Name : String) return Poly_Info_Pointer;
procedure Format_Rotate_Mat (Axis : Character;
Angle : Float;
M : in out Transform_3d);
procedure Give_Obj_Help;
procedure Ico_Fatal (Fmt : String);
procedure Ident_Mat (M : in out Transform_3d);
procedure Init_Dbufs (Fg : X_Pixel;
Bg : X_Pixel;
Planes_Per_Buf : Natural);
procedure Partial_Non_Hom_Transform (N : S_Natural;
M : Transform_3d;
Inn : Point_3d_Array;
Outt : in out Point_3d_Array);
procedure Set_Buf_Color (N : S_Natural; -- color index
Color : X_Color); -- color to set
procedure Set_Buf_Colname (N : S_Natural;
Colname : X_String);
procedure Set_Display_Buf (N : S_Natural);
procedure Set_Draw_Buf (N : S_Natural);
-- static char *help_message() = {
-- "where options include:",
-- " -display host:dpy X server to use",
-- " -geometry geom geometry of window to use",
-- " -r draw in the root window",
-- " -d number dashed line pattern for wire frames",
-- " -colors color ... codes to use on sides",
-- " -dbl use double buffering",
-- " -noedges don't draw wire frame edges",
-- " -faces draw faces",
-- " -i invert",
-- " -sleep number seconds to sleep in between draws",
-- " -obj objname type of polyhedral object to draw",
-- " -objhelp list polyhedral objects available",
-- NULL};
--\f
-- /******************************************************************************
-- * Description
-- * Main routine. Process command-line arguments, then bounce a bounding
-- * box inside the window. Call DrawIco() to redraw the icosahedron.
-- *****************************************************************************/
procedure Main
(Display : X_String := ""; -- host:display
Object : String := "ICO"; -- object to draw
Edges : Boolean := True; -- draw obj edges
Faces : Boolean := False; -- draw obj faces
Geometry : X_String := ""; -- geometry to use
Invert : Boolean := False; -- invert video
Colors : X_String := ""; -- "red,blue,green"
Dashes : S_Natural := 0; -- dash geometry
Sleep : Duration := 0.0; -- pause between draws
Double_Buffer : Boolean := False; -- double buffer
Use_Root : Boolean := False; -- draw upon root
Help_Printout : Boolean := False) is -- print obj names
Fg : X_Pixel;
Bg : X_Pixel;
Winx : S_Short;
Winy : S_Short;
Winw : U_Short;
Winh : U_Short;
Xswa : X_Set_Window_Attributes;
Xwa : X_Window_Attributes;
Poly : Poly_Info_Pointer; -- the poly to draw
Icox : S_Short;
Icoy : S_Short;
Icodeltax : S_Short;
Icodeltay : S_Short;
Icow : U_Short;
Icoh : U_Short;
Xev : X_Event;
Xgcv : X_Gc_Values;
Error : X_Error_String;
Succ : X_Status;
Env : constant X_String := X_Display_Name (Display);
begin
----Process arguments:
declare
K : S_Natural;
begin
Numcolors := 0;
for I in Colors'Range loop
if Colors (I) = ',' then
Numcolors := Numcolors + 1;
end if;
end loop;
if Colors'Length > 0 then
Colornames := new X_String_Pointer_Array (0 .. Numcolors);
Numcolors := 0;
K := Colors'First;
for I in Colors'Range loop
if Colors (I) = ',' then
Colornames (Numcolors) :=
new X_String'(Colors (K .. I - 1));
K := I + 1;
Numcolors := Numcolors + 1;
elsif I = Colors'Last then
Colornames (Numcolors) := new
X_String'(Colors (K .. I));
Numcolors := Numcolors + 1;
end if;
end loop;
end if;
end;
Dblbuf := Double_Buffer;
Doedges := Edges;
Dofaces := Faces;
Sleepcount := Sleep;
Poly := Find_Poly (Object);
if Help_Printout then
Give_Obj_Help;
return;
end if;
if not Dofaces and then not Doedges then
Ico_Fatal ("nothing to draw");
end if;
X_Open_Display (Env, Dpy, Error);
if "=" (Dpy, None_X_Display) then
Ico_Fatal ("Cannot open display:" & To_String (Err (Error)));
end if;
if Invert then
Fg := X_Black_Pixel (Dpy, X_Default_Screen (Dpy));
Bg := X_White_Pixel (Dpy, X_Default_Screen (Dpy));
else
Fg := X_White_Pixel (Dpy, X_Default_Screen (Dpy));
Bg := X_Black_Pixel (Dpy, X_Default_Screen (Dpy));
end if;
----Set up window parameters, create and map window if necessary:
if Use_Root then
Win := X_Default_Root_Window (Dpy);
Winx := 0;
Winy := 0;
Winw := X_Display_Width (Dpy, X_Default_Screen (Dpy));
Winh := X_Display_Height (Dpy, X_Default_Screen (Dpy));
else
Winw := 700;
Winh := 500;
Winx :=
S_Short (X_Display_Width (Dpy, X_Default_Screen (Dpy)) - Winw) /
2;
Winy :=
S_Short (X_Display_Height (Dpy, X_Default_Screen (Dpy)) - Winh) /
2;
if Geometry /= "" then
declare
Flags : X_Parse_Geometry_Flags;
begin
X_Parse_Geometry (Geometry, Winx, Winy, Winw, Winh, Flags);
if Flags (X_Negative) then
Winx :=
S_Short
(X_Display_Width (Dpy, X_Default_Screen (Dpy))) -
Winx - S_Short (Winw);
end if;
if Flags (Y_Negative) then
Winy :=
S_Short
(X_Display_Height (Dpy, X_Default_Screen (Dpy))) -
Winy - S_Short (Winh);
end if;
end;
end if;
Xswa.Event_Mask := X_Event_Mask'
(Button_Press_Mask => True, others => False);
Xswa.Background_Pixel := Bg;
Xswa.Border_Pixel := Fg;
Win := X_Create_Window
(Dpy,
X_Default_Root_Window (Dpy),
Winx,
Winy,
Winw,
Winh,
0,
X_Default_Depth (Dpy, X_Default_Screen (Dpy)),
Input_Output,
X_Default_Visual (Dpy, X_Default_Screen (Dpy)),
(Cw_Event_Mask | Cw_Back_Pixel | Cw_Border_Pixel => True,
others => False),
Xswa);
X_Set_Text_Property (Dpy, Win, "Ico", Xa_Wm_Name);
X_Map_Window (Dpy, Win);
X_Get_Window_Attributes (Dpy, Win, Xwa, Succ);
if Succ = Failed then
Ico_Fatal ("cant get window attributes (size)");
end if;
Win_Width := Xwa.Width;
Win_Height := Xwa.Height;
end if;
----Set up a graphics context:
Gc := X_Create_Gc (Dpy, Win.Drawable, None_X_Gc_Components,
None_X_Gc_Values);
X_Set_Foreground (Dpy, Gc, Fg);
X_Set_Background (Dpy, Gc, Bg);
if Dashes /= 0 then
Xgcv.Line_Style := Line_Double_Dash;
Xgcv.Dashes := U_Char (Dashes);
X_Change_Gc
(Dpy,
Gc,
(Gc_Line_Style | Gc_Dash_List => True, others => False),
Xgcv);
end if;
if Dofaces and then Numcolors >= 1 then
declare
T : S_Natural;
Bits : Natural;
begin
Bits := 0;
T := Numcolors;
while T /= 0 loop
Bits := Bits + 1;
T := T / 2;
end loop;
Init_Dbufs (Fg, Bg, Bits);
end;
-- don't set the background color
for I in Colornames'Range loop
Set_Buf_Colname (I + 1, Colornames (I).all);
end loop;
if Dblbuf then -- insert new colors
Set_Display_Buf (1);
else
Set_Display_Buf (0);
end if;
elsif Dblbuf or else Dofaces then
Init_Dbufs (Fg, Bg, 1);
end if;
if Numcolors = 0 then
Numcolors := 1;
end if;
if Dsync then
X_Sync (Dpy, False);
end if;
----Get the initial position, size, and speed of the bounding-box:
Icow := 150;
Icoh := 150;
-- srandom((int) time(0) % 231);
-- icoX := ((winW - icoW) * (random() and 0xFF)) >> 8;
-- icoY := ((winH - icoH) * (random() and 0xFF)) >> 8;
Icox := S_Short ((S_Long (Winw - Icow) *
S_Long (255.0 * Ran1 (Ran_Data))) / 256);
Icoy := S_Short ((S_Long (Winh - Icoh) *
S_Long (255.0 * Ran1 (Ran_Data))) / 256);
Icodeltax := 13;
Icodeltay := 9;
----Bounce the box in the window:
declare
Prevx : S_Short;
Prevy : S_Short;
begin
loop
if X_Pending (Dpy) /= 0 then
X_Next_Event (Dpy, Xev);
if "=" (Xev.Kind, Button_Press) and then
"=" (Xev.Button.Button, Button_2) then
exit;
end if;
end if;
Prevx := Icox;
Prevy := Icoy;
Icox := Icox + Icodeltax;
if Icox < 0 or else U_Short (Icox) + Icow > Winw then
Icox := Icox - (Icodeltax * 2);
Icodeltax := -Icodeltax;
end if;
Icoy := Icoy + Icodeltay;
if Icoy < 0 or else U_Short (Icoy) + Icoh > Winh then
Icoy := Icoy - (Icodeltay * 2);
Icodeltay := -Icodeltay;
end if;
Draw_Poly (Poly, Win, Gc, Icox, Icoy, Icow, Icoh, Prevx, Prevy);
end loop;
X_Close_Display (Dpy);
end;
exception
when Ico_Fatal_Error =>
null;
end Main;
--\f
function Tl (S : String; L : Natural) return String is
R : String (1 .. L) := (others => ' ');
begin
if S'Length < L then
R (1 .. S'Length) := S;
else
R := S (S'First .. S'First - 1 + L);
end if;
return R;
end Tl;
--\f
procedure Give_Obj_Help is
begin
Text_Io.Put_Line
("Name Short Name #Vert. #Edges #Faces Dual");
for I in Polys'Range loop
Text_Io.Put (Tl (Polys (I).Long_Name.all, 16));
Text_Io.Put (Tl (Polys (I).Short_Name.all, 12));
S_Long_Io.Put (S_Long (Polys (I).Num_Verts), 6);
S_Long_Io.Put (S_Long (Polys (I).Num_Edges), 8);
S_Long_Io.Put (S_Long (Polys (I).Num_Faces), 8);
Text_Io.Put_Line (Polys (I).Dual.all);
end loop;
end Give_Obj_Help;
--\f
function Find_Poly (Name : String) return Poly_Info_Pointer is
function Equal (A, B : String) return Boolean is
Ac : Character;
Bc : Character;
begin
if A'Length /= B'Length then
return False;
end if;
for I in Natural range 0 .. A'Length - 1 loop
Ac := A (A'First + I);
Bc := B (B'First + I);
if Ac /= Bc then
if Ac in 'a' .. 'z' then
Ac := Character'Val (Character'Pos (Ac) -
(Character'Pos ('a') -
Character'Pos ('A')));
end if;
if Bc in 'a' .. 'z' then
Bc := Character'Val (Character'Pos (Bc) -
(Character'Pos ('a') -
Character'Pos ('A')));
end if;
if Ac /= Bc then
return False;
end if;
end if;
end loop;
return True;
end Equal;
begin
for I in Polys'Range loop
if Equal (Polys (I).Long_Name.all,
Name) or else
Equal (Polys (I).Short_Name.all,
Name) then
return Polys (I);
end if;
end loop;
Ico_Fatal ("can't find object " & Name);
end Find_Poly;
--\f
procedure Ico_Clear_Area (X : S_Short;
Y : S_Short;
W : U_Short;
H : U_Short) is
begin
if Dblbuf or else Dofaces then
X_Set_Foreground (Dpy, Gc,
Dbpair.Bufs (Dbpair.Draw_Buf).Pixels (0));
-- use background as foreground color for fill
X_Fill_Rectangle (Dpy, Win.Drawable, Gc, X, Y, W, H);
else
X_Clear_Area (Dpy, Win, X, Y, W, H, False);
end if;
end Ico_Clear_Area;
--\f
------------------------------------------------------------------------------
-- Description
-- Undraw previous polyhedron (by erasing its bounding box).
-- Rotate and draw the new polyhedron.
--
-- Input
-- poly the polyhedron to draw
-- win window on which to draw
-- gc X11 graphics context to be used for drawing
-- icoX, icoY position of upper left of bounding-box
-- icoW, icoH size of bounding-box
-- prevX, prevY position of previous bounding-box
------------------------------------------------------------------------------
procedure Draw_Poly (Poly : Poly_Info_Pointer;
Win : X_Window;
Gc : X_Gc;
Icox : S_Short;
Icoy : S_Short;
Icow : U_Short;
Icoh : U_Short;
Prevx : S_Short;
Prevy : S_Short) is
V : Point_3d_List := Poly.V;
Nv : S_Natural := Poly.Num_Verts;
F : S_Natural_List := Poly.F;
Nf : S_Natural := Poly.Num_Faces;
P0 : S_Natural;
P1 : S_Natural;
Pv2 : S_Natural;
Pe : S_Natural;
Pxv : S_Natural;
V2 : X_Point_Array (0 .. Max_Nv - 1);
Edges : X_Segment_Array (0 .. Max_Edges - 1);
Pf : S_Natural;
Facecolor : S_Natural;
K : S_Natural;
Pcount : S_Natural;
Pxvz : Float;
Ppts : X_Point_Array (0 .. Max_Edges_Per_Poly - 1);
begin
----Set up points, transforms, etc.:
if not Initialized then
declare
R1 : Transform_3d;
R2 : Transform_3d;
begin
Format_Rotate_Mat ('x', 5.0 * 3.1416 / 180.0, R1);
Format_Rotate_Mat ('y', 5.0 * 3.1416 / 180.0, R2);
Concat_Mat (R1, R2, Xform);
Xv (False) (0 .. Nv - 1) := V.all;
Buffer := False;
Wo2 := Float (Icow) / 2.0;
Ho2 := Float (Icoh) / 2.0;
Initialized := True;
end;
end if;
----Switch double-buffer and rotate vertices:
Buffer := not Buffer;
Partial_Non_Hom_Transform (Nv, Xform, Xv (not Buffer), Xv (Buffer));
----Convert 3D coordinates to 2D window coordinates:
Pxv := Xv (Buffer)'First;
Pv2 := V2'First;
for I in reverse 0 .. Nv - 1 loop
V2 (Pv2).X := S_Short ((Xv (Buffer) (Pxv).X + 1.0) * Wo2) + Icox;
V2 (Pv2).Y := S_Short ((Xv (Buffer) (Pxv).Y + 1.0) * Ho2) + Icoy;
Pxv := Pxv + 1;
Pv2 := Pv2 + 1;
end loop;
----Accumulate edges to be drawn, eliminating duplicates for speed:
Pxv := Xv (Buffer)'First;
Pv2 := V2'First;
Pf := F'First;
Pe := Edges'First;
--geb This is unbelieveably slow. R1000 compiler is stupid. Drawn := (others => (others => 0));
Drawn := Zero;
if Dblbuf then
Set_Draw_Buf (Dbpair.Dbuf_Num);
-- switch drawing buffers if double buffered
end if;
if Dofaces then -- for faces, need to clear before FillPoly
if Dblbuf then
Ico_Clear_Area (Dbpair.Bufs (Dbpair.Draw_Buf).Prev_X,
Dbpair.Bufs (Dbpair.Draw_Buf).Prev_Y,
Icow + 1,
Icoh + 1);
end if;
Ico_Clear_Area (Prevx, Prevy, Icow + 1, Icoh + 1);
end if;
if Dsync then
X_Sync (Dpy, False);
end if;
for I in reverse 0 .. Nf - 1 loop
Pcount := F (Pf); -- number of edges for this face
Pf := Pf + 1;
Pxvz := 0.0;
for J in 0 .. Pcount - 1 loop
P0 := F (Pf + J);
Pxvz := Pxvz + Xv (Buffer) (Pxv + P0).Z;
end loop;
-- If facet faces away from viewer, don't consider it:
if Pxvz < 0.0 then
goto Continue;
end if;
if Dofaces then
if Numcolors /= 0 then
Facecolor := I rem Numcolors + 1;
else
Facecolor := 1;
end if;
X_Set_Foreground
(Dpy, Gc, Dbpair.Bufs (Dbpair.Draw_Buf).Pixels (Facecolor));
for J in 0 .. Pcount - 1 loop
P0 := F (Pf + J);
Ppts (J).X := V2 (Pv2 + P0).X;
Ppts (J).Y := V2 (Pv2 + P0).Y;
end loop;
X_Fill_Polygon (Dpy, Win.Drawable, Gc, Ppts (0 .. Pcount - 1),
Convex, Coord_Mode_Origin);
end if;
if Doedges then
for J in 0 .. Pcount - 1 loop
if J < Pcount - 1 then
K := J + 1;
else
K := 0;
end if;
P0 := F (Pf + J);
P1 := F (Pf + K);
if (Drawn (P0, P1) = 0) then
Drawn (P0, P1) := 1;
Drawn (P1, P0) := 1;
Edges (Pe).X1 := V2 (Pv2 + P0).X;
Edges (Pe).Y1 := V2 (Pv2 + P0).Y;
Edges (Pe).X2 := V2 (Pv2 + P1).X;
Edges (Pe).Y2 := V2 (Pv2 + P1).Y;
Pe := Pe + 1;
end if;
end loop;
end if;
<<Continue>> null;
Pf := Pf + Pcount;
end loop;
----Erase previous, draw current icosahedrons; sync for smoothness.
if Doedges then
if Dofaces then
X_Set_Foreground (Dpy, Gc,
Dbpair.Bufs (Dbpair.Draw_Buf).Pixels (0));
-- use background as foreground color
else
if Dblbuf then
Ico_Clear_Area (Dbpair.Bufs (Dbpair.Draw_Buf).Prev_X,
Dbpair.Bufs (Dbpair.Draw_Buf).Prev_Y,
Icow + 1, Icoh + 1);
end if;
Ico_Clear_Area (Prevx, Prevy, Icow + 1, Icoh + 1);
if Dblbuf or else Dofaces then
X_Set_Foreground (Dpy, Gc,
Dbpair.Bufs (Dbpair.Draw_Buf).Pixels
(Dbpair.Pixels_Per_Buf - 1));
end if;
end if;
X_Draw_Segments (Dpy, Win.Drawable, Gc, Edges (0 .. Pe - 1));
end if;
if Dsync then
X_Sync (Dpy, False);
end if;
if Dblbuf then
Dbpair.Bufs (Dbpair.Draw_Buf).Prev_X := Icox;
Dbpair.Bufs (Dbpair.Draw_Buf).Prev_Y := Icoy;
Set_Display_Buf (Dbpair.Dbuf_Num);
end if;
-- X_Sync (Dpy, False);
if Dblbuf then
Dbpair.Dbuf_Num := 1 - Dbpair.Dbuf_Num;
end if;
if Sleepcount /= 0.0 then
delay Sleepcount;
end if;
end Draw_Poly;
--\f
procedure Init_Dbufs (Fg : X_Pixel;
Bg : X_Pixel;
Planes_Per_Buf : Natural) is
K : S_Natural;
M : S_Natural;
Q : S_Natural;
Succ : X_Status;
begin
Dbpair.Planes_Per_Buf := S_Natural (Planes_Per_Buf);
Dbpair.Pixels_Per_Buf := 2 ** Planes_Per_Buf;
if Dblbuf then
Dbpair.Total_Planes := S_Long (2 * Planes_Per_Buf);
else
Dbpair.Total_Planes := S_Long (Planes_Per_Buf);
end if;
Dbpair.Total_Pixels := 2 ** Natural (Dbpair.Total_Planes);
Dbpair.Plane_Masks :=
new X_Plane_Mask_Array (0 .. Dbpair.Total_Planes - 1);
Dbpair.Dbuf_Num := 0;
if Dblbuf then
Q := 2;
else
Q := 1;
end if;
for I in 0 .. Q - 1 loop
declare
B : Dbuf_Info renames Dbpair.Bufs (I);
begin
B.Plane_Masks := Dbpair.Plane_Masks'First +
(I * S_Long (Planes_Per_Buf));
B.Colors := new X_Color_Array (0 .. Dbpair.Total_Pixels - 1);
B.Pixels := new X_Pixel_Array (0 .. Dbpair.Pixels_Per_Buf - 1);
end;
end loop;
Cmap := X_Default_Colormap (Dpy, X_Default_Screen (Dpy));
if "=" (Cmap, None_X_Colormap) then
Ico_Fatal ("can't get default colormap");
end if;
X_Alloc_Color_Cells (Dpy, Cmap, False, Dbpair.Plane_Masks.all,
Dbpair.Pixels (Dbpair.Pixels'First ..
Dbpair.Pixels'First), Succ);
-- allocate color planes */
if Succ = Failed then
Ico_Fatal ("can't allocate color planes");
end if;
Fg_Color.Pixel := Fg;
Bg_Color.Pixel := Bg;
X_Query_Color (Dpy, Cmap, Fg_Color);
X_Query_Color (Dpy, Cmap, Bg_Color);
Set_Buf_Color (0, Bg_Color);
Set_Buf_Color (1, Fg_Color);
for I in 0 .. Q - 1 loop
declare
B : Dbuf_Info renames Dbpair.Bufs (I);
J : S_Natural;
Jj : S_Natural;
begin
--if dblbuf then
-- otherb := dbpair.bufs+(1-i);
--end if;
if Dblbuf then
Q := Dbpair.Pixels_Per_Buf;
else
Q := 1;
end if;
for J0 in 0 .. Q - 1 loop
for J1 in 0 .. Dbpair.Pixels_Per_Buf - 1 loop
J := S_Natural (J0 *
2 ** Natural (Dbpair.Planes_Per_Buf)) or
S_Natural (J1);
if I = 0 then
Jj := J;
else
Jj := S_Natural
(J1 * 2 ** Natural
(Dbpair.Planes_Per_Buf)) or
S_Natural (J0);
end if;
B.Colors (Jj).Pixel := Dbpair.Pixels (0);
K := 0;
M := J;
while M /= 0 loop
if M rem 2 /= 0 then
B.Colors (Jj).Pixel :=
"or" (B.Colors (Jj).Pixel,
X_Pixel (Dbpair.Plane_Masks (K)));
end if;
K := K + 1;
M := M / 2;
end loop;
B.Colors (Jj).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
end loop;
end loop;
B.Prev_X := 0;
B.Prev_Y := 0;
B.En_Plane_Mask := 0;
for J in 0 .. Planes_Per_Buf - 1 loop
B.En_Plane_Mask :=
"or" (B.En_Plane_Mask,
Dbpair.Plane_Masks (B.Plane_Masks + S_Long (J)));
end loop;
for J in 0 .. Dbpair.Pixels_Per_Buf - 1 loop
B.Pixels (J) := Dbpair.Pixels (0);
K := 0;
M := J;
while M /= 0 loop
if M rem 2 /= 0 then
B.Pixels (J) :=
"or" (B.Pixels (J),
X_Pixel (Dbpair.Plane_Masks
(B.Plane_Masks + K)));
end if;
K := K + 1;
M := M / 2;
end loop;
end loop;
end;
end loop;
Set_Draw_Buf (0);
X_Set_Background (Dpy, Gc, Dbpair.Bufs (0).Pixels (0));
X_Set_Plane_Mask (Dpy, Gc, All_Planes);
Ico_Clear_Area (0, 0, Win_Width, Win_Height); -- clear entire window
delay Isleepcount; -- geb? /*** doesn't work without this!!! */
X_Sync (Dpy, False);
if Dblbuf then
Set_Display_Buf (1);
else
Set_Display_Buf (0);
end if;
end Init_Dbufs;
--\f
procedure Set_Buf_Colname (N : S_Natural;
Colname : X_String) is
Succ : X_Status;
Dcolor : X_Color;
Color : X_Color;
begin
X_Lookup_Color (Dpy, Cmap, Colname, Dcolor, Color, Succ);
if Succ = Failed then -- no such color
Ico_Fatal ("no such color " & To_String (Colname));
end if;
Set_Buf_Color (N, Color);
end Set_Buf_Colname;
--\f
procedure Set_Buf_Color (N : S_Natural; -- color index
Color : X_Color) is -- color to set
Cx : S_Natural;
Pix : X_Pixel;
Q : S_Natural;
begin
if Dblbuf then
Q := 2;
else
Q := 1;
end if;
for I in 0 .. Q - 1 loop
declare
B : Dbuf_Info renames Dbpair.Bufs (I);
begin
if Dblbuf then
Q := Dbpair.Pixels_Per_Buf;
else
Q := 1;
end if;
for J in 0 .. Q - 1 loop
Cx := N + J * Dbpair.Pixels_Per_Buf;
Pix := B.Colors (Cx).Pixel;
B.Colors (Cx) := Color;
B.Colors (Cx).Pixel := Pix;
B.Colors (Cx).Flags :=
X_Color_Flags'(Do_Red | Do_Green | Do_Blue => True,
others => False);
end loop;
end;
end loop;
end Set_Buf_Color;
--\f
procedure Set_Draw_Buf (N : S_Natural) is
Xgcv : X_Gc_Values;
Mask : X_Gc_Components;
begin
Dbpair.Draw_Buf := Dbpair.Bufs'First + N;
Xgcv.Plane_Mask := Dbpair.Bufs (Dbpair.Draw_Buf).En_Plane_Mask;
Xgcv.Foreground := Dbpair.Bufs (Dbpair.Draw_Buf).Pixels
(Dbpair.Pixels_Per_Buf - 1);
Xgcv.Background := Dbpair.Bufs (Dbpair.Draw_Buf).Pixels (0);
Mask := X_Gc_Components'
(Gc_Foreground | Gc_Background => True,
others => False);
if Dblbuf then
Mask (Gc_Plane_Mask) := True;
end if;
X_Change_Gc (Dpy, Gc, Mask, Xgcv);
end Set_Draw_Buf;
--\f
procedure Set_Display_Buf (N : S_Natural) is
begin
Dbpair.Dpy_Buf := Dbpair.Bufs'First + N;
X_Store_Colors (Dpy, Cmap, Dbpair.Bufs (Dbpair.Dpy_Buf).Colors.all);
end Set_Display_Buf;
--\f
procedure Ico_Fatal (Fmt : String) is
begin
Text_Io.Put_Line ("ico: " & Fmt);
raise Ico_Fatal_Error;
end Ico_Fatal;
--\f
------------------------------------------------------------------------------
-- Description
-- Concatenate two 4-by-4 transformation matrices.
--
-- Input
-- l multiplicand (left operand)
-- r multiplier (right operand)
--
-- Output
-- *m Result matrix
------------------------------------------------------------------------------
procedure Concat_Mat (L : Transform_3d;
R : Transform_3d;
M : in out Transform_3d) is
begin
for I in 0 .. 3 loop
for J in 0 .. 3 loop
M (I, J) := L (I, 0) * R (0, J)
+ L (I, 1) * R (1, J)
+ L (I, 2) * R (2, J)
+ L (I, 3) * R (3, J);
end loop;
end loop;
end Concat_Mat;
--\f
------------------------------------------------------------------------------
-- Description
-- Format a matrix that will perform a rotation transformation
-- about the specified axis. The rotation angle is measured
-- counterclockwise about the specified axis when looking
-- at the origin from the positive axis.
--
-- Input
-- axis Axis ('x', 'y', 'z') about which to perform rotation
-- angle Angle (in radians) of rotation
-- A Pointer to rotation matrix
--
-- Output
-- *m Formatted rotation matrix
------------------------------------------------------------------------------
procedure Format_Rotate_Mat (Axis : Character;
Angle : Float;
M : in out Transform_3d) is
S : Float;
C : Float;
begin
Ident_Mat (M);
S := Trig.Sin (Angle);
C := Trig.Cos (Angle);
case Axis is
when 'x' =>
M (1, 1) := C;
M (2, 2) := C;
M (1, 2) := S;
M (2, 1) := -S;
when 'y' =>
M (0, 0) := C;
M (2, 2) := C;
M (2, 0) := S;
M (0, 2) := -S;
when 'z' =>
M (0, 0) := C;
M (1, 1) := C;
M (0, 1) := S;
M (1, 0) := -S;
when others =>
raise Program_Error;
end case;
end Format_Rotate_Mat;
--\f
------------------------------------------------------------------------------
-- Description
-- Format a 4x4 identity matrix.
--
-- Output
-- *m Formatted identity matrix
------------------------------------------------------------------------------
procedure Ident_Mat (M : in out Transform_3d) is
begin
for I in reverse 0 .. 3 loop
for J in reverse 0 .. 3 loop
M (I, J) := 0.0;
end loop;
M (I, I) := 1.0;
end loop;
end Ident_Mat;
--\f
------------------------------------------------------------------------------
-- Description
-- Perform a partial transform on non-homogeneous points.
-- Given an array of non-homogeneous (3-coordinate) input points,
-- this routine multiplies them by the 3-by-3 upper left submatrix
-- of a standard 4-by-4 transform matrix. The resulting non-homogeneous
-- points are returned.
--
-- Input
-- n number of points to transform
-- m 4-by-4 transform matrix
-- in array of non-homogeneous input points
--
-- Output
-- *out array of transformed non-homogeneous output points
------------------------------------------------------------------------------
procedure Partial_Non_Hom_Transform (N : S_Natural;
M : Transform_3d;
Inn : Point_3d_Array;
Outt : in out Point_3d_Array) is
Ini : S_Natural := Inn'First;
Outi : S_Natural := Outt'First;
begin
for I in 1 .. N loop
Outt (Outi).X := Inn (Ini).X * M (0, 0)
+ Inn (Ini).Y * M (1, 0)
+ Inn (Ini).Z * M (2, 0);
Outt (Outi).Y := Inn (Ini).X * M (0, 1)
+ Inn (Ini).Y * M (1, 1)
+ Inn (Ini).Z * M (2, 1);
Outt (Outi).Z := Inn (Ini).X * M (0, 2)
+ Inn (Ini).Y * M (1, 2)
+ Inn (Ini).Z * M (2, 2);
Ini := Ini + 1;
Outi := Outi + 1;
end loop;
end Partial_Non_Hom_Transform;
--\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 (Float (Clk) * Float (Natural'Last / 101)));
end;
end Ico_Main;