unit RaetselFileUnit;

interface

 uses dialogs, math;

 type TWort     =    record
                      W:    array of Byte;
                      Bits: Integer;
                     end;
      TRaetselFile = class
                     private
                      F:      File;
                      wacc:   boolean;
                      inhalt,
                      conv:   array of Byte;
                      FPoint: Integer;
                      WB:     array of TWort;
                      procedure FFlush;
                      procedure initWB;
                      procedure concatWs(a,b: integer);
                      function  BisAx(A: TWort; B: array of Byte): boolean;
                      procedure rConvert;
                      procedure wConvert;
                     public
                      Kennung:  String;
                      procedure FAssignfile(FileName: String);
                      function  FReset: boolean;
                      procedure FRewrite;
                      procedure FCloseFile;
                      procedure FBlockWrite(var Data; Len: Integer);
                      function  FBlockRead(var Data; Len: Integer): boolean;
                     end;

implementation

procedure TRaetselFile.Fassignfile(FileName: String);
begin
 AssignFile(F,FileName);
end;

function  TRaetselFile.FReset: boolean;
var C:   Cardinal;
    S:   String;
begin
 wacc:=false;
 Result:=false;
 Reset(F,1);
 if FileSize(F) < 4 then
  begin
   FCloseFile;
   exit;
  end;
 Blockread(F,C,4);
 if C<>$26594131 then
  begin
   FCloseFile;
   exit;
  end;
 Setlength(conv,FileSize(F)-4);
 Blockread(F,conv[0],length(conv));
 rConvert;
 if length(inhalt)<length(Kennung) then
  begin
   FCloseFile;
   exit;
  end;
 S:=Kennung;
 FBlockread(S[1],length(S));
 if S<>Kennung then
  begin
   FCloseFile;
   exit;
  end;
 Result:=true;
end;

procedure TRaetselFile.initWB;
var B: Byte;
begin
(* Setlength(WB,128);
 for B:=0 to 127 do
  begin
   Setlength(WB[B].W,2);
   WB[B].W[0]:=B;
   WB[B].W[1]:=0;
   WB[B].Bits:=7;
  end; *)
 Setlength(WB,2);
 setlength(WB[0].W,2);
 WB[0].W[0]:=$0;
 WB[0].W[1]:=0;
 WB[0].Bits:=1;
 setlength(WB[1].W,2);
 WB[1].W[0]:=$1;
 WB[1].W[1]:=0;
 WB[1].Bits:=1; 
end;

procedure TRaetselFile.concatWs(a,b: integer);
var I: integer;
begin
 setlength(WB,length(WB)+1); // WB erweitern
 with WB[length(WB)-1] do begin
  Bits:=WB[a].Bits+WB[b].Bits;
  Setlength(W,(Bits+7) div 8 + 1);
  for I:=0 to length(W)-1 do
   W[I]:=0;
  for I:=0 to length(WB[a].W)-2 do
   W[I]:=WB[a].W[I];
  for I:=0 to length(WB[b].W)-2 do
   begin
    W[length(WB[a].W)-2+I]:=
     W[length(WB[a].W)-2+I] or
      ($FF and (WB[b].W[I] shl (WB[a].Bits mod 8)));
    if length(WB[a].W)-1+I < length(W) then
     W[length(WB[a].W)-1+I]:=
      W[length(WB[a].W)-1+I] or
       (WB[b].W[I] shr (8 - (WB[a].Bits mod 8)));
   end;
 end;
end;

function  TRaetselFile.BisAx(A: TWort; B: array of Byte): boolean;
var I: Integer;
begin
 Result:=true;
 for I:=0 to (A.Bits div 8)-1 do
  Result:=Result and (A.W[I] = B[I]);
 Result:=Result and ((A.W[length(A.W)-2] and ($FF shr (8-(A.Bits mod 8)))) =
                       (B[length(A.W)-2] and ($FF shr (8-(A.Bits mod 8)))));
end;

procedure TRaetselFile.rConvert;
var rP:       longint;
    wP,I:     integer;
    passt,lp: integer;
    wBuff:    byte;
