DES algorithm supporting Chinese encryption and decryption

Ksaiy (disappear in the sea of people-like Kunming flowers) Post http://community.csdn.net/Expert/topic/3557/3557236.xml? Temp =. 9775049.

 

Unit unit1;

Interface

Uses
Windows, messages, sysutils, variants, classes, graphics, controls, forms,
Dialogs, stdctrls;

Type
Tform1 = Class (tform)
Label1: tlabel;
Label2: tlabel;
Edit1: tedit;
Edit2: tedit;
Button1: tbutton;
Button2: tbutton;
Label3: tlabel;
Button3: tbutton;
Edit3: tedit;
Edit4: tedit;
Edit5: tedit;
Button4: tbutton;
Procedure button3click (Sender: tobject );
Procedure button4click (Sender: tobject );
Private
{Private Declarations}
Public
{Public declarations}
End;

Type
Tkeybyte = array [0 .. 5] of byte;
Tdesmode = (dmencry, dmdecry );

Function encrystr (STR, key: string): string;
Function decrystr (STR, key: string): string;
Function encrystrhex (STR, key: string): string;
Function decrystrhex (strhex, key: string): string;

Const
Bitip: array [0 .. 63] of byte = // ip address of the initial value
(57, 49, 41, 33, 25, 17, 9, 1,
59, 51, 43, 35, 27, 19, 11, 3,
61, 53, 45, 37, 29, 21, 13, 5,
63, 55, 47, 39, 31, 23, 15, 7,
56, 48, 40, 32, 24, 16, 8, 0,
58, 50, 42, 34, 26, 18, 10, 2,
60, 52, 44, 36, 28, 20, 12, 4,
62, 54, 46, 38, 30, 22, 14, 6 );

Bitcp: array [0 .. 63] of byte = // inverse initial IP-1
(39, 7, 47, 15, 55, 23, 63, 31,
38, 6, 46, 14, 54, 22, 62, 30,
37, 5, 45, 13, 53, 21, 61, 29,
36, 4, 44, 12, 52, 20, 60, 28,
35, 3, 43, 11, 51, 19, 59, 27,
34, 2, 42, 10, 50, 18, 58, 26,
33, 1, 41, 9, 49, 17, 57, 25,
32, 0, 40, 8, 48, 16, 56, 24 );

Bitexp: array [0 .. 47] of integer = // bit selection function E
(31, 0, 1, 2, 3, 4, 3, 4, 5, 6, 7, 8, 7, 8, 9, 10,
11,12, 11,12, 13,14, 15,16, 15,16, 17,18, 19,20, 19,20,
22 );

Bitpm: array [0 .. 31] of byte = // replace FUNCTION P
(15, 6, 19, 20, 28, 11, 27, 16,
1, 26, 2 );

Sbox: array [0 .. 7] of array [0 .. 63] of byte = // S box
(14, 4, 13, 1, 2, 15, 11, 8, 3, 10, 6, 12, 5, 9, 0, 7,
0, 15, 7, 4, 14, 2, 13, 1, 10, 6, 12, 11, 9, 5, 3, 8,
4, 1, 14, 8, 13, 6, 2, 11, 15, 12, 9, 7, 3, 10, 5, 0,
15, 12, 8, 2, 4, 9, 1, 7, 5, 11, 3, 14, 10, 0, 6, 13 ),

(15, 1, 8, 14, 6, 11, 3, 4, 9, 7, 2, 13, 12, 0, 5, 10,
3, 13, 4, 7, 15, 2, 8, 14, 12, 0, 1, 10, 6, 9, 11, 5,
0, 14, 7, 11, 10, 4, 13, 1, 5, 8, 12, 6, 9, 3, 2, 15,
13, 8, 10, 1, 3, 15, 4, 2, 11, 6, 7, 12, 0, 5, 14, 9 ),

