home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / signs / util.pas < prev   
Encoding:
Pascal/Delphi Source File  |  1989-10-01  |  8.3 KB  |  269 lines
  1. PROCEDURE gotorc; {(R,C : INTEGER);}
  2. BEGIN
  3.     GOTOXY(C,R)      {I prefer Row,Column over Column, Row}
  4. END;
  5.  
  6.  
  7. PROCEDURE sak; {'strike any key to continue ...'}
  8. VAR tmp:CHAR;
  9. BEGIN
  10.     GOTORC(25,1); CLREOL; highvideo;
  11.     TextAttr := TextAttr + blink;
  12.     WRITE('Strike any key to continue ...');
  13.     TextAttr := TextAttr - blink;
  14.     REPEAT UNTIL KeyPressed;
  15.     GOTORC(25,1); CLREOL;
  16.     tmp:=READKEY
  17. END;
  18.  
  19.  
  20. PROCEDURE alt_inp; {  (VAR alt_str : S14);}
  21. VAR str : S14;
  22.     num,err : INTEGER;
  23. BEGIN
  24.     alt_str := '';
  25.     GOTORC(19,52); lowvideo;
  26.     WRITE('Enter Decimal number ->'); highvideo;
  27.     READLN(str);
  28.     WHILE (str <> '') AND (LENGTH(alt_str) < 14) DO BEGIN
  29.         VAL(str,num,err);
  30.         GOTORC(24,1);
  31.         IF (err <> 0) OR (num < 1) OR (num > 255) THEN BEGIN
  32.             WRITE('Invalid!'^G); CLREOL
  33.         END ELSE BEGIN
  34.             CLREOL; WRITE('adding char #',num);
  35.             alt_str := alt_str + CHR(num);
  36.             IF sign_type = sign THEN space_needed :=
  37.                 space_needed + (ndx_array[num].delta_x * mult_w);
  38.             GOTORC(17,25); CLREOL; highvideo; WRITE(space_needed);
  39.         END;
  40.         GOTORC(19,52); CLREOL; lowvideo;
  41.         WRITE('Enter Decimal number ->'); highvideo;
  42.         READLN(str)
  43.     END; {while something entered}
  44.     GOTORC(24,1); CLREOL;
  45.     GOTORC(19,52); CLREOL
  46. END;
  47.  
  48.  
  49. PROCEDURE putchr; {chrs:S14}
  50. VAR i : INTEGER;
  51. BEGIN
  52. {    IF chrs[1] = CHR(26) THEN
  53.         chrs[1] := CHR(ORD(chrs[1]) + 4);       {can't output an ^Z, so ^^}
  54.                                                 {uses printer2 fixes this}
  55.     FOR i := 1 TO LENGTH(chrs) DO
  56.         CASE output_device OF
  57.              printr : WRITE(lst,chrs[i]);
  58.           recd_file : WRITE(out_file,chrs[i]);
  59.              screen : WRITE(chrs[i])
  60.         END {case}
  61.     {end for each char in passed string}
  62. END; {subprocedure putchr}
  63.  
  64.  
  65. PROCEDURE disp_fs;
  66. BEGIN
  67.     GOTORC(16,41); CLREOL; lowvideo;
  68.     WRITE('Font width: '); highvideo; WRITE(font_width:3); lowvideo;
  69.     WRITE('    Height: '); highvideo; WRITE(font_height:3)
  70. END; {procedure disp_fs}
  71.  
  72.  
  73. PROCEDURE init_ff; { (VAR ff,ffi : S14, VAR ok : BOOLEAN);}
  74. LABEL err_exit;
  75. VAR err : INTEGER;
  76.       i : INTEGER;
  77. BEGIN
  78.     ok := TRUE;
  79.     IF ff <> '' THEN BEGIN
  80.         font_fn := ff;
  81.         err := POS('.',font_fn);
  82.         IF err = 0 THEN font_fn := font_fn + '.FNT'
  83.     END;
  84.     ASSIGN(font_file,font_fn);
  85.     {$I-} RESET(font_file); {$I+}
  86.     err := IORESULT;
  87.     IF err <> 0 THEN BEGIN
  88.        font_fn := '????';
  89.        GOTORC(24,1); highvideo;
  90.        WRITELN('ERR:',err,' opening HP Font file, check it!'^G);
  91.        sak;
  92.        ok := FALSE;
  93.        goto err_exit
  94.     END;
  95.  
  96.     IF ffi <> '' THEN BEGIN
  97.         font_fni := ffi;
  98.         err := POS('.',font_fni);
  99.         IF err = 0 THEN font_fni := font_fni + '.FNX'
  100.     END;
  101.     ASSIGN(font_ndx_file,font_fni);
  102.     {$I-} RESET(font_ndx_file); {$I+}
  103.     err := IORESULT;
  104.     IF err <> 0 THEN BEGIN
  105.        font_fni := '????';
  106.        GOTORC(24,1); highvideo;
  107.        WRITELN('ERR:',err,' opening Font Index file, check it!'^G);
  108.        sak;
  109.        ok := FALSE;
  110.        goto err_exit
  111.     END;
  112.  
  113.     IF ok THEN BEGIN
  114.         FOR i := 0 to 255 DO READ(font_ndx_file,ndx_array[i]);
  115.         CLOSE(font_ndx_file);
  116.         font_width := ndx_array[0].width;
  117.         font_height := ndx_array[0].height;
  118.         disp_fs;
  119.         ff_open := TRUE
  120.     END;
  121. err_exit:
  122. END; {procedure init_ff}
  123.  
  124.  
  125. PROCEDURE set_up_maps (VAR inp_line : S255);
  126. VAR i,j,k : INTEGER;
  127.    ptr8 : PTR_CHAR_MAP_8;
  128.    ptr12 : PTR_CHAR_MAP_12;
  129.    ptr18 : PTR_CHAR_MAP_18;
  130.    ptr24 : PTR_CHAR_MAP_24;
  131.    ptr30 : PTR_CHAR_MAP_30;
  132.      ptr,back : POINTER;
  133.        c : CHAR;
  134. BEGIN
  135.     IF (font_width < 56) and (font_height < 56) THEN map_size := 8
  136.     ELSE IF (font_width < 80) and (font_height < 80) THEN map_size := 12
  137.     ELSE IF (font_width < 104) and (font_height < 104) THEN map_size := 18
  138.     ELSE IF (font_width < 128) and (font_height < 128) THEN map_size := 24
  139.     ELSE IF (font_width < 160) and (font_height < 160) THEN map_size := 30
  140.     ELSE BEGIN
  141.         GOTORC(24,1); WRITE('Font too large for program.');
  142.         sak;
  143.         CLOSE(font_file);
  144.         ff_open := FALSE;
  145.         ask_parm
  146.     END;
  147.     IF (output_device <> screen) OR (input_device = keyboard) THEN BEGIN
  148.         GOTORC(20,8); WRITE('Building maps ->')
  149.     END;
  150.     GOTORC(20,25);
  151.     back := NIL;
  152.     FOR i := 1 TO Length(inp_line) DO BEGIN
  153.         IF (output_device <> screen) OR (input_device = keyboard) THEN WRITE('^');
  154.         CASE map_size OF
  155.          8 : BEGIN
  156.                 new(ptr8);
  157.                 ptr8^.next := NIL;
  158.                 ptr8^.back := back;
  159.                 IF ptr8^.back <> NIL THEN ptr8^.back^.next := ptr8;
  160.                 ptr := ptr8
  161.              END;
  162.          12: BEGIN
  163.                 new(ptr12);
  164.                 ptr12^.next := NIL;
  165.                 ptr12^.back := back;
  166.                 IF ptr12^.back <> NIL THEN ptr12^.back^.next := ptr12;
  167.                 ptr := ptr12
  168.              END;
  169.          18: BEGIN
  170.                 new(ptr18);
  171.                 ptr18^.next := NIL;
  172.                 ptr18^.back := back;
  173.                 IF ptr18^.back <> NIL THEN ptr18^.back^.next := ptr18;
  174.                 ptr := ptr18
  175.              END;
  176.          24: BEGIN
  177.                 new(ptr24);
  178.                 ptr24^.next := NIL;
  179.                 ptr24^.back := back;
  180.                 IF ptr24^.back <> NIL THEN ptr24^.back^.next := ptr24;
  181.                 ptr := ptr24
  182.              END;
  183.          30: BEGIN
  184.                 new(ptr30);
  185.                 ptr30^.next := NIL;
  186.                 ptr30^.back := back;
  187.                 IF ptr30^.back <> NIL THEN ptr30^.back^.next := ptr30;
  188.                 ptr := ptr30
  189.              END
  190.         END; {case}
  191.         back := ptr;
  192.         IF i = 1 THEN ptr_maps := ptr;
  193.         SEEK(font_file,ndx_array[ORD(inp_line[i])].position);
  194.         FOR j := 1 TO ndx_array[ORD(inp_line[i])].height DO
  195.              FOR k := 1 TO TRUNC(0.99+ndx_array[ORD(inp_line[i])].width/8) DO BEGIN
  196.                   READ(font_file,c);
  197.                   CASE map_size OF
  198.                       8 :  ptr8^.map[j,k] := ORD(c);
  199.                      12 : ptr12^.map[j,k] := ORD(c);
  200.                      18 : ptr18^.map[j,k] := ORD(c);
  201.                      24 : ptr24^.map[j,k] := ORD(c);
  202.                      30 : ptr30^.map[j,k] := ORD(c)
  203.                   END {case}
  204.              END
  205.         {end}
  206.     END;
  207.     IF (output_device <> screen) OR (input_device = keyboard) THEN BEGIN
  208.         GOTORC(20,1); CLREOL
  209.     END
  210. END;
  211.  
  212.  
  213. PROCEDURE reset_maps; { (VAR ptr : POINTER);}
  214. VAR
  215.    ptr8b,ptr8 : PTR_CHAR_MAP_8;
  216.    ptr12b,ptr12 : PTR_CHAR_MAP_12;
  217.    ptr18b,ptr18 : PTR_CHAR_MAP_18;
  218.    ptr24b,ptr24 : PTR_CHAR_MAP_24;
  219.    ptr30b,ptr30 : PTR_CHAR_MAP_30;
  220. BEGIN
  221.     CASE map_size OF
  222.      8 : BEGIN
  223.              ptr8 := ptr_maps;
  224.              WHILE ptr8^.next <> NIL DO ptr8 := ptr8^.next;
  225.              WHILE ptr8 <> NIL DO BEGIN
  226.                  ptr8b := ptr8^.back;
  227.                  dispose(ptr8);
  228.                  ptr8 := ptr8b
  229.              END
  230.          END;
  231.     12 : BEGIN
  232.              ptr12 := ptr_maps;
  233.              WHILE ptr12^.next <> NIL DO ptr12 := ptr12^.next;
  234.              WHILE ptr12 <> NIL DO BEGIN
  235.                  ptr12b := ptr12^.back;
  236.                  dispose(ptr12);
  237.                  ptr12 := ptr12b
  238.              END
  239.          END;
  240.     18 : BEGIN
  241.              ptr18 := ptr_maps;
  242.              WHILE ptr18^.next <> NIL DO ptr18 := ptr18^.next;
  243.              WHILE ptr18 <> NIL DO BEGIN
  244.                  ptr18b := ptr18^.back;
  245.                  dispose(ptr18);
  246.                  ptr18 := ptr18b
  247.              END
  248.          END;
  249.     24 : BEGIN
  250.              ptr24 := ptr_maps;
  251.              WHILE ptr24^.next <> NIL DO ptr24 := ptr24^.next;
  252.              WHILE ptr24 <> NIL DO BEGIN
  253.                  ptr24b := ptr24^.back;
  254.                  dispose(ptr24);
  255.                  ptr24 := ptr24b
  256.              END
  257.          END;
  258.     30 : BEGIN
  259.              ptr30 := ptr_maps;
  260.              WHILE ptr30^.next <> NIL DO ptr30 := ptr30^.next;
  261.              WHILE ptr30 <> NIL DO BEGIN
  262.                  ptr30b := ptr30^.back;
  263.                  dispose(ptr30);
  264.                  ptr30 := ptr30b
  265.              END
  266.          END
  267.     END {case}
  268. END; {procedure reset_maps}
  269.