path: root/RaetselFileUnit.pas

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;
  c:=0;
  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;
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 begin // geht ja gar nicht - 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.