stbits.pas

条码控件： 一维条码控件 二维条码控件 PDF417Barcode MaxiCodeBarcode

begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);

    HugeMove(B.btBits^, btBits^, btBlockSize);
    FCount := B.FCount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

constructor TStBits.Create(Max : LongInt);
begin
  {Validate size}
  if Max < 0 then
    RaiseContainerError(stscBadSize);

  CreateContainer(TStNode, 0);

  FMax := Max;
  btBlockSize := (Max+8) div 8;
  HugeGetMem(Pointer(btBits), btBlockSize);
  Clear;
end;

destructor TStBits.Destroy;
begin
  if Assigned(btBits) then
    HugeFreeMem(Pointer(btBits), btBlockSize);

  {Prevent calling Clear}
  IncNodeProtection;
  inherited Destroy;
end;

function StopImmediately(Container : TStBits; N : LongInt;
                         OtherData : Pointer) : Boolean; far;
  {-Iterator function used to stop after first found bit}
begin
  Result := False;
end;

function TStBits.FirstClear : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, True, nil, 0);
end;

function TStBits.FirstSet : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, True, nil, 0);
end;

procedure TStBits.InvertBits;
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := not P^;
    end;
    FCount := FMax-FCount+1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStBits.Iterate(Action : TBitIterateFunc;
                         UseSetBits, Up : Boolean;
                         OtherData : Pointer) : LongInt;
begin
  if Up then
    Result := IterateFrom(Action, UseSetBits, True, OtherData, 0)
  else
    Result := IterateFrom(Action, UseSetBits, False, OtherData, FMax);
end;

function TStBits.IterateFrom(Action : TBitIterateFunc;
                             UseSetBits, Up : Boolean;
                             OtherData : Pointer;
                             From : LongInt) : LongInt;
var
  I, N, F : LongInt;
  O : ShortInt;
  B, TB : Byte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if UseSetBits then
      TB := 0
    else
      TB := $FF;

    if Up then begin
      {do the first possibly-partial byte}
      N := MaxLong(From, 0);
      F := MinLong(btBlockSize-1, N shr 3);
      O := ShortInt(N) and 7;
      B := btByte(F)^;

      while (N <= FMax) and (O <= ShortInt(7)) do begin
        if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
          if not Action(Self, N, OtherData) then begin
            Result := N;
            Exit;
          end;
        inc(O);
        inc(N);
      end;

      {do the rest of the bytes}
      for I := F+1 to btBlockSize-1 do begin
        B := btByte(I)^;
        if B <> TB then begin
          {byte has bits of interest}
          O := 0;
          while (N <= FMax) and (O < ShortInt(8)) do begin
            if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
              if not Action(Self, N, OtherData) then begin
                Result := N;
                Exit;
              end;
            inc(O);
            inc(N);
          end;
        end else
          inc(N, 8);
      end;

    end else begin
      {do the last possibly-partial byte}
      N := MinLong(From, FMax);
      F := MaxLong(N, 0) shr 3;
      O := ShortInt(N) and 7;
      B := btByte(F)^;

      while (N >= 0) and (O >= ShortInt(0)) do begin
        if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
          if not Action(Self, N, OtherData) then begin
            Result := N;
            Exit;
          end;
        dec(O);
        dec(N);
      end;

      {do the rest of the bytes}
      for I := F-1 downto 0 do begin
        B := btByte(I)^;
        if B <> TB then begin
          {byte has bits of interest}
          O := 7;
          while (N >= 0) and (O >= ShortInt(0)) do begin
            if not (UseSetBits xor ((B and (1 shl O)) <> 0)) then
              if not Action(Self, N, OtherData) then begin
                Result := N;
                Exit;
              end;
            dec(O);
            dec(N);
          end;
        end else
          dec(N, 8);
      end;
    end;

    {Iterated all bits}
    Result := -1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

function TStBits.LastClear : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, False, nil, FMax);
end;

function TStBits.LastSet : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, False, nil, FMax);
end;

function TStBits.NextClear(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, True, nil, N+1);
end;

function TStBits.NextSet(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, True, nil, N+1);
end;

procedure TStBits.OrBits(B : TStBits);
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := P^ or B.btByte(I)^;
    end;
    btRecount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

function TStBits.PrevClear(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, False, False, nil, N-1);
end;

function TStBits.PrevSet(N : LongInt) : LongInt;
begin
  Result := IterateFrom(StopImmediately, True, False, nil, N-1);
end;

procedure TStBits.SetBit(N : LongInt);
var
  P : PByte;
  M : Byte;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
{$IFOPT R+}
    if (N < 0) or (N > FMax) then
      RaiseContainerError(stscBadIndex);
{$ENDIF}
    P := btByte(N shr 3);
    M := 1 shl (Byte(N) and 7);
    if (P^ and M) = 0 then begin
      P^ := P^ or M;
      inc(FCount);
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.SetBits;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    HugeFillChar(btBits^, btBlockSize, $FF);
    FCount := FMax+1;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.SubBits(B : TStBits);
var
  I : LongInt;
  P : PByte;
begin
{$IFDEF ThreadSafe}
  EnterClassCS;
  EnterCS;
  B.EnterCS;
  try
{$ENDIF}
    if (not Assigned(B)) or (B.Max <> FMax) then
      RaiseContainerError(stscBadType);
    for I := 0 to btBlockSize-1 do begin
      P := btByte(I);
      P^ := P^ and not B.btByte(I)^;
    end;
    btRecount;
{$IFDEF ThreadSafe}
  finally
    B.LeaveCS;
    LeaveCS;
    LeaveClassCS;
  end;
{$ENDIF}
end;

procedure TStBits.ToggleBit(N : LongInt);
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    if BitIsSet(N) then
      ClearBit(N)
    else
      SetBit(N);
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.LoadFromStream(S : TStream);
var
  Reader : TReader;
  StreamedClass : TPersistentClass;
  StreamedClassName : string;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Clear;
    Reader := TReader.Create(S, 1024);
    try
      with Reader do
        begin
          StreamedClassName := ReadString;
          StreamedClass := GetClass(StreamedClassName);
          if (StreamedClass = nil) then
            RaiseContainerErrorFmt(stscUnknownClass, [StreamedClassName]);
          if (not IsOrInheritsFrom(StreamedClass, Self.ClassType)) or
              (not IsOrInheritsFrom(TStBits, StreamedClass)) then
            RaiseContainerError(stscWrongClass);
          Max := ReadInteger;
          FCount := ReadInteger;
          Read(btBits^, btBlockSize);
        end;
    finally
      Reader.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

procedure TStBits.StoreToStream(S : TStream);
var
  Writer : TWriter;
begin
{$IFDEF ThreadSafe}
  EnterCS;
  try
{$ENDIF}
    Writer := TWriter.Create(S, 1024);
    try
      with Writer do
        begin
          WriteString(Self.ClassName);
          WriteInteger(Max);
          WriteInteger(Count);
          Write(btBits^, btBlockSize);
        end;
    finally
      Writer.Free;
    end;
{$IFDEF ThreadSafe}
  finally
    LeaveCS;
  end;
{$ENDIF}
end;

{$IFDEF ThreadSafe}
initialization
  Windows.InitializeCriticalSection(ClassCritSect);
finalization
  Windows.DeleteCriticalSection(ClassCritSect);
{$ENDIF}
end.