type TDESblock=array [1..8] of byte;
type TDES32bit=array [1..4] of Byte;
type TDES48bit=array [1..6] of Byte;

const PreMutArray: array [1..64] of Byte=(58,   50, 42, 34, 26, 18, 10, 2, 60, 52, 44, 36, 28, 20, 12, 4,
                                          62, 54, 46, 38, 30, 22, 14, 6, 64, 56, 48, 40, 32, 24, 16, 8,
                                          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);

LastPreMutArray: array [1..64] of Byte=(40, 8, 48, 16, 56, 24, 64, 32, 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);

ExtendArray: array [1..48] of byte=(32, 1,  2,  3,  4,  5,
                                    4,  5,  6,  7,  8,  9,
                                    8,  9,  10, 11, 12, 13,
                                    12, 13, 14, 15, 16, 17,
                                    16, 17, 18, 19, 20, 21,
                                    20, 21, 22, 23, 24, 25,
                                    24, 25, 26, 27, 28, 29,
                                    28, 29, 30, 31, 32, 1);


procedure DESEncrypt(InBlock: Pointer; OutBlock: Pointer; Key: Pointer);

implementation

function DESBlockGetBit(Block: pointer; NBit: dword): bool;
begin
  result:=false;
  if ((byte(pointer(dword(Block)+(NBit div 8))^)) and (1 shl (NBit mod 8))>0) then result:=true;
end;

procedure DESBlockSetBit(Block: pointer; NBit: dword);
begin
  byte(pointer(dword(Block)+(NBit div 8))^):=byte(pointer(dword(Block)+(NBit div 8))^) or (1 shl (NBit mod 8));
end;

procedure DESBlockClrBit(Block: pointer; NBit: dword);
begin
  byte(pointer(dword(Block)+(NBit div 8))^):=byte(pointer(dword(Block)+(NBit div 8))^) and (not (1 shl (NBit mod 8)));
end;

function InitialPremutation(block: TDESBlock):TDESblock;
var i: dword;
begin
  ZeroMemory(@Result, 8);
  for i:=1 to 64 do
  begin
    if DESBlockGetBit(@Block, i) then DESBlockSetBit(@Result, PreMutArray[i]);
  end;
end;

function E(Rvect: TDES32bit): TDES48bit;
var i: dword;
begin
  ZeroMemory(@result, 6);
  for i:=1 to 48 do
  begin
    if DESBlockGetBit(@Rvect, ExtendArray[i]) then DESBlockSetBit(@result, i);
  end;
end;

function F(Rvect: TDES32bit; Key: TDES48bit): TDES32bit;
var ExtendedRvect: TDES48bit;
begin
  E(Rvect);
end;