home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / norskdata / ndkhma.pas < prev    next >
Pascal/Delphi Source File  |  2020-01-01  |  5KB  |  193 lines
  1. (* tab p; *)
  2. (*$I_*)
  3. program help(input,output);
  4.  
  5. $include h-decl
  6.  
  7. var     top_of_tree              : item_ptr;
  8.         textfile                 : text;
  9.                                    
  10. procedure crunch_text(var top_of_tree : item_ptr);
  11.  
  12. var log_unit    : integer;
  13.     curr_item   : item_ptr;
  14.     curr_level  : integer;
  15.     index       : integer;
  16.     file_name   : f_string;
  17.     file_type   : t_string;
  18.     status      : integer;
  19.     line_image  : line;
  20.     count       : integer;
  21.  
  22. $include h-extern
  23. $include h-linerut
  24. $include h-itemisc
  25.  
  26.  
  27. procedure get_name(var curr_item : item_ptr);
  28.  
  29. var index : integer;
  30.     ch    : char;
  31.  
  32. begin
  33.     for index := 1 to item_name_length do
  34.         curr_item^.name(.index.) := ' ';
  35.     index := 1;
  36.     repeat
  37.         ch := nextch(line_image,count);
  38.         ch := chr(ord(ch) mod 200b);
  39.         if ch <> chr(cr) then
  40.         begin
  41.             curr_item^.name(.index.) := ch;
  42.             index := index +1;
  43.         end;
  44.    until (ch = chr(cr)) or(index > item_name_length);
  45. end;
  46.  
  47. procedure get_number(var out_number : integer);
  48.  
  49. var ch : char;
  50.  
  51. begin
  52.     ch := nextch(line_image,count);
  53. $iftrue debug
  54.     writeln(ch);
  55. $endif debug
  56.     out_number := 0;
  57.     while ch in (.'0'..'9'.) do
  58.     begin
  59.         out_number := 10*out_number + ord(ch)-ord('0');
  60.         ch := nextch(line_image,count);
  61.     end;
  62.     back_wind(line_image,count);
  63. $iftrue debug
  64.     writeln('Ord ch is',ord(ch));
  65. $endif debug
  66. end;
  67.  
  68. procedure  make_new_item(var curr_item : item_ptr;
  69.                     var curr_level: integer;log_unit : integer);
  70.  
  71. var new_item   : item_ptr;
  72.     new_level  : integer;
  73.     return_ptr : item_ptr;
  74.     index      : integer;
  75.                 
  76. begin
  77.     get_number(new_level);
  78.     if (new_level = last_level ) then
  79.         curr_level := bottom_level
  80.     else
  81.     begin
  82.     new(new_item);
  83.     get_name(new_item);
  84.     reabt(log_unit,new_item^.text_address);
  85. $iftrue debug
  86.     writeln('Curr_level :',curr_level,' New_level : ',new_level);
  87. $endif debug
  88.     if (new_level > curr_level+1) then
  89.         halt('ERROR : Leveling error');
  90.     nil_sub_trees(new_item);
  91.     new_item^.level := new_level;
  92.     if new_level = curr_level then
  93.         curr_item := curr_item^.prev_item;
  94.     if new_level < curr_level then
  95.         for index := 1 to (curr_level - new_level+1) do
  96.             curr_item := curr_item^.prev_item;
  97.     find_empty_sub_item(curr_item,return_ptr);
  98.     if return_ptr = nil then
  99.         curr_item^.sub_items := new_item
  100.     else
  101.         return_ptr^.adj_item := new_item;
  102.     new_item^.adj_item := nil;
  103.     new_item^.prev_item := curr_item;
  104.     curr_level :=new_level;
  105.     curr_item := new_item;
  106.     skip_until_number(line_image,count);
  107.     end;
  108. end;
  109.  
  110. begin
  111.     (* Crunch_text *)
  112.     writeln('Program to CRUNCH a help file');
  113.     write('Starting.....',chr(cr));
  114.     file_name := 'KERMIT''';
  115.     file_type := 'HELP';
  116.     status := 0;
  117.     log_unit := xopen(file_name,file_type,1,status);
  118.     if status <> 0 then
  119.         halt('Error opening Help-file.');
  120.     new(top_of_tree);
  121.     top_of_tree^.level := bottom_level;;
  122.     top_of_tree^.name := '    ';
  123.     nil_sub_trees(top_of_tree);
  124.     reabt(log_unit,top_of_tree^.text_address);
  125.     skip_until_number(line_image,count);
  126.     curr_item := top_of_tree;
  127.     curr_level := bottom_level;
  128.     repeat
  129.         make_new_item(curr_item,curr_level,log_unit);
  130.     until curr_level = bottom_level;
  131.     writeln('End of CRUNCH');
  132. end;
  133.  
  134. procedure print_tree(top_of_tree : item_ptr);
  135.  
  136. var index : integer;
  137.     ptr   : item_ptr;
  138.  
  139. begin
  140.     if top_of_tree <> nil then
  141.     with top_of_tree^ do
  142.     begin
  143.         writeln('Name: ',name,' Byte adr :',text_address);
  144.         ptr := top_of_tree^.sub_items;
  145.         while ptr <> nil do
  146.         begin
  147.             print_tree(ptr);
  148.             ptr := ptr^.adj_item;
  149.         end;
  150.     end;
  151. end;
  152.  
  153. procedure write_tree(top_of_tree : item_ptr);
  154.  
  155. type itemfile = file of item_info;
  156.  
  157. var contfile : itemfile;
  158.     index    : integer;
  159.     status   : integer;
  160.  
  161.  
  162. procedure write_sub_tree(top_of_tree : item_ptr;
  163.                      var infile : itemfile);
  164.  
  165. var xindex : integer;
  166.     ptr    : item_ptr;
  167. begin
  168.     infile^ := top_of_tree^;
  169.     put(infile);
  170.     ptr := top_of_tree^.sub_items;
  171.     while ptr <> nil do
  172.     begin
  173.         write_sub_tree(ptr,infile);
  174.         ptr := ptr^.adj_item;
  175.     end;
  176. end;
  177.  
  178. begin
  179.     connect(contfile,'KERMIT','HLIB','W',status);
  180.     if status <> 0 then
  181.         halt('ERROR : Can''t open library file.');
  182.     rewrite(contfile);
  183.     write_sub_tree(top_of_tree,contfile)
  184. end;
  185.  
  186.  
  187. begin   (* Main program *)
  188.     crunch_text(top_of_tree);
  189.     print_tree(top_of_tree);
  190.     write_tree(top_of_tree);
  191. end.
  192. 
  193.