Category : Files from Magazines
Archive   : PCTJ0687.ZIP
Filename : DRAWCHAR.PAS

 
Output of file : DRAWCHAR.PAS contained in archive : PCTJ0687.ZIP

program TestWrite;

const
ScreenHeight = 199; {rows of screen: 0 ... 199}

type
Nodepointer = ^Node;
Node = record
across : integer; {position in row}
ascii : byte; {character code}
xScale,
yScale : real; {scaling factors}
next : Nodepointer; {forward link}
end;


Var
Lines, LastEntry: array[0..screenheight] of Nodepointer;
{point to first and last entry in row}
Temp : Nodepointer;
xStretch,
yStretch : real;
mode : byte; {inserting = 7, deleting = 0}
ch : char;
x, y : integer;


{ Definitions for the font tables }
Type
CharString = string[40];
Font = array[33..126] of CharString;

Var
FontArray : Font; {Array of strings describing fonts}


procedure LoadFonts;
const
FontsFilename = 'FONTS';
var
Fonts: file of Font;
begin
(**** These are the correct LoadFonts statements:
assign(Fonts, FontsFilename);
read(Fonts,FontArray);
close(Fonts);
****)
{The following is just the letter "A" for demonstration driver.}
FontArray[65] := #10 + #64 + #64 + #138 + #37 + #101;
end; {LoadFonts}



procedure DrawString(Z: Nodepointer; row: integer; mode: byte);
var I, P, Q: integer;
Coordinates: CharString;
x,y: integer;
begin
I:= 1;
with Z^ do begin
Coordinates:= FontArray[ascii];
x:= across; y:= row;
while I < length(Coordinates) do begin
P:= ord(Coordinates[I]); Q:= ord(Coordinates[I+1]);
draw(round((P div 16)* xscale + x),round((P mod 16)*yscale+y),
round((Q div 16)* xscale + x),round((Q mod 16)*yscale+y),
mode);
I:= I + 2
end; {while}
end; {with}
end; {DrawString}



procedure MakeNode(var P: Nodepointer; x:integer; asc :byte;
scx, scy: real);
begin
new(P);
with P^ do begin
across:= x; ascii:= asc; xScale:= scx; yScale:= scy;
next:= nil;
end;
end;



{ Edit: head is Lines[y], last is LastEntry[y]; }
{ P points to the node to be inserted/deleted. }

procedure Edit(var head, last, P: Nodepointer;
row: integer; mode: byte);
var place, follower: Nodepointer;
begin
follower:= head;
if (head = nil) and (mode = 7)
then begin {list is empty, so insert}
head:= P;
last:= P;
DrawString(P, row, mode);
end
else if (head = nil) and (mode = 0) then begin end
else if (P^.across > last^.across) and (mode = 7)
then begin {character further to right than others}
last^.next:= P;
last:= P;
DrawString(P, row, mode);
end
else if (P^.across > last^.across) and (mode = 0)
then begin end
else {must insert or delete a node in the interior of row}
begin
place:= head;
if (P^.across = place^.across) {correct position}
and (mode = 0) {deleting}
then
begin
while (place^.ascii <> P^.ascii)
and (place^.next <> nil)
do begin
follower:= place;
place:= place^.next;
end;
if (place^.ascii = P^.ascii)
then begin
if follower <> head
then follower^.next:= place^.next
else head:= place^.next;
if last = place then last:= follower;
DrawString(place, row, mode);
dispose(place);
dispose(P);
end
end {if deleting}
else if (P^.across <= place^.across) and (mode = 7)
then begin
head:= P;
P^.next:= place;
DrawString(P, row, mode);
end {if inserting}
else {not in first position}
begin
while(place <> last)
and (P^.across > place^.across) do
begin
follower:= place;
place:= place^.next
end; {while}
if (P^.across = place^.across) {correct pos.}
and (mode = 0) {deleting}
then
begin
while (place^.ascii <> P^.ascii)
and (place^.next <> nil)
do begin
follower:= place;
place:= place^.next;
end;
if (place^.ascii = P^.ascii) then begin
follower^.next:= place^.next;
if last = place then last:= follower;
DrawString(place, row, mode);
dispose(place);
dispose(P);
end;
end {if deleting}
else {inserting}
begin
follower^.next:= P;
P^.next:= place;
DrawString(P, row, mode);
end {inserting}
end {not in first position}
end {interior node}
end; {Edit}


(********************************************************************)


procedure WriteOut;
var
place : nodepointer;
row : integer;
begin
for row := 0 to screenheight do begin
place := Lines[row]; {point to head of row}
if place <> nil then {something in row}
repeat
DrawString(place, row, 7);
place:= place^.next;
until place = nil
end; {for}
end; {WriteOut}



procedure InitializeList;
var
I : integer;
begin
For I:= 0 to screenheight do

begin
New(Lines[I]);
Lines[I] := nil;
New(LastEntry[I]);
LastEntry[I] := nil;
end;
end; {InitializeList}



begin

LoadFonts;
InitializeList;
HiRes;

repeat
write('Enter x coordinate: '); readln(x);
write('Enter y coordinate: '); readln(y);
write('Enter horizontal stretch: '); readln(xstretch);
write('Enter vertical stretch: '); readln(ystretch);
write('Add or delete (a/d) ? '); readln(ch);
if ch = 'd' then mode:= 0 else mode:= 7;
MakeNode(Temp, x, 65, xstretch, ystretch);
Edit(Lines[y], LastEntry[y], Temp, y, mode);
write('Draw again (y/n)?'); readln(ch);
until ch = 'n';

HiRes;
WriteOut;
readln;
textmode(C80);

end.


  3 Responses to “Category : Files from Magazines
Archive   : PCTJ0687.ZIP
Filename : DRAWCHAR.PAS

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/