(10, 0, 9, 14, 6, 3, 15, 5, 1, 13, 12, 7, 11, 4, 2, 8,
13, 7, 0, 9, 3, 4, 6, 10, 2, 8, 5, 14, 12, 11, 15, 1,
13, 6, 4, 9, 8, 15, 3, 0, 11, 1, 2, 12, 5, 10, 14, 7,
1, 10, 13, 0, 6, 9, 8, 7, 4, 15, 14, 3, 11, 5, 2, 12 ),

(7, 13, 14, 3, 0, 6, 9, 10, 1, 2, 8, 5, 11, 12, 4, 15,
13, 8, 11, 5, 6, 15, 0, 3, 4, 7, 2, 12, 1, 10, 14, 9,
10, 6, 9, 0, 12, 11, 7, 13, 15, 1, 3, 14, 5, 2, 8, 4,
3, 15, 0, 6, 10, 1, 13, 8, 9, 4, 5, 11, 12, 7, 2, 14 ),

(2, 12, 4, 1, 7, 10, 11, 6, 8, 5, 3, 15, 13, 0, 14, 9,
14, 11, 2, 12, 4, 7, 13, 1, 5, 0, 15, 10, 3, 9, 8, 6,
4, 2, 1, 11, 10, 13, 7, 8, 15, 9, 12, 5, 6, 3, 0, 14,
11, 8, 12, 7, 1, 14, 2, 13, 6, 15, 0, 9, 10, 4, 5, 3 ),

(12, 1, 10, 15, 9, 2, 6, 8, 0, 13, 3, 4, 14, 7, 5, 11,
10, 15, 4, 2, 7, 12, 9, 5, 6, 1, 13, 14, 0, 11, 3, 8,
9, 14, 15, 5, 2, 8, 12, 3, 7, 0, 4, 10, 1, 13, 11, 6,
4, 3, 2, 12, 9, 5, 15, 10, 11, 14, 1, 7, 6, 0, 8, 13 ),

(4, 11, 2, 14, 15, 0, 8, 13, 3, 12, 9, 7, 5, 10, 6, 1,
13, 0, 11, 7, 4, 9, 1, 10, 14, 3, 5, 12, 2, 15, 8, 6,
1, 4, 11, 13, 12, 3, 7, 14, 10, 15, 6, 8, 0, 5, 9, 2,
6, 11, 13, 8, 1, 4, 10, 7, 9, 5, 0, 15, 14, 2, 3, 12 ),

(13, 2, 8, 4, 6, 15, 11, 1, 10, 9, 3, 14, 5, 0, 12, 7,
1, 15, 13, 8, 10, 3, 7, 4, 12, 5, 6, 11, 0, 14, 9, 2,
7, 11, 4, 1, 9, 12, 14, 2, 0, 6, 10, 13, 15, 3, 5, 8,
2, 1, 14, 7, 4, 10, 8, 13, 15, 12, 9, 0, 3, 5, 6, 11 ));

Bitpmc1: array [0 .. 55] of byte = // select a replacement PC-1
(56, 48, 40, 32, 24, 16, 8,
0, 57, 49, 41, 33, 25, 17,
9, 1, 58, 50, 42, 34, 26,
18, 10, 2, 59, 51, 43, 35,
62, 54, 46, 38, 30, 22, 14,
6, 61, 53, 45, 37, 29, 21,
13, 5, 60, 52, 44, 36, 28,
20, 12, 4, 27, 19, 11, 3 );

Bitpmc2: array [0 .. 47] of byte = // select a replacement PC-2
(13, 16, 10, 23, 0, 4,
2, 27, 14, 5, 20, 9,
22, 18, 11, 3, 25, 7,
15, 6, 26, 19, 12, 1,
40, 51, 30, 36, 46, 54,
29, 39, 50, 44, 32, 47,
43, 48, 38, 55, 33, 52,
45, 41, 49, 35, 28, 31 );

VaR
Form1: tform1;
Subkey: array [0 .. 15] of tkeybyte;

Implementation

{$ R *. DFM}

