home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-385-Vol-1of3.iso
/
m
/
miscpas.zip
/
CRFONTS.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-02-09
|
16KB
|
420 lines
program fonts(input,output);
const
key1='TOGGLE'; key2=' '; key3='SHLT'; key4='SHRT'; key5='SHUP';
key6='SHDN'; key7='CLR'; key8='FILL'; key9='#'; key10='MENU';
keyins='+1'; keydel='-1';
maxfont=255; bit1=0; bit8=7;
dot=22; hline=205; vline=186; luc=201; ruc=187; rlc=188; llc=200;
{ ═ ║ ╔ ╗ ╝ ╚ }
{ LOCATION OF FRAME. LUCR0 & LUCC0 LOCATE UPPER LEFT-HAND CORNER, WHILE
HSTEP & VSTEP DETERMINE ITS SIZE. }
lucr0=3; lucc0=4; hstep=2; vstep=1;
menur=5; menuc=40;
type
bigstr = string[80];
bytebits = bit1..bit8;
pattern_set = set of bytebits; char_pattern = array[1..8] of pattern_set;
file_name_type = string[14];
char_pattern_file = file of char_pattern;
reg_length = (reg_word,reg_byte);
regpack = record case reg_length of
reg_word: (ax,bx,cx,dx,bpx,six,dix,dsx,esx,flagx: integer);
reg_byte: (al,ah,bl,bh,cl,ch,dl,dh:Byte;
bp,si,di,ds,es,flag:integer);
end;
keys = (nokey,notfct,
f1,f2,f3,f4,f5,f6,f7,f8,f9,f10,
home,up,pgup,lt,rt,en,dn,pgdn,ins,del);
on_off = (on,off);
var
fonts: array[0..maxfont] of char_pattern;
filename1,filename2: file_name_type;
file1,file2:char_pattern_file;
fontno,fontnr,fontnc,xyr,xyc: integer;
key:keys; ch,chx:char;
i,j:integer;
currow,curcol:integer; { CURRENT LOGICAL CURSOR POSITION }
quit:boolean;
{*************************** P R O C E D U R E S **************************}
procedure Reverse; { CHANGES OUTPUT TO REVERSE VIDEO }
begin TextColor(black); TextBackGround(white); end;
procedure Normal; { CHANGES OUTPUT TO NORMAL VIDEO }
begin TextColor(white); TextBackGround(black); end;
function GetKey(var chx,ch:char): keys;
const esc=27;
begin
if KeyPressed then begin { READ KEYBOARD, AND MAP INTO 'KEYS' TYPE }
read(Kbd,ch); chx:=chr(0);
if ord(ch)=esc then
if KeyPressed then begin chx:=ch; read(Kbd,ch) end;
if chx=chr(0) then GetKey:=notfct
else case ch of
';': GetKey:=f1;
'<': GetKey:=f2;
'=': GetKey:=f3;
'>': GetKey:=f4;
'?': GetKey:=f5;
'@': GetKey:=f6;
'A': GetKey:=f7;
'B': GetKey:=f8;
'C': GetKey:=f9;
'D': GetKey:=f10;
'G': GetKey:=home;
'H': GetKey:=up;
'I': GetKey:=pgup;
'K': GetKey:=lt;
'M': GetKey:=rt;
'O': GetKey:=en;
'P': GetKey:=dn;
'Q': GetKey:=pgdn;
'R': GetKey:=ins;
'S': GetKey:=del;
else GetKey:=notfct;
end { CASE }
end {KEYPRESSED}
else GetKey:=nokey;
end; {GETKEY}
procedure BlinkVideo;
begin TextColor(white+blink) end;
function Locate_Row(i:integer): integer;
begin Locate_Row:=lucr0+vstep*i; end;
function Locate_Col(i:bytebits): integer;
begin Locate_Col:=lucc0+hstep*(i+1); end;
procedure GoToRC(row,col:integer);
begin GotoXY(col,row); end;
{**** REVERSE THE BITS IN A SET TYPE. THE BIT NUMBERING FOR GRAPHICS
PATTERNS IS A MIRROR IMAGE OF THE BIT NUMBERING FOR PASCAL SETS. }
procedure RevFont(font:char_pattern;var tfont:char_pattern);
var i:integer;
{*} procedure RevSet(pset:pattern_set;var tpset:pattern_set);
var i:bytebits;
begin tpset:=[];
for i:=bit1 to bit8 do if i in pset then tpset:=tpset + [bit8-i];
end;
begin
for i:=1 to 8 do RevSet(font[i],tfont[i]);
end;
procedure Display_Coord(row:integer;col:bytebits);
var x,y:integer;
begin x:=WhereX; y:=WhereY; GoToRC(xyr,xyc); Reverse;
write(' ',row:1,',',col+1:1,' '); Normal;
GotoXY(x,y); end;
procedure Dot_Clr(i:integer;j:bytebits; cursor:on_off);
begin fonts[fontno][i]:= fonts[fontno][i] - [j];
GoToRC(Locate_Row(i),Locate_Col(j));
if cursor=on then begin
Display_Coord(i,j); BlinkVideo; write(chr(dot)); Normal; end
else write(' ');
end;
procedure Dot_Set(i:integer;j:bytebits; cursor:on_off);
begin fonts[fontno,i] := fonts[fontno,i] + [j];
GoToRC(Locate_Row(i),Locate_Col(j));
if cursor=on then begin
Display_Coord(i,j); highvideo end
else LowVideo;
write(chr(dot));
Normal;
end;
procedure Dot_Cursor(row:integer;col:bytebits;cursor:on_off);
begin GoToRC(Locate_Row(row),Locate_Col(col));
if col in fonts[fontno,row] then begin
if cursor=on then begin
Display_Coord(row,col); highvideo end
else LowVideo; write(chr(dot)) end
else if cursor=on then begin
Display_Coord(row,col);BlinkVideo; write(chr(dot)); end
else write(' ');
Normal;
end;
procedure Line25; { PRINTOUT THE LINE 25 INFORMATION }
var keyno:integer;
procedure writekey(key:bigstr);
begin Normal; keyno:=keyno+1;
if keyno<>1 then write(' ');
if keyno<=10 then write(keyno:1)
else if keyno=11 then write('INS') else write('DEL');
Reverse; write(key); Normal; end;
begin
GotoXY(1,25); keyno:=0;
writekey(key1); writekey(key2); writekey(key3); writekey(key4); writekey(key5);
writekey(key6); writekey(key7); writekey(key8); writekey(key9); writekey(key10);
writekey(keyins); writekey(keydel);
end; {LINE25}
procedure Display_Border;
var i,rtcol,btmrow:integer;
begin
highvideo;
{ WRITE OUT CORNER CHARACTERS }
GoToRC(lucr0,lucc0); write(chr(luc));
rtcol:=lucc0+9*hstep; GoToRC(lucr0,rtcol); write(chr(ruc));
btmrow:=lucr0+9*vstep; GoToRC(btmrow,lucc0); write(chr(llc));
GoToRC(btmrow,rtcol); write(chr(rlc));
{ WRITE OUT LINES OF FRAME }
for i:=lucc0+1 to rtcol-1 do begin
GoToRC(lucr0,i); write(chr(hline)); GoToRC(btmrow,i); write(chr(hline)); end;
for i:=lucr0+1 to btmrow-1 do begin
GoToRC(i,lucc0); write(chr(vline)); GoToRC(i,rtcol); write(chr(vline)); end;
{ INITIALIZE THE SCREEN POSITION OF THE FONT NUMBER }
fontnr:=lucr0-1; fontnc:=rtcol-4;
xyr:=fontnr; xyc:=lucc0;
end; { DISPLAY_BORDER }
procedure Display_FontNo(fontno:integer);
begin Reverse; GoToRC(fontnr,fontnc); write(' ',fontno:3,' '); Normal; end;
procedure Display_Fonts(font:char_pattern);
var i,row:integer; col,j:bytebits;
begin
LowVideo;
for i:=1 to 8 do begin
row:=Locate_Row(i); { GET SCREEN POSITION OF THE Ith ROW }
for j:=bit1 to bit8 do begin
col:=Locate_Col(j); { GET SCREEN POSITION OF THE Jth COLUMN }
GoToRC(row,col);
if j in font[i] then write(chr(dot)) else write(' ');
end;
end;
currow:=1; curcol:=bit1; Dot_Cursor(currow,curcol,on);
end; { DISPLAY A FONT }
procedure Display_Font(fontno:integer);
begin Display_Fonts(fonts[fontno]); end;
procedure Menus;
label to_lbl,from_lbl,num_lbl;
const romofs=$fa6e; romseg=$f000;
var cmd:1..4; qrow:integer;
font:char_pattern;
sfont,dfont,code,num,i,strpos,xpos,ypos:integer;
instring: string[80];
rom:boolean;
pattern: pattern_set; membyte:Byte Absolute pattern;
ans:char;
filename:file_name_type;
{*}procedure Write_Option(row:integer;str:bigstr);
begin
GoToRC(row,menuc); write(str); end;
{*}procedure Clear_Rows(row:integer);
var i:integer;
begin
for i:=row to 24 do begin GoToRC(i,menuc); ClrEol; end;
end;
{*}function Open_Input_File(var filevar:char_pattern_file;filename:file_name_type):boolean;
begin
Open_Input_File:=true;
Assign(filevar,filename); {$I-} reset(filevar); {$i+}
if IOResult <> 0 then begin
GoToRC(24,menuc); write('NON-EXISTENT FILE'); Open_Input_File:=false end;
end;
{*}procedure Strip_Lblanks(var str:bigstr);
var i:integer; done:boolean;
begin done:=false;
while (str[1]=' ') and (not done) do
begin Move(str[2],str[1],length(str)-1);
str[0]:=chr(ord(str[0])-1);
if ord(str[0])<=0 then done:=true; end;
end; { STRIP }
begin
Write_Option(menur,'1. QUIT');
Write_Option(menur+1,'2. READ FILE');
Write_Option(menur+2, '3. WRITE FILE');
Write_Option(menur+3,'4. COPY FONTS');
Write_Option(menur+5,'COMMAND: ');
read(cmd);
qrow:=menur+7; Clear_Rows(qrow);
case cmd of
1: begin GoToRC(qrow,menuc); write('SURE ? (Y/N): ');
read(ans); if (ans='y') or (ans='Y') then quit:=true; end;
2: begin
GoToRC(qrow,menuc); write('INPUT FILENAME:'); read(filename1);
if Open_Input_File(file1,filename1) then begin
dfont:=0; while not eof(file1) do begin
read(file1,font);
RevFont(font,fonts[dfont]);
dfont:=(dfont+1) mod 256; end;
close (file1); end;
write(' OK'); Display_Font(fontno); end;
3: begin
GoToRC(qrow,menuc);
if length(filename2)=0 then filename2:=filename1;
write('OUTPUT FILENAME (',filename2,'): '); read(filename);
if length(filename)<>0 then filename2:=filename;
Assign(file2,filename2); rewrite(file2);
for sfont:=0 to maxfont do begin
RevFont(fonts[sfont],font); write(file2,font); end;
close(file2); write(' OK'); end;
4: begin
to_lbl:
GoToRC(qrow,menuc); write('TO (',fontno:1,'):');
dfont:=fontno; {$I-} read(dfont); {$i+}
if IOResult <> 0 then goto to_lbl;
from_lbl: GoToRC(qrow+1,menuc); write('FROM (<FONT#> | ROM <FONT#>):');
xpos:=WhereX; ypos:=WhereY; read(instring);
{ PARSE INSTRING; IF CONTAINS WORD 'ROM' THEN COPY FROM ROM }
strpos:=pos('ROM',instring); rom:=false;
if strpos<>0 then begin rom:=true; delete(instring,strpos,3);end;
Strip_Lblanks(instring); val(instring,sfont,code);
if code<>0 then begin
GotoXY(xpos,ypos); ClrEol; goto from_lbl; end;
num_lbl:
GoToRC(qrow+2,menuc); write('NUM (1):'); num:=1; {$I-}read(num); {$i+}
if IOResult <> 0 then goto num_lbl;
if rom then begin
Move(Mem[romseg:(romofs+sfont*8)],fonts[dfont],num*8);
for i:=dfont to dfont+num-1 do {REVERSE BIT PATTERNS}
RevFont(fonts[i],fonts[i]);
end
else Move(fonts[sfont],fonts[dfont],num*8);
write(' OK'); Display_Font(fontno); end; { 4 }
else { DO NOTHING } end; { case }
end; { MENUS }
procedure Perform(key:keys); { MAJOR ROUTINE FOR EXECUTING THE NON-MENU COMMANDS }
var i:integer; j:bytebits;
begin
case key of
f1: { TURN ON BIT }
if curcol in fonts[fontno,currow] then Dot_Clr(currow,curcol,on)
else Dot_Set(currow,curcol,on);
f2: { NOTHING IMPLEMENTED };
f3: begin { SHIFT LEFT }
for j:=bit1 to bit8 do for i:=1 to 8 do
if j=bit8 then Dot_Clr(i,j,off)
else if j+1 in fonts[fontno,i] then Dot_Set(i,j,off)
else Dot_Clr(i,j,off);
Dot_Cursor(currow,curcol,on); end;
f4: begin { SHIFT RIGHT }
for j:=bit8 downto bit1 do for i:=1 to 8 do
if j=bit1 then Dot_Clr(i,j,off)
else if j-1 in fonts[fontno,i] then Dot_Set(i,j,off)
else Dot_Clr(i,j,off);
Dot_Cursor(currow,curcol,on); end;
f5: begin { SHIFT UP }
for i:=1 to 8 do for j:=bit1 to bit8 do
if i=8 then Dot_Clr(i,j,off)
else if j in fonts[fontno,i+1] then Dot_Set(i,j,off)
else Dot_Clr(i,j,off);
Dot_Cursor(currow,curcol,on); end;
f6: begin { SHIFT DOWN }
for i:=8 downto 1 do for j:=bit1 to bit8 do
if i=1 then Dot_Clr(i,j,off)
else if j in fonts[fontno,i-1] then Dot_Set(i,j,off)
else Dot_Clr(i,j,off);
Dot_Cursor(currow,curcol,on); end;
f7: begin { CLEAR FONT }
for i:=1 to 8 do for j:=bit1 to bit8 do Dot_Clr(i,j,off);
currow:=1; curcol:=0; Dot_Cursor(1,0,on); end;
f8: begin { FILL FONT }
for i:=1 to 8 do for j:=bit1 to bit8 do Dot_Set(i,j,off);
currow:=1; curcol:=0; Dot_Cursor(1,0,on); end;
f9: { GET NEW FONT NUMBER TO DISPLAY }
begin GoToRC(fontnr,fontnc); Reverse; read(fontno);
Display_FontNo(fontno); Display_Font(fontno) end;
ins:{ NEXT FONT }
begin fontno:=(fontno+1)mod 256;
Display_FontNo(fontno); Display_Font(fontno) end;
del:{ PREVIOUS FONT }
begin fontno:=(fontno+255) mod 256;
Display_FontNo(fontno); Display_Font(fontno) end;
f10:{ MENUS }
Menus;
{ CURSOR MOVEMENT ROUTINES }
home: begin Dot_Cursor(currow,curcol,off);
currow:=(currow+6)mod 8+1; curcol:=(curcol+7)mod 8;
Dot_Cursor(currow,curcol,on); end;
up: begin Dot_Cursor(currow,curcol,off);
currow:=(currow+6)mod 8+1;
Dot_Cursor(currow,curcol,on); end;
pgup: begin Dot_Cursor(currow,curcol,off);
currow:=(currow+6)mod 8+1; curcol:=(curcol+1) mod 8;
Dot_Cursor(currow,curcol,on); end;
lt: begin Dot_Cursor(currow,curcol,off);
curcol:=(curcol+7)mod 8;
Dot_Cursor(currow,curcol,on); end;
rt: begin Dot_Cursor(currow,curcol,off);
curcol:=(curcol+1) mod 8;
Dot_Cursor(currow,curcol,on); end;
en: begin Dot_Cursor(currow,curcol,off);
currow:=currow mod 8+1; curcol:=(curcol+7)mod 8;
Dot_Cursor(currow,curcol,on); end;
dn: begin Dot_Cursor(currow,curcol,off);
currow:=currow mod 8+1;
Dot_Cursor(currow,curcol,on); end;
pgdn: begin Dot_Cursor(currow,curcol,off);
currow:=currow mod 8+1; curcol:=(curcol+1) mod 8;
Dot_Cursor(currow,curcol,on); end;
end;
end; { PERFORM }
procedure Center_Write(row:integer; str:bigstr);
var col:integer;
begin col:=41-length(str) div 2; GotoXY(col,row); write(str); end;
begin {************** MAIN PROGRAM ********************}
{ SIGN ON }
ClrScr; Reverse;
Center_Write(8,' C R E A T E F O N T S ');
Center_Write(10,' B Y ');
Center_Write(12, ' L . J . W I N K L E R ');
Center_Write(16,' COPYRIGHT 1984 LAWRENCE J. WINKLER ');
Normal; Delay(4000); ClrScr;
{ INITIALIZE VARIABLES }
for fontno:=0 to maxfont do for i:=1 to 8 do fonts[fontno,i]:=[];
fontno:=0; currow:=1; curcol:=bit1; quit:=false;
filename1:=''; filename2:='';
Line25;
Display_Border;
Display_FontNo(fontno); Display_Font(fontno);
while not quit do
if KeyPressed then begin
key:=GetKey(chx,ch);
if (key <> nokey) and (key <> notfct) then Perform(key);
end;
GoToRC(24,10); writeln(' C R E A T E F O N T S TERMINATING');
end.