program Double;
  { Copyright (c) 2001, Tom Verhoeff (TUE) }
  { A good solution for task DOUBLE of IOI2001 Competition }

uses AESlibP;

{$B-,I+,Q+,R+,S+}

const
  TaskName     = 'double';
  CaseID: String = ''; { actually a variable, value can be overruled }
  InpExtension = '.in';
  OutExtension = '.out';
  OutHeader = '#FILE'; { required start of header on first line of output file }
  HexBits      = 4;    { # bits per hex }
  MaxRelevant  = 5;    { maximum number of relevant hexits in keys }

var
  s  : Integer; { key size, i.e. number relevant hexits in keys (task input) }
  p  : HexStr;  { plaintext message (task input) }
  c2 : HexStr;  { double-encrypted ciphertext message (task input) }
  k1 : HexStr;  { first recovered key of pair (task output) }
  k2 : HexStr;  { second recovered key of pair (task output) }

  { derived values }
  sBytes: Integer;   { # key bytes possibly nonzero }
  sPadBits: Integer; { # 0-padding hexits in highest used byte, 0 or 1 }
  sMaxLast: Byte;    { max value of last byte, $ff=255 or $f0=240 }
  sStepLast: Byte;   { min non-zero value of last byte, 1 or $10=16 }
  pt : Block;        { corresponds to p }
  ct : Block;        { corresponds to c2 }
  ck1: Block;        { corresponds to k1 }
  ck2: Block;        { corresponds to k2 }

procedure ReadInput;
  var inp: Text;
  begin
    Assign ( inp, TaskName + CaseID + InpExtension )
  ; reset ( inp )
  ; readln ( inp, s )
  ; readln ( inp, p )
  ; readln ( inp, c2 )
  ; Close ( inp )
  ; sBytes := (s+1) div 2
  ; sPadBits := 4 * ( 1 - (s-1) mod 2 )
  ; sMaxLast := ( $ff SHL sPadBits ) AND $ff
  ; sStepLast := 1 SHL sPadBits
  ; HexStrToBlock ( p, pt )
  ; HexStrToBlock ( c2, ct )
  end; { ReadInput }

procedure WriteOutput;
  var out: Text;
  begin
    BlockToHexStr ( ck1, k1 )
  ; BlockToHexStr ( ck2, k2 )
  ; Assign ( out, TaskName + CaseID + OutExtension )
  ; rewrite ( out )
  ; writeln ( out, OutHeader, ' ', TaskName, ' ', CaseID )
  ; writeln ( out, k1 )
  ; writeln ( out, k2 )
  ; Close ( out )
  end; { WriteOutput }

function  EqualBlock ( const b1, b2: Block ): Boolean;
  var i, j: Integer;
  begin
    i := 0 ; j := BlockLen
  ; while i <> j do
      if b1[i] = b2[i] then Inc ( i )
      else j := i
  ; EqualBlock := ( i = BlockLen )
  end; { EqualBlock }

const
  NKeys   = LongInt ( 1 ) SHL ( HexBits * MaxRelevant ); { max # keys }
  Unoccupied = -1 {NKeys}; { special value for type CompressedKey }
  HashModulus = 2 * NKeys;
  MaxHash =  HashModulus - 1; { power of 2 minus 1 }
  HashSize= MaxRelevant; { # hexits of message taken for hash value,
    one extra bit is also taken to create some "breathing" space }

type
  HashValue = 0 .. MaxHash;
  CompressedKey = LongInt {0 .. Unoccupied};
  Table = array [ HashValue ] of record
       cck: CompressedKey;
       msg: Block;
     end;

function CompressKey ( const ck: Block ): CompressedKey;
  var i: Integer; cck: CompressedKey;
  begin
    cck := ck [ 0 ]
  ; for i := 1 to 3 do
      cck := ( cck SHL 8 ) OR ck [ i ]
  ; CompressKey := cck
  end; { CompressKey }

procedure UncompressKey ( cck: CompressedKey; var ck: Block );
  { pre: ck[s..BlockLen-1] = 0 }
  var i: Integer;
  begin
    for i := 3 downto 1 do begin
      ck [ i ] := cck AND $ff
    ; cck := cck SHR 8
    end { for i }
  ; ck [ 0 ] := cck
  end; { UncompressKey }

function HashMsg ( const mt: Block ): HashValue;
  var i: Integer; hv: Cardinal;
  begin
    hv := mt [ 0 ]
  ; for i := 1 to 3 do
      hv := ( hv SHL 8 ) OR mt [ i ]
  ; HashMsg := hv AND $1fffff
  end; { HashMsg }

procedure InitT ( var t: Table );
  var h: HashValue;
  begin
    for h := 0 to MaxHash do
      t [ h ] . cck := Unoccupied
  end; { InitT }

procedure Store ( var t: Table; const mt, ck: Block );
  var hv: HashValue;
  begin
    hv := HashMsg ( mt )
  ; while t [ hv ] . cck <> Unoccupied do { occupied }
      hv := ( hv + 1 ) mod HashModulus { linear hashing }
  ; with t [ hv ] do begin
      cck := CompressKey ( ck )
    ; msg := mt
    end { with }
  end; { Store }

procedure Retrieve ( const t: Table; const mt: Block;
                     var found: Boolean; var ck: Block );
  { pre:  ck[s..BlockLen-1]=0
    post: if found then mt occurs with key ck else mt does not occur }
  var hv: HashValue;
  begin
    hv := HashMsg ( mt )
  ; found := False
  ; repeat
      with t [ hv ] do
        if cck <> Unoccupied then begin
          found := EqualBlock ( mt, msg )
        ; if found then
            UncompressKey ( cck, ck )
          else { linear hashing }
            hv := ( hv + 1 ) mod HashModulus
        end { if }
    until found or ( t [ hv ] . cck = Unoccupied )
  end; { Retrieve }

procedure FirstKey ( var k: Block );
  var i: Integer;
  begin
    for i := 0 to BlockLen - 1 do
      k [ i ] := 0
  end; { FirstKey }

function NextKey ( var k: Block ): Boolean;
  { ret: whether k is indeed next key }
  var i, j: Integer; max, step: Byte;
  begin
    i := -1 ; j := sBytes - 1
  ; max := sMaxLast
  ; step := sStepLast
  ; while i <> j do
      if k [ j ] = max then begin
        k [ j ] := 0
      ; max := 255
      ; step := 1
      ; Dec ( j )
      end { then }
      else { k[j] <> max } begin
        Inc ( k[j], step )
      ; i := j
      end { else }
  ; NextKey := 0 <= j
  end; { NextKey }

var
  tbl: Table; { auxiliary }

procedure EncryptPhase;
  var mt1: Block;
  begin
    FirstKey ( ck1 )
  ; repeat
      Encrypt ( pt, ck1, mt1 )
    ; Store ( tbl, mt1, ck1 )
    until not NextKey ( ck1 )
  end; { EncryptPhase }

procedure DecryptPhase;
  var mt1: Block; found: Boolean; ck1candidate, ck2candidate: Block;
  begin
    FirstKey ( ck1candidate ) { for Retrieve/UncompressKey }
  ; FirstKey ( ck2candidate )
  ; repeat
      Decrypt ( ct, ck2candidate, mt1 )
    ; Retrieve ( tbl, mt1, found, ck1candidate )
    ; if found then begin
      ; ck1 := ck1candidate
      ; ck2 := ck2candidate
      end { if }
    until found or not NextKey ( ck2candidate )
  ; if not found then writeln ( 'No solution found!?' )
  end; { DecryptPhase }

procedure ComputeAnswer;
  begin
    InitT ( tbl )
  ; EncryptPhase
  ; DecryptPhase
  end; { ComputeAnswer }

begin
  writeln ( 'Solver for Double' )
; writeln ( 'HashModulus        = ', HashModulus : 10 )
; writeln ( 'SizeOf ( Table )   = ', SizeOf ( Table ) : 10 )
; if ParamCount > 0 then CaseID := ParamStr ( 1 )
; ReadInput
; ComputeAnswer
; WriteOutput
end.