home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
kermit.columbia.edu
/
kermit.columbia.edu.tar
/
kermit.columbia.edu
/
archives
/
norskdata.zip
/
ndkhau.pas
< prev
next >
Wrap
Pascal/Delphi Source File
|
1985-06-24
|
11KB
|
388 lines
(* tab p; *)
(*$I_*)
procedure DoHelp;
$include h-decl
var top_of_tree : item_ptr;
textfile : text;
contfile : itemfile;
lv : integer;
log_unit : integer;
file_name : f_string;
file_type : t_string;
status : integer;
$include h-extern
$include h-linerut
$include h-item
procedure crunch_text(var top_of_tree : item_ptr;var contfile : itemfile);
var log_unit : integer;
curr_item : item_ptr;
curr_level : integer;
index : integer;
file_name : f_string;
file_type : t_string;
status : integer;
procedure change_parity(new_item : item_ptr);
var index : integer;
begin
with new_item^ do
for index := 1 to item_name_length do
name(.index.) := chr(ord(name(.index.)) mod 200b);
end;
procedure make_new_item(var curr_item : item_ptr;
var curr_level: integer; var contfile : itemfile);
var new_item : item_ptr;
new_level: integer;
return_ptr : item_ptr;
index : integer;
begin
new_level := contfile^.level;
if (new_level = bottom_level) then
curr_level := bottom_level
else
begin
new(new_item);
new_item^ := contfile^;
nil_sub_trees(new_item);
$IFTRUE DEBUG
WRITELN('CURR_LEVEL :',CURR_LEVEL,' NEW_LEVEL : ',NEW_LEVEL);
WRITELN(NEW_ITEM^.NAME);
$ENDIF DEBUG
if (new_level > curr_level+1) then
halt('ERROR : Leveling error');
if new_level = curr_level then
curr_item := curr_item^.prev_item;
if new_level < curr_level then
for index := 1 to (curr_level - new_level + 1) do
curr_item := curr_item^.prev_item;
find_empty_sub_item(curr_item,return_ptr);
if return_ptr = nil then
curr_item^.sub_items := new_item
else
return_ptr^.adj_item := new_item;
new_item^.adj_item := nil;
new_item^.prev_item := curr_item;
change_parity(new_item);
curr_level :=new_level;
curr_item := new_item;
end;
end;
begin
(* Crunch_text *)
connect(contfile,'(SYSTEM)KERMIT','HLIB','R',status);
if status <> 0 then
begin
connect(contfile,'(HELP)KERMIT','HLIB','R',status);
if status <> 0 then
begin
connect(contfile,'KERMIT','HLIB','R',status);
if status <> 0 then
writeln('ERROR : Can''t open library file.');
end;
end;
reset(contfile);
new(top_of_tree);
top_of_tree^ := contfile^;
top_of_tree^.prev_item := nil;
top_of_tree^.adj_item := nil;
nil_sub_trees(top_of_tree);
curr_level := top_of_tree^.level;
if curr_level <> bottom_level then
halt('ERROR : First level must be minus one');
curr_item := top_of_tree;
repeat
get(contfile);
if not(eof(contfile)) then
make_new_item(curr_item,curr_level,contfile);
$IFTRUE DEBUG
WRITELN('NAME OF ITEM ',CURR_ITEM^.NAME);
$ENDIF DEBUG
until (curr_level = bottom_level) or eof(contfile);
disconnect(contfile);
end;
procedure print_tree(top_of_tree : item_ptr);
var index : integer;
ptr : item_ptr;
begin
if top_of_tree <> nil then
with top_of_tree^ do
begin
lv := lv+2;
for index := 1 to lv do write(' ');
writeln('Name: ',name,' Byte adr :',text_address,' Level',level);
ptr := top_of_tree^.sub_items;
while ptr <> nil do
begin
print_tree(ptr);
ptr := ptr^.adj_item;
end;
lv := lv - 2;
end;
end;
procedure walk_tree(top_of_tree : item_ptr);
const top = 1;
var test_name : name_item;
print_anew : boolean;
exit : boolean;
index : integer;
found : boolean;
line_image : line;
count : integer;
ptr : item_ptr;
item_c : integer;
save_ptr : item_ptr;
ambig_ref : boolean;
back_ptr : item_ptr;
function upper(ch : char) : char;
begin
if ch in (.'a'..'}'.) then
upper := chr(ord(ch) - 40b)
else
upper := ch;
end;
procedure out_name(name : name_item);
var index : integer;
begin
index := 1;
while (index <= item_name_length) and (name(.index.) <> ' ') do
begin
outbt(1,upper(name(.index.)));
index := index + 1;
end
end;
procedure out_text(top_of_tree : item_ptr;
log_unit : integer);
var ch : char;
lc : integer;
begin
writeln;
setbt(log_unit,top_of_tree^.text_address);
out_name(top_of_tree^.name);
writeln;
lc := 0;
repeat
get_line(line_image,count);
if not(line_image(.1.) in (.'0'..'9'.)) then
print_line(line_image);
lc := lc +1;
if lc = 21 then
begin
write('Type <CR> to continue >');
ch := inbt(1);
write(chr(13),' ':25,chr(13));
lc := 0;
end;
until line_image(.1.) in (.'0'..'9'.);
end;
procedure get_name(var in_name : name_item);
var index : integer;
ch : char;
procedure space_fill(var in_name : name_item);
var index : integer;
begin
for index := 1 to item_name_length do
in_name(.index.) := ' ';
end;
begin (* get_name *)
index := 1;
space_fill(in_name);
repeat
ch := inbt(1);
if printable(ch) then
begin
in_name(.index.) := ch;
index := index +1;
end
else
if (ch = chr(del)) and (index > 1) then
begin
outbt(1,chr(bs));outbt(1,' ');outbt(1,chr(bs));
index := index - 1
end;
if (index = 1) and (ch = chr(cr)) then
in_name(.top.) := chr(cr);
until (ch = chr(cr)) or (index > item_name_length);
end;
function match(a_string,b_string : name_item) : boolean;
var index : integer;
function upper(ch : char) : char;
begin
if ch in (.'a'..'}'.) then
upper := chr(ord(ch) - 40b)
else
upper := ch;
end;
begin
index := 1;
while (index <= item_name_length) and
(upper(a_string(.index.)) = upper(b_string(.index.))) do
index := index + 1;
while (index <= item_name_length) and (a_string(.index.) = ' ') do
index := index + 1;
if index > item_name_length then
match := true
else
match := false;
end;
begin (* WalkTree *)
print_anew := true;
brkm(0); (* Break on all *)
echom(1); (* Echo all but control-characters *)
out_text(top_of_tree,log_unit);
repeat
exit := false;
if print_anew then
begin
writeln;
writeln(' ':4,'Additional information available :');
writeln;
ptr := top_of_tree^.sub_items;
item_c := 0;
write(' ':4);
while ptr <> nil do
begin
write(ptr^.name);
ptr := ptr^.adj_item;
item_c := item_c +1;
if item_c = 5 then
begin
writeln;
write(' ':4);
item_c := 0;
end;
end;
writeln;
writeln;
end;
if top_of_tree^.prev_item <> nil then
begin
if top_of_tree^.prev_item^.prev_item = nil then
begin
out_name(top_of_tree^.name);
write(' subtopic ?>');
end
else
begin
back_ptr := top_of_tree;
while back_ptr^.prev_item^.prev_item <> nil do
back_ptr := back_ptr^.prev_item;
out_name(back_ptr^.name);
write(' ');
out_name(top_of_tree^.name);
write(' subtopic ?>');
end;
end
else
write('Item ? >');
get_name(test_name);
writeln;
print_anew := false;
if test_name(.top.) = chr(cr) then
begin
top_of_tree := top_of_tree^.prev_item;
if top_of_tree = nil then
exit := true;
end
else
if test_name(.top.) = '?' then
print_anew := true
else
begin
ptr := top_of_tree^.sub_items;
found := false;
save_ptr := nil;
ambig_ref := false;
while ptr <> nil do
begin
If match(test_name,ptr^.name) then
begin
if save_ptr <> nil then
ambig_ref := true
else
save_ptr := ptr;
out_text(ptr,log_unit);
end;
ptr := ptr^.adj_item;
end;
if save_ptr = nil then
writeln('Sorry, no information on ',test_name)
else
if not(ambig_ref) then
begin
print_anew := false;
if save_ptr^.sub_items <> nil then
begin
top_of_tree := save_ptr;
print_anew := true;
end;
end;
end
until exit;
end;
begin (* Main routine *)
file_name := '(SYSTEM)KERMIT''';
file_type := 'HELP';
log_unit := xopen(file_name,file_type,1,status);
if status <> 0 then
begin
file_name := '(HELP)KERMIT''';
log_unit := xopen(file_name,file_type,1,status);
if status <> 0 then
begin
file_name := 'KERMIT''';
log_unit := xopen(file_name,file_type,1,status);
if status <> 0 then
writeln('ERROR : Can''t open help file.');
end;
end;
crunch_text(top_of_tree,contfile);
lv := 0;
(* print_tree(top_of_tree); *)
walk_tree(top_of_tree);
close(log_unit);
end;.