doc@s.cc.purdue.edu (Craig Norborg) (06/15/87)
Here is part 1 of 2 to Gravity Wars. A game written in Modula 2 by
Ed Bartz. Note that the sources arrangement is somewhat different than
mentioned in his ReadMe file, since I found it much better to pack it
this way. So, definition modules are mixed in with implementation
modules... Binaries will be coming in comp.binaries.amiga
Enjoy!
Craig Norborg
comp.sources.amiga moderator
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
#----cut here-----cut here-----cut here-----cut here----#
#!/bin/sh
# Xshar: Extended Shell Archiver.
# This is part 1 out of 2.
# Run the following text with /bin/sh to create:
# ReadMe
# console.def
# gw.def
# gw.mod
# mywindow.def
# mywindow.mod
# options.def
# This archive created: Fri Jun 12 13:56:35 1987
# By: Craig Norborg (Purdue University Computing Center)
cat << \SHAR_EOF > ReadMe
This posting contains the sources for GravityWars version 1.04.
Since I recieved many requests for them ( 4 or 5) I finally got around to
posting them. The program is written in Tdi Modula 2. File one contains the
Definition modules and file two (which is itself in two parts for mailing
purposes) contains the implementation modules.
These sources are kind of messy I know, I don't have the time
now to give them the reWrite and comments they require but I hope
they are of some use to you.
Also the title screen stuff has been removed. That stuff is a
modified version of the showILBM program that came as an example from TDI.
Although in a phone call to TDI I was told it was Ok to use the program
under certain conditions I was still uncomfortable about it. So to avoid
any problems I removed it from the sources.
Also these sources are NOT public domain. They are to serve only
as an example for programers (probably a bad one). They may be distributed
provided that no charge other than a small copying fee is imposed, and that
all copyright notices remain intact including this message. While
modifications are permitted, any changes must be noted as such in the sources,
and the sources must accompany any excutable made from them if redistributed.
(In otherwords don't mess with the code and give it to some poor fool who'll
yell at me if it don't work.)
SHAR_EOF
cat << \SHAR_EOF > console.def
DEFINITION MODULE Console;
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM Ports IMPORT MsgPortPtr;
FROM Intuition IMPORT WindowPtr;
FROM IO IMPORT IOStdReqPtr;
TYPE
Conport = RECORD
IO : IOStdReqPtr;
msg : MsgPortPtr;
buf : ARRAY [0..80] OF CHAR;
END;
PROCEDURE QueueRead(VAR Rport: Conport);
(* queue up a read request to a console, show where to
* put the character when ready to be returned. Most
* efficient if this is called right after console is
* opened *)
PROCEDURE OpenWRConsole(VAR Wport, Rport: Conport; w : WindowPtr):BOOLEAN;
(* Open a console device *)
PROCEDURE OpenWConsole(VAR Wport: Conport; w : WindowPtr):BOOLEAN;
(* Open a console device *)
PROCEDURE OpenRConsole(VAR Rport: Conport; w : WindowPtr):BOOLEAN;
(* Open a console device *)
PROCEDURE CloseWRConsole(Wport, Rport: Conport);
(* Close a console device *)
PROCEDURE CloseWConsole(Wport : Conport);
(* Close a console device *)
PROCEDURE CloseRConsole(Rport: Conport);
(* Close a console device *)
PROCEDURE PutChar(Wport: Conport; c: CHAR);
(* Output a single character to a specified console *)
PROCEDURE Writestr(Wport: Conport; VAR s: ARRAY OF CHAR; len: LONGINT);
(* Output a stream of known length to a console *)
PROCEDURE PutStr(Wport: Conport; VAR s: ARRAY OF CHAR);
(* Output a NULL-terminated string of characters to a console *)
PROCEDURE MayGetChar(VAR Rport: Conport; VAR c: CHAR): BOOLEAN;
(* see if there is a character to read. If none, don't wait,
* come back with a value of FALSE *)
PROCEDURE GetChar(VAR Rport: Conport; VAR c: CHAR);
(* go and get a character; put the task to sleep if
* there isn't one present *)
PROCEDURE GetStr(VAR Rport, Wport: Conport; VAR s: ARRAY OF CHAR): BOOLEAN;
(* get string from console device *)
END Console.
SHAR_EOF
cat << \SHAR_EOF > gw.def
DEFINITION MODULE GW;
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/14/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM Intuition IMPORT WindowPtr;
TYPE
Pl = RECORD
x,y,r :INTEGER;
color :CARDINAL;
m :REAL;
END;
Mdata = RECORD
P1ang,P1vel,P2ang,P2vel :REAL;
END;
Shell = RECORD
vx,vy: REAL;
x,y : INTEGER;
END;
String = ARRAY [0..80] OF CHAR;
PROCEDURE DrawPlanet(x,y,r:INTEGER;color,ptype:CARDINAL;wp:WindowPtr);
PROCEDURE Distance(A,B :Pl): INTEGER;
PROCEDURE Pposition (VAR PlanetPos: ARRAY OF Pl;Pnum,ptype: CARDINAL; w: WindowPtr);
PROCEDURE Sposition(w: WindowPtr;VAR Ship,PPos: ARRAY OF Pl;Pnum: CARDINAL);
PROCEDURE Stars(wp: WindowPtr);
PROCEDURE Sexplosion(mis:Shell;wp: WindowPtr);
PROCEDURE Pexplosion(mis:Shell;wp: WindowPtr);
PROCEDURE DrawLine (x1,y1,x2,y2,c : CARDINAL; wp : WindowPtr);
PROCEDURE DrawShip(x1,y1,x2,y2 : CARDINAL; wp : WindowPtr);
END GW.
SHAR_EOF
cat << \SHAR_EOF > gw.mod
IMPLEMENTATION MODULE GW;
(*+,+*)
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM SYSTEM IMPORT ADR, BYTE, ADDRESS, NULL, WORD;
FROM Areas IMPORT AreaInfo, AreaInfoPtr, AreaEllipse, AreaEnd, InitArea;
FROM Intuition IMPORT
IntuitionName, IntuitionBase, Window, WindowFlags, NewWindow,
MenuPick, IDCMPFlagSet, WindowFlagSet, WindowPtr, ScreenPtr, Screen,
MenuEnabled, MenuFlagSet, Menu, MenuItem, IntuitionText, ActiveWindow,
ItemFlagSet, ItemText, ItemEnabled, IntuiMessagePtr, CustomScreen ;
FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase, Jam2, Jam1,
DrawingModeSet, BitMapPtr, BitMap, PlanePtr;
FROM Windows IMPORT OpenWindow, CloseWindow;
FROM Screens IMPORT NewScreen, OpenScreen, CloseScreen, ShowTitle;
FROM RandomNumbers IMPORT Random;
FROM MathLib0 IMPORT arctan,pi,real,entier,sin,cos,DegToRad,sqrt,power;
FROM Rasters IMPORT SetRast, RastPort, RastPortPtr, TmpRas, InitTmpRas,
AllocRaster, FreeRaster;
FROM Views IMPORT ModeSet;
FROM Console IMPORT
OpenWConsole,CloseWConsole,PutChar,PutStr,GetChar,GetStr,Conport;
FROM M2Conversions IMPORT ConvertReal, ConvertToReal;
FROM Pens IMPORT Draw, Move,SetAPen,SetDrMd,ReadPixel,WritePixel;
FROM InOut IMPORT WriteLn,WriteString;
FROM MyWindow IMPORT ReadMenu;
PROCEDURE Min (x,y :INTEGER) :INTEGER;
BEGIN
IF x < y THEN RETURN x;
ELSE RETURN y;
END;
END Min;
(***********************************************************************)
PROCEDURE Max (x,y :INTEGER) :INTEGER;
BEGIN
IF x > y THEN RETURN x;
ELSE RETURN y;
END;
END Max;
(***********************************************************************)
PROCEDURE Sdrwline(x1,x2,y1,y2: INTEGER;color: CARDINAL;wp: WindowPtr);
VAR
i,j,k,l,m : INTEGER;
c1,c2 : CARDINAL;
BEGIN
i:= ABS(y2-y1) DIV 3;
IF i>0 THEN
l:=Min(y1,y2);
j:= i + l;
FOR m:= 0 TO 2 DO
c2:=CARDINAL(j-l);
FOR k:= l TO j DO
c1:= Random(c2);
IF c1<(CARDINAL(k-l)) THEN c1:=1;ELSE c1:=0;END;
SetAPen (wp^.RPort,color+c1);
WritePixel(wp^.RPort,k,x2);
WritePixel(wp^.RPort,k,x1);
END;
l:=j;
j:=j+i;
color:= color+1;
END;
DrawLine(l,x2,Max(y1,y2),x2,color,wp);
DrawLine(l,x1,Max(y1,y2),x1,color,wp);
ELSE
DrawLine(y1,x1,y2,x1,color,wp);
DrawLine(y1,x2,y2,x2,color,wp);
END;
END Sdrwline;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE DrawPlanet(x,y,r:INTEGER;color,ptype: CARDINAL;wp: WindowPtr);
CONST
round = 0.83;
VAR
r1,itr,nx,ny,x1,x2,y1,y2 :INTEGER;
BEGIN
IF color>3 THEN
IF ptype = 1 THEN
r1:=entier(real(r)*round);
itr := r1*r1;
FOR ny := 0 TO r1 DO
nx:=entier(sqrt(real(itr-ny*ny))/round);
x1:= x-nx;
x2:= x+nx;
y1:= y-ny;
y2:= y+ny;
IF x1<0 THEN x1:=0; END;
IF y1<0 THEN y1:=0; END;
IF x2>639 THEN x2:=639; END;
IF y2>399 THEN y2:=399; END;
Sdrwline(y1,y2,x1,x2,color,wp);
END;
ELSE
itr := r*r;
FOR nx := 0 TO r DO
ny:=entier(sqrt(real(itr-nx*nx))*round);
x1:= x-nx;
x2:= x+nx;
y1:= y-ny;
y2:= y+ny;
IF x1<0 THEN x1:=0; END;
IF y1<0 THEN y1:=0; END;
IF x2>639 THEN x2:=639; END;
IF y2>399 THEN y2:=399; END;
DrawLine(x1,y1,x1,y2,color+2,wp);
DrawLine(x2,y1,x2,y2,color+2,wp);
END;
END;
END;
IF color<2 THEN
itr := r*r;
FOR nx := 0 TO r DO
ny:=entier(sqrt(real(itr-nx*nx))*round);
x1:= x-nx;
x2:= x+nx;
y1:= y-ny;
y2:= y+ny;
IF x1<0 THEN x1:=0; END;
IF y1<0 THEN y1:=0; END;
IF x2>639 THEN x2:=639; END;
IF y2>399 THEN y2:=399; END;
DrawLine(x1,y1,x1,y2,0,wp);
DrawLine(x2,y1,x2,y2,0,wp);
END;
END;
END DrawPlanet;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Distance(A,B :Pl):INTEGER;
VAR
i : INTEGER;
m,l,k,n : REAL;
BEGIN
m:=real(ABS(A.x-B.x));
k:=real(ABS(A.y-B.y))/0.83;
IF m <= 0.0 THEN m:=0.01;END;
IF k <= 0.0 THEN k:=0.01;END;
l:=sqrt(m*m+k*k);
i:=ABS(entier(l));
RETURN i;
END Distance;
(*++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Pposition (VAR PlanetPos: ARRAY OF Pl;Pnum,ptype: CARDINAL; w: WindowPtr);
VAR
i,j,k,Stop1,Stop2 :INTEGER;
Ok:BOOLEAN;
r3 : REAL;
density : CARDINAL;
mass : ARRAY [0..2] OF REAL;
BEGIN
mass[0] := 0.020;
mass[1] := 0.025;
mass[2] := 0.030;
Stop1:=0;
Stop2:=0;
i:=0;
WHILE i<INTEGER(Pnum) DO
WITH PlanetPos[i] DO
x := Random(519)+60;
y := Random(299)+50;
r := Random(40)+10;
END;
Ok:= TRUE;
j:=i-1;
WHILE ((j>=0)AND Ok) DO
k:=Distance(PlanetPos[i],PlanetPos[j]);
k:=k-PlanetPos[i].r-PlanetPos[j].r;
IF k<20 THEN
Ok := FALSE;
END;
j:=j-1;
END;
Stop1:= ReadMenu(w);
IF Stop1 = 1 THEN Stop2:= 1; END;
IF Ok THEN
WITH PlanetPos[i] DO
r3:=real(r);
r3:=r3*r3*r3;
density:= Random(3);
color := (density*4)+4;
m := r3* mass[density];
IF Random(50)>47 THEN
color := 0;
m := r3* mass[2];
END;
IF Stop2 = 0 THEN DrawPlanet(x,y,r,color,ptype,w); END;
END;
i:=i+1;
END;
END;
END Pposition;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Sposition(w: WindowPtr;VAR Ship,PPos: ARRAY OF Pl;Pnum: CARDINAL);
VAR
k,m : CARDINAL;
i,j,l : INTEGER;
Ok : BOOLEAN;
BEGIN
FOR k:= 0 TO 1 DO;
Ship[k].r := 18;
REPEAT
m:=k*460+40;
Ship[k].y :=Random(300)+50;
Ship[k].x :=Random(100)+m;
Ok:=TRUE;
i:=0;
WHILE ((i<INTEGER(Pnum))AND Ok) DO
j:=Distance(Ship[k],PPos[i]);
IF j<PPos[i].r+40 THEN
Ok:=FALSE;
END;
i:=i+1;
END;
UNTIL Ok;
END;
DrawShip(Ship[0].x,Ship[0].y,Ship[1].x,Ship[1].y,w);
END Sposition;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Stars(wp: WindowPtr);
VAR
i,x,y,c : CARDINAL;
BEGIN
FOR i:= 0 TO 500 DO
x :=Random(639);
y :=Random(399);
SetAPen(wp^.RPort,1);
WritePixel(wp^.RPort,x,y);
END;
END Stars;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Sexplosion(mis:Shell;wp: WindowPtr);
VAR
i,j,k,x,y,x1,y1 : CARDINAL;
BEGIN
FOR i:=0 TO 50 DO
j:= (i DIV 5)+5;
k:= j * 2;
x:= (CARDINAL(mis.x) - j)+Random(k) ;
y:= (CARDINAL(mis.y) - j)+Random(k) ;
SetAPen(wp^.RPort,2);
WritePixel(wp^.RPort,x,y);
END;
FOR i:=0 TO 500 DO
j:= (i DIV 25)+5;
k:= j * 2;
x:= (CARDINAL(mis.x) - j)+Random(k) ;
y:= (CARDINAL(mis.y) - j)+Random(k) ;
x1:= (CARDINAL(mis.x) - 5)+Random(10) ;
y1:= (CARDINAL(mis.y) - 5)+Random(10) ;
k:= Random(3);
SetAPen(wp^.RPort,0);
WritePixel(wp^.RPort,x1,y1);
SetAPen(wp^.RPort,k);
WritePixel(wp^.RPort,x,y);
END;
END Sexplosion;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Pexplosion(mis:Shell;wp: WindowPtr);
VAR
debry : ARRAY [0..2],[0..20] OF CARDINAL;
i,j,k,l : CARDINAL;
BEGIN
l:=0;
i:=0;
WHILE ((l<20)AND(i<100)) DO
j:= 10*(1+(i DIV 50)) + (l DIV 4);
k:= j * 2;
debry[0,l]:= (CARDINAL(mis.x) - j)+Random(k) ;
debry[1,l]:= (CARDINAL(mis.y) - j)+Random(k) ;
debry[2,l]:= ReadPixel(wp^.RPort,debry[0,l],debry[1,l]);
IF debry[2,l]=0 THEN
SetAPen(wp^.RPort,2);
WritePixel(wp^.RPort,debry[0,l],debry[1,l]);
l:=l+1;
END;
i:=i+1;
END;
FOR i:=0 TO l DO
SetAPen(wp^.RPort,debry[2,i]);
WritePixel(wp^.RPort,debry[0,i],debry[1,i]);
END;
END Pexplosion;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE DrawLine (x1,y1,x2,y2,c : CARDINAL; wp : WindowPtr);
BEGIN
WITH wp^ DO
SetAPen (RPort,c); SetDrMd (RPort, Jam1);
Move (RPort ,x1, y1); Draw (RPort , x2, y2);
END
END DrawLine;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE DrawShip(x1,y1,x2,y2 : CARDINAL; wp : WindowPtr);
VAR
n,X1,X2,Y1,Y2 : INTEGER;
pts : ARRAY [0..42] OF INTEGER;
xa,xb,ya,yb : CARDINAL;
BEGIN
X1:=CARDINAL(x1);
X2:=CARDINAL(x2);
Y1:=CARDINAL(y1);
Y2:=CARDINAL(y2);
pts[0]:=17; pts[1]:=7; pts[2]:=15; pts[3]:=17; pts[4]:=6; pts[5]:=15;
pts[6]:=8; pts[7]:=5; pts[8]:=3; pts[9]:=7; pts[10]:=4; pts[11]:=3;
pts[12]:=6; pts[13]:=3;pts[14]:=3; pts[15]:=5;pts[16]:=2; pts[17]:=3;
pts[18]:=8; pts[19]:=1;pts[20]:=26;pts[21]:=9;pts[22]:=0; pts[23]:=27;
pts[24]:=0; pts[25]:=2;pts[26]:=18;pts[27]:=(-4);pts[28]:=3; pts[29]:=13;
pts[30]:=(-4);pts[31]:=4;pts[32]:=13;pts[33]:=(-5);pts[34]:=5; pts[35]:=11;
pts[36]:=(-6);pts[37]:=6;pts[38]:=9; pts[39]:=(-8);pts[40]:=7; pts[41]:=5;
FOR n:= 0 TO 41 BY 3 DO
xa:=CARDINAL(X1-pts[n]);
ya:=CARDINAL(Y1-pts[n+1]);
xb:=CARDINAL(X1-pts[n]+pts[n+2]);
yb:=CARDINAL(Y1-pts[n+1]);
DrawLine(xa,ya,xb,yb,3,wp);
xa:=CARDINAL(X1-pts[n]);
ya:=CARDINAL(Y1+pts[n+1]);
xb:=CARDINAL(X1-pts[n]+pts[n+2]);
yb:=CARDINAL(Y1+pts[n+1]);
DrawLine(xa,ya,xb,yb,3,wp);
END;
pts[0]:=2; pts[1]:=7; pts[2]:=1; pts[3]:=2; pts[4]:=6; pts[5]:=1;
pts[6]:=(-10); pts[7]:=1; pts[8]:=1; pts[9]:=(-9); pts[10]:=0; pts[11]:=3;
FOR n:= 0 TO 11 BY 3 DO
xa:=CARDINAL(X1-pts[n]);
ya:=CARDINAL(Y1-pts[n+1]);
xb:=CARDINAL(X1-pts[n]+pts[n+2]);
yb:=CARDINAL(Y1-pts[n+1]);
DrawLine(xa,ya,xb,yb,2,wp);
xa:=CARDINAL(X1-pts[n]);
ya:=CARDINAL(Y1+pts[n+1]);
xb:=CARDINAL(X1-pts[n]+pts[n+2]);
yb:=CARDINAL(Y1+pts[n+1]);
DrawLine(xa,ya,xb,yb,2,wp);
END;
pts[0]:=17; pts[1]:=7; pts[2]:=12; pts[3]:=17; pts[4]:=6; pts[5]:=13;
pts[6]:=14; pts[7]:=5; pts[8]:=11; pts[9]:=13; pts[10]:=4; pts[11]:=11;
pts[12]:=12;pts[13]:=3;pts[14]:=11; pts[15]:=11;pts[16]:=2; pts[17]:=11;
pts[18]:=12;pts[19]:=1;pts[20]:=30;pts[21]:=12;pts[22]:=0; pts[23]:=30;
pts[24]:=(-12);pts[25]:=2;pts[26]:=5;pts[27]:=(-13);pts[28]:=3; pts[29]:=3;
pts[30]:=(-14);pts[31]:=4;pts[32]:=1;
FOR n:= 0 TO 32 BY 3 DO
xa:=CARDINAL(X2+pts[n]);
ya:=CARDINAL(Y2-pts[n+1]);
xb:=CARDINAL(X2+pts[n]-pts[n+2]);
yb:=CARDINAL(Y2-pts[n+1]);
DrawLine(xa,ya,xb,yb,3,wp);
xa:=CARDINAL(X2+pts[n]);
ya:=CARDINAL(Y2+pts[n+1]);
xb:=CARDINAL(X2+pts[n]-pts[n+2]);
yb:=CARDINAL(Y2+pts[n+1]);
DrawLine(xa,ya,xb,yb,3,wp);
END;
pts[0]:=18; pts[1]:=7; pts[2]:=1; pts[3]:=18; pts[4]:=6; pts[5]:=1;
pts[6]:=3; pts[7]:=1; pts[8]:=1; pts[9]:=3; pts[10]:=0; pts[11]:=1;
FOR n:= 0 TO 11 BY 3 DO
xa:=CARDINAL(X2+pts[n]);
ya:=CARDINAL(Y2-pts[n+1]);
xb:=CARDINAL(X2+pts[n]-pts[n+2]);
yb:=CARDINAL(Y2-pts[n+1]);
DrawLine(xa,ya,xb,yb,2,wp);
xa:=CARDINAL(X2+pts[n]);
ya:=CARDINAL(Y2+pts[n+1]);
xb:=CARDINAL(X2+pts[n]-pts[n+2]);
yb:=CARDINAL(Y2+pts[n+1]);
DrawLine(xa,ya,xb,yb,2,wp);
END;
END DrawShip;
END GW.
SHAR_EOF
cat << \SHAR_EOF > mywindow.def
DEFINITION MODULE MyWindow;
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM Intuition IMPORT WindowPtr, ScreenPtr, Menu, MenuItem, IntuitionText;
FROM Console IMPORT Conport;
TYPE
MenuData = RECORD
menu: ARRAY [0..5] OF Menu;
Items: ARRAY [0..40] OF MenuItem;
Itemtext : ARRAY [0..40] OF IntuitionText;
Text : ARRAY [0..40],[0..80] OF CHAR;
menuname : ARRAY [0..5],[0..80] OF CHAR;
END;
PROCEDURE OpenLibraries () : BOOLEAN;
PROCEDURE InitScreen () : ScreenPtr;
PROCEDURE InitWindow (screen : ScreenPtr) : WindowPtr;
PROCEDURE OpenIOWin(VAR W : Conport; VAR w :WindowPtr;scn: ScreenPtr): BOOLEAN;
PROCEDURE CloseIOWin (VAR W : Conport;w :WindowPtr );
PROCEDURE InitMenu (VAR GravityWarsmenu: MenuData);
PROCEDURE SetColors (sp : ScreenPtr);
PROCEDURE ReadMenu(wp : WindowPtr): INTEGER;
PROCEDURE QueueMenu(wp : WindowPtr): BOOLEAN;
PROCEDURE ReadMouse(wp: WindowPtr;VAR x,y: CARDINAL);
END MyWindow.
SHAR_EOF
cat << \SHAR_EOF > mywindow.mod
IMPLEMENTATION MODULE MyWindow;
(*+,+*)
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM Ports IMPORT ReplyMsg, WaitPort, GetMsg, MessagePtr;
FROM Colors IMPORT SetRGB4;
FROM Libraries IMPORT OpenLibrary, CloseLibrary;
FROM SYSTEM IMPORT ADR, BYTE, ADDRESS, NULL;
FROM Intuition IMPORT
IntuitionName, IntuitionBase, Window, WindowFlags, NewWindow,
MenuPick, IDCMPFlagSet, WindowFlagSet, WindowPtr, ScreenPtr,
MenuEnabled, MenuFlagSet, Menu, MenuItem, IntuitionText, ActiveWindow,
ItemFlagSet, ItemText, ItemEnabled, IntuiMessagePtr, CustomScreen,
MouseButtons, SelectDown, CheckIt, MenuToggle, InactiveWindow;
FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase, Jam2, Jam1,
DrawingModeSet;
FROM Windows IMPORT OpenWindow, CloseWindow, ModifyIDCMP;
FROM Screens IMPORT
NewScreenPtr, NewScreen, OpenScreen, CloseScreen, ShowTitle;
FROM Views IMPORT Lace, Hires, ModeSet;
FROM Menus IMPORT HighComp, SetMenuStrip;
FROM Text IMPORT TextAttr,Text,NormalStyle,FontFlags,FontFlagSet;
FROM Console IMPORT OpenWConsole,CloseWConsole,Conport;
PROCEDURE OpenLibraries () : BOOLEAN;
BEGIN
(* First open intuition library *)
IntuitionBase := OpenLibrary (IntuitionName, 0);
IF IntuitionBase = 0 THEN RETURN FALSE END;
(* Now open the graphics library *)
GraphicsBase := OpenLibrary (GraphicsName, 0);
IF GraphicsBase = 0 THEN RETURN FALSE END;
RETURN TRUE
END OpenLibraries;
(*++++++++++++++++++++++++++++++++++++++ *)
PROCEDURE InitScreen () : ScreenPtr;
VAR
s : NewScreenPtr;
GravityWarsName : ARRAY [0..15] OF CHAR;
FontType : ARRAY [0..15] OF CHAR;
textattr : TextAttr;
BEGIN
FontType := "topaz.font";
GravityWarsName := "GravityWars";
WITH s^ DO
LeftEdge := 0; TopEdge := 0;
Width := 640; Height := 400;
Depth := 4;
DetailPen := BYTE (0); BlockPen := BYTE (1);
ViewModes := ModeSet {Lace, Hires};
Type := CustomScreen;
Font := ADR(textattr);
DefaultTitle := ADR (GravityWarsName);
Gadgets := NULL;
CustomBitMap := NULL
END;
WITH textattr DO
taName :=ADR(FontType);
taYSize := 9;
taStyle := NormalStyle;
taFlags := FontFlagSet{ROMFont};
END;
(* Now open the screen *)
RETURN OpenScreen (s)
END InitScreen;
(*++++++++++++++++++++++++++++++++++++++ *)
(* Initialize and open a window. *)
PROCEDURE InitWindow (screen : ScreenPtr) : WindowPtr;
VAR
w : NewWindow;
BEGIN
WITH w DO
LeftEdge := 0; TopEdge := 0; Width := 640; Height := 400;
DetailPen := BYTE (0);
BlockPen := BYTE (1);
Title := NULL;
Flags := WindowFlagSet {Activate, Borderless};
IDCMPFlags := IDCMPFlagSet {MenuPick,MouseButtons};
Type := CustomScreen;
CheckMark := NULL;
FirstGadget := NULL;;
Screen := screen;
BitMap := NULL;
MinWidth := 10; MinHeight := 10;
MaxWidth := 640; MaxHeight := 400;
END;
(* Now open the window *)
RETURN OpenWindow (w)
END InitWindow;
(*++++++++++++++++++++++++++++++++++++++ *)
(* Initialize and open an IO window. *)
PROCEDURE OpenIOWin(VAR W: Conport;VAR w :WindowPtr; scn: ScreenPtr): BOOLEAN;
VAR
Win : NewWindow;
error : LONGINT;
BEGIN
WITH Win DO
LeftEdge := 0; TopEdge := 0; Width := 640; Height := 30;
DetailPen := BYTE (2);
BlockPen := BYTE (1);
Title := NULL;
Flags := WindowFlagSet {Borderless};
IDCMPFlags := IDCMPFlagSet {InactiveWindow};
Type := CustomScreen;
CheckMark := NULL;
FirstGadget := NULL;;
Screen := scn;
BitMap := NULL;
MinWidth := 639; MinHeight := 10;
MaxWidth := 640; MaxHeight := 50;
END;
(* Now open the window *)
w:=OpenWindow(Win);
RETURN OpenWConsole(W,w);
END OpenIOWin;
(*++++++++++++++++++++++++++++++++++++++ *)
PROCEDURE CloseIOWin (VAR W: Conport;w :WindowPtr );
BEGIN
CloseWConsole(W);
CloseWindow(w);
END CloseIOWin;
(*++++++++++++++++++++++++++++++++++++++ *)
PROCEDURE InitMenu (VAR GravityWarsmenu: MenuData);
PROCEDURE InitItems ();
VAR
i : CARDINAL;
BEGIN
WITH GravityWarsmenu DO
FOR i := 0 TO 34 DO
(* Initialize Item record fields *)
WITH Items[i] DO
NextItem := ADR (Items[i+1]);
IF ((i=8) OR (i=12) OR (i=17) OR (i=22) OR (i=34)) THEN
NextItem := NULL
END;
LeftEdge := 0;
Width := 190; Height := 10;
Flags := ItemFlagSet {ItemText, ItemEnabled} + HighComp;
MutualExclude := 0;
ItemFill := ADR (Itemtext[i]);
SelectFill := NULL; Command := BYTE (0);
SubItem := NULL; NextSelect := 0;
END;
WITH Itemtext [i] DO
FrontPen := BYTE(0); BackPen := BYTE (1);
DrawMode := BYTE (DrawingModeSet {Jam2});
LeftEdge := 0; TopEdge := 1;
ITextFont := NULL; NextText := NULL;
IText := ADR (Text[i])
END;
END;
FOR i:= 0 TO 8 DO
Items[i].TopEdge := i* 10;
Items[i].Width := 250;
END;
FOR i:= 9 TO 12 DO
Items[i].TopEdge := (i-9) * 10;
Items[i].Width := 120;
END;
FOR i:= 13 TO 17 DO
Items[i].TopEdge := (i-13) * 10;
Items[i].Width := 230;
END;
FOR i:= 18 TO 22 DO
Items[i].TopEdge := (i-18) * 10;
Items[i].Width := 130;
END;
FOR i:= 23 TO 34 DO
Items[i].TopEdge := (i-23) * 10;
END;
(* Now put text into the text arrays *)
Text[0] := "written by Ed Bartz";
Text[1] := "with TDI Modula 2";
Text[2] := " Version 1.04";
Text[3] := " Copyright March 1987";
Text[4] := " ";
Text[5] := "This Program is Shareware";
Text[6] := "Send Donation to ";
Text[7] := " 12 Roosevelt St.";
Text[8] := " SouthRiver,N.J. 08882";
Text[9] := "Random Setup ";
Text[10] := "Play Game";
Text[11] := "Stop Game";
Text[12] := "Quit";
Text[13] := "Maximum Planets = 9";
Text[14] := "Erase Missle Trails";
Text[15] := "Redraw Screen";
Text[16] := "Plain Planets";
Text[17] := "Practice";
Text[18] := "Move Ship";
Text[19] := "Move Planet";
Text[20] := "Change Planet";
Text[21] := "Make Planet";
Text[22] := "Delete Planet";
Text[23] := "Velocity: 0 to 10";
Text[24] := " ";
Text[25] := "Angle: 90";
Text[26] := " |";
Text[27] := " 180 --+-- 0";
Text[28] := " |";
Text[29] := " 270";
Text[30] := " ";
Text[31] := "Planet Density:";
Text[32] := " Low - Red";
Text[33] := " Medium - Green";
Text[34] := " High - Blue ";
END;
END InitItems;
BEGIN
InitItems ();
(* Init the single menu *)
WITH GravityWarsmenu DO
WITH menu[0] DO
NextMenu := ADR (menu[1]);
LeftEdge := 3; TopEdge := 0;
Width := 55; Height := 10;
Flags := MenuFlagSet {MenuEnabled};
FirstItem := ADR (Items[0]);
MenuName := ADR (menuname[0])
END;
WITH menu[1] DO
NextMenu := ADR (menu[2]);
LeftEdge := 65; TopEdge := 0;
Width := 44; Height := 10;
Flags := MenuFlagSet {MenuEnabled};
FirstItem := ADR (Items[23]);
MenuName := ADR (menuname[1])
END;
WITH menu[2] DO
NextMenu := ADR (menu[3]);
LeftEdge := 119; TopEdge := 0;
Width := 132; Height := 10;
Flags := MenuFlagSet {MenuEnabled};
FirstItem := ADR (Items[9]);
MenuName := ADR (menuname[2])
END;
WITH menu[3] DO
NextMenu := ADR (menu[4]);
LeftEdge := 261; TopEdge := 0;
Width := 77; Height := 10;
Flags := MenuFlagSet {MenuEnabled};
FirstItem := ADR (Items[13]);
MenuName := ADR (menuname[3])
END;
WITH menu[4] DO
NextMenu := NULL;
LeftEdge := 348; TopEdge := 0;
Width := 132; Height := 10;
Flags := MenuFlagSet {MenuEnabled};
FirstItem := ADR (Items[18]);
MenuName := ADR (menuname[4])
END;
menuname[0] := "About";
menuname[1] := "Help";
menuname[2] := "Game Control";
menuname[3] := "Options";
menuname[4] := "Modify Setup";
END;
END InitMenu;
(*++++++++++++++++++++++++++++++++++++++ *)
PROCEDURE SetColors (sp : ScreenPtr);
BEGIN
WITH sp^ DO
SetRGB4 (ADR(VPort), 0, 0, 0, 0);
SetRGB4 (ADR(VPort), 1, 15, 15, 15);
SetRGB4 (ADR(VPort), 2, 15, 0, 0);
SetRGB4 (ADR(VPort), 3, 8, 8, 9);
SetRGB4 (ADR(VPort), 4, 6, 0, 0);
SetRGB4 (ADR(VPort), 5, 9, 1, 0);
SetRGB4 (ADR(VPort), 6, 12, 2, 0);
SetRGB4 (ADR(VPort), 7, 15, 3, 0);
SetRGB4 (ADR(VPort), 8, 0, 5, 0);
SetRGB4 (ADR(VPort), 9, 1, 8, 0);
SetRGB4 (ADR(VPort), 10, 2, 12, 0);
SetRGB4 (ADR(VPort), 11, 7, 15, 0);
SetRGB4 (ADR(VPort), 12, 0, 0, 6);
SetRGB4 (ADR(VPort), 13, 0, 2, 9);
SetRGB4 (ADR(VPort), 14, 0, 4, 12);
SetRGB4 (ADR(VPort), 15, 0, 6, 15);
END
END SetColors;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE ReadMenu(wp : WindowPtr): INTEGER;
CONST
MenuNull = 0FFFFH;
VAR
msgptr : IntuiMessagePtr;
code : CARDINAL;
class : IDCMPFlagSet;
(* ++++++++++++++++++++++++++++++++++++++ *)
(* Get the item number from the number *)
(* gotten from the intuition message. *)
PROCEDURE ItemPicked (code : CARDINAL) : CARDINAL;
TYPE
ShortSet = SET OF [0..15];
VAR
menunumber,code1 : CARDINAL;
BEGIN
code1 := code;
code1 := CARDINAL (ShortSet(code1) * ShortSet (0001FH));
code := CARDINAL (ShortSet(code DIV 32) * ShortSet (003FH));
IF (code1 = 0) THEN code:= 0;END;
IF (code1 = 1) THEN code:= 0;END;
IF (code1 = 2) THEN code:= code + 1;END;
IF (code1 = 3) THEN code:= code + 5;END;
IF (code1 = 4) THEN code:= code + 10;END;
RETURN code
END ItemPicked;
BEGIN
msgptr := GetMsg (wp^.UserPort);
IF msgptr <> NULL THEN
(* If message is gotten. Process it *)
REPEAT
class := msgptr^.Class; code := msgptr^.Code;
ReplyMsg (MessagePtr(msgptr));
msgptr := GetMsg (wp^.UserPort);
(* If something was picked from the menu, act on it *)
(* If not a menu event check next message *)
UNTIL ((msgptr=NULL) OR (class = IDCMPFlagSet {MenuPick}));
IF (class = IDCMPFlagSet {MenuPick}) AND (code <> MenuNull) THEN
(* Figure out what item was picked *)
RETURN ItemPicked (code);
END
END; (* IF msgptr <> NULL *)
RETURN 0;
END ReadMenu;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE QueueMenu(wp : WindowPtr): BOOLEAN;
CONST
MenuNull = 0FFFFH;
VAR
msgptr : IntuiMessagePtr;
code : CARDINAL;
class : IDCMPFlagSet;
BEGIN
msgptr := GetMsg (wp^.UserPort);
IF msgptr <> NULL THEN
REPEAT
class := msgptr^.Class; code := msgptr^.Code;
msgptr := GetMsg (wp^.UserPort);
UNTIL ((msgptr=NULL) OR (class = IDCMPFlagSet {MenuPick}));
IF (class = IDCMPFlagSet {MenuPick}) AND (code <> MenuNull) THEN
RETURN TRUE;
END
END;
RETURN FALSE;
END QueueMenu;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE ReadMouse(wp: WindowPtr;VAR x,y: CARDINAL);
VAR
msgptr : IntuiMessagePtr;
code : CARDINAL;
class : IDCMPFlagSet;
BEGIN
REPEAT
msgptr:= NULL;
WHILE (msgptr=NULL) DO
msgptr:= GetMsg(wp^.UserPort);
END;
class:= msgptr^.Class;
code:= msgptr^.Code;
x:= CARDINAL(ABS(msgptr^.MouseX));
y:= CARDINAL(ABS(msgptr^.MouseY));
ReplyMsg (MessagePtr(msgptr));
UNTIL ((class=IDCMPFlagSet{MouseButtons})AND(code=SelectDown));
END ReadMouse;
END MyWindow.
SHAR_EOF
cat << \SHAR_EOF > options.def
DEFINITION MODULE Options;
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM Intuition IMPORT WindowPtr;
FROM GW IMPORT Pl;
PROCEDURE DeletePlanet(wp: WindowPtr;VAR pl: ARRAY OF Pl;VAR Pnum: CARDINAL);
PROCEDURE MakePlanet(wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;VAR Pnum,ptype: CARDINAL);
PROCEDURE ChangePlanet(wp: WindowPtr;VAR pl: ARRAY OF Pl;Pnum,ptype: CARDINAL);
PROCEDURE MoveShip(wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;Pnum :CARDINAL);
PROCEDURE MovePlanet(wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;Pnum,ptype :CARDINAL);
PROCEDURE CleanScreen (wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;Pnum,ptype: CARDINAL);
PROCEDURE IdentifyS(x,y: CARDINAL; VAR Sh: ARRAY OF Pl): CARDINAL;
END Options.
SHAR_EOFdoc@s.cc.purdue.edu (Craig Norborg) (06/15/87)
# This is a shell archive.
# Remove everything above and including the cut line.
# Then run the rest of the file through sh.
#----cut here-----cut here-----cut here-----cut here----#
#!/bin/sh
# Xshar: Extended Shell Archiver.
# This is part 2 out of 2.
# Run the following text with /bin/sh to create:
# console.mod
# grav.mod
# options.mod
# This archive created: Fri Jun 12 13:56:35 1987
# By: Craig Norborg (Purdue University Computing Center)
cat << \SHAR_EOF > console.mod
IMPLEMENTATION MODULE Console;
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM IO IMPORT IOStdReqPtr, DoIO, SendIO, CmdRead, CmdWrite, AbortIO;
FROM PortUtils IMPORT CreatePort,DeletePort,CreateStdIO,DeleteStdIO;
FROM Ports IMPORT WaitPort, MsgPortPtr, MessagePtr, GetMsg;
FROM Intuition IMPORT WindowPtr;
FROM Devices IMPORT OpenDevice, CloseDevice;
FROM SYSTEM IMPORT ADR, NULL;
(*+,+*)
PROCEDURE QueueRead(VAR Rport: Conport);
(* queue up a read request to a console, show where to
* put the character when ready to be returned. Most
* efficient if this is called right after console is
* opened *)
BEGIN
Rport.IO^.ioReq.ioCommand := CmdRead;
Rport.IO^.ioData := ADR(Rport.buf[0]);
Rport.IO^.ioLength := 1;
SendIO(Rport.IO^.ioReq);
END QueueRead;
PROCEDURE OpenWRConsole(VAR Wport, Rport: Conport; w: WindowPtr):BOOLEAN;
(* Open a console device *)
VAR
i : INTEGER;
error :LONGCARD;
err : BOOLEAN;
c : CHAR;
BEGIN
error:=1;
Wport.msg := CreatePort("my.con.write",0);
Wport.IO := CreateStdIO(Wport.msg);
Rport.msg := CreatePort("my.con.read",0);
Rport.IO := CreateStdIO(Rport.msg);
IF NOT((Wport.msg=NULL)OR(Wport.IO=NULL)OR(Rport.msg=NULL)OR(Rport.IO=NULL))THEN
Wport.IO^.ioData:= w;
Wport.IO^.ioLength := SIZE(w^);
error := OpenDevice("console.device", 0, Wport.IO, 0);
Rport.IO^.ioReq.ioDevice := Wport.IO^.ioReq.ioDevice;
Rport.IO^.ioReq.ioUnit := Wport.IO^.ioReq.ioUnit;
(* clone required parts of the request *)
END;
IF error>0 THEN err:=FALSE;ELSE err:=TRUE;END;
QueueRead(Rport);
FOR i := 0 TO 79 DO
Rport.buf[i]:= 0C;
Wport.buf[i]:= 0C;
END;
RETURN err
END OpenWRConsole;
PROCEDURE OpenWConsole(VAR Wport: Conport; w: WindowPtr):BOOLEAN;
(* Open a console device *)
VAR
i : INTEGER;
error :LONGCARD;
err : BOOLEAN;
c : CHAR;
BEGIN
error:=1;
Wport.msg := CreatePort("my.con.write",0);
Wport.IO := CreateStdIO(Wport.msg);
IF NOT((Wport.msg=NULL)OR(Wport.IO=NULL))THEN
Wport.IO^.ioData:= w;
Wport.IO^.ioLength := SIZE(w^);
error := OpenDevice("console.device", 0, Wport.IO, 0);
END;
IF error>0 THEN err:=FALSE;ELSE err:=TRUE;END;
FOR i := 0 TO 79 DO
Wport.buf[i]:= 0C;
END;
RETURN err
END OpenWConsole;
PROCEDURE OpenRConsole(VAR Rport: Conport; w: WindowPtr):BOOLEAN;
(* Open a console device *)
VAR
i : INTEGER;
error :LONGCARD;
err : BOOLEAN;
c : CHAR;
BEGIN
error:=1;
Rport.msg := CreatePort("my.con.read",0);
Rport.IO := CreateStdIO(Rport.msg);
IF NOT((Rport.msg=NULL)OR(Rport.IO=NULL))THEN
Rport.IO^.ioData:= w;
Rport.IO^.ioLength := SIZE(w^);
error := OpenDevice("console.device", 0, Rport.IO, 0);
END;
IF error>0 THEN err:=FALSE;ELSE err:=TRUE;END;
IF err THEN QueueRead(Rport); END;
FOR i := 0 TO 79 DO
Rport.buf[i]:= 0C;
END;
RETURN err
END OpenRConsole;
PROCEDURE CloseWRConsole(Wport, Rport: Conport);
BEGIN
AbortIO(Rport.IO^.ioReq);
CloseDevice(Wport.IO);
DeleteStdIO(Wport.IO);
DeleteStdIO(Rport.IO);
DeletePort(Wport.msg);
DeletePort(Rport.msg);
END CloseWRConsole;
PROCEDURE CloseWConsole(Wport: Conport);
BEGIN
CloseDevice(Wport.IO);
DeleteStdIO(Wport.IO);
DeletePort(Wport.msg);
END CloseWConsole;
PROCEDURE CloseRConsole(Rport: Conport);
BEGIN
AbortIO(Rport.IO^.ioReq);
CloseDevice(Rport.IO);
DeleteStdIO(Rport.IO);
DeletePort(Rport.msg);
END CloseRConsole;
PROCEDURE PutChar(Wport: Conport; c: CHAR);
(* Output a single character to a specified console *)
VAR
i : LONGINT;
BEGIN
Wport.IO^.ioReq.ioCommand := CmdWrite;
Wport.IO^.ioData := ADR(c);
Wport.IO^.ioLength := 1;
i:=DoIO(Wport.IO^.ioReq);
(* command works because DoIO blocks until command is
* done (otherwise pointer to the character could become
* invalid in the meantime).
*)
END PutChar;
PROCEDURE Writestr(Wport: Conport; VAR s: ARRAY OF CHAR; len: LONGINT);
(* Output a stream of known length to a console *)
VAR
i : LONGINT;
BEGIN
Wport.IO^.ioReq.ioCommand := CmdWrite;
Wport.IO^.ioData := ADR(s);
Wport.IO^.ioLength := len;
i:=DoIO(Wport.IO^.ioReq);
(* command works because DoIO blocks until command is
* done (otherwise pointer to string could become
* invalid in the meantime).
*)
END Writestr;
PROCEDURE PutStr(Wport: Conport; VAR s: ARRAY OF CHAR);
(* Output a NULL-terminated string of characters to a console *)
VAR
i : LONGINT;
BEGIN
Wport.IO^.ioReq.ioCommand := CmdWrite;
Wport.IO^.ioData := ADR(s);
Wport.IO^.ioLength := MAX (LONGCARD);
(* tells console to end when it
* sees a terminating zero on
* the string. *)
i:=DoIO(Wport.IO^.ioReq);
END PutStr;
PROCEDURE MayGetChar(VAR Rport: Conport; VAR c: CHAR): BOOLEAN;
(* see if there is a character to read. If none, don't wait,
* come back with a value of FALSE *)
BEGIN
IF (GetMsg(Rport.msg)=MessagePtr(0))THEN RETURN FALSE;
ELSE
QueueRead(Rport);
c:= Rport.buf[0];
RETURN TRUE;
END;
END MayGetChar;
PROCEDURE GetChar(VAR Rport: Conport; VAR c: CHAR);
(* go and get a character; put the task to sleep if
there isn't one present *)
VAR
i : MessagePtr;
BEGIN
WHILE GetMsg(Rport.msg) = MessagePtr(0) DO
IF WaitPort(Rport.msg) = MessagePtr(0) THEN END;
END;
QueueRead(Rport);
c:= Rport.buf[0];
END GetChar;
PROCEDURE GetStr(VAR Rport, Wport: Conport; VAR s: ARRAY OF CHAR): BOOLEAN;
VAR
i,j : INTEGER;
str : ARRAY [0..80] OF CHAR;
c : CHAR;
BEGIN
i:=0;
c:=' ';
QueueRead(Rport);
WHILE ((i<79)AND(c#15C)) DO
GetChar(Rport,c);
s[i] := c;
IF c #15C THEN
IF (c=10C)OR(c=177C) THEN
c:=10C;
i:=i-2;
IF i<(-1) THEN i:=(-1);END;
END;
i:=i+1;
PutChar(Wport,c);
END;
END;
QueueRead(Rport);
IF i#0 THEN
s[i]:=0C;
RETURN TRUE;
END;
RETURN FALSE;
END GetStr;
END Console.
SHAR_EOF
cat << \SHAR_EOF > grav.mod
MODULE GravityWars;
(*+,+*)
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/14/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
(* FROM Title IMPORT Showpic; Title screen not included due to copyright
problems .*)
FROM Libraries IMPORT CloseLibrary;
FROM Intuition IMPORT
IntuitionName, IntuitionBase, WindowPtr, ScreenPtr, Menu, Window,
ItemFlagSet, ItemEnabled, MenuToggle, MenuItem, ItemText;
FROM Menus IMPORT SetMenuStrip, HighComp;
FROM GraphicsLibrary IMPORT GraphicsName, GraphicsBase;
FROM Windows IMPORT OpenWindow, CloseWindow;
FROM Screens IMPORT NewScreen, OpenScreen, CloseScreen, ShowTitle;
FROM RandomNumbers IMPORT Random;
FROM MathLib0 IMPORT real,entier,sin,cos,ln,exp;
FROM GW IMPORT
Pl, Mdata, Shell, String, DrawPlanet, Distance, Pposition,
Sposition, Stars, Sexplosion, Pexplosion, DrawLine,
DrawShip;
FROM MyWindow IMPORT
OpenLibraries, InitScreen, InitWindow, OpenIOWin, CloseIOWin,
InitMenu, SetColors, ReadMenu, MenuData, ReadMouse;
FROM Rasters IMPORT SetRast;
FROM Console IMPORT
OpenWConsole, CloseWConsole, PutChar, PutStr, GetChar, GetStr,
QueueRead, Conport, OpenRConsole, CloseRConsole, MayGetChar;
FROM M2Conversions IMPORT
ConvertCardinal, ConvertReal, ConvertToReal, ConvertToCardinal;
FROM Pens IMPORT SetAPen, WritePixel, ReadPixel;
FROM Options IMPORT
DeletePlanet, MakePlanet, ChangePlanet, MovePlanet, CleanScreen,
MoveShip, IdentifyS;
FROM InOut IMPORT WriteInt,WriteCard;
VAR
wp : WindowPtr;
IOwp : WindowPtr;
sp : ScreenPtr;
Wport,Rport : Conport;
GravityWarsmenu : MenuData;
ptype,Pnum,MaxPlan : CARDINAL;
erase : BOOLEAN;
PROCEDURE Game ();
CONST
round = 0.83;
VAR
playernum,color,index : CARDINAL;
PlanetPos : ARRAY [0..15] OF Pl;
Ship : ARRAY [0..1] OF Pl;
p,player : INTEGER;
temp,Set,GameOn,Quit : BOOLEAN;
Outmsg,Inmsg : String;
LastShot : Mdata;
Missle : Shell;
c,char : CHAR;
PROCEDURE Setup;
BEGIN
SetRast(wp^.RPort,0);
Set:=TRUE;
Pnum:= Random(MaxPlan- 4)+4;
Stars(wp);
Pposition(PlanetPos,Pnum,ptype,wp);
Sposition(wp,Ship,PlanetPos,Pnum);
END Setup;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Maximum;
VAR
results1,results : BOOLEAN;
str : ARRAY [0..80] OF CHAR;
BEGIN
results:=OpenIOWin(Wport,IOwp,sp);
IF results THEN
PutStr(Wport,"Input maximum number of planets (5 to 15) ");
results:= GetStr(Rport,Wport,str);
IF results THEN
ConvertToCardinal(str,results,MaxPlan);
IF NOT(results) THEN MaxPlan:=9; END;
ELSE MaxPlan:=9;
END;
IF MaxPlan>15 THEN MaxPlan:= 15; END;
IF MaxPlan<5 THEN MaxPlan:= 5; END;
ConvertCardinal(MaxPlan,2,str);
WITH GravityWarsmenu DO
Text[13][18]:=str[0];
Text[13][19]:=str[1];
END;
CloseIOWin(Wport,IOwp);
END;
END Maximum;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE ChooseSide;
VAR
results1,results : BOOLEAN;
str : ARRAY [0..80] OF CHAR;
BEGIN
results:=OpenIOWin(Wport,IOwp,sp);
IF results THEN
PutStr(Wport,"Choose which ship to practice with (1 or 2):");
results:= GetStr(Rport,Wport,str);
IF results THEN
ConvertToCardinal(str,results,playernum);
IF playernum > 2 THEN playernum := 0; END;
ELSE playernum := 0;
END;
CloseIOWin(Wport,IOwp);
END;
END ChooseSide;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE READMenu;
VAR
p,c : CARDINAL;
BEGIN
c:=0;
c:=ReadMenu(wp);
CASE c OF
1: (* Setup Game *)
Setup; |
2: (* Play Game *)
IF Set THEN
GameOn := TRUE;
FOR p := 18 TO 22 DO
WITH GravityWarsmenu.Items[p] DO
Flags:=Flags-ItemFlagSet{ItemEnabled};
END;
END;
WITH GravityWarsmenu.Items[9] DO
Flags:=Flags-ItemFlagSet{ItemEnabled};
END;
END; |
3: (* Stop Game *)
GameOn:=FALSE;
FOR p:=18 TO 22 DO
WITH GravityWarsmenu.Items[p] DO
Flags:=ItemFlagSet{ItemText, ItemEnabled} + HighComp;
END;
END;
WITH GravityWarsmenu.Items[9] DO
Flags:=ItemFlagSet{ItemText, ItemEnabled} + HighComp;
END; |
4: (* QUIT *)
Quit:=TRUE; |
5: (* Set Maximum Planets *)
Maximum; |
6:(* erase trails *)
IF erase THEN
erase:= FALSE;
GravityWarsmenu.Text[14]:="Erase Missle Trails";
ELSE erase := TRUE;
GravityWarsmenu.Text[14]:="Leave Missle Trails";
END; |
7:(* Redraw screen *)
CleanScreen(wp,Ship,PlanetPos,Pnum,ptype); |
8:(* Change Planet Type *)
IF ptype = 1 THEN
GravityWarsmenu.Text[16]:="Fancy Planets";
ptype := 0;
ELSE
GravityWarsmenu.Text[16]:="Plain Planets";
ptype := 1;
END; |
9:(* One Player/Two Player *)
IF playernum = 0 THEN
ChooseSide;
ELSE playernum := 0;
END;
IF playernum = 0 THEN
GravityWarsmenu.Text[17]:="Practice";
ELSE GravityWarsmenu.Text[17]:="Compete";
END; |
10: (* MoveShip *)
Set:=TRUE;
IF NOT(GameOn) THEN
MoveShip(wp,Ship,PlanetPos,Pnum);
END; |
11: (* MovePlanet *)
Set:=TRUE;
IF NOT(GameOn) THEN
MovePlanet(wp,Ship,PlanetPos,Pnum,ptype);
END; |
12: (*ChangePlanet*)
Set:=TRUE;
IF NOT(GameOn) THEN
ChangePlanet(wp,PlanetPos,Pnum,ptype);
END; |
13: (*MakePlanet*)
Set:=TRUE;
IF NOT(GameOn) THEN
MakePlanet(wp,Ship,PlanetPos,Pnum,ptype);
END; |
14: (*DeletePlanet*)
Set:=TRUE;
IF NOT(GameOn) THEN
DeletePlanet(wp,PlanetPos,Pnum);
END;
ELSE;
END;
END READMenu;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Play;
VAR
ang,vel : REAL;
p : INTEGER;
BEGIN
temp := MayGetChar(Rport,c);
player := 1;
WITH LastShot DO
P1ang:=0.0;
P1vel:=0.0;
P2ang:=0.0;
P2vel:=0.0;
END;
WHILE GameOn AND NOT(Quit) DO
IF player=0 THEN
player:= 1;
ang:=LastShot.P2ang;
vel:=LastShot.P2vel;
ELSE
player:=0;
ang:=LastShot.P1ang;
vel:=LastShot.P1vel;
END;
IF playernum > 0 THEN
player := playernum -1;
IF player=1 THEN
ang:=LastShot.P2ang;
vel:=LastShot.P2vel;
ELSE
ang:=LastShot.P1ang;
vel:=LastShot.P1vel;
END;
END;
GetData(ang,vel,player);
IF vel>10.0 THEN vel:=10.0; END;
IF vel<(-10.0) THEN vel:=(-10.0); END;
IF player=1 THEN
LastShot.P2ang:=ang;
LastShot.P2vel:=vel;
ELSE
LastShot.P1ang:=ang;
LastShot.P1vel:=vel;
END;
WITH Missle DO
vx:=vel*cos((-ang)*0.0174533);
vy:=vel*sin(0.0174533*(-ang));
x:=Ship[player].x;
y:=Ship[player].y;
END;
READMenu;
Launch(Missle);
READMenu;
END;
END Play;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Gravity(VAR mis:Shell);
VAR
dr3,dr,dx,dy,ax,ay : REAL;
p,j,k : INTEGER;
BEGIN
(* This is here to work around a bug in the console device. If the read
device isn't read immediately it goes crazy. If you can fix it let me know
were I went wrong. *)
temp := MayGetChar(Rport,char);
ax := 0.0;
ay := 0.0;
FOR p:= 0 TO Pnum-1 DO
WITH PlanetPos[p] DO
dx:=real(x-mis.x);
dy:=real(y-mis.y);
IF (ABS(dx)>5.0) OR (ABS(dy)>5.0) THEN
dr:=1.5*ln(dx*dx+dy*dy);
dr3:=exp(dr);
ax:=ax+(m*dx)/dr3;
ay:=ay+(m*dy)/dr3;
END;
END;
END;
WITH mis DO
vx:=ax+vx;
vy:=ay+vy;
x:=entier(vx)+x;
y:=entier(vy)+y;
END;
END Gravity;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Launch(VAR Mis:Shell);
VAR
c,i,j,n : CARDINAL;
Outside : BOOLEAN;
oldx,oldy,x1,y1,x2,y2,k,l : INTEGER;
eMis : Shell;
BEGIN
eMis:= Mis;
Gravity (Mis);
i:=ReadPixel(wp^.RPort,Mis.x,Mis.y);
i:=3;
Outside:=FALSE;
REPEAT
Gravity (Mis);
IF (((Mis.x-eMis.x)>18)OR((Mis.x-eMis.x)<(-18))) THEN
Outside:=TRUE;
END;
IF (((Mis.y-eMis.y)>7)OR((Mis.y-eMis.y)<(-7))) THEN
Outside:=TRUE;
END;
UNTIL Outside;
i:=0;
Outside:=FALSE;
oldx:=Mis.x;
oldy:=Mis.y;
WITH Mis DO
REPEAT
READMenu;
SetAPen(wp^.RPort,1);
Gravity(Mis);
IF (x>0)AND(x<639)AND(y>0)AND(y<398)THEN
x1:= (x - oldx);
y1:= (y - oldy);
IF ABS(x1)>ABS(y1) THEN k:=ABS(2*x1);
ELSE k:=ABS(2*y1);
END;
FOR l:=1 TO k DO
x:= ((x1*l) DIV k)+oldx;
y:= ((y1*l) DIV k)+oldy;
n:=ReadPixel(wp^.RPort,x,y);
IF n<3 THEN
WritePixel(wp^.RPort,x,y);
ELSE
i:=n;
x2:=x;
y2:=y;
END;
END;
END;
IF i>2 THEN
x:=x2;
y:=y2;
END;
IF (x<1)THEN oldx:=1; ELSIF (x>638)THEN oldx:=638; ELSE oldx:=x; END;
IF (y<1)THEN oldy:=1; ELSIF (y>398)THEN oldy:=398; ELSE oldy:=y; END;
IF (x<(-320))OR(x>940)OR(y<(-200))OR(y>600)THEN
Outside:=TRUE;
END;
UNTIL (Outside OR (i>2) OR NOT(GameOn) OR Quit);
END;
IF Outside THEN
PutString("Missle Left The Galaxy");
END;
IF i>3 THEN
Pexplosion(Mis,wp);
END;
IF i=3 THEN
j:= IdentifyS(Mis.x,Mis.y,Ship);
IF j<2 THEN
Sexplosion(Mis,wp);
IF j=0 THEN
PutString("Player 2 Wins!!!");
ELSE
PutString("Player 1 Wins!!!");
END;
FOR j:=18 TO 22 DO
WITH GravityWarsmenu.Items[j] DO
Flags:=ItemFlagSet{ItemText, ItemEnabled} + HighComp;
END;
END;
WITH GravityWarsmenu.Items[9] DO
Flags:=ItemFlagSet{ItemText, ItemEnabled} + HighComp;
END;
Set:=FALSE;
GameOn:=FALSE;
ELSE i:=0;
END;
END;
IF erase AND NOT(i=3) THEN
Mis:= eMis;
Gravity (Mis);
i:=ReadPixel(wp^.RPort,Mis.x,Mis.y);
i:=3;
Outside:=FALSE;
REPEAT
Gravity (Mis);
IF (((Mis.x-eMis.x)>18)OR((Mis.x-eMis.x)<(-18))) THEN
Outside:=TRUE;
END;
IF (((Mis.y-eMis.y)>7)OR((Mis.y-eMis.y)<(-7))) THEN
Outside:=TRUE;
END;
UNTIL Outside;
i:=0;
Outside:=FALSE;
oldx:=Mis.x;
oldy:=Mis.y;
WITH Mis DO
REPEAT
READMenu;
SetAPen(wp^.RPort,0);
Gravity(Mis);
IF (x>0)AND(x<639)AND(y>0)AND(y<398)THEN
x1:= (x - oldx);
y1:= (y - oldy);
IF ABS(x1)>ABS(y1) THEN k:=ABS(2*x1);
ELSE k:=ABS(2*y1);
END;
FOR l:=1 TO k DO
x:= ((x1*l) DIV k)+oldx;
y:= ((y1*l) DIV k)+oldy;
n:=ReadPixel(wp^.RPort,x,y);
IF n<3 THEN
WritePixel(wp^.RPort,x,y);
ELSE
i:=n;
x2:=x;
y2:=y;
END;
END;
END;
IF i>2 THEN
x:=x2;
y:=y2;
END;
IF (x<1)THEN oldx:=1; ELSIF (x>638)THEN oldx:=638; ELSE oldx:=x; END;
IF (y<1)THEN oldy:=1; ELSIF (y>398)THEN oldy:=398; ELSE oldy:=y; END;
IF (x<(-320))OR(x>940)OR(y<(-200))OR(y>600)THEN
Outside:=TRUE;
END;
UNTIL (Outside OR (i>2) OR NOT(GameOn) OR Quit);
END;
END;
END Launch;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE PutString(msg:String);
VAR
p : LONGCARD;
results,results1 : BOOLEAN;
BEGIN
results:= OpenIOWin(Wport,IOwp,sp);
IF results THEN
PutStr(Wport,msg);
FOR p := 0 TO 150000 DO;
END;
END;
CloseIOWin(Wport,IOwp);
END PutString;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Newline;
BEGIN
PutChar(Wport,12C);
PutChar(Wport,15C);
END Newline;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE GetData(VAR ang,vel:REAL;player:INTEGER);
VAR
results,results1 : BOOLEAN;
p : CARDINAL;
String : ARRAY [0..80] OF CHAR;
c : CHAR;
BEGIN
results:=OpenIOWin(Wport,IOwp,sp);
IF results THEN
IF player=0 THEN PutStr(Wport,"Player 1");
ELSE PutStr(Wport,"Player 2");
END;
Newline;
PutStr(Wport,"Input Firing angle [");
ConvertReal(ang,9,6,String);
PutStr(Wport,String);
PutStr(Wport,"]: ");
results:= GetStr(Rport,Wport,String);
IF results THEN
ConvertToReal(String,results,ang);
IF NOT(results) THEN ang:=0.0; END;
END;
Newline;
PutStr(Wport,"Input Firing Velocity [");
ConvertReal(vel,9,6,String);
PutStr(Wport,String);
PutStr(Wport,"]: ");
results:= GetStr(Rport,Wport,String);
IF results THEN
ConvertToReal(String,results,vel);
IF NOT(results) THEN vel:=1.0; END;
END;
END;
CloseIOWin(Wport,IOwp);
END GetData;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
BEGIN
ShowTitle (sp,FALSE);
Set := FALSE;
Quit:=FALSE;
GameOn:=FALSE;
ptype := 1;
playernum := 0;
erase := FALSE;
LOOP (***** Main GravityWars loop *****)
temp := MayGetChar(Rport,c);
p:=Random(700);(*Randomize*)
READMenu;
IF GameOn THEN
Play;
END;
IF Quit THEN
EXIT;
END;
END; (* LOOP *)
END Game;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
BEGIN
(* This is here because, NIL <> ADDRESS (0) *)
(* Open assorted libraries *)
MaxPlan:= 9;
Pnum := 0;
(* Normally the title screen routine would be called here. However since
most of that routine was the showilbm.mod program I removed it from the
source rather than worry about copyright problems.
Showpic('title'); *)
IF OpenLibraries () THEN
(* Intialize everything else *)
sp := InitScreen ();
wp := InitWindow (sp);
InitMenu (GravityWarsmenu);
(* Attach the menu to the window *)
SetMenuStrip (wp, GravityWarsmenu.menu[0]);
(* Set up colors *)
SetColors (sp);
(* Lets Play*)
erase := OpenRConsole(Rport,wp);
IF erase THEN
Game ();
END;
(* Close windows etc...*)
CloseRConsole(Rport);
CloseWindow (wp);
CloseScreen (sp);
CloseLibrary (IntuitionBase);
CloseLibrary (GraphicsBase)
END
END GravityWars.
SHAR_EOF
cat << \SHAR_EOF > options.mod
IMPLEMENTATION MODULE Options;
(*+,+*)
(**********************************************************************
*************** Written by Ed Bartz ***************
*************** Copyright 5/21/87 ***************
*************** This program may be redistributed ***************
*************** or modified as long as these ***************
*************** notices and all other references ***************
*************** to the author remain intack. ***************
*************** Also this may not be used for ***************
*************** profit by anyone without the ***************
*************** express permission of the author. ***************
**********************************************************************)
FROM Intuition IMPORT
IntuitionName, IntuitionBase, WindowPtr, ScreenPtr, Menu, Window,
ItemFlagSet, ItemEnabled, MenuToggle, MenuItem, ItemText;
FROM RandomNumbers IMPORT Random;
FROM MathLib0 IMPORT real,entier,sqrt;
FROM GW IMPORT
Pl, Mdata, Shell, DrawPlanet, Distance, Stars, DrawLine,
DrawShip;
FROM MyWindow IMPORT
OpenIOWin, CloseIOWin, ReadMouse;
FROM Rasters IMPORT SetRast;
FROM Console IMPORT
OpenRConsole, CloseRConsole, PutChar, PutStr, GetChar, GetStr,
QueueRead, Conport;
FROM M2Conversions IMPORT
ConvertCardinal, ConvertReal, ConvertToReal, ConvertToCardinal;
FROM Pens IMPORT SetAPen, WritePixel, ReadPixel;
PROCEDURE DeletePlanet(wp: WindowPtr;VAR pl: ARRAY OF Pl;VAR Pnum: CARDINAL);
VAR
i,x,y : CARDINAL;
BEGIN
ReadMouse(wp,x,y);
i:= IdentifyP(x,y,Pnum,pl);
DeletePlanet1(wp,pl,i,Pnum);
END DeletePlanet;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE MakePlanet(wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;VAR Pnum,ptype: CARDINAL);
VAR
ok : BOOLEAN;
density,i,x,y : CARDINAL;
temp : Pl;
r3 : REAL;
mass : ARRAY [0..2] OF REAL;
BEGIN
mass[0]:=0.02;
mass[1]:=0.025;
mass[2]:=0.03;
ReadMouse(wp,x,y);
i:= Pnum;
IF i<15 THEN
pl[i].x:=x;
pl[i].y:=y;
ReadMouse(wp,x,y);
temp.x:=x;
temp.y:=y;
pl[i].r:= Distance(pl[i],temp);
IF pl[i].r>255 THEN pl[i].r :=255; END;
r3:= real(pl[i].r);
IF Room(pl,Sh,pl[i],Pnum,0) THEN
r3:=r3*r3*r3;
density:= Random(3);
pl[i].color:= (density*4)+4;
pl[i].m:=r3*mass[density];
WITH pl[i] DO
DrawPlanet(x,y,r,color,ptype,wp);
END;
Pnum:=i+1;
END;
END;
END MakePlanet;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE ChangePlanet(wp: WindowPtr;VAR pl: ARRAY OF Pl;Pnum,ptype: CARDINAL);
VAR
c,x,y,i : CARDINAL;
BEGIN
ReadMouse(wp,x,y);
i:= IdentifyP(x,y,Pnum,pl);
c:= pl[i].color;
IF c=4 THEN c:=8;
ELSE IF c=8 THEN c:=12;
ELSE IF c=12 THEN c:=4; END;
END;
END;
pl[i].color:=c;
WITH pl[i] DO
DrawPlanet(x,y,r,color,ptype,wp);
END;
END ChangePlanet;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE MoveShip(wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;Pnum :CARDINAL);
VAR
x,y,i : CARDINAL;
c : CHAR;
ok : BOOLEAN;
temp : Pl;
BEGIN
ReadMouse(wp,x,y);
i:= IdentifyS(x,y,Sh);
IF i< 2 THEN
deleteship(wp,Sh[i]);
ReadMouse(wp,x,y);
temp.x:=x;
temp.y:=y;
temp.r:=Sh[i].r;
ok:= Room(pl,Sh,temp,Pnum,(1+i));
IF ok THEN
Sh[i].x:= x;
Sh[i].y:= y;
END;
DrawShip(Sh[0].x,Sh[0].y,Sh[1].x,Sh[1].y,wp);
END;
END MoveShip;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE deleteship(wp: WindowPtr; p: Pl);
CONST
round = 0.83;
VAR
i,j,k,itr,nx,ny,x1,x2,y1,y2 : INTEGER;
BEGIN
WITH p DO
FOR ny:=0 TO 7 DO
x1:=x-18;
x2:=x+18;
y1:=y-ny;
y2:=y+ny;
IF x1<0 THEN x1:=0; END;
IF y1<0 THEN y1:=0; END;
IF x2>639 THEN x2:=639; END;
IF y2>399 THEN y2:=399; END;
DrawLine(x1,y1,x2,y1,0,wp);
DrawLine(x1,y2,x2,y2,0,wp);
END;
SetAPen(wp^.RPort,1);
FOR i:= 0 TO 3 DO
j:= INTEGER(Random(36))-18;
k:= INTEGER(Random(14))-7;
itr:= ReadPixel(wp^.RPort,x+j,y+k);
IF itr=0 THEN
WritePixel(wp^.RPort,x+j,y+k);
END;
END;
END;
END deleteship;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE MovePlanet(wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;Pnum,ptype :CARDINAL);
VAR
x,y,i : CARDINAL;
temp,temp1 : Pl;
ok : BOOLEAN;
BEGIN
ReadMouse(wp,x,y);
i:= IdentifyP(x,y,Pnum,pl);
temp1.x:= pl[i].x;
temp1.y:= pl[i].y;
temp1.r:= pl[i].r;
temp1.color:= pl[i].color;
temp1.m:= pl[i].m;
DeletePlanet1(wp,pl,i,Pnum);
ReadMouse(wp,x,y);
temp.x:=x;
temp.y:=y;
temp.r:=temp1.r;
ok:= Room(pl,Sh,temp,Pnum,0);
IF ok THEN
pl[Pnum].x:= x;
pl[Pnum].y:= y;
ELSE
pl[Pnum].x:=temp1.x;
pl[Pnum].y:=temp1.y;
END;
pl[Pnum].r:=temp1.r;
pl[Pnum].m:=temp1.m;
pl[Pnum].color:=temp1.color;
WITH pl[Pnum] DO
DrawPlanet(x,y,r,color,ptype,wp);
END;
Pnum:=Pnum+1;
END MovePlanet;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE DeletePlanet1(wp: WindowPtr;VAR p: ARRAY OF Pl;VAR l,Pnum:CARDINAL);
CONST
round = 0.83;
VAR
i,j,k,itr,nx,ny : INTEGER;
BEGIN
IF Pnum#0 THEN
WITH p[l] DO
DrawPlanet(x,y,r,1,0,wp);
SetAPen(wp^.RPort,1);
FOR i:= 0 TO (r DIV 5) DO
j:= INTEGER(Random(2*r))-r;
k:= INTEGER(Random(2*r))-r;
itr:= ReadPixel(wp^.RPort,x+j,y+k);
IF itr=0 THEN
WritePixel(wp^.RPort,x+j,y+k);
END;
END;
END;
Pnum:= Pnum-1;
FOR i:= l TO Pnum-1 DO
p[i].x:= p[i+1].x;
p[i].y:= p[i+1].y;
p[i].r:= p[i+1].r;
p[i].m:= p[i+1].m;
p[i].color:= p[i+1].color;
END;
END;
END DeletePlanet1;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE CleanScreen (wp: WindowPtr;VAR Sh,pl: ARRAY OF Pl;Pnum,ptype: CARDINAL);
VAR
i : CARDINAL;
BEGIN
SetRast(wp^.RPort,0);
Stars(wp);
DrawShip(Sh[0].x,Sh[0].y,Sh[1].x,Sh[1].y,wp);
WHILE (Pnum>0) DO
Pnum:= Pnum-1;
WITH pl[Pnum] DO
DrawPlanet(x,y,r,color,ptype,wp);
END;
END;
END CleanScreen;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE IdentifyP(x,y,Pnum: CARDINAL; VAR pl: ARRAY OF Pl): CARDINAL;
VAR
j,l : INTEGER;
Mouse : Pl;
i,k : CARDINAL;
BEGIN
Mouse.x := INTEGER(x);
Mouse.y := INTEGER(y);
j:= 10000;
k:= 100;
FOR i:= 0 TO (Pnum-1) DO
l:=Distance(Mouse,pl[i]);
IF j > ABS(l) THEN
k:= i;
j:= ABS(l);
END;
END;
RETURN k;
END IdentifyP;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE IdentifyS(x,y: CARDINAL; VAR Sh: ARRAY OF Pl): CARDINAL;
VAR
j,l : INTEGER;
Mouse : Pl;
i,k : CARDINAL;
BEGIN
Mouse.x := INTEGER(x);
Mouse.y := INTEGER(y);
j:= 10000;
k:= 100;
FOR i:= 0 TO 1 DO
l:=Distance(Mouse,Sh[i]);
IF j > ABS(l) THEN
k:= i;
j:= ABS(l);
END;
END;
IF j<50 THEN
RETURN k;
ELSE
RETURN 2;
END;
END IdentifyS;
(*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++*)
PROCEDURE Room(VAR Pln,Sh: ARRAY OF Pl;new: Pl;Pn,sh: CARDINAL): BOOLEAN;
VAR
i,k : INTEGER;
ok : BOOLEAN;
BEGIN
ok:=TRUE;
FOR k:=0 TO (Pn-1) DO
i:= Distance(Pln[k],new);
IF (i<(Pln[k].r+new.r)) THEN ok:=FALSE;END;
END;
IF sh<1 THEN
FOR k:=0 TO 1 DO
i:= Distance(Sh[k],new);
IF (i<(Sh[k].r+new.r)) THEN ok:=FALSE;END;
END;
ELSE
i:= Distance(Sh[1-(sh-1)],new);
IF (i<(Sh[1-(sh-1)].r+new.r)) THEN ok:=FALSE;END;
END;
RETURN ok;
END Room;
END Options.
SHAR_EOF