Chapter 8 - Sample Macros
The following is a listing of the several sample macros included with your DCAL development kit. A short description is included for each macro so that you may more easily find those which apply to your development task.
 
Sample Macro Directory
ARROW
Specifically designed as an introduction to DCAL for the beginner. The macro enters a simple arrow into a drawing made up of lines. The macro is extensively commented, explaining virtually every line of code in detail.

ATR
Demonstrates how to create symbols in a drawing, and how to add attributes to entities, symbol descriptions, and to a drawing at the system level.

CONCRETE
3D parametric macro using entities of type slab as a basic building block. The macro also contains some good examples of dragging cases.

CROP
Demonstrates how the function CLIP may be used as an editing tool, as wel* as how to perform a basic editing operation on the database.

DAFILE
Demonstrates all basic techniques necessary for operating upon a direct access, binary datafile. It uses FORMLIB for capturing and editing input data.

DOORLABL
Complete source code to theDataCAD DOORLABL macro.

DRAG
Demonstrates nearly all dragging routines available in DCAL.

ENTER3D
Demonstrates the techniques used for entering 3D entities from parallel projections (such as elevations).

FORMLIB
A reusable toolkit for entering and editing collections of data via a forms type screen input system. This library is used by the sample macros FORM, FORMATR, and DAFILE.

FORMATR
Allows the editing of sytem, symbol, and entity attributes via a forms-like interface.

FORM
Outlines the steps required for using FORMLIB to create custom input screens.

GETARC
Demonstrates the use of the function getarc which is used in many DC-Modeler menus.

HATCH
Demonstrates how to use the hatch_mode function.

LYRUTIL
Allows saving and reloading collections of layers. Primarily designed for packing large drawing files or recovering corrupted data files.

MENU3D
Demonstrates all menu calls to the 3D Viewer and DC-Modeler. PLOT Demonstrates the use of the plot_mode procedure.

POLYLINE
Demonstrates polyvert procedures and functions as well as polyline input.

REVSURF
Demonstrates techniques for creating surfaces of revolution.

READTEXT
Demonstrates techniques for reading text files and adding their contents to a drawing.

SPIRAL
The parametric SPIRAL stair macro included with DataCAD.

STAIR
The parametric STAIR macro included with DataCAD.

STUD
The parametric STUD macro for creating drawings of stud wall construction.

SYMEXP
Takes the instance of a symbol in a drawing and explodes it into individual entities.

SYMTMPLT
Examines all of the symbols in a drawing and creates a template file from the information. Particularly useful for DXF-IN operations.

VIEWMAST
Complete source code to the VIEWMAST macro included with the DC- Modeler. Demonstrates nearly all of the functions and procedures related to viewing and saved views.

WNDWLABL
The WNDWLABL macro included with DataCAD.

WRITE
Demonstrates how to scan a database and write out the entire contents of each entity to a text file. May be used as a skeleton for macros which interrogate the database and write its contents to a file in one or another form for post processing.

WRTUTL
A set of utilities for creating messages. WRTUTL is used by many of the sample macros in this collection.

Each macro is in a separate sub-directory. Many macros include a .lnk or a .bat file. The .lnk file contains the linker statement used by the dcl.exe linker. When there are more than one object file, the .lnk file simplifies the linking process. Take for example the CONCRETE macro, to link it, use the command:
 
dcl <concrete.lnk
 
The .bat files are like MAKE files in that they recompile all modules of the macro and then relink the macro. To recompile and relink the entire CONCRETE macro, type:
 
CONCRETE
 
The batch and linker files assume that each sample macro is in a separate sub-directory, and that the system includes files are in a sub- directory at the same directory level. As well, macros which use the WRTUTL library also assume that the WRTUTL subdirectory is at the same directory level.
 
MTEC ----|-- DCX ----|-- INC System includes
files
| |-- WRTUTL Message utilities
| |-- ARROW Arrow macro
| |-- CONCRETE Concrete macro
| .
| . etc.
| .
|-- DWG
|-- SUP
|-- SYM
 
