home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
World of Shareware - Software Farm 2
/
wosw_2.zip
/
wosw_2
/
PASCAL
/
SCRMBL00.ZIP
/
SCRAMBLE.PAS
< prev
Wrap
Pascal/Delphi Source File
|
1990-10-07
|
8KB
|
305 lines
program scramble;
uses crt;
var
key : string;
keyelem : array [0..255] of byte;
infilename : string;
outfilename : string;
infile : file of byte;
outfile : file of byte;
enc : boolean;
done : boolean;
keylen : integer;
randtable : array [0..7,0..54] of word; { Table to store values for additive random number generator }
shuftable : array [0..7,0..63] of word; { Table to store values for shuffler }
n : array [0..7] of shortint; { Pointer to position in randtable }
a : array [0..7] of word; { Last value for linear congruential generators }
block : array [0..255] of byte; { Block storage }
blocklen : longint;
len : longint;
m : array [0..1,0..1] of byte;
determ : byte; { determinant of matrix }
procedure start;
var
answer : char;
count : integer;
begin
len := 0;
writeln('SCRAMBLE Encryptor/Decryptor v0.0 (beta) Copyright(C) 1990 by Sean Lynch');
writeln;
writeln('[E]ncrypt file');
writeln('[D]ecrypt file');
writeln('[Q]uit');
repeat
answer := readkey;
until (answer = 'e') or (answer = 'E') or (answer = 'd') or (answer = 'D') or (answer = 'q') or (answer = 'Q');
writeln;
if (answer = 'q') or (answer = 'Q') then halt(1);
infilename := '';
write('Input file: ');
readln(infilename);
if infilename = '' then halt(1);
assign(infile,infilename);
reset(infile);
outfilename := '';
write('Output file: ');
readln(outfilename);
if outfilename = '' then halt(1);
assign(outfile,outfilename);
rewrite(outfile);
write('Key ( <= 255 characters): ');
key := '';
readln(key);
keylen := length(key);
if (keylen > 255) or (key = '') then halt(1);
for count := 0 to keylen-1 do keyelem[count] := ord(key[count+1]);
for count := keylen to 218 do keyelem[count] := (keyelem[count-keylen]*117+37) mod 256;
if (answer = 'e') or (answer = 'E') then enc := true
else enc := false;
end;
function rand(switch : shortint) : word;
var
x : word;
j : integer;
c : word;
t : word;
begin
x := (randtable[switch,(n[switch]+31)mod 55]+randtable[switch,n[switch]]) mod 65536;
j := x mod 64;
randtable[switch,n[switch]] := x;
n[switch] := (n[switch]+1) mod 55;
c := (a[switch]*(switch*8+21)+(switch*6+31)) mod 65536;
rand := (shuftable[switch,j] + c) mod 65536;
shuftable[switch,j] := x;
end;
procedure seed; { Seed random number generators }
{ There are 8 random number generators }
var
count : integer;
switch : integer;
x : word;
j : integer;
begin
x := keyelem[27];
for switch := 0 to 3 do
begin
n[switch] := 0;
n[switch+4] := 0;
for count := 0 to 54 do
begin
randtable[switch,count] := abs(keyelem[count+1+55*switch]+keyelem[count+1+55*switch+35]*256);
randtable[switch+4,count] := abs(((keyelem[count+1+55*switch]*145+121)mod 256)+keyelem[count+1+55*switch+34]*256);
end;
randtable[switch,54] := abs(randtable[switch,1]xor 113+256*randtable[switch,23]);
a[switch] := x;
a[switch+4] := (x*28333+9385) mod 65536;
for count := 0 to 63 do
begin
x := (x*21481+5745)mod 65536;
j := x*55 div 65536;
shuftable[switch,count] := (x+randtable[switch,j]) mod 65536;
x := (x*28973+37489) mod 65536;
j := x*55 div 65536;
shuftable[switch+4,count] := (x+randtable[switch,j]) mod 65536;
end
end
end;
procedure readenc;
var
count : longint;
fin : byte;
l : longint;
begin
l :=filesize(infile)-len;
if l < 256 then
begin
blocklen := l-1;
done := true;
end
else begin
blocklen := (rand(0) mod 128) + 128;
done := false;
end;
for count := 0 to blocklen do
read(infile,block[count]);
len := len + blocklen + 1;
end;
procedure genmatrix; { Generate polygraphic substitution matrix }
var
x : word;
begin
repeat
x := rand(2);
m[0,0] := hi(x);
m[0,1] := lo(x);
x := rand(3);
m[1,0] := hi(x);
m[1,1] := lo(x);
determ := (65536+m[0,0]*m[1,1] - m[0,1]*m[1,0])mod 256;
until determ mod 2 = 1;
end;
function dmod(x : integer;y : integer) : integer; { modular division }
var z : byte;
begin
z := 0;
while (x-y*z) mod 256 <> 0 do z := z + 1;
dmod := z;
end;
procedure gdematrix; { Generate inverse of matrix }
var d : array[0..1,0..1] of integer;
begin
d[0,0] := dmod(m[1,1],determ);
d[0,1] := dmod(256-m[0,1],determ);
d[1,0] := dmod(256-m[1,0],determ);
d[1,1] := dmod(m[0,0],determ);
m[0,0] := d[0,0];
m[0,1] := d[0,1];
m[1,0] := d[1,0];
m[1,1] := d[1,1];
end;
procedure polysub; { Digraphic substitution (You can increase size of matrix if you can figure out how)}
var
count : byte;
x : integer;
c : array [0..1] of byte;
{ If there is an odd # of characters in the block, the last one is left as is }
begin
for count := 0 to (blocklen-1) div 2 do
begin
c[0] := (131072+block[count*2]*m[0,0]+block[count*2+1]*m[0,1]) mod 256; { linear transformation }
c[1] := (131072+block[count*2]*m[1,0]+block[count*2+1]*m[1,1]) mod 256;
block[count*2] := c[0];
block[count*2+1] := c[1];
end;
end;
procedure enpose; { encryption transpositions }
var
out : array [0..255] of byte;
filled : array [0..255] of boolean;
count : byte;
x : byte;
begin
for count := 0 to blocklen do filled[count] := false;
for count := 0 to blocklen do
begin
x := rand(4) * (blocklen+1) div 65536;
while filled[x] do x := (x+1) mod (blocklen+1);
out[x] := block[count];
filled[x] := true;
end;
for count := 0 to blocklen do block[count] := out[count];
end;
procedure depose; { decryption transpositions }
var
out : array [0..255] of byte;
filled : array [0..255] of boolean;
count : byte;
x : byte;
begin
for count := 0 to blocklen do filled[count] := false;
for count := 0 to blocklen do
begin
x := rand(4) * (blocklen+1) div 65536;
while filled[x] do x := (x+1) mod (blocklen+1);
out[count] := block[x];
filled[x]:= true;
end;
for count := 0 to blocklen do block[count] := out[count];
end;
procedure xora(switch : shortint); { xor operation }
var
last : byte;
x : word;
count : longint;
y : byte;
begin
last := lo(rand(switch));
for count := 0 to blocklen do
begin
x := rand(switch);
y := block[count];
block[count] := block[count] xor lo(x) xor hi(x) xor last;
last := y;
end;
end;
procedure xorb(switch : shortint); { xor operation }
var
last : byte;
x : word;
count : byte;
begin
last := lo(rand(switch));
for count := 0 to blocklen do
begin
x := rand(switch);
block[count] := block[count] xor lo(x) xor hi(x) xor last;
last := block[count];
end;
end;
procedure writeout;
var count : byte;
begin
for count := 0 to blocklen do write(outfile,block[count]);
end;
procedure encrypt;
begin
write('Encrypting');
repeat
write('.');
readenc;
xora(1);
genmatrix;
polysub;
xora(5);
xora(7);
enpose;
xora(6);
writeout;
until done;
end;
procedure decrypt;
begin
write('Decrypting');
repeat
write('.');
readenc;
xorb(6);
depose;
xorb(7);
xorb(5);
genmatrix;
gdematrix;
polysub;
xorb(1);
writeout;
until done;
end;
begin
start;
seed;
if enc then encrypt else decrypt;
close(infile);
close(outfile);
writeln('Done!');
end.