Programmer 7500/MAX_PROGRAMMERS.iso/INFO/TURBOPAS/CRYPTO2.ZIP/CRYPTO2.PAS

Pascal/Delphi Source File | 1985-09-28 | 18.8 KB | 661 lines

PROGRAM Crypto;

{ Helps in the decoding of "cryptograms" }

{------------------------------------------------------------}
{ This program can be copied freely and modified if desired. }
{ Inquiries, improvements, complaints can be addressed to:   }
{                                                            }
{                   Scott R. Houck                           }
{                   200 N. Pickett St. #314                  }
{                   Alexandria, VA  22304                    }
{                                                            }
{                   [phone]                           }
{                                                            }
{ Modified by David A. Peterson -- 28 Sept 85                }
{             124 East Rose Place                            }
{             Little Canada, MN  55117                       }
{                                                            }
{             [phone]                                 }
{                                                            }
{  Modifications for word matching, cryptogram puzzle file.  }
{                                                            }
{------------------------------------------------------------}

  CONST
    F1        = #59;    { Extended ASCII codes for function keys }
    F2        = #60;
    F3        = #61;
    F9        = #67;
    F10       = #68;
    Space     = #32;    { ASCII space }
    BackSpace = #08;
    Bell      = #07;
    Escape    = #27;
    NewLine   = #13;
    LineFeed  = #10;

    MaxWordLen = 17;
    MaxLines   =  7;
    {
    | IBM line drawing characters -- double lines
    }
    UpLeft2   = #201;
    UpRight2  = #187;
    LoLeft2   = #200;
    LoRight2  = #188;
    Across2   = #205;
    Down2     = #186;


  TYPE
    CharSet  = SET OF Char;
    _String  = String [80];
    Word     = String [17];
    Movement = ( Ahead, Behind );

  VAR
    Line        : ARRAY [1 .. MaxLines] OF _String;
    UnLine      : ARRAY [1 .. MaxLInes] OF _String;
    Words       : ARRAY [1 .. 100] OF Word;
    Locs        : ARRAY [1 .. 100] OF
      RECORD
        X : Byte;
        Y : Byte
      END;
    Def         : ARRAY [Space .. 'Z'] OF Char;
    Count       : ARRAY [Space .. 'Z'] OF Integer;
    Finished    : Boolean;
    NoMoreCodes : Boolean;
    CurWord     : Byte;
    Letter      : Char;
    NumLines    : Integer;
    CurLine     : Integer;
    CurChar     : Integer;
    NumWords    : Integer;
    WhichOne    : Integer;
    InStr       : _String;

  PROCEDURE Beep;

    BEGIN { Beep }
      Write (Bell)
    END;  { Beep }

  FUNCTION DupChar ( Number     : Byte;
                     ASCIIValue : Char ) : _String;

    VAR
      Temp : _String;

    BEGIN { DupChar }
      FillChar (Temp[1], Number, ASCIIValue);
      Temp[0] := Chr (Number);
      DupChar := Temp
    END;  { DupChar }

  FUNCTION StrNum ( Num : Byte;
                    Pad : Boolean ) : _String;

    VAR
      _StrNum : _String;

    BEGIN { StrNum }
      Str (Num, _StrNum);
      IF Pad AND (Num < 10) THEN
        _StrNum := '0' + _StrNum;
      StrNum := _StrNum
    END;  { StrNum }

  PROCEDURE PlaceStr ( X, Y : Byte;
                       PStr : _String );

    BEGIN { PlaceStr }
      GotoXy (X, Y);
      Write (PStr)
    END;  { PlaceStr }

  PROCEDURE PlaceCursor;

    BEGIN { PlaceCursor }
      WITH Locs [CurWord] DO
        GotoXy (X + 7, Y * 3)
    END;  { PlaceCursor }

  PROCEDURE MoveCursor ( Move : Movement );

    BEGIN { MoveCursor }
      CASE Move OF
        Behind :
          IF CurWord = 1 THEN
            CurWord := NumWords
          ELSE
            CurWord := CurWord - 1;
        Ahead  :
          IF CurWord = NumWords THEN
            CurWord := 1
          ELSE
            CurWord := CurWord + 1
      END
    END;  { MoveCursor }

  PROCEDURE ShowCredits;

    BEGIN { ShowCredits }
      TextColor (LightCyan);
      Port[985] := 0;
      ClrScr;
      PlaceStr (31, 7, UpLeft2 + DupChar (15, Across2) + UpRight2);
      PlaceStr (31, 8, Down2);
      TextColor (LightRed);
      Write ('  C R Y P T O  ');
      TextColor (LightCyan);
      WriteLn (Down2);
      PlaceStr (31, 9, LoLeft2 + DupChar (15, Across2) + LoRight2);
      TextColor (LightMagenta);
      PlaceStr (27, 12, 'Written by Scott R. Houck');
      Delay (4000)
    END;  { ShowCredits }

  PROCEDURE Initialize;

    BEGIN { Initialize }
      ClrScr;
      NormVideo;
      CurWord  := 1;
      WhichOne := 0;
      InStr    := '';
      FillChar (Line, SizeOf (Line), 0);
      FillChar (UnLine, SizeOf (UnLine), 0);
      FOR Letter := Space to 'Z' DO
        BEGIN
          IF Letter < 'A' THEN
            Def[Letter] := Letter
          ELSE
            Def[Letter] := Space;
          Count[Letter] := 0
        END;
      Finished    := False;
      NoMoreCodes := False
    END;  { Initialize }

  PROCEDURE GetChar ( VAR Ch       : Char;
                          Legal    : CharSet;
                      VAR Extended : Boolean );

    VAR
      Ok : Boolean;

    BEGIN { GetChar }
      REPEAT
        Read (Kbd, Ch);
        Ch       := UpCase (Ch);
        Ok       := Ch IN Legal;
        Extended := (Ch = Escape) AND KeyPressed;
        IF Ok THEN
          IF extended THEN
            BEGIN
              Read (Kbd, Ch);
              Ok := Ch IN Legal
            END;
        IF NOT Ok THEN
          Beep
      UNTIL Ok
    END;  { GetChar }

  PROCEDURE GetLine ( VAR Buffer : _String );

    VAR
      Ch       : Char;
      Done     : Boolean;
      Extended : Boolean;

    BEGIN { GetLine }
      Done   := False;
      Buffer := '';
      REPEAT
        GetChar (Ch, [BackSpace, NewLine, Escape, F1, F2, Space .. 'Z'], Extended);
        IF NOT Extended THEN
          CASE Ch OF
            BackSpace  :
              IF Buffer = '' THEN
                Beep
              ELSE
                BEGIN
                  Write (BackSpace, Space, BackSpace);
                  Delete (Buffer, Length (Buffer), 1)
                END;
          NewLine      : Done := True;
          Space .. 'Z' :
            IF Length (Buffer) > 65 THEN
              Beep
            ELSE
              BEGIN
                Buffer := Buffer + Ch;
                Write (Ch)
              END
          END
        ELSE IF Extended AND (Ch IN [F1, F2] ) THEN
          BEGIN
            Buffer := Ch;
            Done   := True
          END
        ELSE
          Beep
      UNTIL Done;
      WriteLn
    END;  { GetLine }

  PROCEDURE DoSample;

    BEGIN { DoSample }
      NumLines := 4;
      Line[1]  := 'SR KWA YSZN OW EW LQKMOWVQPXG, OUSG MQWVQPX HSYY IN P QNPY';
      Line[2]  := 'OSXN-GPDNQ.  NPLU OSXN KWA ENRSTN P YNOONQ, OUN GLQNNT SG';
      Line[3]  := 'AMEPONE.  S UPDN STLYAENE P YNOONQ RQNCANTLK LUPQO PTE P';
      Line[4]  := 'MQSTO WMOSWT OWW.'
    END;  { DoSample }

  FUNCTION NumStr ( AStr : _String ) : Integer;

    VAR
      Error   : Integer;
      _NumStr : Integer;

    BEGIN { NumStr }
      FOR Error := Length (AStr) DOWNTO 1 DO
        IF NOT (AStr[Error] IN ['0' .. '9'] ) THEN
          Delete (AStr, Error, 1);
      Val (AStr, _NumStr, Error);
      IF Error > 0 THEN
        _NumStr := 0;
      NumStr := _NumStr
    END;  { NumStr }

  PROCEDURE GetFromCryptFile;

    VAR
      Len       : Byte;
      CurOne    : Integer;
      CryptFile : Text;

    BEGIN { GetFromCryptFile }
      NumLines := 1;
      Assign (CryptFile, 'A:Crypto.Pzl');
      {$I-}
      Reset (CryptFile);
      {$I+}
      IF IoResult = 0 THEN
        ReadLn (CryptFile, InStr)
      ELSE
        InStr := 'Bad File';
      IF InStr[1] <> '!' THEN
        BEGIN
          WriteLn;
          WriteLn ('Unable to get cryptogram from file. Program stops.');
          Halt
        END
      ELSE
        BEGIN
          CurOne   := NumStr (InStr);
          WhichOne := Random (CurOne - 1) + 1;
          REPEAT
            REPEAT
              ReadLn (CryptFile, InStr)
            UNTIL InStr[1] = '#';
            CurOne := NumStr (InStr)
          UNTIL CurOne = WhichOne;
          ReadLn (CryptFile, InStr); { Letter = Letter }
          Def[InStr[1] ] := InStr[5];
          ReadLn (CryptFile, Line[1] );
          IF Length (Line[1] ) > 65 THEN { Move part of it over to next line }
            BEGIN
              Len := Length (Line[1] );
              WHILE Line[1][len] IN [Space .. 'Z'] - [Space] DO
                BEGIN
                  Line[2] := Line[1][Len] + Line[2];
                  Delete (Line[1], 1, Len);
                  Len := Len - 1
                END;
              Delete (Line[1], 1, Len) { Remove space at end of line }
            END
        END
    END;  { GetFromCryptFile }

  PROCEDURE EnterCode;

    VAR
      Done     : Boolean;
      ThisWord : Byte;
      Len      : Byte;
      AString  : _String;
      AWord    : Word;

    BEGIN { EnterCode }
      Done     := False;
      NumLines := 1;
      TextColor (LightCyan);
      PlaceStr (10, 3, 'Enter up to ' + StrNum (MaxLines, False) + ' lines of encoded text.  ');
      WriteLn('Press <ENTER> to quit.');
      PlaceStr (11, 5, 'Press <F1> to do a sample code, <F2> to get from file.');
      GotoXy (1, 7);
      REPEAT
        TextColor (LightRed);
        Write ('Line ', NumLines, ':  ');
        NormVideo;
        GetLine (Line[NumLines] );
        IF (Line[NumLines] = '') OR (Line[NumLines][1] IN [F1, F2] ) OR (NumLines = MaxLines) THEN
          Done := True;
        NumLines := Succ (NumLines)
      UNTIL Done;
      NumLines := Pred (NumLines);
      IF      Line[NumLines] = F1 THEN
        DoSample
      ELSE IF Line[NumLines] = F2 THEN
        GetFromCryptFile;
      FOR CurLine := 1 TO NumLines DO
        BEGIN
          FOR CurChar := 1 TO Length (Line[CurLine] ) DO
            Count[Line[CurLine][CurChar] ] := Succ (Count[Line[CurLine][CurChar] ] );
          FOR CurChar := 1 TO Length (Line[CurLine] ) DO
            UnLine[CurLine] := UnLine[CurLine] + Def[Line[CurLine][CurChar] ]
        END;
      FillChar (Words, SizeOf (Words), 0);
      FillChar (Locs, SizeOf (Locs), 0);
      ThisWord := 0;
      FOR CurLine := 1 TO NumLines DO
        BEGIN
          AString := Line[CurLine];
          WHILE Length (AString) > 0 DO
            BEGIN
              AWord := '';
              Len   := 0;
              WHILE (Length (AString) > 0) AND NOT (AString[1] IN ['A' .. 'Z'] ) DO
                Delete (AString, 1, 1);
              WHILE (Len < Length (AString) ) AND (AString[Len + 1] IN ['A' .. 'Z'] ) DO
                BEGIN
                  Len := Len + 1;
                  IF Len <= MaxWordLen THEN
                    AWord := AWord + AString[Len]
                END;
              IF Len > 0 THEN
                BEGIN
                  ThisWord := ThisWord + 1;
                  WITH Locs[ThisWord] DO
                    BEGIN
                      X := Length (Line[CurLine] ) - Length (AString) + 1;
                      Y := CurLine
                    END;
                  Delete (AString, 1, Len);
                  WHILE (Length (AString) > 0) AND NOT (AString[1] IN ['A' .. 'Z'] ) DO
                    Delete (AString, 1, 1);
                  Words[ThisWord] := AWord
                END
            END
        END;
      NumWords := ThisWord
    END;  { EnterCode }

  PROCEDURE Display;

    BEGIN { Display }
      ClrScr;
      NormVideo;
      FOR CurLine := 1 TO NumLines DO
        PlaceStr (8, 3 * CurLine, Line[CurLine] );
      TextColor (LightCyan);
      IF Length (InStr) > 0 THEN
        BEGIN
          PlaceStr (1, 12, InStr);
          PlaceStr (1, 13, 'Cryptogram ' + StrNum (WhichOne, False) )
        END;
      PlaceStr (11, 24, 'Press <F1> for letter frequency chart   <F3> word matches');
      PlaceStr (11, 25, 'Press <F2> to print   <F9> move left    <F10> move right')
    END;  { Display }

  PROCEDURE Update;

    BEGIN { Update }
      TextColor (LightCyan);
      FOR CurLine := 1 TO NumLines DO
        BEGIN
          GotoXy (8, 3 * CurLine - 1);
          Write (UnLine[CurLine] )
        END;
      NormVideo
    END;  { Update }

  PROCEDURE ShowFreq;

    VAR
      Key     : Char;
      Letter1 : Char;
      Letter2 : Char;
      CurChar : Integer;
      Count1  : Integer;
      Count2  : Integer;

    BEGIN { ShowFreq }
      ClrScr;
      TextColor (LightGreen);
      PlaceStr (20, 3, UpLeft2 + DupChar(39, Across2) + UpRight2);
      FOR CurChar := 1 TO 20 DO
        BEGIN
          PlaceStr (20, CurChar + 3, Down2);
          PlaceStr (60, CurChar + 3, Down2)
        END;
      PlaceStr (20, 24, LoLeft2 + DupChar(39, Across2) + LoRight2);
      TextColor (LightMagenta);
      PlaceStr (24, 4, 'LETTER  FREQ       LETTER  FREQ');
      NormVideo;
      Letter1 := 'A';
      Letter2 := 'N';
      FOR CurChar := 1 TO 13 DO
        BEGIN
          Count1  := Count[Letter1];
          Count2  := Count[Letter2];
          PlaceStr (27, CurChar + 5, Letter1);
          IF Count1 <> 0 THEN
            Write (Count1:7);
          PlaceStr (46, CurChar + 5, Letter2);
          IF Count2 <> 0 THEN
            Write (Count2:7);
          Letter1 := Succ (Letter1);
          Letter2 := Succ (Letter2)
        END;
      PlaceStr (28, 20, '   Alphabet Frequency');
      PlaceStr (28, 21, 'ETAONRISHDLFCMUGPYWBKXJQZ');
      TextColor (LightRed);
      PlaceStr (28, 23, 'PRESS ANY KEY TO CONTINUE');
      Read (Kbd, Key);
      Display;
      Update
    END;  { ShowFreq }

  PROCEDURE PrintWork;

    BEGIN { PrintWork }
      IF Length (InStr) > 0 THEN
        BEGIN
          WriteLn (Lst, InStr);
          WriteLn (Lst, 'Cryptogram ' + StrNum (WhichOne, False) );
          Write (Lst,   '=============');
          IF WhichOne > 9 THEN
            WriteLn (Lst, '=')
          ELSE
            WriteLn (Lst)
        END;
      FOR CurLine := 1 TO NumLines DO
        BEGIN
          WriteLn (Lst, UnLine[CurLine]);
          WriteLn (Lst, Line[CurLine] );
          WriteLn (Lst)
        END
    END;  { PrintWork }

  PROCEDURE ShowMatch;

    CONST
      AChar  : Boolean = False;
      MCount : Integer =     0;

    VAR
      AMatch : Boolean;
      Len    : Byte;
      MFile  : Text;
      AWord  : Word;
      MWord  : Word;

    BEGIN { ShowMatch }
      AWord := Words[CurWord];
      Len   := Length (AWord);
      FOR CurChar := 1 TO Len DO
        BEGIN
          AWord[CurChar] := Def[AWord[CurChar] ];
          IF AWord[CurChar] IN ['A' .. 'Z'] THEN
            AChar := True
        END;
      IF AChar THEN
        BEGIN
          Assign (MFile, 'A:Words' + StrNum (Len, True) + '.Dct');
          Reset (MFile);
          WHILE NOT Eof (MFile) DO
            BEGIN
              ReadLn (MFile, MWord);
              AMatch  := True;
              CurChar := 0;
              REPEAT
                CurChar := CurChar + 1;
                IF (AWord[CurChar] <> Space) AND (AWord[CurChar] <> MWord[CurChar] ) THEN
                  AMatch := False
              UNTIL NOT AMatch OR (CurChar = Len);
              IF AMatch THEN
                BEGIN
                  WITH Locs[CurWord] DO
                    PlaceStr (X + 7, 3 * Y - 1, MWord);
                  Delay (1000)
                END
            END;
          Close (MFile)
        END;
      WITH Locs[CurWord] DO
        PlaceStr (X + 7, 3 * Y - 1, AWord)
    END;  { ShowMatch }

  PROCEDURE InputDef;

    VAR
      Done     : Boolean;
      Unique   : Boolean;
      Extended : Boolean;
      DefCh    : Char;
      Code     : Char;

    PROCEDURE GetDefCh;

      VAR
        CurChar : Integer;

      BEGIN { GetDefCh }
        REPEAT
          TextColor (LightMagenta);
          Done   := False;
          Unique := True;
          PlaceStr (15, 23, 'Type the definition for ' + code + ' (space to blank out):  ');
          ClrEol;
          GetChar (DefCh, [Escape, F1, F2, F9, F10, Space, 'A' .. 'Z'], Extended);
          IF Extended THEN
            CASE DefCh OF
              F1  : ShowFreq;
              F2  : PrintWork;
              F9  : MoveCursor (Behind);
              F10 : MoveCursor (Ahead)
            END
          ELSE
            BEGIN
              Done := True;
              Write (DefCh);
              FOR Letter := 'A' to 'Z' DO
                IF (Def[Letter] = DefCh) AND (Letter <> Code) AND (DefCh <> Space) THEN
                  BEGIN
                    PlaceStr (15, 23, 'You already defined ' + Letter + ' as ' + DefCh + '.');
                    ClrEol;
                    Beep;
                    Delay(2000);
                    Unique := False
                  END;
              IF Unique THEN
                BEGIN
                  Def[Code] := DefCh;
                  FOR CurLine := 1 TO NumLines DO
                    FOR CurChar := 1 TO Length (Line[CurLine] ) DO
                      UnLine[CurLine][CurChar] := Def[Line[CurLine][CurChar] ]
                END
            END
        UNTIL Done AND Unique
      END;  { GetDefCh }

    BEGIN { InputDef }
      REPEAT
        Done := False;
        TextColor (LightMagenta);
        PlaceStr (15, 23, 'Type a code letter or press <ENTER> to quit:  ');
        ClrEol;
        PlaceCursor;
        GetChar (Code, [NewLine, Escape, F1, F2, F3, F9, F10, 'A' .. 'Z'], Extended);
        IF      Code = NewLine THEN
          Finished := True
        ELSE IF Extended THEN
          CASE Code OF
            F1  : ShowFreq;
            F2  : PrintWork;
            F3  : ShowMatch;
            F9  : MoveCursor (Behind);
            F10 : MoveCursor (Ahead)
          ELSE
            Done := True
          END
        ELSE
          Done := True
      UNTIL Done OR Finished;
      IF NOT Finished AND NOT (Extended AND (Code IN [F1, F2, F9, F10] ) ) THEN
        GetDefCh
    END;  { InputDef }

  PROCEDURE DoAnother;

    VAR
      Ans      : Char;
      Extended : Boolean;

    BEGIN { DoAnother }
      TextColor (LightMagenta);
      PlaceStr (15, 23, 'Do you want to work on another code? (Y/N)  ');
      ClrEol;
      GetChar (Ans, ['Y', 'N'], Extended);
      NoMoreCodes := ans = 'N'
    END;  { DoAnother }

  PROCEDURE WrapItUp;

    BEGIN { WrapItUp }
      GotoXy (1, 23); ClrEol;
      GotoXy (1, 24); ClrEol;
      GotoXy (1, 25); ClrEol;
      GotoXy (1, 24)
    END;  { WrapItUp }

  BEGIN { Crypto }
    ShowCredits;
    REPEAT
      Initialize;
      EnterCode;
      Display;
      REPEAT
        Update;
        InputDef
      UNTIL Finished;
      DoAnother
    UNTIL NoMoreCodes;
    WrapItUp
  END   { Crypto }.