PROGRAM pop;

{******************************************************************************
**
**  Function:  This program runs a psuedo 'self-destruct' sequence
**
*****************************************************************************}

CONST
    Max_Length = 80;         {max number of characters on a output line}
     Max_Width = 40;           {these must match then input file}
    Max_Height = 24;           {and match CONSTs in mf.pas!}
     Bit_Width = 5;            {Max_Width/8}

{default problem parameters - TurboPascal Initialized 'Constants'}
      font_fn : STRING[14]                 = 'a:Font1.Dat'; {font filename}
    sign_type : (sign,banner)              = sign;
   block_type : (letter,block,overstrike)  = block;
   block_char : CHAR                       = #88;
       mult_w : INTEGER                    = 2;         {height multiplier}
       mult_h : INTEGER                    = 1;         {width multiplier}
    inter_spc : INTEGER                    = 5;         {space between chars}
 input_device : (keyboard,text_file)       = keyboard;
   num_copies : INTEGER                    = 1;
output_device : (screen,printer,recd_file) = screen;
  device_size : (wide,normal)              = normal;
    inv_video : BOOLEAN                    = FALSE;
  given_width : INTEGER                    = 80;
    centering : BOOLEAN                    = TRUE;
   font_width : INTEGER                    = 10;
  font_height : INTEGER                    = 12; {size of font in use}
  avail_chars : INTEGER                    = 80;
         time : INTEGER                    = 20;
TYPE
    CHARACTER_RECORD = RECORD  {record type used for random access}
      character : CHAR;        {the character}
          width : INTEGER;     {how wide is it}
         height : INTEGER;     {how high}
            pic : ARRAY[1..Max_Height,1..Max_Width] OF CHAR
    END; {record}              {its 'picture'}

     BIT_RECORD = RECORD           {record type used for random access}
        character : CHAR;
            width : INTEGER;
           height : INTEGER;
          bit_map : ARRAY[1..Max_height,1..Bit_Width] OF BYTE
    END; {record}

    FONT_FILE_TYPE = FILE OF BIT_RECORD;
    SIGN_ARRAY = ARRAY[1..Max_Height,1..Max_Length] OF CHAR;
    S80 = STRING[80];   {for input}
    S2  = STRING[2];    {for Hex input}

