wct@po.CWRU.Edu (William C. Thompson) (06/24/91)
unit xgraph;
{ Written by William C. Thompson (wct@po.cwru.edu) - 1991 }
{ This unit was written for programs with heavy graphics usage.
There are a number of procedures to make graphics more bearable.
There are some procedures that do different drawings.
There are some procedures that can/recall a screen image. }
interface
uses graph,math;
var
europeanfont,complexfont,triplexscriptfont,scriptfont,simplefont:integer;
procedure setfillcolor(col:word);
procedure setfillpatt(pat: word);
procedure settextfont(font:word);
procedure settextsize(size:word);
procedure settextdir(dir:word);
procedure settextall(font,dir,size,hor,ver:word);
procedure ngon(cx,cy,sides: word; r,ang: real);
procedure fline(x1,y1,x2,y2:word; warp,pixres:real);
procedure fbranch(fn:string ; warp,pixres:real);
procedure frip(fn: string; warp,pixres: real);
procedure saveimage(x1,y1,x2,y2:word; fn:string; var size:word);
procedure recallimage(fn: string; p:pointer; size:word);
procedure killimage(p:pointer; size:word);
implementation
type
buffer = array[1..64000] of byte;
procedure setfillcolor(col:word);
var
s: fillsettingstype;
begin
getfillsettings(s);
setfillstyle(s.pattern,col)
end;
procedure setfillpatt(pat: word);
var
s: fillsettingstype;
begin
getfillsettings(s);
setfillstyle(pat,s.color)
end;
procedure settextfont(font:word);
var
s: textsettingstype;
begin
gettextsettings(s);
settextstyle(font, s.direction, s.charsize)
end;
procedure settextsize(size:word);
var
s: textsettingstype;
begin
gettextsettings(s);
settextstyle(s.font, s.direction, size)
end;
procedure settextdir(dir:word);
var
s: textsettingstype;
begin
gettextsettings(s);
settextstyle(s.font, dir, s.charsize)
end;
procedure settextall(font,dir,size,hor,ver:word);
begin
settextstyle(font,dir,size);
settextjustify(hor,ver)
end;
procedure ngon(cx,cy,sides: word; r,ang: real);
var
i: word;
begin
for i:=0 to sides-1 do
line(round(cx+r*cos(i/sides*2*pi+ang-pi/2)),
round(cy+r*sin(i/sides*2*pi+ang-pi/2)),
round(cx+r*cos((i+1)/sides*2*pi+ang-pi/2)),
round(cy+r*sin((i+1)/sides*2*pi+ang-pi/2)));
end;
procedure fline(x1,y1,x2,y2:word; warp,pixres:real);
{ Generates a fractal line from (x1,y1) bent by warp % such that no
two points are more than pixres pixels apart. A higher warp means
the line can deviate more. Caution: a warp above 1.0 is not good }
var
d,ang:real;
x3,y3:word; { point of elbow }
begin
d:=distance(x1,y1,x2,y2);
if d<=pixres then line(x1,y1,x2,y2)
else begin
ang:=random(65535)*9.5875262E-5; { generate [0,2 pi) }
x3:=round((x1+x2)/2+d/2*warp*sin(ang));
y3:=round((y1+y2)/2+d/2*warp*cos(ang));
fline(x1,y1,x3,y3,warp,pixres);
fline(x3,y3,x2,y2,warp,pixres)
end
end;
procedure fbranch(fn:string ; warp,pixres:real);
{ reads a fractal branch file from disk and draws it with
parameters warp and pixres, as described in fline. There
is a maximum of 250 nodes. Define a branch as follows:
number of nodes e.g. 5
list of each node's coordinates 100 100
...
list of connections from node to node 1 2
... }
var
f: text;
i: word;
a,b: word; { node numbers }
pts: word; { number of nodes }
x, y: array[1..250] of word; { node coordinates }
begin
assign(f,fn);
reset(f);
{ read in points }
readln(f,pts);
for i:=1 to pts do readln(f,x[i],y[i]);
while not eof(f) do begin
readln(f,a,b);
if [a,b]*[1..pts]=[a,b] then fline(x[a],y[a],x[b],y[b],warp,pixres)
end;
close(f);
end;
procedure frip(fn: string; warp,pixres: real);
{ Reads and draws a fractal rip (looks like a river)
A rip file is defined as follows:
List of coordinates to connect e.g. 100 100
150 120
160 180
...
This can be used to draw lakes, borders, etc. }
var
x1,y1,x2,y2: word;
f: text;
begin
assign(f,fn);
reset(f);
{ read first point }
readln(f,x1,y1);
while not eof(f) do begin
readln(f,x2,y2);
fline(x1,y1,x2,y2,warp,pixres);
x1:=x2;
y1:=y2
end;
close(f)
end;
procedure saveimage(x1,y1,x2,y2:word; fn:string; var size:word);
{ This procedure captures an image from the screen and writes
it to the specified file and returns the size. There is no error
checking as to how much memory is available. The size of an image
is the number of pixels divided by two plus 6 (VGA mode) }
var
f: file;
p: pointer;
n: word;
begin
size:=imagesize(x1,y1,x2,y2);
new(p);
getmem(p,size); { allocate space }
getimage(x1,y1,x2,y2,p^); { capture the image from screen }
assign(f,fn);
rewrite(f,1); { objects are 1 byte large }
blockwrite(f,p^,size,n); { write image to disk }
freemem(p,size); { return memory }
close(f);
end;
procedure recallimage(fn: string; p:pointer; size:word);
{ This procedure reads in an image from the specified file
Note: you must know the size of the image beforehand. You can
do this by looking at the size of the file fn. It would
be possible to read in bytes until the file is empty, but
that is much slower and you wouldn't know how to allocate. }
var
f: file;
n: word;
begin
new(p);
getmem(p,size); { allocate space }
assign(f,fn); { prepare file }
reset(f,1); { object are 1 byte large }
blockread(f,p^,size,n); { read in image }
close(f);
end;
procedure killimage(p:pointer; size:word);
{ disposes the image }
begin
freemem(p,size)
end;
begin
europeanfont:=installuserfont('euro');
complexfont:=installuserfont('lcom');
triplexscriptfont:=installuserfont('tscr');
scriptfont:=installuserfont('scri');
simplefont:=installuserfont('simp');
end.
unit xcrt;
{ Written by William C. Thompson (wct@po.cwru.edu) - 1991
Special thanks to Mike Lacy for contributions
As yet, this unit is only designed to handle screens with
80 columns. Including checking for 40 columns would slow
down the procedures which are intended to be very fast.
A program using 40 columns could easily borrow the ideas
used in this unit. I have confirmed that they do work for
43/50 rows. It doesn't work for 40 columns. }
interface
uses crt,dos,keydef;
type
screenpoint=record { occupies 3 bytes of space }
c:char;
colattr: word;
end;
screenpt=^screen;
screen=array[0..3999] of screenpoint;
{ This is a maximum size for a screen - 80 columns * 50 rows = 4000.
The maximum space required would then be 12000 bytes. }
block=record
rows,cols: word;
sp: screenpt
end;
procedure beep(hz,dur: word);
function getch(x,y: byte): char;
procedure putch(x,y: byte; c: char);
procedure writexy(x,y: byte; s: string);
procedure colorxy(x,y,forecol,backcol,blink: byte);
procedure textbox(nwx,nwy,sex,sey: word);
procedure textxbox(nwx,nwy,sex,sey: word);
procedure textline(startat,endat,c:word; attr:byte);
procedure fillrectangle(x1,y1,x2,y2:word);
function readallkeys:char;
function yesorno:char;
function getoneof(s:string):char;
procedure cursoron;
procedure cursoroff;
procedure savewindow(x1,y1,x2,y2: word; var w: block);
procedure killwindow(var w:block);
procedure recallwindow(x1,y1:word; var w: block);
implementation
const
base:word=$B800; { This may change for another machine }
procedure beep(hz,dur: word);
begin
sound(hz);
delay(dur);
nosound
end;
function getch(x,y: byte):char;
{ returns character at absolute position x,y through memory
The error checking has been removed to speed up function }
begin
getch:=char(mem[base:(160*y+2*x-162)]); { 2*80*(y-1)+2*(x-1) }
end;
procedure putch(x,y: byte; c: char);
{ QUICKLY writes c to absolute position x,y through memory
This is at least 10 times faster than a gotoxy(x,y), write(c)
Another bonus is that the cursor doesn't move.
The error checking has been removed }
begin
mem[base:(160*y+2*x-162)]:=ord(c);
mem[base:(160*y+2*x-161)]:=textattr;
end;
procedure writexy(x,y: byte; s: string);
{ Writes string at x,y and returns to old position. The coordinates
are relative to the current window. }
var
ox,oy: byte;
begin
ox:=wherex;
oy:=wherey;
gotoxy(x,y);
write(s);
gotoxy(ox,oy)
end;
procedure colorxy(x,y,forecol,backcol,blink: byte);
{ Directly change the color attributes of char at absolute screen x,y
To turn blink on, set it to 128 }
var
offset: word;
begin
if (x>80) or (y>25) then exit;
mem[base:(160*y+2*x-161)]:=forecol+16*backcol+blink;
end;
procedure textbox(nwx,nwy,sex,sey: word);
{ draws a thin text rectangle defined by the two points }
var
i: integer;
begin
{ handle special cases first, nwx=sex or nwy=sey }
if nwx=sex then { straight line down }
for i:=nwy to sey do putch(nwx,i,#179)
else if nwy=sey then { straight line across }
for i:=nwx to sex do putch(i,nwy,#196)
else if (nwx<sex) and (nwy<sey) then begin
{ draw corners }
putch(nwx,nwy,#218);
putch(nwx,sey,#192);
putch(sex,sey,#217);
putch(sex,nwy,#191);
{ draw lines }
for i:=nwy+1 to sey-1 do putch(nwx,i,#179);
for i:=nwy+1 to sey-1 do putch(sex,i,#179);
for i:=nwx+1 to sex-1 do begin
putch(i,nwy,#196);
putch(i,sey,#196);
end
end
end;
procedure textxbox(nwx,nwy,sex,sey: word);
{ draws a thick text defined by the two points }
var
i: integer;
begin
{ handle special cases first, nwx=sex or nwy=sey }
if nwx=sex then { straight line down }
for i:=nwy to sey do putch(nwx,i,#186)
else if nwy=sey then { straight line across }
for i:=nwx to sex do putch(i,nwy,#205)
else if (nwx<sex) and (nwy<sey) then begin
{ draw corners }
putch(nwx,nwy,#201);
putch(nwx,sey,#200);
putch(sex,sey,#188);
putch(sex,nwy,#187);
{ draw lines }
for i:=nwy+1 to sey-1 do putch(nwx,i,#186);
for i:=nwy+1 to sey-1 do putch(sex,i,#186);
for i:=nwx+1 to sex-1 do begin
putch(i,nwy,#205);
putch(i,sey,#205);
end;
end
end;
procedure textline(startat,endat,c:word; attr:byte);
{ draws a line -
attr=0 => thin horizontal attr=1 => thin vertical
attr=2 => thick horizontal attr=3 => thick vertical
The first two parameters are the starting and ending values
of the range of the line, vertical or horizontal. The third
is the constant value. i.e. horiz => (x1,x2,y), vert => (y1,y2,x) }
var
i: integer;
begin
if attr mod 2=0 then begin
gotoxy(startat,c);
if attr div 2=0 then for i:=startat to endat do putch(i,c,#196)
else for i:=startat to endat do putch(i,c,#205)
end
else
if attr div 2=0 then for i:=startat to endat do putch(c,i,#179)
else for i:=startat to endat do putch(c,i,#186)
end;
procedure fillrectangle(x1,y1,x2,y2:word);
var
i,j,imax,jmax: word;
begin
if x1>=x2 then imax:=x1 else imax:=x2;
if y1>=y2 then jmax:=y1 else jmax:=y2;
for i:=x1+x2-imax to imax do
for j:=y1+y2-jmax to jmax do putch(i,j,#219)
end;
function readallkeys:char;
{ This function correctly reads in a keypress and returns the
correct value for "other" keys. See the KEYDEF unit for what
each special key returns. Note: the function doesn't return
actual character for special keys (F1-F10,etc.) - it is only
a character to represent the special key that was pressed. }
var
ch: char;
ch2: char;
begin
ch:=readkey;
if ch=#0 then readallkeys:=transformedkey(readkey)
else readallkeys:=ch
end;
function yesorno:char;
{ waits for the user to press 'y','Y','n','N' }
var
ch: char;
begin
repeat
ch:=upcase(readallkeys)
until ch in ['Y','N'];
yesorno:=ch
end;
function getoneof(s:string):char;
{ waits for the user to input a character contained in s }
var
ch: char;
begin
repeat
ch:=readallkeys
until pos(ch,s)>0;
getoneof:=ch
end;
procedure cursoron;
var
regs: registers;
begin
regs.ah:=1;
regs.ch:=11;
regs.cl:=13;
intr($10, regs);
end;
procedure cursoroff;
var
regs: registers;
begin
regs.ch:=regs.ch or $20;
regs.ah:=1;
intr($10, regs);
end;
procedure savewindow(x1,y1,x2,y2: word; var w: block);
{ This procedure saves a screen block. It is not intended to
open up a window, but can be used to store what is underneath
a window. (absolute coordinates) }
var
i,j: word;
size: word;
begin
with w do begin
rows:=0;
cols:=0;
if (x2<x1) and (y2<y1) then exit; { invalid window }
rows:=x2-x1+1;
cols:=y2-y1+1;
size:=rows*cols*3; { bytes required to store screen }
getmem(sp,size); { allocate sufficient space }
for i:=0 to rows-1 do
for j:=0 to cols-1 do with sp^[j*rows+i] do begin
c:=char(mem[base:(160*(j+y1)+2*(i+x1)-162)]);
colattr:=mem[base:(160*(j+y1)+2*(i+x1)-161)];
end
end
end;
procedure killwindow(var w:block);
{ Free space taken up by screen block (absolute coordinates) }
begin
with w do freemem(sp,rows*cols*3)
end;
procedure recallwindow(x1,y1:word; var w:block);
{ redraw window at (x1,y1) (absolute coordinates) }
var
i,j: word;
begin
with w do begin
for i:=0 to rows-1 do
for j:=0 to cols-1 do with sp^[j*rows+i] do begin
mem[base:(160*(j+y1)+2*(i+x1)-162)]:=ord(c);
mem[base:(160*(j+y1)+2*(i+x1)-161)]:=colattr { color it }
end
end
end;
end.
You can grab the *.CHR files for the extra fonts from the
garbo address.
--
William C. Thompson "And you run and you run to catch up with the sun, but
wct@po.cwru.edu it's sinking, racing around to come up behind you again."
Michelson 620D x2080 - Soon to be Rich and Famous Published Pascal God
A.K.A. Kaiser - Minister of Truth - Master of Time, Space, and Dimension, ^