|-- TPL
In each macro and in each .lnk file, the pathnames for system includes files, and for object files are designed with the above directory structure in mind. All pathnames are relative, such that the name of the DCX subdirectory is unimportant, only the location of the INC and WRTUTL directories relative to the macro source code.

Hatch
This program is a simple example of the routine hatch_mode. It uses a hardwired brick hatch pattern.

PROGRAM hatch;
 
#include '../wrtutl/wrtutl.inc'
#include '../inc/_hatch.inc'
 
CONST
ssNum = 15;
PROCEDURE getOrigin (org : IN OUT point);
VAR
done: boolean;
result : integer;
key : integer;
pt : point;
 
BEGIN
done := false;
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtlvl (Hatch);
wrtmsg (Enter hatch origin.);
result := getpoint (pt, key);
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
ELSIF result = res_normal THEN
org := pt;
done := true;
END;
UNTIL done;
END getOrigin;
 
PROCEDURE getHtype (htype : IN OUT integer);
 
VAR
done : boolean;
key : integer;
BEGIN
done := false;
REPEAT
lblsinit;
lblset ( 1, 'Normal);
lblset ( 2, 'Outer);
lblset ( 3, 'Ignore);
lblset (20, 'Exit);
lblson;
wrtlvl (Hatch);
wrtmsg (Select hatch type.);
getesc (key);
IF key = f1 THEN
htype := htype_normal;
done := true;
ELSIF key = f2 THEN
htype := htype_outer;
done := true;
ELSIF key = f3 THEN
htype := htype_ignore;
done := true;
ELSIF key = s0 THEN
done := true;
END;
UNTIL done;
END getHtype;
 
PROCEDURE hatch_main;
VAR
sl : scanLineType;
done : boolean;
result : integer;
brk : integer;
key : integer;
mode : mode_type;
mode1 : mode_type;
ent : entity;
addr : entaddr;
minPt : point;
maxPt : point;
min1 : point;
max1 : point;
frst : boolean;
ang : real;
scale : real;
org : point;
htype : integer;
BEGIN
done := false;
setpoint (org, 0.0);
ang := 0.0;
htype := htype_normal;
scale := 1.0;
REPEAT
REPEAT
lblsinit;
lblset (10, 'HtchType);
lblset (12, 'Scale);
lblset (13, 'Angle);
lblset (14, 'Origin);
lblset (20, 'Exit);
wrtlvl (Hatch);
result := getmode (hatch', mode, key);
IF result = res_escape THEN
IF key = f0 THEN
getHtype (htype);
ELSIF key = s2 THEN
wrtmsg (Enter hatch scale: );
getrll (scale);
ELSIF key = s3 THEN
wrtmsg (Enter hatch angle: );
getang (ang);
ELSIF key = s4 THEN
getOrigin (org);
ELSIF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
{ find the extents of the entities and
place them into a selection set }
ssClear (ssNum);
frst := true;
addr := ent_first (mode);
WHILE ent_get (ent, addr) DO
addr := ent_next (ent, mode);
ssAdd (ssNum, ent);
ent_extent (ent, min1, max1);
IF frst THEN
minPt := min1;
maxPt := max1;
frst := false;
ELSE
minPt.x := min (min1.x, minPt.x);
minPt.y := min (min1.y, minPt.y);
minPt.z := min (min1.z, minPt.z);
maxPt.x := max (max1.x, maxPt.x);
maxPt.y := max (max1.y, maxPt.y);
maxPt.z := max (max1.z, maxPt.z);
END;
END;
brk := 0;
mode_init (mode);
mode_ss (mode, ssNum);
{ get the entities out of the selection set}
{ draw the horizontal lines 2 2/3 inches apart }
sl.ang := 0.0;
setpoint (sl.origin, 0.0);
sl.delta.x := 0.0;
sl.delta.y := 2.6667 * 32.0;
sl.numdash := 0;
hatch_mode (mode, sl, zbase, zhite, org,
ang, scale, htype,
getlyrcurr, minPt, maxPt, true, brk, true);
{ draw the vertical (dashed) lines every 8 inches }
sl.ang := halfpi; { oriented vertically }
setpoint (sl.origin, 0.0);
sl.delta.x := 2.6667 * 32.0;
sl.delta.y := 4.0 * 32.0;
sl.numdash := 2;
sl.dash [1] := 2.6667 * 32.0;
sl.dash [2] := 2.6667 * 32.0;
sl.dashDraw [1] := true;
sl.dashDraw [2] := false;
hatch_mode (mode, sl, zbase, zhite, org,
ang, scale, htype,
getlyrcurr, minPt, maxPt, true, brk, true);
ssClear (ssNum);
END;
UNTIL done;
END hatch_main;
 
BEGIN
hatch_main;
END hatch.
Plot1
This program gives examples of the plotter routines available through a DCAL macro.
 
PROGRAM plot1;
 
#include '../wrtutl/wrtutl.inc'
#include '../inc/_plot.inc'
 
VAR
done : boolean;
key : integer;
cent : point;
wndwMin : point;
wndwMax : point;
vwptMin : point;
vwptMax : point;
tofile : boolean;
fname : str80;
paperx : real;
papery : real;
init : boolean;
ang : real;
ManyPens : boolean;
PROCEDURE getPaper (size : integer; custx, custy : real;
x, y : IN OUT real);
BEGIN
IF size = 1 THEN
x := 10.5;
y := 8.0;
ELSIF size = 2 THEN
x := 16.0;
y := 10.0;
ELSIF size = 3 THEN
x := 21.0;
y := 16.0;
ELSIF size = 4 THEN
x := 33.0;
y := 21.0;
ELSIF size = 5 THEN
x := 43.0;
y := 33.0;
ELSE
x := custx;
y := custy;
END;
x := x * 32.0; { convert from inches to world coords }
y := y * 32.0; { convert from inches to world coords }
END getPaper;
PROCEDURE wrtPaperErr;
BEGIN
errStart;
errDis (paperx);
errStr ( );
errDis (papery);
errShow;
END wrtPaperErr;
 
PROCEDURE doplot;
 
VAR
 
plot : plot_type;
mode : mode_type;
key : integer;
 
BEGIN
IF plot_open (pltpenwidth, pltpenspeed, paperx, papery,
tofile, 'test.plt', 1, plot) = fl_ok THEN
wrterr (ok);
wrtmsg (Plotting...);
mode_init (mode);
mode_lyr (mode, lyr_on);
plot_mode (plot, mode, ManyPens, pltpensort, pltcolor,
vwptMin, vwptMax, wndwMin, wndwMax, cent, ang);
plot_close (plot);
END;
END doplot;
 
PROCEDURE getVwpt (min, max : IN OUT point);
 
VAR
minPt,
maxPt : point;
screenRatio : real;
paperRatio : real;
minBox,
maxBox : point;
done : boolean;
key : integer;
result : integer;
pt1 : point;
pt2 : point;
pt3 : point;
 
BEGIN
IF (absr (wndwMax.x - wndwMin.x) < 0.01) OR
(absr (wndwMax.y - wndwMin.y) < 0.01) THEN
wrterr (Invalid window, select window first.);
ELSE
{ draw the sheet of paper on the screen }
vwptClear;
currWndw (minPt, maxPt);
screenRatio := (maxPt.x - minPt.x) /
(maxPt.y - minPt.y);
paperRatio := paperx / papery;
IF paperRatio < screenRatio THEN
ELSE
END;
done := false;
REPEAT
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtmsg (Enter first corner of viewport.);
result := getpoint (pt1, key);
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtmsg (Enter second corner of viewport.);
ratioBox := true;
ratioRatio := (wndwMax.x -
wndwMin.x)/(wndwMax.y - wndwMin.y);
rubbx := true;
result := getpoint (pt2, key);
ratioBox := false;
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtmsg (Position viewport.);
minBox.x := pt1.x - pt2.x;
minBox.y := pt1.y - pt2.y;
setPoint (maxBox, 0.0);
setpoint (pt3, 0.0);
dragBoxMove (pt3, minBox, maxBox,
linecolor);
result := getpoint (pt3, key);
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
END;
END;
END;
UNTIL done;
wrtmsg (Enter vwptMin.x: );
getdis (min.x);
wrtmsg (Enter vwptMin.y: );
getdis (min.y);
wrtmsg (Enter vwptMax.x: );
getdis (max.x);
wrtmsg (Enter vwptMax.y: );
getdis (max.y);
END;
END getVwpt;
 
PROCEDURE getWndw (min, max : IN OUT point);
 
VAR
done : boolean;
key: integer;
result : integer;
pt1: point;
pt2: point;
 
BEGIN
done := false;
REPEAT
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtmsg (Enter first corner of window.);
result := getpoint (pt1, key);
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtmsg (Enter second corner of window.);
rubbx := true;
result := getpoint (pt2, key);
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
order (pt1.x, pt2.x, min.x, max.x);
order (pt1.y, pt2.y, min.y, max.y);
{ if we entered both points, get out }
done := true;
ELSE
{ if we pressed exit, go back to the
previous loop }
done := false;
END;
END;
UNTIL done;
END getWndw;
 
PROCEDURE extra;
 
VAR
done : boolean;
key : integer;
BEGIN
done := false;
REPEAT
lblsinit;
lblset ( 1, 'Plot);
lblsett ( 2, 'To File', tofile);
lblset ( 3, 'Vwpt);
lblset ( 4, 'Wndw);
lblset ( 5, 'Paper);
lblset (20, 'Exit);
lblson;
wrtmsg (Select plotter function.);
wrtPaperErr;
getesc (key);
IF key = f1 THEN
doPlot;
ELSIF key = f2 THEN
tofile := NOT tofile;
ELSIF key = f3 THEN
getVwpt (vwptMin, vwptMax);
ELSIF key = f4 THEN
getWndw (wndwMin, wndwMax);
ELSIF key = f5 THEN
ELSIF key = s0 THEN
done := true;
END;
UNTIL done;
END extra;
 
PROCEDURE layout;
VAR
done : boolean;
pt : point;
key: integer;
result : integer;
min: point;
max: point;
str: str80;
fac: real;
BEGIN
done := false;
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
wrtlvl (Layout);
wrtmsg (Enter center of plot.);
getPaper (pltPSize, pltPCustx, pltPCusty,
paperx, papery);
scale_get (pltScaleNum, fac, str);
setpoint (pt, 0.0);
min.x := -paperx / 2.0 / fac;
min.y := -papery / 2.0 / fac;
max.x := -min.x;
max.y := -min.y;
dragBoxMove (pt, min, max, linecolor);
result := getpoint (pt, key);
IF result = res_escape THEN
IF key = s0 THEN
done := true;
END;
END;
UNTIL done OR (result = res_normal);
IF NOT done THEN
pltcentx := pt.x;
pltcenty := pt.y;
END;
END layout;
 
PROCEDURE doplotData;
VAR
vwptMin : point;
vwptMax : point;
wndwMin : point;
wndwMax : point;
str : str80;
fac : real;
plot : plot_type;
mode : mode_type;
cent : point;
ang : real;
 
BEGIN
getPaper (pltPSize, pltPCustx, pltPCusty,
paperx, papery);
scale_get (pltScaleNum, fac, str);
vwptmin.x := 0.0;
vwptmin.y := 0.0;
vwptmax.x := paperx;
vwptmax.y := papery;
wndwMin.x := pltCentx - paperx / 2.0 / fac;
wndwMin.y := pltCenty - papery / 2.0 / fac;
wndwMax.x := pltCentx + paperx / 2.0 / fac;
wndwMax.y := pltCenty + papery / 2.0 / fac;
setpoint (cent, 0.0);
ang := 0.0;
IF plot_open (pltpenwidth, pltpenspeed,
paperx, papery, false, 'test.plt', 1, plot)
= fl_ok THEN
wrterr (ok);
wrtmsg (Plotting...);
mode_init (mode);
mode_lyr (mode, lyr_on);
plot_mode (plot, mode, ManyPens, pltpensort, pltcolor,
vwptMin, vwptMax, wndwMin, wndwMax, cent, ang);
plot_close (plot);
END;
END doplotData;
 
PROCEDURE scale;
 
VAR
i : integer;
str : str80;
done : boolean;
fac : real;
 
BEGIN
done := false;
REPEAT
lblsinit;
FOR i := 1 TO 18 DO
scale_get (i, fac, str);
lblset (i, str);
cvrllst (fac, str);
lblmsg (i, str);
END;
lblset (20, 'NoChange);
lblson;
wrtlvl (Scale);
wrtmsg (Select plotter scale.);
getesc (key);
i := fnKeyConv (key);
IF ((1 <= i) AND (i <= 18)) THEN
pltScaleNum := i;
done := true;
ELSIF key = s0 THEN
done := true;
END;
UNTIL done;
END scale;
 
PROCEDURE doPaper;
 
VAR
done: boolean;
key : integer;
result : integer;
r : real;
 
BEGIN
done := false;
REPEAT
lblsinit;
lblsett ( 1, '8.5x11A', pltPsize = 1);
lblsett ( 2, '11x17 B', pltPsize = 2);
lblsett ( 3, '18x24 C', pltPsize = 3);
lblsett ( 4, '24x36 D', pltPsize = 4);
lblsett ( 5, '36x48 E', pltPsize = 5);
lblsett ( 7, ' Custom', pltPsize = 6);
lblset (20, 'NoChange);
lblson;
wrtlvl (PaperSiz);
wrtmsg (Select paper size.);
getPaper (pltPSize, pltPCustx, pltPCusty,
paperx, papery);
wrtPaperErr;
getesc (key);
IF key = f1 THEN
pltPsize := 1;
ELSIF key = f2 THEN
pltPsize := 2;
ELSIF key = f3 THEN
pltPsize := 3;
ELSIF key = f4 THEN
pltPsize := 4;
ELSIF key = f5 THEN
pltPsize := 5;
ELSIF key = f7 THEN
wrtmsg (Enter plotting width ("X" axis):);
r := pltPcustx * 32.0;
getdis (r);
pltPcustx := r / 32.0;
wrtmsg (Enter plotting height ("Y" axis):);
r := pltPcusty * 32.0;
getdis (r);
pltPcusty := r / 32.0;
pltPsize := 6; { custom }
ELSIF key = s0 THEN
done := true;
END;
UNTIL done;
END doPaper;
 
VAR
str : str80;
str1 : str80;
i : integer;
fac : real;
 
BEGIN
done := false;
IF NOT init THEN
getPaper (pltPSize, pltPCustx, pltPCusty,
paperx, papery);
tofile := false;
fname := '';
setpoint (vwptMin, 0.0);
vwptMax.x := paperx;
vwptMax.y := papery;
setpoint (wndwMin, 0.0);
setpoint (wndwMax, 0.0);
setpoint (cent, 0.0);
ang := 0.0;
ManyPens := false;
init := true;
END;
REPEAT
lblsinit;
lblset ( 1, 'Plot);
lblmsg ( 1, 'Plot all layers that are
turned on.);
lblset ( 2, 'Backgrnd);
lblmsg ( 2, 'Background plotting.);
lblset ( 3, 'To File);
lblset ( 4, 'Scale);
str := 'Current scale = ';
scale_get (pltScaleNum, fac, str1);
strcat (str, str1);
lblmsg ( 4, str);
lblset ( 5, 'PaperSiz);
lblset ( 6, 'PenSpeed);
lblmsg ( 6, 'Set plotter pen speed.);
lblset ( 7, 'PenWidth);
lblmsg ( 7, 'Set plotter pen width.);
lblset ( 8, 'Partial);
lblset ( 9, 'Layout);
lblset (10, 'Lyout Sz);
lblset (11, 'LyoutDiv);
lblsett (12, 'Rotate', pltRot);
lblsett (13, 'ClrPlot', pltColor);
IF ManyPens AND pltColor THEN
lblset (14, 'Set Pens);
lblsett (15, 'PenSort', pltpensort);
END;
lblsett (16, 'ManyPens', ManyPens);
lblset (19, 'extra);
lblset (20, 'Exit);
lblson;
wrtlvl (Plotter);
wrtmsg (Select plotter function.);
getesc (key);
IF key = f1 THEN
doplotData;
ELSIF key = f2 THEN
ELSIF key = f3 THEN
ELSIF key = f4 THEN
scale;
ELSIF key = f5 THEN
doPaper;
ELSIF key = f6 THEN
wrtlvli (146 {'PenSpeed'});
wrtmsgi (172);
i := pltpenspeed;
getint (i);
pltpenspeed := absi (i);
ELSIF key = f7 THEN
ELSIF key = f8 THEN
ELSIF key = f9 THEN
layout;
ELSIF key = f0 THEN
ELSIF key = s1 THEN
ELSIF key = s2 THEN
ELSIF key = s3 THEN
pltColor := NOT pltColor;
ELSIF key = s4 THEN
IF pltColor AND ManyPens THEN
END;
ELSIF key = s5 THEN
pltpensort := NOT pltpensort;
ELSIF key = s6 THEN
ManyPens := NOT ManyPens;
ELSIF key = s9 THEN
extra;
ELSIF key = s0 THEN
done := true;
END;
UNTIL done;
END plot1.
 
Stair
PROGRAM stair;
 
VAR
str1 : string (80);
str : string (20);
ch : char;
init,
getout,
done1,
done : boolean;
result,
clr,
oldcolor,
stairtype,
key : integer;
stairnum,
numrisers : integer;
angle1, { angle up stairs }
angle2: real;{ angle across stairs }
cent1,
cent,
pt1,
pt2,
pt3,
pt4 : point;
zstart,
riserheight,
depth,
width : real;
 
{
*************************************
* *
* <- depth ->*
* *
* pt4-------pt3 *
* | ^ |*
* | | |*
* | | |*
* | w |*
* | i |*
* | d |*
* | t |*
* | h |*
* | | |*
* | | |*
* | v |*
* pt1-------pt2 *
* *
*************************************
}
 
PROCEDURE addriser (pt1, pt2, pt3, pt4 : point;
num : integer);
 
CONST
zero = 0.0;
 
VAR
ent : entity;
 
BEGIN
ent_init (ent, entblk);
ent.blkpnt [ 1].x := pt1.x;
ent.blkpnt [ 1].y := pt1.y;
ent.blkpnt [ 1].z := zstart + (float (num) *
riserheight);
ent.blkpnt [ 2].x := pt2.x;
ent.blkpnt [ 2].y := pt2.y;
ent.blkpnt [ 2].z := zstart + (float (num) *
riserheight);
ent.blkpnt [ 3].x := pt4.x;
ent.blkpnt [ 3].y := pt4.y;
ent.blkpnt [ 3].z := zstart + (float (num) *
riserheight);
ent.blkpnt [ 4].x := pt1.x;
ent.blkpnt [ 4].y := pt1.y;
ent.blkpnt [ 4].z := zstart + (float (num) *
riserheight) + riserheight;
ent_add (ent);
ent_draw (ent, drmode_white);
END addriser;
 
PROCEDURE doesc (key : integer; getout : OUT
boolean);
 
BEGIN
IF key = f1 THEN
wrterr (Drawing stairs by left side.);
stairtype := 1;
ELSIF key = f2 THEN
wrterr (Drawing stairs by right side.);
stairtype := 2;
ELSIF key = f3 THEN
wrterr (Drawing stairs by center line.);
stairtype := 3;
ELSIF key = f5 THEN
wrtmsg (Enter the number of risers: );
getint (numrisers);
ELSIF key = f6 THEN
wrtmsg (Enter the width of the stairs: );
getdis (width);
ELSIF key = f7 THEN
wrtmsg (Enter the height of the risers: );
getdis (riserheight);
ELSIF key = f8 THEN
wrtmsg (Enter the depth of tread: );
getdis (depth);
ELSIF key = f9 THEN
wrtmsg (Select color of stairs.);
getclr (clr);
ELSIF key = f0 THEN
wrtmsg (Enter the starting height of the
stairs: );
getdis (zstart);
ELSIF key = s0 THEN
getout := true;
END;
END doesc;
 
PROCEDURE setkeys;
 
BEGIN
lblsinit;
lblsett ( 1, ' Left', (stairtype = 1));
lblsett ( 2, ' Right', (stairtype = 2));
lblsett ( 3, ' Center', (stairtype = 3));
lblset ( 5, 'NumRisrs);
lblset ( 6, 'Width);
lblset ( 7, 'Height);
lblset ( 8, 'Depth);
lblset ( 9, 'Color);
lblset (10, 'Start Ht);
lblset (20, 'Exit);
lblson;
END setkeys;
 
PROCEDURE get_point1;
 
BEGIN
REPEAT
setkeys;
IF stairtype = 3 THEN
str := 'center';
ELSIF stairtype = 1 THEN
str := 'left side';
ELSE
str := 'right side';
END;
str1 := 'Enter ';
strcat (str1, str);
strcat (str1, ' of stairs at bottom.);
wrtmsg (str1);
result := getpoint (cent, key);
IF result = res_escape THEN
doesc (key, getout);
END;
UNTIL (result = res_normal) OR getout;
END get_point1;
PROCEDURE get_point2;
 
BEGIN
REPEAT
lblsinit;
lblset (20, 'Exit);
lblson;
str1 := 'Enter another point on the ';
strcat (str1, str);
strcat (str1, ' of the stairs.);
wrtmsg (str1);
rubln := true;
result := getpoint (cent1, key);
IF result = res_escape THEN
IF key = s0 THEN
getout := true;
END;
END;
UNTIL (result = res_normal) OR getout;
END get_point2;
 
PROCEDURE setitup;
 
BEGIN
light (true);
lblsinit;
lblset ( 8, '********);
lblset (10, 'WORKING);
lblset (12, '********);
lblson;
wrtmsg (Constructing stairs, please wait.);
angle1 := angle (cent, cent1);
angle2 := angle1 - radians (90.0);
{ calculate the first point, from now on, all
of the cases are the same }
IF stairtype = 3 THEN
{ we have the center, move to the left half the width }
polar (cent, angle2, -width / 2.0, pt1);
ELSIF stairtype = 1 THEN
{ we already have the left, don't need to calculate anything }
pt1 := cent;
ELSE
{ we have the right side, move to the left by an entire stair width }
polar (cent, angle2, -width, pt1);
END;
oldcolor := linecolor;
linecolor := clr;
stairnum := 1;
END setitup;
 
PROCEDURE doit;
 
BEGIN
stopgroup;
WHILE stairnum <= numrisers DO
polar (pt1, angle1, depth, pt2);
polar (pt1, angle2, width, pt4);
polar (pt2, angle2, width, pt3);
addriser (pt1, pt2, pt3, pt4, stairnum -1);
pt1 := pt2;
stairnum := stairnum + 1;
END;
stopgroup;
light (false);
 
END doit;
 
PROCEDURE initialize;
 
BEGIN
stairtype := 1;
clr := linecolor;
numrisers := 12;
width := 1536.0;
riserheight := 192.0;
depth := 256.0;
zstart := 0.0;
init := true;
END initialize;
 
BEGIN
{ set up defaults }
IF NOT init THEN
initialize;
END;
getout := false;
wrtlvl (Stair);
REPEAT
get_point1;
IF NOT getout THEN
get_point2;
IF NOT getout THEN
setitup;
doit;
linecolor := oldcolor;
END;
END;
UNTIL getout;
END stair.