свежий исходник
{$WARN UNSAFE_CODE OFF}
unit ExpiredPassports;

interface

type
TPassportMap= array of array of byte;

procedure MapInvert(var Map: TPassportMap; Serial, No: integer); //инвертировать один бит карты
procedure MapInclude(var Map: TPassportMap; Serial, No: integer); //установить один бит карты
procedure MapExclude(var Map: TPassportMap; Serial, No: integer); //сбросить один бит карты
function MapTest(var Map: TPassportMap; Serial, No: integer): boolean; //получить состояние одного бита карты

procedure LoadPassportList(var Map: TPassportMap; const FileName: string); //загрузить карту, используя файл ФМС

procedure SavePassportMap(var Map: TPassportMap; const FileName: string); //сохранить карту в формате без сжатия
procedure LoadPassportMap(var Map: TPassportMap; const FileName: string); //загрузить карту в формате без сжатия

procedure SavePassportPacket(var Map: TPassportMap; const FileName: string); //сохранить карту в формате дельта-кодов
procedure LoadPassportPacket(var Map: TPassportMap; const FileName: string); //загрузить карту в формате дельта-кодов

procedure SavePassportPacket2(var Map: TPassportMap; const FileName: string); //сохранить карту в формате дельта-кодов 2 в 1
procedure LoadPassportPacket2(var Map: TPassportMap; const FileName: string); //загрузить карту в формате дельта-кодов 2 в 1

implementation

type
TBuffer= array[0..999999] of byte;

procedure MapInvert(var Map: TPassportMap; Serial, No: integer);
begin;
if (Serial<0) or (Serial>9999) or (No<0) or (No>999999) then exit;
if Length(Map)=0 then SetLength(Map, 10000);
if Length(Map[Serial])=0 then begin;
SetLength(Map[Serial], 125000);
FillChar(Map[Serial,0], 125000, 0);
end;
Map[Serial, No shr 3]:=1 shl (No and 7) xor Map[Serial, No shr 3];
end;

procedure MapInclude(var Map: TPassportMap; Serial, No: integer);
begin;
if (Serial<0) or (Serial>9999) or (No<0) or (No>999999) then exit;
if Length(Map)=0 then SetLength(Map, 10000);
if Length(Map[Serial])=0 then begin;
SetLength(Map[Serial], 125000);
FillChar(Map[Serial,0], 125000, 0);
end;
Map[Serial, No shr 3]:=1 shl (No and 7) or Map[Serial, No shr 3];
end;

procedure MapExclude(var Map: TPassportMap; Serial, No: integer);
begin;
if (Serial<0) or (Serial>9999) or (No<0) or (No>999999) then exit;
if Length(Map)=0 then exit;
if Length(Map[Serial])=0 then exit;
Map[Serial, No shr 3]:=(not (1 shl (No and 7))) and Map[Serial, No shr 3];
end;

function MapTest(var Map: TPassportMap; Serial, No: integer): boolean;
begin;
Result:=false;
if (Serial<0) or (Serial>9999) or (No<0) or (No>999999) then exit;
if Length(Map)=0 then exit;
if Length(Map[Serial])=0 then exit;
Result:=1 shl (No and 7) and Map[Serial, No shr 3]<>0;
end;

function SubstrToInt(const s: string; i1, i2: integer): integer;
var
i, c: integer;
begin;
Result:=0;
for i:=i1 to i2 do begin;
c:=ord(s[i])-ord('0');
if cardinal(c)>9 then begin;
Result:=-1;
exit;
end;
Result:=Result*10+c;
end;
end;

procedure LoadPassportList(var Map: TPassportMap; const FileName: string);
var
Fi: Text;
s: string;
begin;
Map:=nil;
Assign(Fi, Filename); Reset(Fi);
while not EOF(Fi) do begin;
ReadLn(Fi, s);
if (Length(s)=11) and (s[5]=',')
then MapInclude(Map, SubstrToInt(s,1,4), SubstrToInt(s,6,11));
end;
CloseFile(Fi);
end;

