wct@po.CWRU.Edu (William C. Thompson) (04/25/91)
I got over 20 request in under 12 hours for source code for
these two new units, so I have decided to just post them to
the board instead. It would save myself inordinate amounts
of time and energy. Please report any bugs and send any
thanks/offerings to wct@po.cwru.edu
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;
procedure setfillcolor(col:word);
procedure setfillpattern(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(x1,y1:word; fn: string; size:word; wput:byte);
implementation
type
buffer = array[1..64000] of byte;
procedure setfillcolor(col:word);
var
s: fillsettingstype;
begin
getfillsettings(s);
setfillstyle(s.pattern,col)
end;
procedure setfillpattern(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: ^buffer;
n: word;
begin
size:=imagesize(x1,y1,x2,y2);
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(x1,y1:word; fn: string; size:word; wput:byte);
{ This procedure reads in an image from the specified file
and puts the image on the screen }
var
f: file;
p: ^buffer;
n: word;
begin
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);
putimage(x1,y1,p^,wput); { put image on screen }
freemem(p,size); { return memory }
end;
end.
unit keydef;
{ This unit contains all the constants and transformations for
the xcrt unit function ReadAllKeys }
interface
const
{ These are the constants for readallkeys }
CtrlF1:char=#138; CtrlF2:char=#139; CtrlF3:char=#140; CtrlF4:char=#141;
CtrlF5:char=#142; CtrlF6:char=#143; CtrlF7:char=#144; CtrlF8:char=#145;
CtrlF9:char=#146; CtrlF10:char=#147;
ShftF1:char=#148; ShftF2:char=#149; ShftF3:char=#150; ShftF4:char=#151;
ShftF5:char=#152; ShftF6:char=#153; ShftF7:char=#154; ShftF8:char=#155;
ShftF9:char=#156; ShftF10:char=#157;
AltF1:char=#158; AltF2:char=#159; AltF3:char=#160; AltF4:char=#161;
AltF5:char=#162; AltF6:char=#163; AltF7:char=#164; AltF8:char=#165;
AltF9:char=#166; AltF10:char=#167;
AltA:char=#168; AltB:char=#169; AltC:char=#170; AltD:char=#171;
AltE:char=#172; AltF:char=#173; AltG:char=#174; AltH:char=#175;
AltI:char=#176; AltJ:char=#177; AltK:char=#178; AltL:char=#179;
AltM:char=#180; AltN:char=#181; AltO:char=#182; AltP:char=#183;
AltQ:char=#184; AltR:char=#185; AltS:char=#186; AltT:char=#187;
AltU:char=#188; AltV:char=#189; AltW:char=#190; AltX:char=#191;
AltY:char=#192; AltZ:char=#193;
Ins:char=#194; Home:char=#195; PgUp:char=#196; Del:char=#197;
EndKey:char=#198; PgDn:char=#199; UpArrow:char=#200; LeftArrow:char=#201;
RightArrow:char=#202; DownArrow:char=#203;
CtrlLeftArrow:char=#204; CtrlRightArrow:char=#205;
F1:char=#206; F2:char=#207; F3:char=#208; F4:char=#209; F5:char=#210;
F6:char=#211; F7:char=#212; F8:char=#213; F9:char=#214; F10:char=#215;
Alt1:char=#216; Alt2:char=#217; Alt3:char=#218; Alt4:char=#219;
Alt5:char=#220; Alt6:char=#221; Alt7:char=#222; Alt8:char=#223;
Alt9:char=#224; Alt0:char=#225;
CtrlHome:char=#226; CtrlEnd:char=#227; CtrlPgUp:char=#228;
CtrlPgDn:char=#229;
function transformedkey(c:char):char;
implementation
function transformedkey(c:char):char;
begin
case ord(c) of
59..68:transformedkey:=chr(ord(c)+ord(F1)-59); { F1-F10 }
94..103:transformedkey:=chr(ord(c)-94+ord(CtrlF1)); { CtrlF1-CtrlF10 }
84..93:transformedkey:=chr(ord(c)-84+ord(ShftF1)); { ShftF1-ShftF10 }
104..113:transformedkey:=chr(ord(c)-104+ord(AltF1)); { AltF1-AltF10 }
30:transformedkey:=AltA; 48:transformedkey:=AltB; 46:transformedkey:=AltC;
32:transformedkey:=AltD; 18:transformedkey:=AltE; 33:transformedkey:=AltF;
44:transformedkey:=AltG; 35:transformedkey:=AltH; 23:transformedkey:=AltI;
36:transformedkey:=AltJ; 37:transformedkey:=AltK; 38:transformedkey:=AltL;
50:transformedkey:=AltM; 49:transformedkey:=AltN; 24:transformedkey:=AltO;
25:transformedkey:=AltP; 16:transformedkey:=AltQ; 19:transformedkey:=AltR;
31:transformedkey:=AltS; 20:transformedkey:=AltT; 22:transformedkey:=AltU;
47:transformedkey:=AltV; 17:transformedkey:=AltW; 45:transformedkey:=AltX;
21:transformedkey:=AltY; 44:transformedkey:=AltZ;
120..129:transformedkey:=chr(ord(c)-120+ord(Alt1)); { Alt1-Alt0 }
72:transformedkey:=UpArrow;
75:transformedkey:=LeftArrow;
77:transformedkey:=RightArrow;
80:transformedkey:=DownArrow;
115:transformedkey:=CtrlLeftArrow;
116:transformedkey:=CtrlRightArrow;
82:transformedkey:=Ins;
71:transformedkey:=Home;
73:transformedkey:=PgUp;
83:transformedkey:=Del;
79:transformedkey:=EndKey;
81:transformedkey:=PgDn;
119:transformedkey:=CtrlHome;
117:transformedkey:=CtrlEnd;
132:transformedkey:=CtrlPgUp;
118:transformedkey:=CtrlPgDn;
end
end;
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);
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 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;
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.
There you go. If I make any serious changes, I will post. Once
again, please report any bugs or changes you feel are necessary/
beneficial.
--
Ticking away, the moments that make up a dull day. | William C. Thompson
You fritter and waste the hours in an offhand way. | Michelson 620D (wct)
Kicking around on a piece of ground in your hometown,| a.k.a. Master of Time,
waiting for someone or something to show you the way.| Space, and Dimension