language-Modula2-0.1: examples/Modula-2_Libraries/andrea-m2/lib/generic/psgraphic.mod
IMPLEMENTATION MODULE PSGraphics;
(* simple PostScript Graphics routines *)
(* J. Andrea, May.16/91 *)
(* This code may be freely used and distributed, it may not be sold. *)
FROM FileSystem IMPORT Done, Create, Close, WriteChar, File, EOL;
FROM MathLib0 IMPORT sin, cos;
CONST
absolute_rows = 776;
absolute_cols = 575;
row_offset = 20;
col_offset = 20;
max_rows = absolute_rows - row_offset;
max_cols = absolute_cols - col_offset;
VAR
current_row, current_col :CARDINAL;
true_row, true_col :CARDINAL;
output_open :BOOLEAN;
biggest :CARDINAL;
digits :ARRAY [0..9] OF CHAR;
i :CARDINAL;
outf :File;
font_chosen :CARDINAL;
unstroked_lines :CARDINAL;
(* ----------------------------------------------------------------- *)
PROCEDURE CheckLocation( row, col :CARDINAL; VAR new_row, new_col :CARDINAL );
(* don't allow new position to be out of bounds *)
BEGIN
IF row > max_rows THEN row := max_rows; END;
IF col > max_cols THEN col := max_cols; END;
new_row := row; new_col := col;
END CheckLocation;
(* ----------------------------------------------------------------- *)
PROCEDURE TrueLocation;
(* and invert positions so that y (rows) run bottom to top,
and apply offsets as required *)
BEGIN
true_row := current_row + row_offset;
true_col := current_col + col_offset;
END TrueLocation;
(* ----------------------------------------------------------------- *)
PROCEDURE Output( string :ARRAY OF CHAR );
(* write the given string to the output file *)
VAR i, L :CARDINAL;
BEGIN
L := LEN( string ) - 1;
FOR i := 0 TO L DO
WriteChar( outf, string[i] );
END;
END Output;
(* ----------------------------------------------------------------- *)
PROCEDURE OutputNumber( x :CARDINAL );
(* assumption that x is less than 1000 *)
BEGIN
IF x > 99 THEN
(* 3 digits *)
i := x DIV 100;
WriteChar( outf, digits[i] );
x := x - 100 * i;
i := x DIV 10;
WriteChar( outf, digits[i] );
x := x - 10 * i;
WriteChar( outf, digits[x] );
ELSE
IF x > 9 THEN
(* 2 digits *)
i := x DIV 10;
WriteChar( outf, digits[i] );
x := x - 10 * i;
WriteChar( outf, digits[x] );
ELSE
(* 1 digit *)
WriteChar( outf, digits[x] );
END;
END;
END OutputNumber;
(* ----------------------------------------------------------------- *)
PROCEDURE NewLine;
BEGIN
WriteChar( outf, EOL );
END NewLine;
(* ----------------------------------------------------------------- *)
PROCEDURE DoingALine( yes :BOOLEAN );
(* define the output file to hold the graphics commands *)
(* ----------------------------------------------- *)
PROCEDURE DoStroke;
BEGIN
Output( 'stroke' ); NewLine;
unstroked_lines := 0;
(* but where did the current point go, it disappeared with
to stroke, so get a new current point *)
Move( current_col, current_row );
END DoStroke;
BEGIN
IF yes THEN
IF unstroked_lines = 0 THEN
(* if there arn't any lines already done, then there probably isn't
a PostScript current point, make one *)
Move( current_col, current_row );
ELSE
(* every 1000 lines do a stroke because of a possible PostScript limit *)
IF unstroked_lines > 1000 THEN
DoStroke;
END;
END;
unstroked_lines := unstroked_lines + 1;
ELSE
(* this next operation won't be a line, so if there are lines
left over, we better paint them *)
IF unstroked_lines > 0 THEN
DoStroke;
END;
END;
END DoingALine;
(* ----------------------------------------------------------------- *)
PROCEDURE BeginPS( filename :ARRAY OF CHAR );
(* define the output file to hold the graphics commands *)
BEGIN
IF output_open THEN EndPS; END;
Create( outf, filename, TRUE, TRUE );
IF Done() THEN
output_open := TRUE;
Output( '%!' ); NewLine;
Output( '/L { lineto } bind def' ); NewLine;
Output( '/M { moveto } bind def' ); NewLine;
current_row := 0; current_col := 0;
font_chosen := 0;
unstroked_lines := 0;
END;
END BeginPS;
(* ----------------------------------------------------------------- *)
PROCEDURE EndPS;
(* close the current output file *)
BEGIN
IF output_open THEN
IF unstroked_lines > 0 THEN Output( 'stroke ' ); END;
Output( 'showpage' ); NewLine;
Close( outf );
output_open := FALSE;
END;
END EndPS;
(* ----------------------------------------------------------------- *)
PROCEDURE GetDimensions( VAR columns, rows :CARDINAL );
(* return the dimensions of the display *)
BEGIN
columns := max_cols;
rows := max_rows;
END GetDimensions;
(* ----------------------------------------------------------------- *)
PROCEDURE GetPosition( VAR column, row :CARDINAL );
(* return the current location of the cursor *)
BEGIN
column := current_col;
row := current_row;
END GetPosition;
(* ----------------------------------------------------------------- *)
PROCEDURE Border;
(* draw a border *)
BEGIN
IF output_open THEN
DoingALine( FALSE );
(* move to the corner *)
Move( col_offset, row_offset );
(* output the lines to draw the border, using relative motion *)
OutputNumber( max_cols );
Output( ' ' );
OutputNumber( 0 );
Output( ' rlineto' );
Output( ' ' );
OutputNumber( max_rows );
Output( ' ' );
OutputNumber( 0 );
Output( ' rlineto' );
Output( ' ' );
OutputNumber( max_cols );
Output( ' neg ' );
OutputNumber( 0 );
Output( ' rlineto' );
Output( ' closepath stroke' ); NewLine;
(* return to the current location *)
Move( current_col, current_row );
END;
END Border;
(* ----------------------------------------------------------------- *)
PROCEDURE Move( column, row :CARDINAL );
(* move to the new location, make it the current point *)
BEGIN
IF output_open THEN
DoingALine( FALSE );
CheckLocation( row, column, current_row, current_col );
TrueLocation;
OutputNumber( true_col );
Output( ' ' );
OutputNumber( true_row );
Output( ' M' );
NewLine;
END;
END Move;
(* ----------------------------------------------------------------- *)
PROCEDURE Dot;
(* draw a dot at the current location *)
BEGIN
IF output_open THEN
TrueLocation;
Line( true_col, true_row+1 );
END;
END Dot;
(* ----------------------------------------------------------------- *)
PROCEDURE Line( column, row :CARDINAL );
(* draw a line from the current point to the new point *)
BEGIN
IF output_open THEN
DoingALine( TRUE );
CheckLocation( row, column, current_row, current_col );
TrueLocation;
OutputNumber( true_col );
Output( ' ' );
OutputNumber( true_row );
Output( ' L' );
NewLine;
END;
END Line;
(* ----------------------------------------------------------------- *)
PROCEDURE Circle( radius :CARDINAL; filled :BOOLEAN );
(* draw a circle of the given radius from the current point *)
BEGIN
IF output_open THEN
IF radius > biggest THEN radius := biggest; END;
TrueLocation;
DoingALine( FALSE );
OutputNumber( true_col );
Output( ' ' );
OutputNumber( true_row );
Output( ' ' );
OutputNumber( radius );
Output( ' 0 360 arc ' );
Output( ' closepath' );
IF filled THEN
Output( ' fill' );
ELSE
Output( ' stroke' );
END;
NewLine;
(* return to the current location *)
Move( current_col, current_row );
END;
END Circle;
(* ----------------------------------------------------------------- *)
PROCEDURE Rectangle( width, height :CARDINAL; filled :BOOLEAN );
(* draw a rectangle, one corner at current point,
opposite corner at current+width,current+height *)
BEGIN
IF output_open THEN
IF width + current_col > max_cols THEN
width := max_cols - current_col; END;
IF height + current_row > max_rows THEN
height := max_rows - current_row; END;
DoingALine( FALSE );
OutputNumber( width );
Output( ' ' );
OutputNumber( 0 );
Output( ' rlineto' );
Output( ' ' );
OutputNumber( height );
Output( ' ' );
OutputNumber( 0 );
Output( ' rlineto' );
Output( ' ' );
OutputNumber( width );
Output( ' neg ' );
OutputNumber( 0 );
Output( ' rlineto' );
Output( ' closepath' );
IF filled THEN
Output( ' fill' );
ELSE
Output( ' stroke' );
END;
NewLine;
(* return to the current location *)
Move( current_col, current_row );
END;
END Rectangle;
(* ----------------------------------------------------------------- *)
PROCEDURE Vector( length :CARDINAL; angle :REAL;
VAR new_col, new_row :CARDINAL );
VAR
a, z :REAL;
delta :CARDINAL;
(* ------------------------ *)
PROCEDURE Delta( length :REAL ) :CARDINAL;
BEGIN
length := ABS( length );
IF length > FLOAT( biggest ) THEN
RETURN biggest;
ELSE
RETURN CARDINAL( TRUNC( length ) );
END;
END Delta;
BEGIN
IF length > biggest THEN
length := biggest;
END;
a := ABS( angle );
WHILE a >= 360. DO
a := a - 360.
END;
IF angle >= 0. THEN
angle := a;
ELSE
angle := 360. - a;
END;
IF ( angle <= 1. ) OR ( angle >= 359. ) THEN
new_col := current_col + length;
new_row := current_row;
ELSE
IF ( angle >= 89. ) AND ( angle <= 91. ) THEN
new_row := current_row + length;
new_col := current_col;
ELSE
IF ( angle >= 179. ) AND ( angle <= 181. ) THEN
IF length >= current_col THEN
new_col := 0;
ELSE
new_col := current_col - length;
END;
new_row := current_row;
ELSE
IF ( angle >= 269. ) AND ( angle <= 271. ) THEN
IF length >= current_row THEN
new_row := 0;
ELSE
new_row := current_row - length;
END;
new_col := current_col;
ELSE
a := angle * 3.141592653 / 180.;
z := FLOAT( length ) * sin( a );
IF z >= 0. THEN
new_row := current_row + Delta(z);
ELSE
delta := Delta(z);
IF delta >= current_row THEN
new_row := 0;
ELSE
new_row := current_row - delta;
END;
END;
z := FLOAT( length ) * cos( a );
IF z >= 0. THEN
new_col := current_col + Delta(z);
ELSE
delta := Delta(z);
IF delta >= current_col THEN
new_col := 0;
ELSE
new_col := current_col - delta;
END;
END;
END;
END;
END;
END;
END Vector;
(* ----------------------------------------------------------------- *)
PROCEDURE VectorLine( length :CARDINAL; angle :REAL );
(* draw a line from the current location given a length and angle *)
VAR
new_row, new_col :CARDINAL;
BEGIN
IF output_open THEN
Vector( length, angle, new_col, new_row );
Line( new_col, new_row );
END;
END VectorLine;
(* ----------------------------------------------------------------- *)
PROCEDURE VectorMove( length :CARDINAL; angle :REAL );
(* move from the current location given a length and angle *)
VAR
new_row, new_col :CARDINAL;
BEGIN
IF output_open THEN
Vector( length, angle, new_col, new_row );
Move( new_col, new_row );
END;
END VectorMove;
(* ----------------------------------------------------------------- *)
PROCEDURE Text( string :ARRAY OF CHAR; size :CARDINAL );
(* put up some text at the current location *)
BEGIN
IF output_open THEN
DoingALine( FALSE );
IF size > biggest THEN size := biggest END;
IF font_chosen # size THEN
font_chosen := size;
Output( '/Times-Roman findfont ' );
OutputNumber( size );
Output( ' scalefont setfont' );
NewLine;
END;
Output( '(' ); Output( string ); Output( ')show' ); NewLine;
(* return to the current location *)
Move( current_col, current_row );
END;
END Text;
(* ----------------------------------------------------------------- *)
PROCEDURE Command( string :ARRAY OF CHAR );
(* put some other PostScript command into the output stream *)
BEGIN
IF output_open THEN
DoingALine( FALSE );
Output( string ); NewLine;
END;
END Command;
BEGIN (* PSGraphics *)
output_open := FALSE;
IF absolute_rows > absolute_cols THEN
biggest := absolute_rows;
ELSE
biggest := absolute_cols;
END;
FOR i := 0 TO 9 DO
digits[i] := CHAR( i + 48 );
END;
END PSGraphics.