home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / SCRMBL00.ZIP / SCRAMBLE.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1990-10-07  |  7.4 KB  |  305 lines
  1. program scramble;
  2. uses crt;
  3. var
  4.   key : string;
  5.   keyelem : array [0..255] of byte;
  6.   infilename : string;
  7.   outfilename : string;
  8.   infile : file of byte;
  9.   outfile : file of byte;
  10.   enc : boolean;
  11.   done : boolean;
  12.   keylen : integer;
  13.   randtable : array [0..7,0..54] of word; { Table to store values for additive random number generator }
  14.   shuftable : array [0..7,0..63] of word; { Table to store values for shuffler }
  15.   n : array [0..7] of shortint; { Pointer to position in randtable }
  16.   a : array [0..7] of word; { Last value for linear congruential generators }
  17.   block : array [0..255] of byte; { Block storage }
  18.   blocklen : longint;
  19.   len : longint;
  20.   m : array [0..1,0..1] of byte;
  21.   determ : byte; { determinant of matrix }
  22.  
  23. procedure start;
  24. var
  25.   answer : char;
  26.   count : integer;
  27.  
  28. begin
  29.   len := 0;
  30.   writeln('SCRAMBLE Encryptor/Decryptor v0.0 (beta) Copyright(C) 1990 by Sean Lynch');
  31.   writeln;
  32.   writeln('[E]ncrypt file');
  33.   writeln('[D]ecrypt file');
  34.   writeln('[Q]uit');
  35.   repeat
  36.     answer := readkey;
  37.   until (answer = 'e') or (answer = 'E') or (answer = 'd') or (answer = 'D') or (answer = 'q') or (answer = 'Q');
  38.   writeln;
  39.   if (answer = 'q') or (answer = 'Q') then halt(1);
  40.   infilename := '';
  41.   write('Input file: ');
  42.   readln(infilename);
  43.   if infilename = '' then halt(1);
  44.   assign(infile,infilename);
  45.   reset(infile);
  46.   outfilename := '';
  47.   write('Output file: ');
  48.   readln(outfilename);
  49.   if outfilename = '' then halt(1);
  50.   assign(outfile,outfilename);
  51.   rewrite(outfile);
  52.   write('Key ( <= 255 characters): ');
  53.   key := '';
  54.   readln(key);
  55.   keylen := length(key);
  56.   if (keylen > 255) or (key = '') then halt(1);
  57.   for count := 0 to keylen-1 do keyelem[count] := ord(key[count+1]);
  58.   for count := keylen to 218 do keyelem[count] := (keyelem[count-keylen]*117+37) mod 256;
  59.   if (answer = 'e') or (answer = 'E') then enc := true
  60.   else enc := false;
  61. end;
  62.  
  63. function rand(switch : shortint) : word;
  64. var
  65.   x : word;
  66.   j : integer;
  67.   c : word;
  68.   t : word;
  69.  
  70. begin
  71.   x := (randtable[switch,(n[switch]+31)mod 55]+randtable[switch,n[switch]]) mod 65536;
  72.   j := x mod 64;
  73.   randtable[switch,n[switch]] := x;
  74.   n[switch] := (n[switch]+1) mod 55;
  75.   c := (a[switch]*(switch*8+21)+(switch*6+31)) mod 65536;
  76.   rand := (shuftable[switch,j] + c) mod 65536;
  77.   shuftable[switch,j] := x;
  78. end;
  79.  
  80. procedure seed; { Seed random number generators }
  81. { There are 8 random number generators }
  82. var
  83.   count : integer;
  84.   switch : integer;
  85.   x : word;
  86.   j : integer;
  87.  
  88. begin
  89.   x := keyelem[27];
  90.   for switch := 0 to 3 do
  91.   begin
  92.     n[switch] := 0;
  93.     n[switch+4] := 0;
  94.     for count := 0 to 54 do
  95.     begin
  96.       randtable[switch,count] := abs(keyelem[count+1+55*switch]+keyelem[count+1+55*switch+35]*256);
  97.       randtable[switch+4,count] := abs(((keyelem[count+1+55*switch]*145+121)mod 256)+keyelem[count+1+55*switch+34]*256);
  98.     end;
  99.     randtable[switch,54] := abs(randtable[switch,1]xor 113+256*randtable[switch,23]);
  100.     a[switch] := x;
  101.     a[switch+4] := (x*28333+9385) mod 65536;
  102.     for count := 0 to 63 do
  103.     begin
  104.       x := (x*21481+5745)mod 65536;
  105.       j := x*55 div 65536;
  106.       shuftable[switch,count] := (x+randtable[switch,j]) mod 65536;
  107.       x := (x*28973+37489) mod 65536;
  108.       j := x*55 div 65536;
  109.       shuftable[switch+4,count] := (x+randtable[switch,j]) mod 65536;
  110.     end
  111.   end
  112. end;
  113.  
  114. procedure readenc;
  115. var
  116.   count : longint;
  117.   fin : byte;
  118.   l : longint;
  119.  
  120. begin
  121.   l :=filesize(infile)-len;
  122.   if l < 256 then
  123.   begin
  124.     blocklen := l-1;
  125.     done := true;
  126.   end
  127.   else begin
  128.     blocklen := (rand(0) mod 128) + 128;
  129.     done := false;
  130.   end;
  131.   for count := 0 to blocklen do
  132.   read(infile,block[count]);
  133.   len := len + blocklen + 1;
  134. end;
  135.  
  136. procedure genmatrix; { Generate polygraphic substitution matrix }
  137. var
  138.   x : word;
  139. begin
  140.   repeat
  141.     x := rand(2);
  142.     m[0,0] := hi(x);
  143.     m[0,1] := lo(x);
  144.     x := rand(3);
  145.     m[1,0] := hi(x);
  146.     m[1,1] := lo(x);
  147.     determ := (65536+m[0,0]*m[1,1] - m[0,1]*m[1,0])mod 256;
  148.   until determ mod 2 = 1;
  149. end;
  150.  
  151. function dmod(x : integer;y : integer) : integer; { modular division }
  152. var z : byte;
  153. begin
  154.   z := 0;
  155.   while (x-y*z) mod 256 <> 0 do z := z + 1;
  156.   dmod := z;
  157. end;
  158.  
  159. procedure gdematrix; { Generate inverse of matrix }
  160. var d : array[0..1,0..1] of integer;
  161. begin
  162.   d[0,0] := dmod(m[1,1],determ);
  163.   d[0,1] := dmod(256-m[0,1],determ);
  164.   d[1,0] := dmod(256-m[1,0],determ);
  165.   d[1,1] := dmod(m[0,0],determ);
  166.   m[0,0] := d[0,0];
  167.   m[0,1] := d[0,1];
  168.   m[1,0] := d[1,0];
  169.   m[1,1] := d[1,1];
  170. end;
  171.  
  172. procedure polysub; { Digraphic substitution (You can increase size of matrix if you can figure out how)}
  173. var
  174.   count : byte;
  175.   x : integer;
  176.   c : array [0..1] of byte;
  177. { If there is an odd # of characters in the block, the last one is left as is }
  178. begin
  179.   for count := 0 to (blocklen-1) div 2 do
  180.   begin
  181.     c[0] := (131072+block[count*2]*m[0,0]+block[count*2+1]*m[0,1]) mod 256; { linear transformation }
  182.     c[1] := (131072+block[count*2]*m[1,0]+block[count*2+1]*m[1,1]) mod 256;
  183.     block[count*2] := c[0];
  184.     block[count*2+1] := c[1];
  185.   end;
  186. end;
  187.  
  188. procedure enpose; { encryption transpositions }
  189. var
  190.   out : array [0..255] of byte;
  191.   filled : array [0..255] of boolean;
  192.   count : byte;
  193.   x : byte;
  194. begin
  195.   for count := 0 to blocklen do filled[count] := false;
  196.   for count := 0 to blocklen do
  197.   begin
  198.     x := rand(4) * (blocklen+1) div 65536;
  199.     while filled[x] do x := (x+1) mod (blocklen+1);
  200.     out[x] := block[count];
  201.     filled[x] := true;
  202.   end;
  203.   for count := 0 to blocklen do block[count] := out[count];
  204. end;
  205.  
  206. procedure depose; { decryption transpositions }
  207. var
  208.   out : array [0..255] of byte;
  209.   filled : array [0..255] of boolean;
  210.   count : byte;
  211.   x : byte;
  212. begin
  213.   for count := 0 to blocklen do filled[count] := false;
  214.   for count := 0 to blocklen do
  215.   begin
  216.     x := rand(4) * (blocklen+1) div 65536;
  217.     while filled[x] do x := (x+1) mod (blocklen+1);
  218.     out[count] := block[x];
  219.     filled[x]:= true;
  220.   end;
  221.   for count := 0 to blocklen do block[count] := out[count];
  222. end;
  223.  
  224. procedure xora(switch : shortint); { xor operation }
  225. var
  226.   last : byte;
  227.   x : word;
  228.   count : longint;
  229.   y : byte;
  230. begin
  231.   last := lo(rand(switch));
  232.   for count := 0 to blocklen do
  233.   begin
  234.     x := rand(switch);
  235.     y := block[count];
  236.     block[count] := block[count] xor lo(x) xor hi(x) xor last;
  237.     last := y;
  238.   end;
  239. end;
  240.  
  241. procedure xorb(switch : shortint); { xor operation }
  242. var
  243.   last : byte;
  244.   x : word;
  245.   count : byte;
  246. begin
  247.   last := lo(rand(switch));
  248.   for count := 0 to blocklen do
  249.   begin
  250.     x := rand(switch);
  251.     block[count] := block[count] xor lo(x) xor hi(x) xor last;
  252.     last := block[count];
  253.   end;
  254. end;
  255.  
  256. procedure writeout;
  257. var count : byte;
  258. begin
  259.   for count := 0 to blocklen do write(outfile,block[count]);
  260. end;
  261.  
  262. procedure encrypt;
  263. begin
  264.   write('Encrypting');
  265.   repeat
  266.     write('.');
  267.     readenc;
  268.     xora(1);
  269.     genmatrix;
  270.     polysub;
  271.     xora(5);
  272.     xora(7);
  273.     enpose;
  274.     xora(6);
  275.     writeout;
  276.   until done;
  277. end;
  278.  
  279. procedure decrypt;
  280. begin
  281.   write('Decrypting');
  282.   repeat
  283.     write('.');
  284.     readenc;
  285.     xorb(6);
  286.     depose;
  287.     xorb(7);
  288.     xorb(5);
  289.     genmatrix;
  290.     gdematrix;
  291.     polysub;
  292.     xorb(1);
  293.     writeout;
  294.   until done;
  295. end;
  296.  
  297. begin
  298.   start;
  299.   seed;
  300.   if enc then encrypt else decrypt;
  301.   close(infile);
  302.   close(outfile);
  303.   writeln('Done!');
  304. end.
  305.