begin
 initWB;
 Setlength(inhalt,0);
 rP:=0;
 wP:=0;
 wBuff:=0;
 lp:=-1;
 setlength(conv,length(conv)+1);
 conv[length(conv)-1]:=0;
 while rP<((length(conv)-1)*8) do
  begin
   passt:=0;
   for I:=0 to ceil(ln(length(WB))/ln(2))-1 do
    begin
     passt:=passt or (byte(odd(conv[rP div 8] shr (rP mod 8))) shl I);
     inc(rP);
    end;
   for I:=0 to WB[passt].Bits-1 do
    begin
     if wP=8 then
      begin
       setlength(inhalt,length(inhalt)+1);
       inhalt[length(inhalt)-1]:=wBuff;
       wP:=0;
       wBuff:=0;
      end;
     wBuff:=wBuff or (Byte(odd((WB[passt].W[I div 8] shr (I mod 8)))) shl wP);
     inc(wP);
    end;
   if lp<>-1 then
    concatWs(lp,passt);
   lp:=passt;
  end;
 setlength(conv,length(conv)+1);
 conv[length(conv)-1]:=wBuff;
end;

procedure TRaetselFile.wConvert;
var rP:              longint;
    wP,I,J:          integer;
    rBuff:           array of Byte;
    rBBits,passt,lp: integer;
    wBuff:           byte;
begin
 initWB;   
 Setlength(conv,0);
 rP:=0;
 wP:=0;
 wBuff:=0;
 lp:=-1;
 Setlength(inhalt,length(inhalt)+1);
 inhalt[length(inhalt)-1]:=0;
 while rP<((length(inhalt)-1)*8) do
  begin
   setlength(rBuff,0);
   rBBits:=0;
   passt:=-1;
   for I:=length(WB)-1 downto 0 do
    with WB[I] do begin
     if Bits > (8*length(inhalt) - rP) then continue;
     if Bits > rBBits then
      begin // mehr r-Buffern
       Setlength(rBuff,(Bits+7) div 8);
       rBBits:=Bits;
       for J:=0 to length(rBuff)-1 do
        begin
         rBuff[J]:=0;
         if J + rP div 8 < length(inhalt) then
          rBuff[J]:=rBuff[J] or (inhalt[J + rP div 8] shr (rP mod 8));
         if J+1 + rP div 8 < length(inhalt) then
          rBuff[J]:=rBuff[J] or ($FF and (inhalt[(rP div 8) + J+1] shl (8-(rP mod 8))));
        end;
      end;
     if ((passt=-1) or (WB[passt].Bits < WB[I].Bits)) and
        BisAx(WB[I],rBuff) then
      passt:=I;
    end;
   if passt=-1 then // geht ja gar nicht ...
    begin           // ... geht ja wohl!
     Messagedlg('Zu wenig Wörter im Wörterbuch!',mterror,[mbOk],0);
     exit;
    end;
   rP:=rP+WB[passt].Bits;
   for I:=0 to ceil(ln(length(WB))/ln(2))-1 do
    begin // WB-index speichern
     if wP=8 then
      begin // w-buffer leeren
       setlength(conv,length(conv)+1);
       conv[length(conv)-1]:=wBuff;
       wP:=0;
       wBuff:=0;
      end;
     wBuff:=wBuff or Byte(odd(passt shr I)) shl wP;
     inc(wP);
    end;
   if lp<>-1 then
    concatWs(lp,passt);
   lp:=passt;
  end;
 setlength(conv,length(conv)+1);
 conv[length(conv)-1]:=wBuff;
end;

procedure TRaetselFile.FFlush;
begin
 wConvert;
 BlockWrite(F,conv[0],length(conv));
 SetLength(inhalt,0);
end;

procedure TRaetselFile.FRewrite;
var C: Cardinal;
begin
 wacc:=true;
 Rewrite(F,1);
 C:=$26594131;
 BlockWrite(F,C,4);
 Setlength(inhalt,length(Kennung));
 Move(Kennung[1],inhalt[0],length(Kennung));
 FPoint:=length(inhalt);
end;

procedure TRaetselFile.FCloseFile;
begin
 if wacc then
  begin
   FFlush;
   CloseFile(F);
  end;
 Setlength(inhalt,0);
 FPoint:=0;
end;

procedure TRaetselFile.FBlockWrite(var Data; Len: Integer);
begin
 Setlength(inhalt,length(inhalt)+Len);
 Move(Data,inhalt[FPoint],Len);
 FPoint:=length(inhalt);
end;

function  TRaetselFile.FBlockRead(var Data; Len: Integer): boolean;
begin
 Result:=Len<=(length(inhalt)-FPoint);
 if not Result then
  begin
   FCloseFile;
   exit;
  end;
 Move(inhalt[FPoint],Data,Len);
 FPoint:=FPoint+Len;
end;

end.