home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Frostbyte's 1980s DOS Shareware Collection
/
floppyshareware.zip
/
floppyshareware
/
USCX
/
TURBO-06.ZIP
/
INDEX.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-02-23
|
29KB
|
718 lines
program index;
var
in_char : char; { character returned by readakey function }
place : byte; { pointer to current "position" of select screen }
col: byte; { column on screen for display purposes }
count : byte; { temporary counter variable }
Filename : string[12]; { name of file to be deleted }
num : integer; { loop limit variable }
heaptop : ^integer; { marker to start of free heapspace }
print_flag : boolean; { true if printer attached }
type
filepointer = ^heapinfo; { establish 'filepointer' as pointer type }
result = record
ax,bx,cx,dx,bp,si,di,ds,es,flags : integer;
end;
heapinfo = record { format of heap records }
name : string[12]; { filename w/ extension }
description : string[80]; { descriptive string }
next : filepointer; { 'next' ptr in 2x link list }
last : filepointer; { 'last' ptr in 2x link list }
end;
fileinfo = record { format of disk file records }
name : string[12]; { filename w/ extension }
description : string[80]; { descriptive string }
end;
var
first,current,last, tptra : filepointer; { 2x link list pointers }
filerec : fileinfo; { filerec is current record from disk }
file1 : file of fileinfo;
intr_rec : result;
label exit;
const
alpha : byte = 2;
background : byte = 1;
testline:array [1..42] of byte =
($c9,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$bb,
$c8,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$cd,$bc);
testline2:array [1..21] of byte =
($40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40,$40);
vertlineleft:array [1..8] of byte =
($c9,$ba,$ba,$ba,$ba,$ba,$ba,$c8);
vertlineleftback:array [1..8] of byte =
($40,$40,$40,$40,$40,$40,$40,$40);
vertlineright:array [1..8] of byte =
($bb,$ba,$ba,$ba,$ba,$ba,$ba,$bc);
vertlinerightback :array [1..8] of byte =
($40,$40,$40,$40,$40,$40,$40,$40);
firstletter:array[1..6] of byte =
($0f,$0f,$0f,$0f,$0f,$0f);
cursorlineaccent : array[1..12] of byte =
($5f,$50,$50,$50,$50,$50,$50,$50,$50,$50,$50,$50);
cursorlinenormal:array[1..12] of byte =
($0f,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07,$07);
{*******************************************************************}
function cursordown(pos,modval:byte) : byte;
{*******************************************************************}
{ this routine will return the updated value of the pointer 'pos'
for doing a cursor down movement.
'pos' = current pointer position (0 <= pos < modval)
'modval' = upper limit (ie count of items in list)
example: if you have 5 items in the list, this function will return
a number between 0 & modval-1. (0 & 4) }
begin
cursordown := (pos + 1) mod modval;
end; { end of cursordown }
{*******************************************************************}
function cursorup(pos,mod_val:byte) : byte;
{*******************************************************************}
{ this routine will return the updated value of the pointer 'pos'
for doing a cursor up movement.
'pos' = current pointer position (0 <= pos < modval)
'modval' = upper limit (ie count of items in list)
example: if you have 5 items in the list, this function will return
a number between 0 & modval-1. ( 0 & 4 ) }
begin
cursorup := (pos + mod_val - 1) mod mod_val;
end; {end of cursorup }
{*******************************************************************}
function readakey : char;
{*******************************************************************}
{ this function returns the value of a keystroke. If an extended keystroke
is used ( like a cursorkey), that keystroke is detected, and modified
as per below. This will assign normal codes to the cursor movements,
not the ones assigned by turbo pascal. }
var
in_key : char;
begin
read(kbd,in_key); { wait for a keystroke }
if keypressed then { if an extended key, read keystroke }
begin
read(kbd,in_key); { then the extended keystroke }
case in_key of
'H' : in_key := ^K; { vert tab (cursor up)}
'M' : in_key := ^I; { cursor right (tab) }
'P' : in_key := ^J; { line feed (cursor down)}
'K' : in_key := ^S; { backspace (cursor left)}
'S' : in_key := ^P; { DLE }
end; { end of case }
end;
readakey := in_key; { set value for return }
end; { end of readakey }
{******************************************************************}
procedure quickprint(Row,Col,HowMany,start_pos:integer;code,option:byte);
{******************************************************************}
{ option 1 = print horizontally
option 2 = print vertically
option 3 = highlight alpha or background
Row = starting row position
Col = starting screen column
Howmany = number of bytes to be displayed or highlighted
start_pos = either the offset of an array to be printed, or
the attribute byte value to be set
code = 2 for alpha bytes, 1 for backgrounds
option = as described above }
var
Start: integer; { starting offset into graphics ram }
count: integer; { loop counter }
begin
Start := ((Row-1)*160) + (Col*2) - code;
for count := 0 to howmany-1 do
begin
if option = 3
then mem[$b800:start] := start_pos
else Mem[$b800:start] := mem[cseg:start_pos+count]; { set attribute byte }
if option = 2 then start := start + 160
else start := start + 2; { increment to next byte}
end;
end; { end of quickprint }
{*******************************************************************}
procedure movecursor(var place,col:byte;row,num,width:byte);
{*******************************************************************}
{ this proc will move a cursor between user define limits on the screen
place = current cursor position ( between 0 and # items-1 )
col = screen column where cursor starts
row = screen row where current cursor is
num = number of lines of cursor travel possible
width = width of cursor ( # characters ) }
begin
repeat
in_char := readakey; { get a character from keyboard }
case in_char of
^K : begin { cursor up }
quickprint(row+place,col,width,ofs(cursorlinenormal),background,1);
place := cursorup(place,num); { calc new row }
quickprint(row+place,col,width,ofs(cursorlineaccent),background,1);
end;
^J : begin { cursor down }
quickprint(row+place,col,width,ofs(cursorlinenormal),background,1);
place := cursordown(place,num); { calc new row }
quickprint(row+place,col,width,ofs(cursorlineaccent),background,1);
end;
end; {end case}
until (in_char in [^M,^[,'R','r','W','w','D','d','I','i','Q','q','P','p','S','s','F','f']);
end; {end movecursor}
{*******************************************************************}
procedure putbox;
{*******************************************************************}
{ this procedure will put the 'box' on the screen for any given
routine. no parameters are passed. }
begin
clrscr;
quickprint(9,30,21,ofs(testline),alpha,1);
quickprint(9,30,21,ofs(testline2),background,1);
quickprint(16,30,21,ofs(testline)+21,alpha,1);
quickprint(16,30,21,ofs(testline2),background,1);
quickprint(9,30,8,ofs(vertlineleft),alpha,2);
quickprint(9,30,8,ofs(vertlineleftback),background,2);
quickprint(9,50,8,ofs(vertlineright),alpha,2);
quickprint(9,50,8,ofs(vertlinerightback),background,2);
end; { end putbox}
{*******************************************************************}
procedure init;
{*******************************************************************}
{ this procedure initializes the disk file this program requires
to be present. No parameters are passed. It checks for an existing
file, and warns if the file will be destroyed }
begin
putbox;
gotoxy(34,9);write(' INITIALIZE ');
{$i-}
reset(file1);
{$i+}
if ioresult <> 0 { file not in existance }
then begin
rewrite(file1); { create file }
first := nil; { set pointers for empty lists }
tptra := nil; { set pointers for empty lists }
end
else begin { file exists - may be overwritten }
gotoxy(31,11);write('Index file exists.');
gotoxy(31,12);write('Current index file');
gotoxy(33,13);write('will be lost.');
gotoxy(32,14);write('Continue (Y/N)? ');
read(in_char); { read response }
if upcase(in_char) = 'Y' { if 'y' then do }
then begin
erase(file1); { purge exist. file }
rewrite(file1); { create empty file }
first := nil; { set pointers for empty lists }
tptra := nil; { set pointers for empty lists }
end;
end;
end; { end of initialize }
{*******************************************************************}
procedure showmenu;
{********************************************************************}
{ this proc displays the main menu for the program }
begin
putbox; { draw box }
gotoxy(32,9);write(' INDEX Main Menu ');
gotoxy(35,10);write('Read files');
gotoxy(35,11);write('Write file');
gotoxy(35,12);write('Delete file');
gotoxy(35,13);write('Initialize');
gotoxy(35,14);write('Quit');
gotoxy(35,15);write('Print');
quickprint(10,35,6,ofs(firstletter),background,2); {highlight first letter }
quickprint(10,35,12,ofs(cursorlineaccent),background,1); {display cursor }
{ display help line }
gotoxy(10,25);textcolor(black);textbackground(lightgray);
write(chr($18),chr($19));textcolor(lightgray);textbackground(black);
write('-move bar. Select by pressing a ');textcolor(white);
write('highlighted ');textcolor(lightgray);
write('letter or ');textcolor(black);textbackground(lightgray);
write('<',chr($c4),chr($d9));textcolor(lightgray);textbackground(black);
end; { end of showmenu }
{******************************************************************}
procedure select;
{******************************************************************}
{ this proc will allow the user to select any file from the list
to either read its contents, or delete it from the list. If there are
more files than space to show them, this function will allow
the user to scroll through the complete list. }
var
row, col, place : byte;
label exit;
begin
count := 0;row := 10; col := 35; place := 0; num := 6;
window(col,row,col+12,row+6); { set window for filename display }
gotoxy(1,1);
if tptra = nil { check ptr to start of list }
then begin { if = nil: list empty }
writeln('No current');
writeln(' files ');
delay(5000);
goto exit;
end
else repeat { if <> nil: list has entries }
writeln(tptra^.name); { display filename }
tptra := tptra^.next; { move to next in list }
count := count + 1;
until (count = num) or (tptra = nil); { continue until all displayed or window full }
window(col,row,col+12,row+5); { reset window to 1 row smaller(takes care of last}
{ writeln command and it reposition of the cursor }
tptra := first; { reset temp pointer }
gotoxy(col,row);quickprint(row,col,12,$70,background,3);
{*** loop from here until a file is selected *****}
repeat
in_char := readakey; { grab a input character }
case in_char of
^K : begin { cursor up}
if tptra^.last <> nil { if <> nil, we can travel back through list }
then if place = 0 { if at top: need to scroll back }
then begin
tptra := tptra^.last; { go back one entry }
gotoxy(1,1);
{ push (scroll) entries down and make room for one at top }
insline;quickprint(row+place+1,col,12,$07,background,3);
write(tptra^.name);
quickprint(row+place,col,12,$70,background,3);
end
else begin { not at top: we can move cursor up w/o scroll }
quickprint(row+place,col,12,$07,background,3);
place := cursorup(place,num);
quickprint(row+place,col,12,$70,background,3);
tptra := tptra^.last;
end;
end;
^J : begin { move down }
if tptra^.next <> nil { if <> nil, we can still travel forward in list }
then if place = num-1 { if =, we need to scroll screen up }
then begin
tptra := tptra^.next; { get next entry }
gotoxy(1,1);delline; { scroll up and make room at bottom }
quickprint(row+place-1,col,12,$07,background,3);
gotoxy(1,num); { goto bottom of screen }
write(tptra^.name); { display next filename }
quickprint(row+place,col,12,$70,background,3);
end
else begin { we can travel down (forward) w/o scroll }
quickprint(row+place,col,12,$07,background,3);
place := cursordown(place,num);
quickprint(row+place,col,12,$70,background,3);
tptra := tptra^.next;
end;
end;
end; { end case }
until (in_char in [^M,^[,';']);
exit:
window(1,1,80,25); { reset window }
end; { end of select}
{*******************************************************************}
procedure readfiles;
{*******************************************************************}
{ this proc reads the current contents of the index file and
sets up the double link list pointers. If the file 'INDEX.NDX'
is not on the disk, an error message is printed out }
var
row, place, col : byte;
begin
{$i-}
assign(file1,'INDEX.NDX');
reset(file1);
{$i+}
if ioresult <> 0
then begin { file doesnt exist }
putbox;
gotoxy(36,9);write(' ERROR ');
gotoxy(32,11);write(' Program must be');
gotoxy(32,12);write('initialized first');
delay(5000);
end
else begin { file exists-set up double link lists }
first := nil; { set initial pointers to nil }
tptra := nil; { set initial pointers to nil }
while not eof(file1) do
begin
read(file1,filerec); { read a record from file }
new(current); { grab pointer from pool }
current^.name := filerec.name; { set name }
current^.description := filerec.description; {set description }
current^.next := first; { set forward pointer }
current^.last := nil; { set backward pointer }
if first <> nil then first^.last := current; { special case}
if first = nil then last := current; {set 'last' pointer for kicks}
first := current; { update initial pointer }
tptra := current; { update initial pointer }
end;
end;
end; { end of readfiles }
{*************************************************************}
procedure writefiles;
{*************************************************************}
{ this proc will add (insert) a file name/description into the
current link-list of files }
var dummy : char;
label exit;
begin
putbox; { display box }
gotoxy(36,9);write(' WRITE ');gotoxy(33,12);write('Enter filename:');
gotoxy(35,25);
textcolor(black);textbackground(lightgray);
write('<',chr($c4),chr($d9));
textcolor(lightgray);textbackground(black);
write('-exit');
{ read filename to be added-if null, exit from this proc }
gotoxy(36,14);read(filerec.name);
if length(filerec.name) = 0 then goto exit;
{******* convert filename to all caps *****}
for count := 1 to length(filerec.name) do
filerec.name[count] := upcase(filerec.name[count]);
{******** check for existing filename first *********}
current := nil;
while tptra <> nil do
begin
if tptra^.name = filerec.name then current := tptra;
tptra := tptra^.next;
end;
{ set a window for easy display }
window(31,10,49,15);clrscr;writeln;
if current = nil { file not currently in list }
then begin
writeln(' Enter description');
write(' (80 chars max.):');
window(1,1,80,25); { reset window }
quickprint(22,1,80,$70,background,3); { highlight input line }
gotoxy(1,22);read(filerec.description);{ read description }
new(current); { grab new pointer from pool }
current^.name := filerec.name; { set name }
current^.description := filerec.description; { set description }
current^.next := first; { set front pointer }
current^.last := nil; { set back pointer }
if first <> nil then first^.last := current; { special case pointer }
if first = nil then last := current; { set 'last' ptr for kicks}
first := current; { update initial pointer }
tptra := current; { update initial pointer }
end
else begin { file already in index file }
write('WARNING-description');
writeln(' exists. This');
writeln(' will overwrite.');
write('Continue (y/n) ? ');
read(dummy); { read response }
clrscr;
if upcase(dummy) = 'Y'
then begin { update file entry }
clrscr;writeln;
writeln(' Enter description');
write(' (80 chars max.):');
window(1,1,80,25); { reset the window }
quickprint(22,1,80,$70,background,3); { highlight input line }
gotoxy(1,22);read(filerec.description); { read response }
current^.name := filerec.name; { update name }
current^.description := filerec.description; { update descr }
tptra := first; { reset the temp pointer }
end
else window(1,1,80,25); { reset window to normal }
end;
exit:
end; { end of writefiles }
{***************************************************************}
procedure closeupshop;
{***************************************************************}
{ this proc will write the new file list out to the disk file. It
is used when the user selects the 'Q' option. }
begin
rewrite(file1); { reset file pointer }
while tptra <> nil do { write out until end of lists }
begin
filerec.name := tptra^.name;
filerec.description := tptra^.description;
write(file1,filerec);
tptra := tptra^.next; { update pointer to next item }
end;
close(file1); { close the file }
end; {end of closeupshop }
{*************************************************************}
procedure lookfile;
{*************************************************************}
{ this proc will allow the user to select which file to
view. It calls routine 'select' }
label exit;
begin
putbox; { display box }
gotoxy(36,9);write(' READ ');
{ display help line }
gotoxy(7,25);textcolor(black);textbackground(lightgray);
write(chr($18),chr($19));textcolor(lightgray);textbackground(black);
write('-move bar. Select by pressing function key ');textcolor(white);
write('F1 ');textcolor(lightgray);
write('or ');textcolor(black);textbackground(lightgray);
write('<',chr($c4),chr($d9));textcolor(lightgray);textbackground(black);
write('. ');textcolor(black);textbackground(lightgray);
write('Esc');textcolor(lightgray);textbackground(black);
write('-exit');
select; { return with file to be viewed ( or ESC to quit }
if in_char = ^[ then goto exit; { ESC ? go back to main menu }
if tptra <> nil
then begin
gotoxy(1,22);
clreol;write(tptra^.description); { write descrip. line }
quickprint(22,1,80,$40,background,3); { highlight it }
repeat
until keypressed; { loop until key pressed }
end;
tptra := first; { reset temp pointer }
exit:
end; { end of lookfile }
{*************************************************************}
procedure deletefiles;
{*************************************************************}
{ this proc will delete a given file from the link list. }
var
deleted : boolean;
label exit;
begin
putbox; { display box }
gotoxy(36,9);write(' DELETE ');
{ display help line }
gotoxy(10,25);textcolor(black);textbackground(lightgray);
write(chr($18),chr($19));textcolor(lightgray);textbackground(black);
write('-move bar. Select by pressing function key ');textcolor(white);
write('F1 ');textcolor(lightgray);
write('or ');textcolor(black);textbackground(lightgray);
write('<',chr($c4),chr($d9));textcolor(lightgray);textbackground(black);
write('. ');textcolor(black);textbackground(lightgray);
write('Esc');textcolor(lightgray);textbackground(black);
write('-exit');
select; { return with file to be deleted or ESC to exit }
if in_char = ^[ then goto exit; { ESC ? - exit }
filename := tptra^.name; { set file for deletion }
deleted := false; { set deleted flag to false }
if first = nil { empty list ? }
then writeln('nothing to delete')
else { list not empty-is it first item ? }
if first^.name = filename then
begin
first := first^.next;
first^.last := nil;
deleted := true;
end
else begin { not first item-search for filename }
current := first^.next;
{ last := first; }
while (current <> nil) and (deleted = false) do
begin {traverse and delete }
if current^.name = filename then { is current name the one ? }
begin { yes }
current^.last^.next := current^.next;
if current^.next <> nil
then current^.next^.last := current^.last;
{ last^.next := current^.next;} { reset pointer }
{ last := current^.next; } { reset pointer }
{ if last <> nil } { special case }
{ then last^.last := current^.last; }
deleted := true; { set deleted flag to true }
end
else { move to next list name }
begin
{ last := current;} { update ptr of last entry }
current := current^.next; { update ptr to next entry }
end;
end;
end;
exit:
tptra := first; { reset temp pointer }
end; { end of delete }
{*******************************************************************}
procedure print;
{*******************************************************************}
{ this proc will print the contents of the link list on either
the printer, to the screen, or to a disk file }
var namefile : string[12];
file2 : text;
label exit;
begin
putbox;
gotoxy(37,9);write(' PRINT ');
gotoxy(35,11);write('Screen');
gotoxy(35,12);write('File');
gotoxy(35,13);write('Printer');
quickprint(10,35,6,ofs(firstletter),background,2);
quickprint(11,35,12,ofs(cursorlineaccent),background,1);
gotoxy(7,25);textcolor(black);textbackground(lightgray);
write(chr($18),chr($19));textcolor(lightgray);textbackground(black);
write('-move bar. Select by pressing a ');textcolor(white);
write('highlighted ');textcolor(lightgray);
write('letter or ');textcolor(black);textbackground(lightgray);
write('<',chr($c4),chr($d9));textcolor(lightgray);textbackground(black);
write('. ');textcolor(black);textbackground(lightgray);
write('Esc');textcolor(lightgray);textbackground(black);
write('-exit');
place := 0;movecursor(place,col,11,3,12);
if in_char = ^[ then goto exit;
case in_char of
'S','s' : place := 0;
'F','f' : place := 1;
'P','p' : place := 2;
end; { end case }
if place = 0 then clrscr;
if place = 1
then begin
window(31,10,49,15);clrscr;writeln;
writeln(' Enter filename: ');
read(namefile);
if length(namefile) = 0 then goto exit;
assign(file2,namefile);
rewrite(file2);
end;
while tptra <> nil do
begin
filerec.name := tptra^.name;
filerec.description := tptra^.description;
case place of
0 : begin
writeln(filerec.name);
writeln(filerec.description);writeln;
delay(500);
end;
1 : writeln(file2,filerec.name:12,' ',filerec.description);
2 : begin
if print_flag = true
then writeln(lst,filerec.name:12,' ',filerec.description)
else begin
clrscr;gotoxy(10,10);write('Printer error');delay(1000);
end;
end;
end; { end case }
tptra := tptra^.next;
end;
if place = 1 then close(file2);
tptra := first;
exit:
window(1,1,80,25);
end; { end of print }
{**************************************************************}
{* main driver starts here .... *}
{**************************************************************}
begin
textmode(bw80);lowvideo;
{******** set no visible cursor ********}
intr_rec.ax := $0100;
intr_rec.cx := $0f0f;
intr($10,intr_rec);
{********** printer test ************}
print_flag := false;
place := port[$0379];
if place = $df then print_flag := true;
place := port[$03bd];
if place = $df then print_flag := true;
readfiles;
repeat
clrscr;
showmenu;
place := 0;col := 35;
{ no parms given so get cursor movement results }
movecursor(place,col,10,6,12);
{ if in_char = ^M, then place has cursor position }
{ else jump based on in_char value }
case in_char of { case #2 }
'R','r' : place := 0;
'W','w' : place := 1;
'D','d' : place := 2;
'I','i' : place := 3;
'Q','q' : place := 4;
'P','p' : place := 5;
end; { end case #2 }
case place of { case #1 }
0 : begin { read }
lookfile;
end;
1 : begin { write }
writefiles;
end;
2 : begin { delete }
deletefiles;
end;
3 : begin { init }
init
end;
4 : begin { quit }
goto exit
end;
5 : begin { print }
print;
end;
end; { end case #1 }
until true = false;
exit:
closeupshop;
release(heaptop);
lowvideo;
end.