home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / norskdata / ndkhau.pas < prev    next >
Pascal/Delphi Source File  |  2020-01-01  |  10KB  |  388 lines
  1. (* tab p; *)
  2. (*$I_*)
  3. procedure   DoHelp;
  4.  
  5. $include h-decl
  6.  
  7. var     top_of_tree              : item_ptr;
  8.         textfile                 : text;
  9.         contfile                 : itemfile;
  10.         lv : integer;
  11.         log_unit                 : integer;
  12.         file_name                : f_string;
  13.         file_type                : t_string;
  14.         status                   : integer;
  15.  
  16. $include h-extern
  17. $include h-linerut                 
  18. $include h-item
  19.  
  20. procedure crunch_text(var top_of_tree : item_ptr;var contfile : itemfile);
  21.  
  22. var log_unit    : integer;
  23.     curr_item   : item_ptr;
  24.     curr_level  : integer;
  25.     index       : integer;
  26.     file_name   : f_string;
  27.     file_type   : t_string;
  28.     status      : integer;
  29.  
  30.  
  31. procedure change_parity(new_item : item_ptr);
  32.  
  33. var index : integer;
  34.  
  35. begin
  36.     with new_item^ do
  37.         for index := 1 to item_name_length do
  38.             name(.index.) := chr(ord(name(.index.)) mod 200b);
  39. end;
  40.  
  41.  
  42. procedure  make_new_item(var curr_item : item_ptr;
  43.                     var curr_level: integer; var contfile : itemfile);
  44.  
  45. var new_item : item_ptr;
  46.     new_level: integer;
  47.     return_ptr : item_ptr;
  48.     index      : integer;
  49.  
  50. begin
  51.     new_level := contfile^.level;
  52.     if (new_level = bottom_level) then
  53.         curr_level := bottom_level
  54.     else
  55.     begin
  56.         new(new_item);
  57.         new_item^ := contfile^;
  58.         nil_sub_trees(new_item);
  59. $IFTRUE DEBUG
  60.         WRITELN('CURR_LEVEL :',CURR_LEVEL,' NEW_LEVEL : ',NEW_LEVEL);
  61.         WRITELN(NEW_ITEM^.NAME);
  62. $ENDIF DEBUG
  63.         if (new_level > curr_level+1) then
  64.             halt('ERROR : Leveling error');
  65.         if new_level = curr_level then
  66.             curr_item := curr_item^.prev_item;
  67.         if new_level < curr_level  then
  68.             for index := 1 to (curr_level - new_level + 1) do
  69.                 curr_item := curr_item^.prev_item;
  70.         find_empty_sub_item(curr_item,return_ptr);
  71.         if return_ptr = nil then
  72.             curr_item^.sub_items := new_item
  73.         else
  74.             return_ptr^.adj_item := new_item;
  75.         new_item^.adj_item := nil;
  76.         new_item^.prev_item := curr_item;
  77.         change_parity(new_item);
  78.         curr_level :=new_level;
  79.         curr_item := new_item;
  80.     end;
  81. end;
  82.  
  83. begin
  84.     (* Crunch_text *)
  85.     connect(contfile,'(SYSTEM)KERMIT','HLIB','R',status);
  86.     if status <> 0 then
  87.     begin
  88.         connect(contfile,'(HELP)KERMIT','HLIB','R',status);
  89.         if status <> 0 then
  90.         begin
  91.             connect(contfile,'KERMIT','HLIB','R',status);
  92.             if status <> 0 then
  93.                 writeln('ERROR : Can''t open library file.');
  94.         end;
  95.     end;
  96.     reset(contfile);
  97.     new(top_of_tree);
  98.     top_of_tree^ := contfile^;
  99.     top_of_tree^.prev_item := nil;
  100.     top_of_tree^.adj_item := nil;
  101.     nil_sub_trees(top_of_tree);
  102.     curr_level := top_of_tree^.level;
  103.     if curr_level <> bottom_level then
  104.         halt('ERROR : First level must be minus one');
  105.     curr_item := top_of_tree;
  106.     repeat
  107.         get(contfile);
  108.         if not(eof(contfile)) then
  109.         make_new_item(curr_item,curr_level,contfile);
  110. $IFTRUE DEBUG
  111.     WRITELN('NAME OF ITEM ',CURR_ITEM^.NAME);
  112. $ENDIF DEBUG
  113.     until (curr_level = bottom_level) or eof(contfile);
  114.     disconnect(contfile);
  115. end;
  116.  
  117. procedure print_tree(top_of_tree : item_ptr);
  118.  
  119. var index : integer;
  120.     ptr   : item_ptr;
  121.  
  122. begin
  123.     if top_of_tree <> nil then
  124.     with top_of_tree^ do
  125.     begin
  126.         lv := lv+2;
  127.         for index := 1 to lv do write(' ');
  128.         writeln('Name: ',name,' Byte adr :',text_address,' Level',level);
  129.         ptr := top_of_tree^.sub_items;
  130.         while ptr <> nil do
  131.         begin
  132.             print_tree(ptr);
  133.             ptr := ptr^.adj_item;
  134.         end;
  135.         lv := lv - 2;
  136.     end;
  137. end;
  138.  
  139. procedure walk_tree(top_of_tree : item_ptr);
  140.  
  141. const top = 1;
  142.  
  143. var test_name  : name_item;
  144.     print_anew : boolean;
  145.     exit       : boolean;
  146.     index      : integer;
  147.     found      : boolean;
  148.     line_image : line;
  149.     count      : integer;
  150.     ptr        : item_ptr;
  151.     item_c     : integer;
  152.     save_ptr   : item_ptr;
  153.     ambig_ref  : boolean;
  154.     back_ptr   : item_ptr;
  155.  
  156. function upper(ch : char) : char;
  157.  
  158. begin
  159.     if ch in (.'a'..'}'.) then
  160.         upper := chr(ord(ch) - 40b)
  161.     else
  162.         upper := ch;
  163. end;
  164.  
  165. procedure out_name(name : name_item);
  166.  
  167. var index : integer;
  168.  
  169. begin
  170.     index := 1;
  171.     while (index <= item_name_length) and (name(.index.) <> ' ') do
  172.     begin
  173.         outbt(1,upper(name(.index.)));
  174.         index := index + 1;
  175.     end
  176. end;
  177.  
  178.  
  179. procedure out_text(top_of_tree : item_ptr;
  180.                    log_unit    : integer);
  181.  
  182. var ch : char;
  183.     lc : integer;
  184.  
  185. begin
  186.     writeln;
  187.     setbt(log_unit,top_of_tree^.text_address);
  188.     out_name(top_of_tree^.name);
  189.     writeln;
  190.     lc := 0;
  191.     repeat
  192.         get_line(line_image,count);
  193.         if not(line_image(.1.) in (.'0'..'9'.)) then
  194.             print_line(line_image);
  195.         lc := lc +1;
  196.         if lc = 21 then
  197.         begin
  198.             write('Type <CR> to continue >');
  199.             ch := inbt(1);
  200.             write(chr(13),' ':25,chr(13));
  201.             lc := 0;
  202.         end;
  203.     until line_image(.1.) in (.'0'..'9'.);
  204. end;
  205.  
  206.  
  207. procedure get_name(var in_name : name_item);
  208.  
  209. var index : integer;
  210.     ch    : char;
  211.  
  212. procedure space_fill(var in_name : name_item);
  213.  
  214. var index : integer;
  215.  
  216. begin
  217.     for index := 1 to item_name_length do
  218.         in_name(.index.) := ' ';
  219. end;
  220.  
  221. begin (* get_name *)
  222.     index := 1;
  223.     space_fill(in_name);
  224.     repeat
  225.         ch := inbt(1);
  226.         if printable(ch) then
  227.             begin
  228.                 in_name(.index.) := ch;
  229.                 index := index +1;
  230.             end 
  231.         else
  232.             if (ch = chr(del)) and (index > 1) then
  233.             begin
  234.                 outbt(1,chr(bs));outbt(1,' ');outbt(1,chr(bs));
  235.                 index := index - 1
  236.             end;
  237.         if (index = 1) and (ch = chr(cr)) then
  238.             in_name(.top.) := chr(cr);
  239.     until (ch = chr(cr)) or (index > item_name_length);
  240. end;
  241.  
  242. function match(a_string,b_string : name_item) : boolean;
  243.  
  244. var index : integer;
  245.  
  246. function upper(ch : char) : char;
  247.  
  248. begin
  249.     if ch in (.'a'..'}'.) then
  250.         upper := chr(ord(ch) - 40b)
  251.     else
  252.         upper := ch;
  253. end;
  254.  
  255. begin
  256.     index := 1;
  257.     while (index <= item_name_length) and 
  258.           (upper(a_string(.index.)) = upper(b_string(.index.))) do
  259.         index := index + 1;
  260.     while (index <= item_name_length) and (a_string(.index.) = ' ') do
  261.         index := index + 1;
  262.     if index > item_name_length then
  263.         match := true
  264.     else
  265.         match := false;
  266. end;
  267.  
  268.  
  269. begin   (* WalkTree *)
  270.     print_anew := true;
  271.     brkm(0);    (* Break on all *)
  272.     echom(1);   (* Echo all but control-characters *)
  273.     out_text(top_of_tree,log_unit);
  274.     repeat
  275.         exit := false;
  276.         if print_anew then
  277.         begin
  278.             writeln;
  279.             writeln(' ':4,'Additional information available :');
  280.             writeln;
  281.             ptr := top_of_tree^.sub_items;
  282.             item_c := 0;
  283.             write(' ':4);
  284.             while ptr <> nil do
  285.             begin
  286.                 write(ptr^.name);
  287.                 ptr := ptr^.adj_item;
  288.                 item_c := item_c +1;
  289.                 if item_c = 5 then
  290.                 begin
  291.                     writeln;
  292.                     write(' ':4);
  293.                     item_c := 0;
  294.                 end;
  295.             end;
  296.             writeln;
  297.             writeln;
  298.         end;
  299.         if top_of_tree^.prev_item <> nil then
  300.         begin
  301.             if top_of_tree^.prev_item^.prev_item = nil then
  302.             begin
  303.                 out_name(top_of_tree^.name);
  304.                 write(' subtopic ?>');
  305.             end  
  306.             else
  307.             begin
  308.                 back_ptr := top_of_tree;
  309.                 while back_ptr^.prev_item^.prev_item <> nil do
  310.                     back_ptr := back_ptr^.prev_item;
  311.                 out_name(back_ptr^.name);
  312.                 write(' ');
  313.                 out_name(top_of_tree^.name);
  314.                 write(' subtopic ?>');
  315.             end;
  316.         end 
  317.         else
  318.             write('Item ? >');
  319.         get_name(test_name);
  320.         writeln;
  321.         print_anew := false;
  322.         if test_name(.top.) = chr(cr) then
  323.             begin
  324.                 top_of_tree := top_of_tree^.prev_item;
  325.                 if top_of_tree = nil then
  326.                     exit := true;
  327.             end
  328.         else
  329.             if test_name(.top.) = '?' then
  330.                 print_anew := true
  331.             else
  332.             begin
  333.                 ptr := top_of_tree^.sub_items;
  334.                 found := false;
  335.                 save_ptr := nil;
  336.                 ambig_ref := false;
  337.                 while ptr <> nil do
  338.                 begin
  339.                     If match(test_name,ptr^.name) then
  340.                     begin
  341.                         if save_ptr <> nil then
  342.                             ambig_ref := true
  343.                         else
  344.                             save_ptr := ptr;
  345.                         out_text(ptr,log_unit);
  346.                     end;
  347.                     ptr := ptr^.adj_item;
  348.                 end;
  349.                 if save_ptr = nil then
  350.                     writeln('Sorry, no information on ',test_name)
  351.                 else
  352.                     if not(ambig_ref) then
  353.                     begin
  354.                         print_anew := false;
  355.                         if save_ptr^.sub_items <> nil then
  356.                         begin
  357.                             top_of_tree := save_ptr;
  358.                             print_anew := true;
  359.                         end;
  360.                     end;
  361.             end 
  362.     until   exit;
  363. end;
  364.  
  365. begin   (* Main routine *)
  366.     file_name := '(SYSTEM)KERMIT''';
  367.     file_type := 'HELP';
  368.     log_unit := xopen(file_name,file_type,1,status);
  369.     if status <> 0 then
  370.     begin
  371.         file_name := '(HELP)KERMIT''';
  372.         log_unit := xopen(file_name,file_type,1,status);
  373.         if status <> 0 then
  374.         begin
  375.             file_name := 'KERMIT''';
  376.             log_unit := xopen(file_name,file_type,1,status);
  377.             if status <> 0 then
  378.                 writeln('ERROR : Can''t open help file.');
  379.         end;
  380.     end;
  381.     crunch_text(top_of_tree,contfile);
  382.     lv := 0;
  383. (*  print_tree(top_of_tree); *)
  384.     walk_tree(top_of_tree);
  385.     close(log_unit);
  386. end;.
  387. 
  388.