Category : Pascal Source Code
Archive   : CRYPTO.ZIP
Filename : CRYPTO.PAS

 
Output of file : CRYPTO.PAS contained in archive : CRYPTO.ZIP

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 }
{ }
{ (703) 823-3469 }
{ }
{------------------------------------------------------------}

Const
F1 = #59; { Extended ASCII codes for function keys }
F2 = #60;

Type
charset = set of char;
str80 = string[80];

Var
line: array [1..7] of str80;
def: array [#32..'Z'] of char;
count: array [#32..'Z'] of integer;
i, j, k: integer;
letter: char;
finished, no_more_codes: boolean;

Procedure Beep;
begin
Write(#7);
end;

Function Dup (n, ASCII: integer): str80;
var k: integer;
temp: str80;
begin
temp := '';
For k := 1 to n do temp := temp + chr(ASCII);
Dup := temp;
end;

Procedure ShowCredits;
begin
TextColor(11); Port[985] := 0; ClrScr;
Gotoxy(31,7); Writeln(#201,Dup(15,205),#187);
Gotoxy(31,8); Write(#186);
TextColor(12); Write(' C R Y P T O ');
TextColor(11); Writeln(#186);
Gotoxy(31,9); Writeln(#200,Dup(15,205),#188);
TextColor(13);
Gotoxy(27,12); Write('Written by Scott R. Houck');
Delay(4000);
end;

Procedure Initialize;
begin
ClrScr;
NormVideo;
For letter := #32 to 'Z' do
begin
If letter < 'A' then def[letter] := letter
else def[letter] := #32;
count[letter] := 0;
end;
finished := false;
no_more_codes := false;
end;

Procedure GetChar(var ch: char; legal: charset; var extended: boolean);
var ok: boolean;
begin
Repeat
Read(kbd,ch);
ch := UpCase(ch);
ok := ch in legal;
extended := (ch=#27) 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;

Procedure GetLine(var buffer: str80);
var ch: char;
done, extended: boolean;
begin
done := false;
buffer := '';
Repeat
GetChar(ch,[#8,#13,#27,F1,#32..'Z'],extended);
If not extended then
Case ch of
#8: If buffer='' then Beep else
begin
Write(#8#32#8);
Delete(buffer,length(buffer),1);
end;
#13: done := true;
#32..'Z': If length(buffer) > 65 then Beep else
begin
buffer := buffer + ch;
Write(ch);
end;
end
else If extended and (ch=F1) then
begin
buffer := F1;
done := true;
end
else Beep;
Until done;
Writeln;
end;

Procedure DoSample;
begin
i := 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;

Procedure EnterCode;
var done: boolean;
begin
done := false;
i := 1;
TextColor(11);
Gotoxy(10,3);
Write('Enter up to 7 lines of encoded text. ');
Writeln('Press to quit.');
Gotoxy(23,5);
Writeln('Press to do a sample code.'^J^J^J);
Repeat
TextColor(12);
Write('Line ', i, ': ');
NormVideo;
GetLine(line[i]);
If (line[i]='') or (line[i]=F1) or (i > 6) then done := true;
i := Succ(i);
Until done;
i := Pred(i);
If line[i]=F1 then DoSample;
For j := 1 to i do
For k := 1 to length(line[j]) do
count[line[j][k]] := Succ(count[line[j][k]]);
end;

Procedure Display;
begin
ClrScr;
NormVideo;
For j := 1 to i do
begin
Gotoxy(8,3*j);
Write(line[j]);
end;
TextColor(11);
Gotoxy(15,24);
Write('Press to see a letter frequency chart');
Gotoxy(15,25);
Write('Press to print your work on the printer');
end;

Procedure Update;
begin
TextColor(11);
For j := 1 to i do
begin
Gotoxy(8,3*j-1);
For k := 1 to length(line[j]) do Write(def[line[j][k]]);
end;
NormVideo;
end;

Procedure ShowFreq;
var k, count1, count2: integer;
letter1, letter2, key: char;
begin
ClrScr;
TextColor(10);
Gotoxy(20,3);
Writeln(#201,Dup(39,205),#187);
For k := 1 to 17 do
begin
Gotoxy(20,k+3);
Writeln(#186,Dup(39,32),#186);
end;
Gotoxy(20,21);
Writeln(#200,Dup(39,205),#188);
TextColor(13);
Gotoxy(24,4);
Write('LETTER FREQ LETTER FREQ');
NormVideo;
For k := 1 to 13 do
begin
letter1 := chr(k+64);
count1 := count[letter1];
letter2 := chr(k+77);
count2 := count[letter2];
Gotoxy(27,k+5);
Write(letter1);
If count1 <> 0 then Write(count1:7);
Gotoxy(46,k+5);
Write(letter2);
If count2 <> 0 then Write(count2:7);
end;
Gotoxy(28,20);
TextColor(12);
Write('PRESS ANY KEY TO CONTINUE');
Read(kbd,key);
Display;
Update;
end;

Procedure PrintWork;
begin
For j := 1 to i do
begin
For k := 1 to length(line[j]) do Write(Lst,def[line[j][k]]);
Writeln(Lst);
Writeln(Lst,line[j]);
Writeln(Lst);
end;
end;

Procedure InputDef;
var done, unique, extended: boolean;
defn, code: char;
begin
Repeat
done := false;
TextColor(13);
Gotoxy(15,23); ClrEol;
Write('Type a code letter or press to quit: ');
GetChar(code,[#13,#27,F1,F2,'A'..'Z'],extended);
If code=#13 then finished := true;
If extended and (code=F1) then ShowFreq;
If extended and (code=F2) then PrintWork;
If not extended then done := true;
Until done;
If not finished then
Repeat
TextColor(13);
done := false;
unique := true;
Gotoxy(15,23); ClrEol;
Write('Type the definition for ', code,
' (space to blank out): ');
GetChar(defn,[#27,F1,F2,#32,'A'..'Z'],extended);
If extended and (defn=F1) then ShowFreq;
If extended and (defn=F2) then PrintWork;
If not extended then
begin
done := true;
Write(defn);
For letter := 'A' to 'Z' do
If (def[letter]=defn) and (letter<>code) and (defn<>#32) then
begin
Gotoxy(15,23); ClrEol; Beep;
Write('You already defined ', letter, ' as ', defn, '.');
Delay(2000);
unique := false;
end;
end;
Until done and unique;
If not finished then def[code] := defn;
end;

Procedure DoAnother;
var ans: char;
extended: boolean;
begin
TextColor(13);
Gotoxy(15,23); ClrEol;
Write('Do you want to work on another code? (Y/N) ');
GetChar(ans,['Y','N'],extended);
no_more_codes := (ans='N');
end;

Procedure WrapItUp;
begin
Gotoxy(15,23); ClrEol;
Gotoxy(15,24); ClrEol;
Gotoxy(15,25); ClrEol;
Gotoxy(1,24);
end;

Begin { Crypto }
ShowCredits;
Repeat
Initialize;
EnterCode;
Display;
Update;
While not finished do
begin
InputDef;
Update;
end;
DoAnother;
Until no_more_codes;
WrapItUp;
End.
ed do
begin