procedure SavePassportMap(var Map: TPassportMap; const FileName: string);
var
Fi: file;
Serial: integer;
begin;
Assign(Fi, Filename); Rewrite(Fi,1);
for Serial:=0 to Length(Map)-1 do if Length(Map[Serial])=125000 then begin;
BlockWrite(Fi, Serial, 4);
BlockWrite(Fi, Map[Serial,0], 125000);
end;
CloseFile(Fi);
end;

procedure LoadPassportMap(var Map: TPassportMap; const FileName: string);
var
Fi: file;
Serial, Count: integer;
begin;
Map:=nil; SetLength(Map, 10000);
Assign(Fi, Filename); Reset(Fi,1);
while true do begin;
BlockRead(Fi, Serial, 4, Count);
if Count=0 then break;
if (Count<>4) or (Serial<0) or (Serial>9999) then begin;
Map:=nil; break;
end;
SetLength(Map[Serial], 125000);
BlockRead(Fi, Map[Serial,0], 125000, Count);
if Count<>125000 then begin;
Map:=nil; break;
end;
end;
CloseFile(Fi);
end;

procedure EncodeDelta(var Buf: TBuffer; var BufPos: integer; Delta: integer);
begin;
if Delta<=$7F then begin;
Buf[BufPos]:=Delta;
inc(BufPos);
end
else if Delta<=$3FFF then begin;
Buf[BufPos]:=Delta and $3F or $80;
Buf[BufPos+1]:=Delta shr 6;
inc(BufPos, 2);
end
else begin;
Buf[BufPos]:=Delta and $3F or $C0;
Buf[BufPos+1]:=Delta shr 6;
Buf[BufPos+2]:=Delta shr 14;
inc(BufPos, 3);
end;
end;

function DecodeDelta(var Buf: TBuffer; var BufPos: integer): integer;
begin;
Result:=Buf[BufPos];
if Result<=$7F then begin;
inc(BufPos);
end
else if Result<=$BF then begin;
Result:=integer(Buf[BufPos+1]) shl 6
or Result and $3F;
inc(BufPos, 2);
end
else begin;
Result:=integer(Buf[BufPos+2]) shl 14
or integer(Buf[BufPos+1]) shl 6
or Result and $3F;
inc(BufPos, 3);
end;
end;

procedure SavePassportPacket(var Map: TPassportMap; const FileName: string);
var
Fi: file;
Serial, No, OldNo, Val, Bit, BufPos, i, j: integer;
Buf: TBuffer;
begin;
Assign(Fi, Filename); Rewrite(Fi,1);
for Serial:=0 to Length(Map)-1 do if Length(Map[Serial])=125000 then begin;
BlockWrite(Fi, Serial, 4);
Bit:=Map[Serial,0] and 1;
BlockWrite(Fi, Bit, 1);
No:=0; OldNo:=0; BufPos:=0;
for i:=0 to 125000-1 do begin;
Val:=Map[Serial,i];
if (Val=0) and (Bit=0) or (Val=255) and (Bit<>0) then begin;
inc(No, 8);
end
else for j:=0 to 7 do begin;
if Val and 1<>Bit then begin;
EncodeDelta(Buf, BufPos, No-OldNo-1);
OldNo:=No;
Bit:=Bit xor 1;
end;
inc(No);
Val:=Val shr 1;
end
end;
EncodeDelta(Buf, BufPos, No-OldNo-1);
BlockWrite(Fi, BufPos, 4);
BlockWrite(Fi, Buf[0], BufPos);
end;
CloseFile(Fi);
end;