VAR
       font_file : FONT_FILE_TYPE;
        char_rec : CHARACTER_RECORD; {global's easier than passing pointers!}
        out_line : STRING[80]; {global pass to/from out_char}


{************************* Procedures called *********************************}

PROCEDURE out_sign         (VAR inp_line : S80);              FORWARD;
FUNCTION  check_sign           (inp_line : S80;
                        VAR actual_width : INTEGER;
                           VAR out_array : SIGN_ARRAY) : BOOLEAN; FORWARD;
PROCEDURE find_rec                  (inp : S80;
                                position : INTEGER);              FORWARD;
PROCEDURE out_char                (ochar : CHAR);                 FORWARD;


{**************************** Program Start **********************************}


PROCEDURE GOTORC(R,C : INTEGER);
BEGIN
    GOTOXY(C,R);
END;

PROCEDURE main;
VAR  ans : CHAR;        {entered char}
     count : INTEGER;     {loop control}
     i,j,c : INTEGER;
     inp_line : s80;
BEGIN
    CLRSCR;
    WRITELN('Self Destruct Sequence Activated');
    WRITELN;
    WRITELN('Enter authorization code to start countdown');
    WRITELN;
    WRITELN('Correct code will begin self destruct,');
    WRITELN('anything else will abort countdown.');
    WRITELN;
    WRITE('Enter code ->');
    READ(KBD,ans);
    WRITELN(chr($1b),'#');
    WRITELN;
    WRITE('Correct code entered, self destruct in ',time,' seconds ...');
    delay(1000);
    CLRSCR;
    WRITE(CHR($1B),'^                          SELF DESTRUCT IN PROGRESS',
                        CHR($1B),'q',CHR($1b),'.0');
    ASSIGN(font_file,font_fn);
    RESET(font_file);
    out_line := '';
    FOR count := time DOWNTO 0 DO BEGIN
        GOTORC(5,1);
        STR(count,inp_line);
        out_sign(inp_line);
    END; {while not done}
    CLRSCR;
    CLOSE(font_file);
    write(chr($1b),'"');
    while NOT keypressed DO begin
        i := round(24*Random);
        j := round(79*Random);
        c := round(95*random+32);
        GOTORC(i,j);
        write(chr(c));
    END;
    WRITE(chr($1b),'.2');
    CLRSCR;
END; {PROCEDURE main}


PROCEDURE out_sign; {(VAR inp_line : S80)}
VAR   page_offset,page_offset_lcv,
  width_lcv,height_lcv,mult_h_lcv,
          line_width : INTEGER;
           out_array : SIGN_ARRAY; {'Sign' output line is built into this}
           err : BOOLEAN;
BEGIN
    err := check_sign(inp_line,line_width,out_array);
    page_offset := ROUND((avail_chars - line_width) / 2);
    IF inv_video THEN out_char(^D);  {start with a blank line}
    FOR height_lcv := 1 TO font_height DO            {output line}
        FOR mult_h_lcv := 1 TO mult_h DO BEGIN
            FOR page_offset_lcv := 1 TO page_offset DO out_char(' ');
            FOR width_lcv := 1 TO line_width DO
                out_char(out_array[height_lcv,width_lcv]);
            {end for width}
            out_char(^D);
        END; {for height multiplier}
    {end for height}
    out_char(^D);
END; {PROCEDURE out_sign}


FUNCTION check_sign; {(inp_line : S80; VAR actual_width : INTEGER) : BOOLEAN}
LABEL done;
VAR height_lcv,width_lcv,
     mult_w_lcv,char_num : INTEGER;
                     err : BOOLEAN;
                   ochar : CHAR;
BEGIN
    FOR height_lcv := 1 to font_height DO
        FOR width_lcv :=1 TO Max_Length DO
            out_array[height_lcv,width_lcv] := ' '; {initialize line array}
    actual_width := 1;
    FOR char_num := 1 TO LENGTH(inp_line) DO BEGIN        {build line}
        find_rec(inp_line,char_num);
        FOR width_lcv := 1 TO char_rec.width DO
            FOR mult_w_lcv := 1 TO mult_w DO BEGIN
                FOR height_lcv := 1 TO char_rec.height DO BEGIN
                    IF char_rec.pic[height_lcv,width_lcv] <> ' ' THEN
                        ochar := char_rec.character
                    ELSE
                        ochar := ' ';
                    {end if}
                    out_array[height_lcv,actual_width] := ochar
                END; {for height}
                actual_width := actual_width + 1
            END; {for width multiplier}
        {end for width of char}
        actual_width := actual_width + inter_spc    {space between chars}
    end; { for each input char}
    check_sign := FALSE
END; {PROCEDURE check_sign}


PROCEDURE find_rec; { (inp : S80; position : INTEGER) }
VAR  search_char : CHAR;
      rec_number : INTEGER;
             rec : BIT_RECORD;
       i,j,count : INTEGER;
BEGIN
    search_char := COPY(inp,position,1);
    rec_number := ORD(search_char) - 32;
    SEEK(font_file,rec_number);
    READ(font_file,rec);
    FOR i := 1 TO font_height DO
         FOR j := 1 TO font_width DO
             char_rec.pic[i,j] := ' ';  {zero transfer record}
    char_rec.character := rec.character;
    char_rec.width := rec.width;
    char_rec.height := rec.height;
    FOR i := 1 TO Max_Height DO
         FOR j := 1 TO Bit_Width DO BEGIN
             count := rec.bit_map[i,j];
             IF count >= 128 THEN BEGIN
                 char_rec.pic[i,8*j] := 'X';
                 count := count - 128
             END;
             IF count >= 64 THEN BEGIN
                 char_rec.pic[i,8*j-1] := 'X';
                 count := count -  64
             END;
             IF count >= 32 THEN BEGIN
                 char_rec.pic[i,8*j-2] := 'X';
                 count := count -  32
             END;
             IF count >= 16 THEN BEGIN
                 char_rec.pic[i,8*j-3] := 'X';
                 count := count -  16
             END;
             IF count >= 8 THEN BEGIN
                 char_rec.pic[i,8*j-4] := 'X';
                 count := count -   8
             END;
             IF count >= 4 THEN BEGIN
                 char_rec.pic[i,8*j-5] := 'X';
                 count := count -   4
             END;
             IF count >= 2 THEN BEGIN
                 char_rec.pic[i,8*j-6] := 'X';
                 count := count -   2
             END;
             IF count >= 1 THEN char_rec.pic[i,8*j-7] := 'X';
         END
    {end for}
END;


PROCEDURE out_char; { (ochar : CHAR) }
VAR
    i,given_length,os_lcv,strikes : INTEGER;
    find_char : CHAR;
BEGIN
    IF ochar <> ^D THEN {add char to out_line}
        out_line := out_line + ochar
    ELSE BEGIN          {output out_line}
        given_length := LENGTH(out_line);
        IF inv_video THEN BEGIN
            find_char := ' ';
            i := 1;
            WHILE (find_char = ' ') AND (i <= given_length) DO BEGIN
                IF out_line[i] <> ' ' THEN find_char := out_line[i];
                i := i + 1
            END; {while}
            IF find_char = ' ' THEN find_char := 'x';
            FOR i := 1 TO given_length DO
                IF out_line[i] = ' ' THEN
                    out_line[i] := find_char
                ELSE
                    out_line[i] := ' ';
            FOR i := given_length TO (avail_chars - 2) DO
                out_line := out_line + find_char;
            given_length := LENGTH(out_line)
        END; {if inv-video}

        IF block_type = block THEN
            FOR i := 1 TO given_length DO
                IF out_line[i] <> ' ' THEN
                    out_line[i] := block_char;

            FOR i := 1 TO given_length DO
                   write(out_line[i]);
            {for each char in out_line}
            CLREOL; write(^M);
        write(^J);
        out_line := '' {zero input}
    END {if eol}
END; {procedure out_char}


BEGIN
    main;
END.