home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / programs / list / tsigns41.ark / POP.PAS < prev    next >
Pascal/Delphi Source File  |  1986-12-24  |  10KB  |  278 lines
  1. PROGRAM pop;
  2.  
  3. {******************************************************************************
  4. **
  5. **  Function:  This program runs a psuedo 'self-destruct' sequence
  6. **
  7. *****************************************************************************}
  8.  
  9. CONST
  10.     Max_Length = 80;         {max number of characters on a output line}
  11.      Max_Width = 40;           {these must match then input file}
  12.     Max_Height = 24;           {and match CONSTs in mf.pas!}
  13.      Bit_Width = 5;            {Max_Width/8}
  14.  
  15. {default problem parameters - TurboPascal Initialized 'Constants'}
  16.       font_fn : STRING[14]                 = 'a:Font1.Dat'; {font filename}
  17.     sign_type : (sign,banner)              = sign;
  18.    block_type : (letter,block,overstrike)  = block;
  19.    block_char : CHAR                       = #88;
  20.        mult_w : INTEGER                    = 2;         {height multiplier}
  21.        mult_h : INTEGER                    = 1;         {width multiplier}
  22.     inter_spc : INTEGER                    = 5;         {space between chars}
  23.  input_device : (keyboard,text_file)       = keyboard;
  24.    num_copies : INTEGER                    = 1;
  25. output_device : (screen,printer,recd_file) = screen;
  26.   device_size : (wide,normal)              = normal;
  27.     inv_video : BOOLEAN                    = FALSE;
  28.   given_width : INTEGER                    = 80;
  29.     centering : BOOLEAN                    = TRUE;
  30.    font_width : INTEGER                    = 10;
  31.   font_height : INTEGER                    = 12; {size of font in use}
  32.   avail_chars : INTEGER                    = 80;
  33.          time : INTEGER                    = 20;
  34. TYPE
  35.     CHARACTER_RECORD = RECORD  {record type used for random access}
  36.       character : CHAR;        {the character}
  37.           width : INTEGER;     {how wide is it}
  38.          height : INTEGER;     {how high}
  39.             pic : ARRAY[1..Max_Height,1..Max_Width] OF CHAR
  40.     END; {record}              {its 'picture'}
  41.  
  42.      BIT_RECORD = RECORD           {record type used for random access}
  43.         character : CHAR;
  44.             width : INTEGER;
  45.            height : INTEGER;
  46.           bit_map : ARRAY[1..Max_height,1..Bit_Width] OF BYTE
  47.     END; {record}
  48.  
  49.     FONT_FILE_TYPE = FILE OF BIT_RECORD;
  50.     SIGN_ARRAY = ARRAY[1..Max_Height,1..Max_Length] OF CHAR;
  51.     S80 = STRING[80];   {for input}
  52.     S2  = STRING[2];    {for Hex input}
  53.  
  54. VAR
  55.        font_file : FONT_FILE_TYPE;
  56.         char_rec : CHARACTER_RECORD; {global's easier than passing pointers!}
  57.         out_line : STRING[80]; {global pass to/from out_char}
  58.  
  59.  
  60. {************************* Procedures called *********************************}
  61.  
  62. PROCEDURE out_sign         (VAR inp_line : S80);              FORWARD;
  63. FUNCTION  check_sign           (inp_line : S80;
  64.                         VAR actual_width : INTEGER;
  65.                            VAR out_array : SIGN_ARRAY) : BOOLEAN; FORWARD;
  66. PROCEDURE find_rec                  (inp : S80;
  67.                                 position : INTEGER);              FORWARD;
  68. PROCEDURE out_char                (ochar : CHAR);                 FORWARD;
  69.  
  70.  
  71. {**************************** Program Start **********************************}
  72.  
  73.  
  74. PROCEDURE GOTORC(R,C : INTEGER);
  75. BEGIN
  76.     GOTOXY(C,R);
  77. END;
  78.  
  79. PROCEDURE main;
  80. VAR  ans : CHAR;        {entered char}
  81.      count : INTEGER;     {loop control}
  82.      i,j,c : INTEGER;
  83.      inp_line : s80;
  84. BEGIN
  85.     CLRSCR;
  86.     WRITELN('Self Destruct Sequence Activated');
  87.     WRITELN;
  88.     WRITELN('Enter authorization code to start countdown');
  89.     WRITELN;
  90.     WRITELN('Correct code will begin self destruct,');
  91.     WRITELN('anything else will abort countdown.');
  92.     WRITELN;
  93.     WRITE('Enter code ->');
  94.     READ(KBD,ans);
  95.     WRITELN(chr($1b),'#');
  96.     WRITELN;
  97.     WRITE('Correct code entered, self destruct in ',time,' seconds ...');
  98.     delay(1000);
  99.     CLRSCR;
  100.     WRITE(CHR($1B),'^                          SELF DESTRUCT IN PROGRESS',
  101.                         CHR($1B),'q',CHR($1b),'.0');
  102.     ASSIGN(font_file,font_fn);
  103.     RESET(font_file);
  104.     out_line := '';
  105.     FOR count := time DOWNTO 0 DO BEGIN
  106.         GOTORC(5,1);
  107.         STR(count,inp_line);
  108.         out_sign(inp_line);
  109.     END; {while not done}
  110.     CLRSCR;
  111.     CLOSE(font_file);
  112.     write(chr($1b),'"');
  113.     while NOT keypressed DO begin
  114.         i := round(24*Random);
  115.         j := round(79*Random);
  116.         c := round(95*random+32);
  117.         GOTORC(i,j);
  118.         write(chr(c));
  119.     END;
  120.     WRITE(chr($1b),'.2');
  121.     CLRSCR;
  122. END; {PROCEDURE main}
  123.  
  124.  
  125. PROCEDURE out_sign; {(VAR inp_line : S80)}
  126. VAR   page_offset,page_offset_lcv,
  127.   width_lcv,height_lcv,mult_h_lcv,
  128.           line_width : INTEGER;
  129.            out_array : SIGN_ARRAY; {'Sign' output line is built into this}
  130.            err : BOOLEAN;
  131. BEGIN
  132.     err := check_sign(inp_line,line_width,out_array);
  133.     page_offset := ROUND((avail_chars - line_width) / 2);
  134.     IF inv_video THEN out_char(^D);  {start with a blank line}
  135.     FOR height_lcv := 1 TO font_height DO            {output line}
  136.         FOR mult_h_lcv := 1 TO mult_h DO BEGIN
  137.             FOR page_offset_lcv := 1 TO page_offset DO out_char(' ');
  138.             FOR width_lcv := 1 TO line_width DO
  139.                 out_char(out_array[height_lcv,width_lcv]);
  140.             {end for width}
  141.             out_char(^D);
  142.         END; {for height multiplier}
  143.     {end for height}
  144.     out_char(^D);
  145. END; {PROCEDURE out_sign}
  146.  
  147.  
  148. FUNCTION check_sign; {(inp_line : S80; VAR actual_width : INTEGER) : BOOLEAN}
  149. LABEL done;
  150. VAR height_lcv,width_lcv,
  151.      mult_w_lcv,char_num : INTEGER;
  152.                      err : BOOLEAN;
  153.                    ochar : CHAR;
  154. BEGIN
  155.     FOR height_lcv := 1 to font_height DO
  156.         FOR width_lcv :=1 TO Max_Length DO
  157.             out_array[height_lcv,width_lcv] := ' '; {initialize line array}
  158.     actual_width := 1;
  159.     FOR char_num := 1 TO LENGTH(inp_line) DO BEGIN        {build line}
  160.         find_rec(inp_line,char_num);
  161.         FOR width_lcv := 1 TO char_rec.width DO
  162.             FOR mult_w_lcv := 1 TO mult_w DO BEGIN
  163.                 FOR height_lcv := 1 TO char_rec.height DO BEGIN
  164.                     IF char_rec.pic[height_lcv,width_lcv] <> ' ' THEN
  165.                         ochar := char_rec.character
  166.                     ELSE
  167.                         ochar := ' ';
  168.                     {end if}
  169.                     out_array[height_lcv,actual_width] := ochar
  170.                 END; {for height}
  171.                 actual_width := actual_width + 1
  172.             END; {for width multiplier}
  173.         {end for width of char}
  174.         actual_width := actual_width + inter_spc    {space between chars}
  175.     end; { for each input char}
  176.     check_sign := FALSE
  177. END; {PROCEDURE check_sign}
  178.  
  179.  
  180. PROCEDURE find_rec; { (inp : S80; position : INTEGER) }
  181. VAR  search_char : CHAR;
  182.       rec_number : INTEGER;
  183.              rec : BIT_RECORD;
  184.        i,j,count : INTEGER;
  185. BEGIN
  186.     search_char := COPY(inp,position,1);
  187.     rec_number := ORD(search_char) - 32;
  188.     SEEK(font_file,rec_number);
  189.     READ(font_file,rec);
  190.     FOR i := 1 TO font_height DO
  191.          FOR j := 1 TO font_width DO
  192.              char_rec.pic[i,j] := ' ';  {zero transfer record}
  193.     char_rec.character := rec.character;
  194.     char_rec.width := rec.width;
  195.     char_rec.height := rec.height;
  196.     FOR i := 1 TO Max_Height DO
  197.          FOR j := 1 TO Bit_Width DO BEGIN
  198.              count := rec.bit_map[i,j];
  199.              IF count >= 128 THEN BEGIN
  200.                  char_rec.pic[i,8*j] := 'X';
  201.                  count := count - 128
  202.              END;
  203.              IF count >= 64 THEN BEGIN
  204.                  char_rec.pic[i,8*j-1] := 'X';
  205.                  count := count -  64
  206.              END;
  207.              IF count >= 32 THEN BEGIN
  208.                  char_rec.pic[i,8*j-2] := 'X';
  209.                  count := count -  32
  210.              END;
  211.              IF count >= 16 THEN BEGIN
  212.                  char_rec.pic[i,8*j-3] := 'X';
  213.                  count := count -  16
  214.              END;
  215.              IF count >= 8 THEN BEGIN
  216.                  char_rec.pic[i,8*j-4] := 'X';
  217.                  count := count -   8
  218.              END;
  219.              IF count >= 4 THEN BEGIN
  220.                  char_rec.pic[i,8*j-5] := 'X';
  221.                  count := count -   4
  222.              END;
  223.              IF count >= 2 THEN BEGIN
  224.                  char_rec.pic[i,8*j-6] := 'X';
  225.                  count := count -   2
  226.              END;
  227.              IF count >= 1 THEN char_rec.pic[i,8*j-7] := 'X';
  228.          END
  229.     {end for}
  230. END;
  231.  
  232.  
  233. PROCEDURE out_char; { (ochar : CHAR) }
  234. VAR
  235.     i,given_length,os_lcv,strikes : INTEGER;
  236.     find_char : CHAR;
  237. BEGIN
  238.     IF ochar <> ^D THEN {add char to out_line}
  239.         out_line := out_line + ochar
  240.     ELSE BEGIN          {output out_line}
  241.         given_length := LENGTH(out_line);
  242.         IF inv_video THEN BEGIN
  243.             find_char := ' ';
  244.             i := 1;
  245.             WHILE (find_char = ' ') AND (i <= given_length) DO BEGIN
  246.                 IF out_line[i] <> ' ' THEN find_char := out_line[i];
  247.                 i := i + 1
  248.             END; {while}
  249.             IF find_char = ' ' THEN find_char := 'x';
  250.             FOR i := 1 TO given_length DO
  251.                 IF out_line[i] = ' ' THEN
  252.                     out_line[i] := find_char
  253.                 ELSE
  254.                     out_line[i] := ' ';
  255.             FOR i := given_length TO (avail_chars - 2) DO
  256.                 out_line := out_line + find_char;
  257.             given_length := LENGTH(out_line)
  258.         END; {if inv-video}
  259.  
  260.         IF block_type = block THEN
  261.             FOR i := 1 TO given_length DO
  262.                 IF out_line[i] <> ' ' THEN
  263.                     out_line[i] := block_char;
  264.  
  265.             FOR i := 1 TO given_length DO
  266.                    write(out_line[i]);
  267.             {for each char in out_line}
  268.             CLREOL; write(^M);
  269.         write(^J);
  270.         out_line := '' {zero input}
  271.     END {if eol}
  272. END; {procedure out_char}
  273.  
  274.  
  275. BEGIN
  276.     main;
  277. END.
  278.