home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Oakland CPM Archive
/
oakcpm.iso
/
sigm
/
vol194
/
graf2.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1984-10-17
|
18KB
|
486 lines
{************************************************************************
* *
* Copyright 1984 by *
* Thomas E. Speer *
* All rights reserved *
* *
* This file provides the ability to draw graphics characters, *
* plot axes, and do whole rectangular grids. *
* *
************************************************************************}
{------------------------------------------------------------------------}
PROCEDURE chset( xsize, ysize, theta: REAL );
{ This procedure sets the character size and orientation
inputs:
xsize horizontal size of character
ysize vertical size of character
theta clockwise rotation of character (0 := upright)
outputs:
none returned
}
VAR
t: REAL;
BEGIN
chxsz := xsize;
chysz := ysize;
chrot := theta;
t := theta/57.29578;
scale[3] := cos( t );
scale[4] := sin( t );
END;
{------------------------------------------------------------------------}
FUNCTION posang ( angle:REAL ):REAL;
{ This function returns an angle that is in the range 0 to 360 deg.
inputs:
angle angle to be converted
outputs:
posang converted angle
}
BEGIN
IF ( (angle < 360.0) AND (angle >= 0.0)) THEN
posang := angle
ELSE BEGIN
angle := angle - 360.0 * Trunc(angle/360.0);
IF (angle < 0.0 ) THEN angle := angle + 360.;
posang := angle;
END
END;
{------------------------------------------------------------------------}
PROCEDURE ticend( rmin,rmax, dr:REAL; VAR pr1,pr2:REAL );
{ This function calculates endpoints which are multiples of dr and
lie between rmin and rmax.
inputs:
rmin,rmax range of values along axis
dr increment used for axis
outputs:
*pr1,*pr2 new values corresponding to rmin,rmax
}
VAR
r1,r2:REAL;
BEGIN
r1 := Trunc( rmin/dr) * dr;
r2 := Trunc( rmax/dr) * dr;
IF ( (r1 < 0.0) OR (r2 < 0.0) ) THEN BEGIN
IF ((r1>0.0) OR (r2>0.0)) THEN BEGIN
pr1 := r1;
pr2 := r2;
END
ELSE BEGIN
IF ((dr<0.0) AND (r1>rmin)) THEN r1 := r1 + dr;
IF ((dr>0.0) AND (r2>rmax)) THEN r2 := r2 - dr;
END
END
ELSE BEGIN
IF ((dr>0.0) AND (r1<rmin)) THEN r1 := r1 + dr;
IF ((dr<0.0) AND (r2<rmax)) THEN r2 := r2 - dr;
END;
pr1 := r1;
pr2 := r2;
END;
{------------------------------------------------------------------------}
FUNCTION dxdy( x1,x2:REAL; nx:INTEGER; VAR lblnum,lbldec:INTEGER ):REAL;
{ This function calculates a good engineering value for the
increment between tic marks on an axis.
inputs:
x1,x2 minimum and maximum values to associated w/ axis
nx approximate number of intervals for axis
outputs:
dxdy increment between tic marks
lblnum number of characters required for labels
lbldec number of characters after decimal point
}
VAR
xlen,dx,dxlog,dxmant,t,ln10: REAL;
dxexp: INTEGER;
BEGIN
ln10 := ln(10.0);
xlen := x2-x1;
IF (xlen = 0.0) THEN BEGIN
write(CON, 'zero length axis in dxdy. 0 returned');
lbldec := 0;
lblnum := 0;
dxdy := 0;
END
ELSE BEGIN
dx := Abs( xlen/nx ); { calculate raw dx }
dxlog := ln(dx)/ln10;
dxexp := Trunc(dxlog);
dxmant := dxlog - dxexp;
IF (dxmant <= 0.0) THEN BEGIN
dxexp := dxexp - 1;
dxmant := dxmant + 1;
END;
dx := 1.; { select good engr. values }
IF (dxmant > 0.18) THEN
dx := 2.;
IF (dxmant > 0.40) THEN
dx := 5.;
IF (dxmant > 0.88) THEN
dx := 10.0;
dx := dx * exp( ln10*dxexp ) * xlen/Abs( xlen );
dxlog := xlen; { how many digits in numbers? }
IF (x1 <> 0.0) THEN BEGIN
t := Abs( x1);
IF (t > dxlog) THEN dxlog :=t;
END;
IF (x2 <> 0.0) THEN BEGIN
t := Abs( x2);
IF (t > dxlog) THEN dxlog := t;
END;
dxlog := ln(dxlog)/ln10;
IF (dxlog > 0.0 ) THEN
lblnum := Trunc( dxlog + 1.0 )
ELSE
lblnum := 0;
dxlog := Abs( xlen); { now get f format spec }
IF (x1 <> 0.0) THEN BEGIN
t := Abs( x1);
IF (t < dxlog) THEN dxlog := t;
END;
IF (x2 <> 0.0) THEN BEGIN
t := Abs( x2);
IF (t < dxlog) THEN dxlog := t;
END;
t := Abs( dx);
IF (t < dxlog) THEN dxlog := t;
dxlog := ln(dxlog)/ln10;
IF (dxlog < 0.0) THEN
lbldec := Trunc( -dxlog + 1.0 )
ELSE
lbldec := 0;
lblnum := lblnum + lbldec + 2;
dxdy := dx;
END
END;
{------------------------------------------------------------------------}
PROCEDURE gchar( cx,cy:REAL ;charin:CHAR );
{ This procedure will plot a graphic character at an arbitrary
size and orientation.
inputs:
cx,cy coordinates for lower left corner of char.
charin character to be plotted
outputs:
none returned
Note: The elements of tchar have a specific format. The lower 4
bits contain the Y coordinate, the next 3 bits the X
coordinate, and the high bit indicates whether or not the byte
corresponds to a move or a line ("pen up" or "pen down"). The
value 255 signals the end of the sequence of segments for a
character.
}
CONST
tchar:ARRAY [1..721] of BYTE = ( { 721 elements }
255, 56, 181, 51, 178, 255, 40, 166, 72, 198, 255, 40,
162, 72, 194, 6, 230, 4, 228, 255, 56, 178, 87, 151,
134, 149, 213, 228, 211, 147, 255, 104, 130, 8, 168, 166,
134, 136, 68, 228, 226, 194, 196, 255, 98, 151, 168, 184,
199, 198, 148, 147, 162, 178, 212, 255, 6, 151, 152, 136,
135, 151, 255, 72, 182, 180, 194, 255, 40, 182, 180, 162,
255, 21, 213, 39, 195, 71, 163, 255, 55, 179, 21, 213,
255, 17, 162, 163, 147, 146, 162, 255, 21, 213, 255, 34,
163, 147, 146, 162, 255, 88, 146, 255, 40, 200, 214, 212,
194, 162, 148, 150, 168, 255, 38, 184, 178, 34, 194, 255,
23, 168, 200, 215, 214, 147, 146, 210, 255, 23, 168, 200,
215, 214, 197, 212, 211, 194, 162, 147, 255, 72, 194, 55,
148, 212, 255, 88, 152, 150, 198, 213, 211, 194, 162, 147,
255, 87, 200, 168, 151, 147, 162, 194, 211, 212, 197, 165,
148, 255, 24, 216, 162, 255, 37, 197, 212, 211, 194, 162,
147, 148, 165, 150, 151, 168, 200, 215, 214, 197, 255, 19,
162, 194, 211, 215, 200, 168, 151, 150, 165, 197, 214, 255,
23, 167, 166, 150, 151, 20, 164, 163, 147, 148, 255, 17,
162, 163, 147, 146, 162, 22, 166, 165, 149, 150, 255, 87,
149, 211, 255, 22, 214, 20, 212, 255, 23, 213, 147, 255,
23, 168, 200, 215, 214, 180, 50, 177, 255, 23, 168, 200,
215, 211, 194, 162, 147, 148, 165, 181, 178, 255, 2, 184,
226, 20, 212, 255, 5, 197, 212, 211, 194, 130, 136, 200,
215, 214, 197, 255, 87, 200, 152, 135, 131, 146, 194, 211,
255, 2, 136, 200, 214, 212, 194, 130, 255, 88, 136, 130,
210, 53, 133, 255, 88, 136, 130, 53, 133, 255, 87, 200,
152, 135, 131, 146, 194, 211, 213, 181, 255, 2, 136, 88,
210, 85, 133, 255, 40, 200, 56, 178, 34, 194, 255, 20,
147, 162, 178, 195, 200, 56, 216, 255, 8, 130, 88, 133,
210, 255, 24, 146, 210, 255, 2, 136, 181, 232, 226, 255,
2, 136, 226, 232, 255, 7, 152, 216, 231, 227, 210, 146,
131, 135, 255, 2, 136, 200, 215, 214, 197, 133, 255, 7,
152, 216, 231, 228, 194, 146, 131, 135, 68, 226, 255, 2,
136, 200, 215, 214, 197, 133, 53, 210, 255, 87, 200, 152,
135, 134, 149, 197, 212, 211, 194, 146, 131, 255, 8, 232,
56, 178, 255, 24, 147, 162, 194, 211, 216, 255, 8, 178,
232, 255, 8, 146, 181, 210, 232, 255, 8, 226, 104, 130,
255, 24, 180, 178, 88, 180, 255, 8, 232, 130, 226, 255,
88, 184, 178, 210, 255, 24, 210, 255, 24, 184, 178, 146,
255, 22, 184, 214, 255, 0, 224, 255, 102, 215, 216, 232,
231, 215, 255, 5, 150, 182, 197, 195, 178, 146, 131, 148,
196, 67, 210, 255, 24, 146, 194, 211, 212, 197, 149, 255,
85, 165, 148, 147, 162, 210, 255, 88, 210, 162, 147, 148,
165, 213, 255, 82, 162, 147, 148, 165, 197, 212, 148, 255,
87, 200, 184, 167, 162, 21, 197, 255, 17, 160, 176, 193,
197, 165, 148, 147, 162, 194, 255, 18, 152, 21, 181, 196,
194, 255, 50, 181, 55, 184, 255, 18, 145, 160, 176, 193,
197, 71, 200, 255, 24, 146, 20, 199, 37, 210, 255, 40,
184, 178, 34, 194, 255, 2, 133, 4, 149, 165, 180, 178,
52, 197, 213, 228, 226, 255, 18, 149, 20, 165, 197, 212,
210, 255, 20, 165, 197, 212, 211, 194, 162, 147, 148, 255,
16, 149, 197, 212, 211, 194, 146, 255, 80, 213, 165, 148,
147, 162, 210, 255, 18, 149, 20, 165, 181, 196, 255, 19,
162, 194, 211, 196, 164, 149, 166, 198, 213, 255, 40, 163,
178, 194, 211, 212, 22, 182, 255, 21, 147, 162, 194, 211,
213, 83, 226, 255, 21, 178, 213, 255, 21, 162, 180, 194,
213, 255, 21, 194, 18, 197, 255, 21, 178, 85, 178, 161,
144, 255, 21, 213, 146, 210, 255, 72, 184, 167, 166, 149,
164, 163, 178, 194, 255, 48, 184, 255, 40, 184, 199, 198,
213, 196, 195, 178, 162, 255, 7, 152, 168, 198, 214, 231,
255 );
ichar:ARRAY [1..95] of INTEGER = ( { 95 elements }
1, 2, 7, 12, 21, 32, 45, 57, 64, 69, 74, 81,
86, 93, 96, 102, 105, 115, 121, 130, 142, 148, 158, 171,
175, 192, 205, 216, 228, 232, 237, 241, 250, 263, 269, 281,
290, 298, 305, 311, 322, 329, 336, 345, 351, 355, 361, 366,
376, 384, 396, 406, 419, 424, 431, 435, 441, 446, 452, 457,
462, 465, 470, 474, 477, 484, 497, 505, 512, 520, 529, 537,
548, 555, 560, 569, 576, 582, 595, 603, 613, 621, 629, 636,
647, 656, 665, 669, 675, 680, 687, 692, 702, 705, 715 );
VAR
schar,cmd,ix,iy: BYTE;
i: INTEGER;
x,y,t: REAL;
BEGIN
schar := Ord(charin) AND 127;
IF (schar >= 32) THEN BEGIN
i := schar - 31;
i := ichar[i];
WHILE tchar[i] < 255 DO BEGIN
cmd := tchar[i];
i := i + 1;
iy := cmd AND 15;
ix := cmd AND 112;
ix := ix DIV 16;
x := ix * chxsz / 7.0;
y := iy * chysz / 9.0;
t := x;
x := cx + scale[3]*t - scale[4]*y;
y := cy + scale[4]*t + scale[3]*y;
IF (cmd < 128) THEN
gmove( x,y )
ELSE
vector( x,y )
END
END
END;
{------------------------------------------------------------------------}
PROCEDURE gwrite(x,y:REAL ;chars:textline; nchar:INTEGER);
{ This function plots a string of graphic characters with the
preset orientation and size.
inputs:
x,y coordinates for start of string (bottom left corner)
chars string to be plotted
outputs:
none returned
}
VAR
i: INTEGER;
BEGIN
FOR i := 1 TO nchar DO BEGIN
gchar( x, y, chars[i] );
x := x + chxsz*scale[3];
y := y + chxsz*scale[4];
END
END;
{------------------------------------------------------------------------}
PROCEDURE axis(r1,r2,dri,sx1,sy1,sx2,sy2,ticlen,ticang: REAL;
lblnum,lbldec: INTEGER; lblang: REAL);
{ This procedure plots and labels a linear graph axis
inputs:
r1 real world value at start of axis
r2 real world value at end of axis
dri real world increment for labels
sx1,sy1 screen coordinates of start of axis
sx2,sy2 screen coordinates at end of axis
ticlen length of tic marks (screen units 0.0-->1.0)
ticang angle between horizontal and tic marks
lblnum number of characters in labels
lbldec number of digits right of decimal place
lblang angle between horizontal and labels
outputs:
none returned
}
VAR
angtic,anglbl,lentic,xlen,ylen,rlen,dr,rtic,rend,xtic,ytic,
angtst,xlabel,ylabel,t,radian,x,y,dtic: REAL;
alabel: STRING[20];
stemp: STRING[6];
BEGIN
radian := 57.29578;
IF ((dri = 0.0) OR (r2-r1 = 0.0)) THEN BEGIN
Write(CON, 'Zero value for real length or increment. Axis not plotted');
END
ELSE BEGIN
IF (lblnum < 7) THEN lblnum := 7;
IF ( ((r1<0.0) OR (r2<0.0)) AND (lblnum<8) ) THEN lblnum := 8;
angtic := ticang;
IF (ticlen < 0.0) THEN angtic := -angtic;
angtic := posang (angtic);
anglbl := posang (lblang);
lentic := Abs( ticlen );
xlen := sx2-sx1;
ylen := sy2-sy1;
rlen := r2-r1;
dr := Abs( dri ) * Abs( rlen )/rlen;
ticend(r1,r2,dr,rtic,rend);
angtst := posang(angtic - anglbl);
angtic := angtic/radian;
anglbl := anglbl/radian;
xtic := lentic * cos( angtic );
ytic := lentic * sin( angtic );
scale[3] := cos( anglbl );
scale[4] := sin( anglbl );
{ calculate offsets for labels }
IF ( (angtst < 45.0) OR { tic is "left" of label }
(angtst >= 315.0) ) THEN BEGIN
xlabel := ( chxsz*scale[3] + chysz*scale[4])/2.0;
ylabel := (-chysz*scale[3] - chxsz*scale[4])/2.0;
END
ELSE IF ( angtst < 135.0) THEN BEGIN { tic is "below" label }
t := (lblnum-lbldec-1) * chxsz;
xlabel := -t*scale[3] - chysz*scale[4]/2.0;
ylabel := -t*scale[4] + chysz*scale[3]/2.0;
END
ELSE IF ( angtst < 225.0) THEN BEGIN { tic is "right" of label }
t := ( lblnum + 0.5 ) *chxsz;
xlabel := -scale[4]*chysz/2.0 - t*scale[3];
ylabel := -scale[3]*chysz/2.0 - t*scale[4];
END
ELSE IF ( angtst < 315.0) THEN BEGIN { tic is "above" label }
t := (lblnum-lbldec-1) * chxsz;
xlabel := -t*scale[3] + chysz*scale[4]*1.5;
ylabel := -t*scale[4] - chysz*scale[3]*1.5;
END;
{ Draw Axis }
segmnt( sx1,sy1, sx2,sy2 );
WHILE ((dr<0.0)AND(rtic>=rend)) OR ((dr>0.0)AND(rtic<=rend)) DO BEGIN
dtic := (rtic-r1)/rlen;
x := xlen*dtic + sx1;
y := ylen*dtic + sy1;
gmove(x,y);
x := x + xtic;
y := y + ytic;
vector(x,y);
x := x + xlabel;
y := y + ylabel;
Str(rtic:lblnum:lbldec, alabel);
gwrite(x, y, alabel, lblnum);
rtic := rtic + dr;
END;
{ clean up static storage }
t := chrot/radian;
scale[3] := cos( t );
scale[4] := sin( t );
END
END;
{-------------------------------------------------------------------------}
PROCEDURE graph(xmini,xmaxi:REAL; nx:INTEGER; ymini,ymaxi:REAL;ny:INTEGER;
sxl,sxr,syb,syt:REAL);
{ This procedure plots and labels a graph and establishes scale factors
for future use.
inputs:
xmini,xmaxi min & max real world values for x axis
nx approximate no. of intervals on x axis
ymini,ymaxi min & max real world values for y axis
ny approximate no. of intervals on y axis
sxl,sxr screen left & right coord. for graph area
syb,syt screen bottom & top coord. for graph area
outputs:
none returned
}
VAR
dx,dy,tic,xdot,ydot,dxydot,xydot,ticnd: REAL;
lblnum,lbldec: INTEGER;
BEGIN
{ Set Scale Factors }
xmin := xmini;
ymin := ymini;
xmax := xmaxi;
ymax := ymaxi;
swindo(sxl,sxr,syb,syt);
{ Draw Axes }
dx := dxdy(xmin,xmax,nx,lblnum,lbldec);
nxchar := lblnum;
axis(xmin,xmax,dx, sxl,syb,sxr,syb, chysz/2.,270.0, lblnum,lbldec,0.0);
dy := dxdy(ymin,ymax,ny,lblnum,lbldec);
nychar := lblnum;
axis(ymin,ymax,dy, sxl,syb,sxl,syt, chxsz/2.,180.0, lblnum,lbldec,90.0);
{ Do Vertical Dotted Lines }
ticend(xmin,xmax,dx,tic,ticnd);
dxydot := dy/5.0;
IF (tic = xmin) THEN tic := tic + dx;
WHILE ((dx>0.0)AND(tic<=ticnd)) OR ((dx<0.0)AND(tic>=ticnd)) DO BEGIN
xdot := sx(tic);
tic := tic + dx;
xydot := ymin + dxydot;
WHILE ((dxydot>0.0)AND(xydot<=ymax)) OR
((dxydot<0.0)AND(xydot>=ymax)) DO BEGIN
ydot := sy(xydot);
xydot := xydot + dxydot;
point( xdot,ydot );
END
END;
{ Do Horizontal Dotted Lines }
ticend(ymin,ymax,dy,tic,ticnd);
dxydot := dx/5.0;
IF (tic = ymin) THEN tic := tic + dy;
WHILE ((dy>0.0)AND(tic<=ticnd)) OR ((dy<0.0)AND(tic>=ticnd)) DO BEGIN
ydot := sy(tic);
tic := tic + dy;
xydot := xmin + dxydot;
WHILE ((dxydot>0.0)AND(xydot<=xmax)) OR
((dxydot<0.0)AND(xydot>=xmax)) DO BEGIN
xdot := sx(xydot);
xydot := xydot + dxydot;
point( xdot,ydot );
END
END
END;
{-------------------------------------------------------------------------}