Procedure initpermutation (VAR indata: array of byte );
VaR
Newdata: array [0 .. 7] of byte;
I: integer;
Begin
Fillchar (newdata, 8, 0 );
For I: = 0 to 63 do
If (indata [bitip [I] SHR 3] and (1 SHL (7-(bitip [I] and $07) <> 0 then
Newdata [I shr 3]: = newdata [I shr 3] Or (1 SHL (7-(I and $07 )));
For I: = 0 to 7 do indata [I]: = newdata [I];
End;

Procedure conversepermutation (VAR indata: array of byte );
VaR
Newdata: array [0 .. 7] of byte;
I: integer;
Begin
Fillchar (newdata, 8, 0 );
For I: = 0 to 63 do
If (indata [bitcp [I] SHR 3] and (1 SHL (7-(bitcp [I] and $07) <> 0 then
Newdata [I shr 3]: = newdata [I shr 3] Or (1 SHL (7-(I and $07 )));
For I: = 0 to 7 do indata [I]: = newdata [I];
End;

Procedure expand (indata: array of byte; var outdata: array of byte );
VaR
I: integer;
Begin
Fillchar (outdata, 6, 0 );
For I: = 0 to 47 do
If (indata [bitexp [I] SHR 3] and (1 SHL (7-(bitexp [I] and $07) <> 0 then
Outdata [I shr 3]: = outdata [I shr 3] Or (1 SHL (7-(I and $07 )));
End;

Procedure permutation (VAR indata: array of byte );
VaR
Newdata: array [0 .. 3] of byte;
I: integer;
Begin
Fillchar (newdata, 4, 0 );
For I: = 0 to 31 do
If (indata [bitpm [I] SHR 3] and (1 SHL (7-(bitpm [I] and $07) <> 0 then
Newdata [I shr 3]: = newdata [I shr 3] Or (1 SHL (7-(I and $07 )));
For I: = 0 to 3 do indata [I]: = newdata [I];
End;

Function Si (S, inbyte: byte): byte;
VaR
C: byte;
Begin
C: = (inbyte and $20) or (inbyte and $ 1E) SHR 1) or
(Inbyte and $01) SHL 4 );
Result: = (sbox [s] [c] and $ 0f );
End;

Procedure permutationchoose1 (indata: array of byte;
VaR outdata: array of byte );
VaR
I: integer;
Begin
Fillchar (outdata, 7, 0 );
For I: = 0 to 3 do
If (indata [bitpmc1 [I] SHR 3] and (1 SHL (7-(bitpmc1 [I] and $07) <> 0 then
Outdata [I shr 3]: = outdata [I shr 3] Or (1 SHL (7-(I and $07 )));
End;

Procedure permutationchoose2 (indata: array of byte;
VaR outdata: array of byte );
VaR
I: integer;
Begin
Fillchar (outdata, 6, 0 );
For I: = 0 to 47 do
If (indata [bitpmc2 [I] SHR 3] and (1 SHL (7-(bitpmc2 [I] and $07) <> 0 then
Outdata [I shr 3]: = outdata [I shr 3] Or (1 SHL (7-(I and $07 )));
End;

Procedure cyclemove (VAR indata: array of byte; bitmove: byte );
VaR
I: integer;
Begin
For I: = 0 to bitmove-1 do
Begin
Indata [0]: = (indata [0] SHL 1) or (indata [1] SHR 7 );
Indata [1]: = (indata [1] SHL 1) or (indata [2] SHR 7 );
Indata [2]: = (indata [2] SHL 1) or (indata [3] SHR 7 );
Indata [3]: = (indata [3] SHL 1) or (indata [0] and $10) SHR 4 );
Indata [0]: = (indata [0] and $ 0f );
End;
End;

Procedure makekey (inkey: array of byte; var outkey: array of tkeybyte );
Const
Bitdisplace: array [0 .. 15] of byte =
);
VaR
Outdata56: array [0 .. 6] of byte;
Key28l: array [0 .. 3] of byte;
Key28r: array [0 .. 3] of byte;
Key56o: array [0 .. 6] of byte;
I: integer;
Begin
Permutationchoose1 (inkey, outdata56 );

Key28l [0]: = outdata56 [0] SHR 4;
Key28l [1]: = (outdata56 [0] SHL 4) or (outdata56 [1] SHR 4 );
Key28l [2]: = (outdata56 [1] SHL 4) or (outdata56 [2] SHR 4 );
Key28l [3]: = (outdata56 [2] SHL 4) or (outdata56 [3] SHR 4 );
Key28r [0]: = outdata56 [3] and $ 0f;
Key28r [1]: = outdata56 [4];
Key28r [2]: = outdata56 [5];
Key28r [3]: = outdata56 [6];

For I: = 0 to 15 do
Begin
Cyclemove (key28l, bitdisplace [I]);
Cyclemove (key28r, bitdisplace [I]);
Key56o [0]: = (key28l [0] SHL 4) or (key28l [1] SHR 4 );
Key56o [1]: = (key28l [1] SHL 4) or (key28l [2] SHR 4 );
Key56o [2]: = (key28l [2] SHL 4) or (key28l [3] SHR 4 );
Key56o [3]: = (key28l [3] SHL 4) or (key28r [0]);
Key56o [4]: = key28r [1];
Key56o [5]: = key28r [2];
Key56o [6]: = key28r [3];
Permutationchoose2 (key56o, outkey [I]);
End;
End;

Procedure encry (indata, subkey: array of byte;
VaR outdata: array of byte );
VaR
Outbuf: array [0 .. 5] of byte;
Buf: array [0 .. 7] of byte;
I: integer;
Begin
Expand (indata, outbuf );
For I: = 0 to 5 do outbuf [I]: = outbuf [I] XOR subkey [I];
Buf [0]: = outbuf [0] SHR 2;
Buf [1]: = (outbuf [0] and $03) SHL 4) or (outbuf [1] SHR 4 );
Buf [2]: = (outbuf [1] and $ 0f) SHL 2) or (outbuf [2] SHR 6 );
Buf [3]: = outbuf [2] and $ 3f;
Buf [4]: = outbuf [3] SHR 2;
Buf [5]: = (outbuf [3] and $03) SHL 4) or (outbuf [4] SHR 4 );
Buf [6]: = (outbuf [4] and $ 0f) SHL 2) or (outbuf [5] SHR 6 );
Buf [7]: = outbuf [5] and $ 3f;
For I: = 0 to 7 do Buf [I]: = Si (I, Buf [I]);
For I: = 0 to 3 do outbuf [I]: = (BUF [I * 2] SHL 4) or Buf [I * 2 + 1];
Permutation (outbuf );
For I: = 0 to 3 do outdata [I]: = outbuf [I];
End;

Procedure desdata (desmode: tdesmode;
Indata: array of byte; var outdata: array of byte );
// Indata and outdata are both 8 bytes. Otherwise, an error occurs.
VaR
I, J: integer;
Temp, Buf: array [0 .. 3] of byte;
Begin
For I: = 0 to 7 do outdata [I]: = indata [I];
Initpermutation (outdata );
If desmode = dmencry then
Begin
For I: = 0 to 15 do
Begin
For J: = 0 to 3 Do temp [J]: = outdata [J]; // temp = ln
For J: = 0 to 3 do outdata [J]: = outdata [J + 4]; // LN + 1 = rn
Encry (outdata, subkey [I], Buf); // Rn = KN => Buf
For J: = 0 to 3 do outdata [J + 4]: = temp [J] XOR Buf [J]; // rn + 1 = ln ^ Buf
End;

For J: = 0 to 3 Do temp [J]: = outdata [J + 4];
For J: = 0 to 3 do outdata [J + 4]: = outdata [J];
For J: = 0 to 3 do outdata [J]: = temp [J];
End
Else if desmode = dmdecry then
Begin
For I: = 15 downto 0 do
Begin
For J: = 0 to 3 Do temp [J]: = outdata [J];
For J: = 0 to 3 do outdata [J]: = outdata [J + 4];
Encry (outdata, subkey [I], Buf );
For J: = 0 to 3 do outdata [J + 4]: = temp [J] XOR Buf [J];
End;
For J: = 0 to 3 Do temp [J]: = outdata [J + 4];
For J: = 0 to 3 do outdata [J + 4]: = outdata [J];
For J: = 0 to 3 do outdata [J]: = temp [J];
End;
Conversepermutation (outdata );
End;

//////////////////////////////////////// //////////////////////

Function encrystr (STR, key: string): string;
VaR
Strbyte, outbyte, keybyte: array [0 .. 7] of byte;
Strresult: string;
I, J: integer;
Begin
If (length (STR)> 0) and (ord (STR [length (STR)]) = 0) then
Raise exception. Create ('error: The last char is null Char .');
If length (key) <8 then
While length (key) <8 Do key: = Key + CHR (0 );
While length (STR) mod 8 <> 0 do STR: = STR + CHR (0 );

For J: = 0 to 7 do keybyte [J]: = ord (Key [J + 1]);
Makekey (keybyte, subkey );

Strresult: = '';

For I: = 0 to length (STR) Div 8-1 do
Begin
For J: = 0 to 7 do
Strbyte [J]: = ord (STR [I * 8 + J + 1]);
Desdata (dmencry, strbyte, outbyte );
For J: = 0 to 7 do
Strresult: = strresult + CHR (outbyte [J]);
End;

Result: = strresult;
End;

Function decrystr (STR, key: string): string;
VaR
Strbyte, outbyte, keybyte: array [0 .. 7] of byte;
Strresult: string;
I, J: integer;
Begin
If length (key) <8 then
While length (key) <8 Do key: = Key + CHR (0 );

For J: = 0 to 7 do keybyte [J]: = ord (Key [J + 1]);
Makekey (keybyte, subkey );

Strresult: = '';

For I: = 0 to length (STR) Div 8-1 do
Begin
For J: = 0 to 7 do strbyte [J]: = ord (STR [I * 8 + J + 1]);
Desdata (dmdecry, strbyte, outbyte );
For J: = 0 to 7 do
Strresult: = strresult + CHR (outbyte [J]);
End;
While (length (strresult)> 0) and
(Ord (strresult [length (strresult)]) = 0) Do
Delete (strresult, length (strresult), 1 );
Result: = strresult;
End;

//////////////////////////////////////// ///////////////////

Function encrystrhex (STR, key: string): string;
VaR
Strresult, tempresult, temp: string;
I: integer;
Begin
Tempresult: = encrystr (STR, key );
Strresult: = '';
For I: = 0 to length (tempresult)-1 do
Begin
Temp: = format ('% x', [ord (tempresult [I + 1]);
If length (temp) = 1 then temp: = '0' + temp;
Strresult: = strresult + temp;
End;
Result: = strresult;
End;

Function decrystrhex (strhex, key: string): string;
Function hextoint (HEX: string): integer;
VaR
I, Res: integer;
Ch: Char;
Begin
Res: = 0;
For I: = 0 to length (HEX)-1 do
Begin
Ch: = hex [I + 1];
If (CH> = '0') and (CH <= '9') then
Res: = res * 16 + ord (CH)-ord ('0 ')
Else if (CH> = 'A') and (CH <= 'F') then
Res: = res * 16 + ord (CH)-ord ('A') + 10
Else if (CH> = 'A') and (CH <= 'F') then
Res: = res * 16 + ord (CH)-ord ('A') + 10
Else raise exception. Create ('error: Not a hex string ');
End;
Result: = res;
End;

VaR
STR, temp: string;
I: integer;
Begin
STR: = '';
For I: = 0 to length (strhex) Div 2-1 do
Begin
Temp: = copy (strhex, I * 2 + 1, 2 );
STR: = STR + CHR (hextoint (temp ));
End;
Result: = decrystr (STR, key );
End;

Call example sub:

// Encryption
Procedure tform1.button3click (Sender: tobject );
Begin
Edit5.text: = encrystrhex (edit3.text, edit4.text );
End;

// Decrypt
Procedure tform1.button4click (Sender: tobject );
Begin
Edit5.text: = decrystrhex (edit3.text, edit4.text );
End;

End.