diff options
Diffstat (limited to 'raetselFileUnit.pas')
| -rw-r--r-- | raetselFileUnit.pas | 274 |
1 files changed, 274 insertions, 0 deletions
diff --git a/raetselFileUnit.pas b/raetselFileUnit.pas new file mode 100644 index 0000000..1a389ab --- /dev/null +++ b/raetselFileUnit.pas @@ -0,0 +1,274 @@ +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.
|