[Back to TEXTWNDW SWAG index] [Back to Main SWAG index] [Original]
{ WRITTEN BY TIM SCHEMPP
OCTOBER 21, 1993 }
unit drawline;
interface
procedure horizline(x1,x2,y:integer; default:char);
procedure vertline(x,y1,y2:integer; default:char);
procedure rectlines(x1,y1,x2,y2:integer; default:char);
{ IF writetomemory IS SET TO TRUE, LINES WILL BE DRAWN AN AVERAGE OF
ABOUT 15 TO 20 PERCENT FASTER THAN IF writetomemory IS SET TO FALSE.
HOWEVER, IF DATA IS WRITTEN DIRECTLY TO VIDEO MEMORY, YOU ARE STUCK WITH
THE SCREENS CURRENT COLORS (TEXTCOLOR AND TEXTBACKGROUND HAVE NO EFFECT).
THE DEFAULT VALUE OF writetomemory IS FALSE. }
var writetomemory:boolean;
implementation
uses crt; {for gotoxy, wherex and wherey}
const symbols:array[1..40] of char=
('³','´','µ','�','·','¸','¹','º','»','¼','½','¾','¿',
'À','Á','Â','Ã','Ä','Å','Æ','Ç','È','É','Ê','Ë','Ì',
'Í','Î','Ï','Ð','Ñ','Ò','Ó','Ô','Õ','Ö','×','Ø','Ù',
'Ú');
codes:array[1..40] of string[4]=
('1010','1011','1012','2021','0021','0012','2022','2020',
'0022','2002','2001','1002','0011','1100','1101','0111',
'1110','0101','1111','1210','2120','2200','0220','2202',
'0222','2220','0202','2222','1202','2101','0212','0121',
'2100','1200','0210','0120','2121','1212','1001','0110');
{THE SCREEN DIMENSIONS}
screenwidth=80; screenlength=25;
{******}
{READS A CHARACTER FROM VIDEO MEMORY AT THE GIVEN COORDINANTS}
function Memread(col,row:integer):char;
Const
Seg = $B000; { Video memory address for color system }
Ofs = $8000; { For monochrome system, make Ofs = $0000 }
Var
SChar : Integer;
Begin
SChar := ((Row-1)*160) + ((Col-1)*2); { Compute starting location }
memread:=chr(Mem[Seg:Ofs + SChar]); { read character from memory}
End;
{******}
{WRITES A CHARACTER DIRECTORY TO VIDEO MEMORY AT THE GIVEN COORDINATES}
{NOTE: THE CURRENT COLORS AT THE GIVEN COORDINANTS ARE USED FOR DRAWING.}
procedure Memwrite(col,row:integer; c:char);
Const
Seg = $B000; { Video memory address for color system }
Ofs = $8000; { For monochrome system, make Ofs = $0000 }
Var
SChar : Integer;
Begin
SChar := ((Row-1)*160) + ((Col-1)*2); { Compute starting location }
Mem[Seg:Ofs + SChar]:=ord(c); { write character to memory}
End;
{******}
{PROCEDURE USED INTERNALLY TO CREATE A SET OF CHARACTER CODES}
function getcode(c:char; direction:byte):char;
var counter:integer;
begin
counter:=1;
while (counter<=40) and (c<>symbols[counter]) do inc(counter);
if counter>40 then getcode:='0' else getcode:=codes[counter,direction];
end;
{******}
{PROCEDURE DRAWS A LINE IN TEXT MODE FROM (X1,Y) TO (X2,Y)}
{DEFAULT IS EITHER '1' OR '2' FOR SINGLE OF DOUBLE LINES}
procedure horizline(x1,x2,y:integer; default:char);
var code:string[4];
defaultchar:char;
c,index:integer;
xpos,ypos:integer;
begin
xpos:=wherex; ypos:=wherey;
if x2<x1 then begin c:=x1; x1:=x2; x2:=c; end;
if default='1' then defaultchar:=symbols[18]
else defaultchar:=symbols[27];
for c:=x1 to x2 do
begin
code:='0000';
if y<>0 then code[1]:=getcode(memread(c,y-1),3) else code[1]:='0';
if (c=x2) and (x2=screenwidth) then code[2]:='0'
else if (c=x2) then code[2]:=getcode(memread(x2+1,y),4)
else code[2]:=default;
if y<>screenlength then code[3]:=getcode(memread(c,y+1),1)
else code[3]:='0';
if (c=x1) and (x1=1) then code[4]:='0'
else
if (c=x1) then code[4]:=getcode(memread(x1-1,y),2)
else code[4]:=default;
index:=1;
while (index<=40) and (code<>codes[index]) do inc(index);
if writetomemory then
if index>40 then memwrite(c,y,defaultchar)
else memwrite(c,y,symbols[index])
else
if index>40 then begin gotoxy(c,y); write(defaultchar); end
else begin gotoxy(c,y); write(symbols[index]); end;
end; {counter}
if not writetomemory then gotoxy(xpos,ypos);
end;
{******}
{PROCEDURE DRAWS A LINE IN TEXT MODE FROM (X,Y1) TO (X,Y2)}
{DEFAULT IS EITHER '1' OR '2' FOR SINGLE OF DOUBLE LINES}
procedure vertline(x,y1,y2:integer; default:char);
var code:string[4];
defaultchar:char;
c,index:integer;
xpos,ypos:integer;
begin
xpos:=wherex; ypos:=wherey;
if y2<y1 then begin c:=y1; y1:=y2; y2:=c; end;
if default='1' then defaultchar:=symbols[1]
else defaultchar:=symbols[8];
for c:=y1 to y2 do
begin
code:='0000';
if (c=y2) and (y2=screenlength) then code[3]:='0'
else if (c=y2) then code[3]:=getcode(memread(x,y2+1),1)
else code[3]:=default;
if x<>screenwidth then code[2]:=getcode(memread(x+1,c),4)
else code[1]:='0';
if x<>1 then code[4]:=getcode(memread(x-1,c),2)
else code[1]:='0';
if (c=y1) and (y1=0) then code[1]:='0'
else if (c=y1) then code[1]:=getcode(memread(x,y1-1),3)
else code[1]:=default;
index:=1;
while (index<=40) and (code<>codes[index]) do inc(index);
if writetomemory then
if index>40 then memwrite(x,c,defaultchar)
else memwrite(x,c,symbols[index])
else
if index>40 then begin gotoxy(x,c); write(defaultchar) end
else begin gotoxy(x,c); write(symbols[index]); end;
end; {counter}
if not writetomemory then gotoxy(xpos,ypos);
end;
{******}
{PROCEDURE DRAWS A RECTANGLE IN TEXT MODE}
{DEFAULT IS EITHER '1' OR '2' FOR SINGLE OF DOUBLE LINES}
procedure rectlines(x1,y1,x2,y2:integer; default:char);
begin
horizline(x1,x2,y1,default);
horizline(x1,x2,y2,default);
vertline(x1,y1,y2,default);
vertline(x2,y1,y2,default);
end;
{******}
begin
writetomemory:=false;
end. {unit}
{------------------- DEMO PROGRAM ------------------------}
{ ---------------- CUT HERE --------------------------}
{ WRITTEN BY TIM SCHEMPP
OCTOBER 21, 1993 }
{THIS PROGRAM DEMONSTARTES THE USE OF THE UNIT drawline. UNIT DRAWLINE
WILL USE THE ASCII SET TO DRAW LINES. WHEN LINE INTERSECTIONS ARE
FOUND, THE PROCEDURES DESCIDE WHICH CHARACTER FITS BEST. THUS MAKING
IT VERY EASY TO CREATE VARIOUS TABLES AND OTHER SCREEN SET UPS. THE
UNIT ALSO HAS THE ABILITY TO WRITE DIRECTORY TO VIDEO MEMORY FOR
A 15% TO 20% IMPROVEMENT IN SPEED. SEE DRAWLINE.DOC FOR MORE INFO.}
program demo;
uses crt,drawline;
var counter:integer;
begin
{SET THE SCREEN UP}
textbackground(black);
textcolor(white);
clrscr;
{THE CALL TO CLEAR SCREEN FILLED THE SCREEN WITH SPACES WITH A BLACK
BACKGROUND AND A WHITE FOREGROUND. IF writetomemory IS SET TO TRUE,
ALL OF THE OUTPUT WILL BE WRITTEN WITH A BLACK BACKGROUND AND A WHITE
FOREGROUND REGARDLESS OF TEXT ATTRIBUTE CHANGES.}
{writetomemory:=true;} { <--- ADD THIS STATEMENT AND SEE COLOR DIFFERENCE}
{WRITE SOME TEXT}
gotoxy(22,6);
textcolor(lightblue);
write('LINE DRAWING DEMONSTARTATION PROGRAM');
textcolor(yellow);
{DRAW A RECTANGLE WITH DOUBLE LINES}
rectlines(10,4,70,20,'2');
{DRAW SOME HORIZONTAL SINGLE LINES}
for counter:=9 to 19 do
horizline(10,70,counter,'1');
{DRAW SOME SINGLE VERTICLE LINES}
counter:=20;
while counter<=60 do
begin
vertline(counter,8,20,'1');
inc(counter,10);
end; {WHILE}
{DRAW ONE LAST HORIZONTAL DOUBLE LINE}
horizline(10,70,8,'2');
repeat until keypressed;
end.
[Back to TEXTWNDW SWAG index] [Back to Main SWAG index] [Original]