procedure LoadPassportPacket(var Map: TPassportMap; const FileName: string);
var
Fi: file;
Serial, No, OldNo, Bit, BufLen, BufPos: integer;
Buf: TBuffer;
var
Count: integer;
begin;
Map:=nil; SetLength(Map, 10000);
Assign(Fi, Filename); Reset(Fi,1);
while true do begin;
BlockRead(Fi, Serial, 4, Count);
if Count=0 then break;
if (Count<>4) or (Serial<0) or (Serial>9999) then begin;
Map:=nil; break;
end;
Bit:=0; BlockRead(Fi, Bit, 1, Count); Bit:=Bit xor 1;
if (Count<>1) or (Bit and -2<>0) then begin;
Map:=nil; break;
end;
BlockRead(Fi, BufLen, 4, Count);
if (Count<>4) or (BufLen<=0) or (BufLen>SizeOf(Buf)) then begin;
Map:=nil; break;
end;
BlockRead(Fi, Buf[0], BufLen, Count);
if Count<>BufLen then begin;
Map:=nil; break;
end;
SetLength(Map[Serial], 125000);
No:=0; OldNo:=0; BufPos:=0;
while BufPos<BufLen do begin;
No:=DecodeDelta(Buf, BufPos)+1+No;
Bit:=Bit xor 1;
if (BufPos>BufLen) or (No>999999+1) then break;
if Bit=0 then while OldNo<No do begin;
if (OldNo and 7=0) and (OldNo+7<No) then begin;
Map[Serial, OldNo shr 3]:=0;
inc(OldNo, 8);
end
else begin;
Map[Serial, OldNo shr 3]:=(not (1 shl (OldNo and 7))) and Map[Serial, OldNo shr 3];
inc(OldNo);
end;
end
else while OldNo<No do begin;
if (OldNo and 7=0) and (OldNo+7<No) then begin;
Map[Serial,OldNo shr 3]:=$FF;
inc(OldNo, 8);
end
else begin;
Map[Serial, OldNo shr 3]:=1 shl (OldNo and 7) or Map[Serial, OldNo shr 3];
inc(OldNo);
end;
end;
end;
if (BufPos<>BufLen) or (No<>999999+1) then begin;
Map:=nil; break;
end;
end;
CloseFile(Fi);
end;

procedure EncodeDelta2(var Buf: TBuffer; var BufPos, CodeLen: integer; Delta: integer);
begin;
if (CodeLen>0) and (Delta<=8) then begin; //пробуем запихнуть маленькую дельту в предыдущий код
if Delta=0 then begin; //используем $40 как флаг нулевой дельты
if CodeLen=1
then Buf[BufPos-1]:=$40 or Buf[BufPos-1]
else Buf[BufPos+1-CodeLen]:=$40 or Buf[BufPos+1-CodeLen];
CodeLen:=0; //чтобы больше не пихать, место занято
exit;
end
else if (CodeLen=1) and (Buf[BufPos-1]<=7) then begin; //если предыдущий код был маленький, то пихаем в него ненулевую дельту
Buf[BufPos-1]:=(Delta-1) shl 3 or $80 or Buf[BufPos-1];
CodeLen:=0; //чтобы больше не пихать, место занято
exit;
end;
end;
if Delta<=$3F then begin;
Buf[BufPos]:=Delta;
inc(BufPos);
CodeLen:=1;
end
else if Delta<=$FFF then begin;
Buf[BufPos]:=Delta and $3F or $C0;
Buf[BufPos+1]:=Delta shr 6;
inc(BufPos, 2);
CodeLen:=2;
end
else begin;
Buf[BufPos]:=Delta and $3F or $C0;
Buf[BufPos+1]:=Delta shr 6 and $3F or $80;
Buf[BufPos+2]:=Delta shr 12;
inc(BufPos, 3);
CodeLen:=3;
end;
end;

function DecodeDelta2(var Buf: TBuffer; var BufPos, NextDelta: integer): integer;
begin;
if NextDelta>=0 then begin;
Result:=NextDelta;
NextDelta:=-1;
exit;
end;
Result:=Buf[BufPos];
if Result<=$3F then begin;
inc(BufPos);
end
else if Result<=$7F then begin;
NextDelta:=0;
Result:=Result and $3F;
inc(BufPos);
end
else if Result<=$BF then begin;
NextDelta:=Result shr 3 and $7 + 1;
Result:=Result and 7;
inc(BufPos);
end
else begin;
if Buf[BufPos+1] and $40<>0 then NextDelta:=0;
Result:=integer(Buf[BufPos+1]) and $3F shl 6
or Result and $3F;
if Buf[BufPos+1] and $80=0
then inc(BufPos, 2)
else begin;
Result:=integer(Buf[BufPos+2]) shl 12 or Result;
inc(BufPos, 3);
end;
end;
end;

