home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / programs / list / tsigns41.ark / SIGNS2.PAS < prev    next >
Pascal/Delphi Source File  |  1986-12-24  |  10KB  |  280 lines
  1. PROCEDURE input_menu;
  2. BEGIN
  3.     GOTORC(1,48); normvideo; WRITE('Input Text  ');
  4.     GOTORC( 5,1); WRITE(' '); GOTORC( 6,1); WRITE(' '); GOTORC( 7,1); WRITE(' ');
  5.     GOTORC( 8,1); WRITE(' '); GOTORC( 9,1); WRITE(' '); GOTORC(10,1); WRITE(' ');
  6.     GOTORC(11,1); WRITE(' '); GOTORC(12,1); WRITE(' '); GOTORC(13,1); WRITE(' ');
  7.     GOTORC(14,1); WRITE('      ');
  8.     GOTORC( 4,42); WRITE(' '); GOTORC( 5,42); WRITE(' '); GOTORC( 6,42); WRITE(' ');
  9.     GOTORC( 7,42); WRITE(' '); GOTORC( 8,42); WRITE(' '); GOTORC( 9,42); WRITE(' ');
  10.     GOTORC(10,42); WRITE(' '); GOTORC(11,42); WRITE(' '); GOTORC(12,42); WRITE(' ');
  11.     GOTORC(13,42); WRITE(' '); GOTORC(14,42); WRITE(' ');
  12.     GOTORC(20,1);
  13.     WRITE('   ^P'); lowvideo; WRITE(': Change parameters     '); normvideo;
  14.     WRITE('^F,^L'); lowvideo; WRITE(': Send Formfeed to LST    '); normvideo;
  15.     WRITE('^X'); lowvideo; WRITE(': Restart Input'); normvideo;
  16.     GOTORC(21,1);
  17.     WRITE('^C,^D'); lowvideo; WRITE(': Done, quit to OS      '); normvideo;
  18.     WRITE('^R,^T'); lowvideo; WRITE(': Send Reverse Formfeed   '); normvideo;
  19.     WRITE('^H'); lowvideo; WRITE(': Backspace'); normvideo;
  20.     GOTORC(22,1);
  21.     WRITE('<ret>'); lowvideo; WRITE(': Process Input         '); normvideo;
  22.     WRITE('   ^A'); lowvideo; WRITE(': Alternate Input (HEX)   ');
  23.     GOTORC(19,1); WRITE('Input Text -> '); normvideo;
  24. END;
  25.  
  26.  
  27. PROCEDURE inp_hex;  {VAR add_str : S80}
  28. VAR str : S14;
  29.     num,err : INTEGER;
  30. BEGIN
  31.     add_str := '';
  32.     GOTORC(19,42); lowvideo;
  33.     WRITE('Enter HEX number ->'); normvideo;
  34.     READLN(str);
  35.     WHILE str <> '' DO BEGIN
  36.         VAL('$'+str,num,err);
  37.         GOTORC(18,42);
  38.         IF (err <> 0) OR (num < 20) OR (num > 255) THEN BEGIN
  39.             WRITE('Invalid!'^G); CLREOL
  40.         END ELSE BEGIN
  41.             CLREOL; WRITE('adding char #',num);
  42.             add_str := add_str + CHR(num)
  43.         END;
  44.         GOTORC(19,42); CLREOL; lowvideo;
  45.         WRITE('Enter HEX number ->'); normvideo;
  46.         READLN(str)
  47.     END; {while something entered}
  48.     GOTORC(18,42); CLREOL;
  49.     GOTORC(19,42); CLREOL
  50. END;
  51.  
  52.  
  53. PROCEDURE find_rec; { (fchr : CHAR); }
  54. VAR   rec_number : INTEGER;
  55.              rec : BIT_RECORD;
  56.        i,j,count : INTEGER;
  57. BEGIN
  58.     rec_number := ORD(fchr) - 32;
  59.     SEEK(font_file,rec_number);
  60.     READ(font_file,rec);
  61.     FOR i := 1 TO font_height DO
  62.          FOR j := 1 TO font_width DO
  63.              char_rec.pic[i,j] := ' ';  {zero transfer record}
  64.     char_rec.character := rec.character;
  65.     char_rec.width := rec.width;
  66.     char_rec.height := rec.height;
  67.     FOR i := 1 TO Max_Height DO
  68.          FOR j := 1 TO Bit_Width DO BEGIN
  69.              count := rec.bit_map[i,j];
  70.              IF count >= 128 THEN BEGIN
  71.                  char_rec.pic[i,8*j] := 'X';
  72.                  count := count - 128
  73.              END;
  74.              IF count >= 64 THEN BEGIN
  75.                  char_rec.pic[i,8*j-1] := 'X';
  76.                  count := count -  64
  77.              END;
  78.              IF count >= 32 THEN BEGIN
  79.                  char_rec.pic[i,8*j-2] := 'X';
  80.                  count := count -  32
  81.              END;
  82.              IF count >= 16 THEN BEGIN
  83.                  char_rec.pic[i,8*j-3] := 'X';
  84.                  count := count -  16
  85.              END;
  86.              IF count >= 8 THEN BEGIN
  87.                  char_rec.pic[i,8*j-4] := 'X';
  88.                  count := count -   8
  89.              END;
  90.              IF count >= 4 THEN BEGIN
  91.                  char_rec.pic[i,8*j-5] := 'X';
  92.                  count := count -   4
  93.              END;
  94.              IF count >= 2 THEN BEGIN
  95.                  char_rec.pic[i,8*j-6] := 'X';
  96.                  count := count -   2
  97.              END;
  98.              IF count >= 1 THEN char_rec.pic[i,8*j-7] := 'X';
  99.          END
  100.     {end for}
  101. END;
  102.  
  103.  
  104. PROCEDURE out_char; { (ochar : CHAR; VAR chr_pos : INTEGER) }
  105. VAR
  106.     add,i,os_lcv,strikes : INTEGER;
  107.     find_char : CHAR;
  108. BEGIN
  109.     IF ochar <> ^D THEN BEGIN {add char to out_line}
  110.         chr_pos := chr_pos + 1;
  111.         out_line[chr_pos] := ochar
  112.     END ELSE BEGIN          {output out_line}
  113.         IF block_type = bit THEN BEGIN
  114.             CASE bit_cnt OF
  115.                 0 : add := 1;
  116.                 1 : add := 2;
  117.                 2 : add := 4;
  118.                 3 : add := 8;
  119.                 4 : add := 16;
  120.                 5 : add := 32;
  121.                 6 : add := 64;
  122.             END; {case}
  123.             FOR i := 1 TO chr_pos DO
  124.                 IF out_line[i] <> ' ' THEN
  125.                     gout_line[i] := CHR(ORD(gout_line[i]) + add);
  126.             IF bit_cnt < 6 THEN
  127.                 bit_cnt := bit_cnt + 1
  128.             ELSE BEGIN
  129.                 gdump;            {dump the line}
  130.                 FOR i := 1 TO Max_Length DO gout_line[i] := CHR(0);
  131.                 bit_cnt := 0      {clear graphics line}
  132.             END
  133.         END ELSE BEGIN
  134.             IF inv_video THEN BEGIN
  135.                 find_char := ' ';
  136.                 i := 1;
  137.                 WHILE (find_char = ' ') AND (i <= chr_pos) DO BEGIN
  138.                     IF out_line[i] <> ' ' THEN find_char := out_line[i];
  139.                     i := i + 1
  140.                 END; {while}
  141.                 IF find_char = ' ' THEN find_char := block_char;
  142.                 FOR i := 1 TO chr_pos DO
  143.                     IF out_line[i] = ' ' THEN
  144.                         out_line[i] := find_char
  145.                     ELSE
  146.                         out_line[i] := ' ';
  147.                 FOR i := (chr_pos + 1) TO (avail_chars - 1) DO
  148.                     out_line[i] := find_char;
  149.                 chr_pos := avail_chars - 1
  150.             END; {if inv-video}
  151.  
  152.             IF block_type = block THEN
  153.                 FOR i := 1 TO chr_pos DO
  154.                     IF out_line[i] <> ' ' THEN
  155.                         out_line[i] := block_char;
  156.             IF block_type = overstrike THEN {multiple hits?}
  157.                 strikes := LENGTH(Os_Strng)
  158.             ELSE
  159.                 strikes := 1;
  160.  
  161.             FOR os_lcv := 1 TO strikes DO BEGIN
  162.                 FOR i := 1 TO chr_pos DO
  163.                     IF (block_type = overstrike) AND (out_line[i] <> ' ') THEN
  164.                         putchr(Os_Strng[os_lcv])
  165.                     ELSE
  166.                         putchr(out_line[i]);
  167.                     {for each char in out_line}
  168.                 putchr(^M)
  169.             END; {for overstrikes}
  170.  
  171.             putchr(^J)
  172.         END; {if eol}
  173.         chr_pos := 0
  174.     END {if block_type = bit}
  175. END; {procedure out_char}
  176.  
  177.  
  178. PROCEDURE putchr; {chr:CHAR}
  179. BEGIN
  180.     CASE output_device OF
  181.         printer : WRITE(lst,chr);
  182.       recd_file : WRITE(out_file,chr);
  183.          screen : WRITE(con,chr)
  184.     END {case}
  185. END; {subprocedure putchr}
  186.  
  187.  
  188. PROCEDURE gdump;
  189. VAR i : INTEGER;
  190. BEGIN
  191.     putchr(^C);         {into graphics}
  192.     FOR i := 1 TO Max_Length DO BEGIN
  193.         IF gout_line[i] = ^C THEN putchr(^C);   {double all ^C's}
  194.         putchr(gout_line[i])
  195.     END;
  196.     putchr(^C); putchr(^B);   {out of graphics}
  197.     putchr(^N);   {cr and graphics lf}
  198. END;
  199.  
  200.  
  201. PROCEDURE set_up_prt; { (reset_prt : BOOLEAN) }
  202. BEGIN
  203.     IF NOT dumb_prt THEN BEGIN
  204.         WRITE(lst,CHR(27),'R2$'); {Draft quality print}
  205.         IF reset_prt THEN BEGIN
  206.             WRITE(lst,CHR(30));       {12 cpi}
  207.             WRITE(lst,CHR(27),'B8$'); {6 lpi}
  208.             WRITE(lst,CHR(27),'Q4$')  {Black}
  209.         END ELSE BEGIN
  210.             CASE prt_lpi OF
  211.                 six     : WRITE(lst,CHR(27),'B8$');
  212.                 eight   : WRITE(lst,CHR(27),'B6$');
  213.                 twelve  : WRITE(lst,CHR(27),'B4$');
  214.                 ten     : WRITE(lst,CHR(27),'B5$')
  215.             END; {case}
  216.             CASE prt_cpi OF
  217.                 pica     : WRITE(lst,CHR(29));
  218.                 squeezed : WRITE(lst,CHR(31));
  219.                 elite    : WRITE(lst,CHR(30));
  220.                 tiny     : WRITE(lst,CHR(30))   {20 cpi n/a on Prism, use 16.7}
  221.             END; {case}
  222.             CASE prt_color OF
  223.                 black    : WRITE(lst,CHR(27),'Q4$');
  224.                 blue     : WRITE(lst,CHR(27),'Q3$');
  225.                 green    : WRITE(lst,CHR(27),'Q2$');
  226.                 red      : WRITE(lst,CHR(27),'Q1$');
  227.             END {case}
  228.         END;
  229.         WRITE(lst,CHR(13))       {and a final <cr> to return head}
  230.     END
  231. END;
  232.  
  233.  
  234. PROCEDURE avail_space;
  235. LABEL skip;
  236. VAR  pitch : REAL;
  237. BEGIN
  238.     IF NOT disp THEN GOTO skip;  {return w/o doing anything}
  239.     IF given_width = 0 THEN BEGIN
  240.         IF output_device = printer THEN BEGIN
  241.             CASE prt_cpi OF
  242.                 pica     : pitch := 10;
  243.                 elite    : pitch := 12;
  244.                 squeezed : pitch := 16.5;    {use 17 for Epson}
  245.                 tiny     : pitch := 20;      {n/a on IDS printer}
  246.             END; {case}
  247.             IF device_size = wide THEN
  248.                 avail_chars := TRUNC(pitch * 14)
  249.             ELSE
  250.                 avail_chars := TRUNC(pitch * 8)
  251.        END ELSE       {output_device = screen or recd_file}
  252.            IF device_size = wide THEN
  253.                avail_chars := 132
  254.            ELSE
  255.                avail_chars := 80;
  256.        {end if}
  257.     END ELSE {width WAS given}
  258.         avail_chars := given_width;
  259.     {end if width was not given}
  260.  
  261.     GOTORC(16,1); lowvideo; WRITE('Calculated width available -> ');
  262.     normvideo; WRITE(avail_chars,'  ');
  263.     IF font_height <> 0 THEN BEGIN
  264.         GOTORC(17,1); CLREOL; lowvideo;
  265.         IF sign_type = sign THEN BEGIN     {est based on 8+1 spaces/char}
  266.             WRITE('Approx # of *input* chars allowed -> '); normvideo;
  267.             WRITE((ROUND(avail_chars/(mult_w*(font_width+inter_spc-2)))):1,'  ')
  268.         END ELSE BEGIN
  269.             WRITE('Output line must be at least -> '); normvideo;
  270.             WRITE((font_height * mult_h) + given_offset);
  271.             IF ((font_height * mult_h) + given_offset) > avail_chars THEN
  272.                WRITE('<- Error: Output overflow!'^G)
  273.             {if overflow}
  274.         END {if sign output approx max input line}
  275.     END;
  276. skip:
  277. END;
  278.  
  279.  
  280.