procedure SavePassportPacket2(var Map: TPassportMap; const FileName: string);
var
Fi: file;
Serial, No, OldNo, Val, Bit, BufPos, CodeLen, i, j: integer;
Buf: TBuffer;
begin;
Assign(Fi, Filename); Rewrite(Fi,1);
for Serial:=0 to Length(Map)-1 do if Length(Map[Serial])=125000 then begin;
BlockWrite(Fi, Serial, 4);
Bit:=Map[Serial,0] and 1;
BlockWrite(Fi, Bit, 1);
No:=0; OldNo:=0; BufPos:=0; CodeLen:=0;
for i:=0 to 125000-1 do begin;
Val:=Map[Serial,i];
if (Val=0) and (Bit=0) or (Val=255) and (Bit<>0) then begin;
inc(No, 8);
end
else for j:=0 to 7 do begin;
if Val and 1<>Bit then begin;
EncodeDelta2(Buf, BufPos, CodeLen, No-OldNo-1);
OldNo:=No;
Bit:=Bit xor 1;
end;
inc(No);
Val:=Val shr 1;
end
end;
EncodeDelta2(Buf, BufPos, CodeLen, No-OldNo-1);
BlockWrite(Fi, BufPos, 4);
BlockWrite(Fi, Buf[0], BufPos);
end;
CloseFile(Fi);
end;

procedure LoadPassportPacket2(var Map: TPassportMap; const FileName: string);
var
Fi: file;
Serial, No, OldNo, Bit, BufLen, BufPos, NextDelta: integer;
Buf: TBuffer;
var
Count: integer;
begin;
Map:=nil; SetLength(Map, 10000);
Assign(Fi, Filename); Reset(Fi,1);
while true do begin;
BlockRead(Fi, Serial, 4, Count);
if Count=0 then break;
if (Count<>4) or (Serial<0) or (Serial>9999) then begin;
Map:=nil; break;
end;
Bit:=0; BlockRead(Fi, Bit, 1, Count); Bit:=Bit xor 1;
if (Count<>1) or (Bit and -2<>0) then begin;
Map:=nil; break;
end;
BlockRead(Fi, BufLen, 4, Count);
if (Count<>4) or (BufLen<=0) or (BufLen>SizeOf(Buf)) then begin;
Map:=nil; break;
end;
BlockRead(Fi, Buf[0], BufLen, Count);
if Count<>BufLen then begin;
Map:=nil; break;
end;
SetLength(Map[Serial], 125000);
No:=0; OldNo:=0; BufPos:=0; NextDelta:=-1;
while (BufPos<BufLen) or (NextDelta>=0) do begin;
No:=DecodeDelta2(Buf, BufPos, NextDelta)+1+No;
Bit:=Bit xor 1;
if (BufPos>BufLen) or (No>999999+1) then break;
if Bit=0 then while OldNo<No do begin;
if (OldNo and 7=0) and (OldNo+7<No) then begin;
Map[Serial, OldNo shr 3]:=0;
inc(OldNo, 8);
end
else begin;
Map[Serial, OldNo shr 3]:=(not (1 shl (OldNo and 7))) and Map[Serial, OldNo shr 3];
inc(OldNo);
end;
end
else while OldNo<No do begin;
if (OldNo and 7=0) and (OldNo+7<No) then begin;
Map[Serial,OldNo shr 3]:=$FF;
inc(OldNo, 8);
end
else begin;
Map[Serial, OldNo shr 3]:=1 shl (OldNo and 7) or Map[Serial, OldNo shr 3];
inc(OldNo);
end;
end;
end;
if (BufPos<>BufLen) or (NextDelta>=0) or (No<>999999+1) then begin;
Map:=nil; break;
end;
end;
CloseFile(Fi);
end;

end.