tebitmap.pas

这个东西的功能很强大

    procedure Clear;
    function ValueOf(const Key: Cardinal): Integer;
  end;

  { TFasterHashedStringList - A TStringList that uses TIntegerHash to improve the
    speed of Find. Based on Borland's implementation. }
  TFasterHashedStringList = class(TStringList)
  private
    FValueHash: TIntegerHash;
    FValueHashValid: Boolean;
    procedure UpdateValueHash;
  protected
    procedure Changed; override;
  public
    destructor Destroy; override;
    function IndexOfDC(const DC: Cardinal): Integer;
  end;

const
  BitmapList: TFasterHashedStringList = nil;

{ TIntegerHash }

procedure TIntegerHash.Add(const Key: Cardinal; Value: Integer);
var
  Hash: Integer;
  Bucket: PHashItem;
begin
  Hash := HashOfInteger(Key) mod Cardinal(Length(Buckets));
  New(Bucket);
  Bucket^.Key := Key;
  Bucket^.Value := Value;
  Bucket^.Next := Buckets[Hash];
  Buckets[Hash] := Bucket;
end;

procedure TIntegerHash.Clear;
var
  I: Integer;
  P, N: PHashItem;
begin
  for I := 0 to Length(Buckets) - 1 do
  begin
    P := Buckets[I];
    while P <> nil do
    begin
      N := P^.Next;
      Dispose(P);
      P := N;
    end;
    Buckets[I] := nil;
  end;
end;

constructor TIntegerHash.Create(Size: Cardinal);
begin
  inherited Create;
  SetLength(Buckets, Size);
end;

destructor TIntegerHash.Destroy;
begin
  Clear;
  inherited Destroy;
end;

function TIntegerHash.Find(const Key: Cardinal): PPHashItem;
var
  Hash: Integer;
begin
  Hash := HashOfInteger(Key) mod Cardinal(Length(Buckets));
  Result := @Buckets[Hash];
  while Result^ <> nil do
  begin
    if Result^.Key = Key then
      Exit
    else
      Result := @Result^.Next;
  end;
end;

function TIntegerHash.HashOfInteger(const Key: Cardinal): Cardinal;
type
  TBuffer = array[0..0] of Cardinal;
  PBuffer = ^TBuffer;
var
  P: PBuffer;
  h: Cardinal;
begin
  // start with a good "random" bit pattern so that
  // even single byte hashes are well scattered over
  // a 32-bit range
  Result := $9E3779B9;
  P := @Key;

  h := P[0];
  Inc(Result, ($9E3779B9 * h));

  // i.e. rotate the Result bit-pattern to the right to keep
  // early bits in the key from getting completely lost
  Result := (Result shr 15) or (Result shl 17);
end;

function TIntegerHash.ValueOf(const Key: Cardinal): Integer;
var
  P: PHashItem;
begin
  P := Find(Key)^;
  if P <> nil then
    Result := P^.Value
  else
    Result := -1;
end;

{ TFasterHashedStringList }

procedure TFasterHashedStringList.Changed;
begin
  inherited Changed;
  FValueHashValid := False;
end;

destructor TFasterHashedStringList.Destroy;
begin
  FValueHash.Free;
  inherited Destroy;
end;

function TFasterHashedStringList.IndexOfDC(const DC: Cardinal): Integer;
begin
   UpdateValueHash;
   Result := FValueHash.ValueOf(DC);
end;

function FastIntToStr(I: LongWord): string;
begin
  Str(I, result);
end;

function StrToCardinal(const S: string): Cardinal;
var
  I,L: Word;
begin
  I := 1;
  Result := 0;
  L:= Length(s);
  while I <= L do
  begin
    Result := Result * 10 + Ord(s[I]) - Ord('0');
    Inc(I);
  end;
end;

procedure TFasterHashedStringList.UpdateValueHash;
var
  I: Integer;
begin
  if FValueHashValid then Exit;

  if FValueHash = nil then
    FValueHash := TIntegerHash.Create
  else
    FValueHash.Clear;
  for I := 0 to Count - 1 do
    FValueHash.Add(StrToCardinal(Self[I]), I);
  FValueHashValid := True;
end;

{ BitmapList Routines }

procedure AddBitmapToList(B: TteBitmap);
begin
  if BitmapList = nil then
  begin
    BitmapList := TFasterHashedStringList.Create;
    {$IFDEF KS_COMPILER6_UP}
    BitmapList.CaseSensitive := true; // Faster acces
    {$ENDIF}
  end;
  BitmapList.AddObject(FastIntToStr(B.DC),B); //Search based on DC
end;

procedure RemoveBitmapFromList(B: TteBitmap);
var Index: Integer;
begin
  if BitmapList <> nil then
  begin
    Index := BitmapList.IndexOfDC(B.DC);
    if Index <> -1 then
      BitmapList.Delete(Index);
  end;
end;

function FindBitmapByDC(DC: HDC): TteBitmap;
var
  i: integer;
begin
  i:= BitmapList.IndexOfDC(DC);
  if i <> -1 then
    Result := TteBitmap(BitmapList.Objects[i])
  else
    Result := nil;
end;

procedure FreeBitmapList;
begin
  if BitmapList <> nil then FreeAndNil(BitmapList);
end;

{$ELSE }

const
  BitmapList: TList = nil;

{ BitmapList Routines }

procedure AddBitmapToList(B: TteBitmap);
begin
  if BitmapList = nil then BitmapList := TList.Create;
  BitmapList.Add(B);
end;

procedure RemoveBitmapFromList(B: TteBitmap);
begin
  if BitmapList <> nil then
    BitmapList.Remove(B);
end;

function FindBitmapByDC(DC: HDC): TteBitmap;
var
  i: integer;
begin
  for i := 0 to BitmapList.Count - 1 do
    if TteBitmap(BitmapList[i]).DC = DC then
    begin
      Result := TteBitmap(BitmapList[i]);
      Exit;
    end;
  Result := nil;
end;

procedure FreeBitmapList;
begin
  if BitmapList <> nil then FreeAndNil(BitmapList);
end;

{$ENDIF}

{ Color function }

{$IFDEF KS_CLX}
function RGB(R, G, B: byte): TColor;
begin
  Result := (B shl 16) or (G shl 8) or R;
end;
{$ENDIF}

function teColor(Color: TColor; A: Byte = $FF): TteColor;
var
  C: TColor;
  Tmp: cardinal;
begin
  C := ColorToRGB(Color);
  Tmp := A;
  Result := FromRGB(C) + (Tmp shl 24);
end;

function teColor(R, G, B: SmallInt; A: Byte = $FF): TteColor;
begin
  if R > $FF then R := $FF;
  if G > $FF then G := $FF;
  if B > $FF then B := $FF;
  if R < 0 then R := 0;
  if G < 0 then G := 0;
  if B < 0 then B := 0;

  TteColorRec(Result).R := R;
  TteColorRec(Result).G := G;
  TteColorRec(Result).B := B;
  TteColorRec(Result).A := A;
end;

function teColor(ColorRec: TteColorRec): TteColor;
begin
  Result := ToRGB(Longword(ColorRec));
end;

function teColorToColor(Color: TteColor): TColor;
begin
  Result := ToRGB(Color);
end;

function teColorToColor16(Color: TteColor): word; // 16-bit, 5-6-5
begin
  with TteColorRec(Color) do
    Result :=
      (R shr 3 shl 11) or  // R-5bit
      (G shr 2 shl 5) or   // G-6bit
      (B shr 3);           // B-5bit
end;

function teColorToColor15(Color: TteColor): word; // 15-bit, 5-5-5
begin
  with TteColorRec(Color) do
    Result :=
      (R shr 3 shl 10) or  // R-5bit
      (G shr 3 shl 5) or   // G-5bit
      (B shr 3);           // B-5bit
end;

{ Color space conversions }

function HSLtoRGB(H, S, L: Single): TteColor;
var
  M1, M2: Single;
  R, G, B: Byte;

  function HueToColor(Hue: Single): Byte;
  var
    V: Double;
  begin
    Hue := Hue - Floor(Hue);

    if 6 * Hue < 1 then V := M1 + (M2 - M1) * Hue * 6
    else if 2 * Hue < 1 then V := M2
    else if 3 * Hue < 2 then V := M1 + (M2 - M1) * (2 / 3 - Hue) * 6
    else V := M1;
    Result := Round(255 * V);
  end;
begin
  if S = 0 then
  begin
    R := Round(255 * L);
    G := R;
    B := R;
  end
  else
  begin
    if L <= 0.5 then M2 := L * (1 + S)
    else M2 := L + S - L * S;
    M1 := 2 * L - M2;
    R := HueToColor(H + 1 / 3);
    G := HueToColor(H);
    B := HueToColor(H - 1 / 3)
  end;
  Result := teColor(R, G, B);
end;

procedure RGBtoHSL(RGB: TteColor; out H, S, L: single);
var
  R, G, B, D, Cmax, Cmin: Single;
begin
  R := TteColorRec(RGB).R / 255;
  G := TteColorRec(RGB).G / 255;
  B := TteColorRec(RGB).B / 255;
  Cmax := Max(R, Max(G, B));
  Cmin := Min(R, Min(G, B));
  L := (Cmax + Cmin) / 2;

  if Cmax = Cmin then
  begin
    H := 0;
    S := 0
  end
  else
  begin
    D := Cmax - Cmin;
    if L < 0.5 then S := D / (Cmax + Cmin)
    else S := D / (2 - Cmax - Cmin);
    if R = Cmax then H := (G - B) / D
    else
      if G = Cmax then H  := 2 + (B - R) /D
      else H := 4 + (R - G) / D;
    H := H / 6;
    if H < 0 then H := H + 1
  end;
end;

function ChangeHue(Color: TteColor; DeltaHue: integer): TteColor;
var
  H, S, L: single;
  HValue: integer;
begin
  RGBtoHSL(Color, H, S, L);

  HValue := Round(H * 255);
  Inc(HValue, DeltaHue);

  if HValue > 255 then HValue := HValue - 255;
  if HValue < 0 then HValue := 255 + HValue;

  Result := HSLtoRGB(HValue / 255, S, L);
end;

function ChangeBrightness(Color: TteColor; DeltaBrightness: integer): TteColor;
var
  R, G, B: integer;
begin
  R := TteColorRec(Color).R;
  G := TteColorRec(Color).G;
  B := TteColorRec(Color).B;

  Inc(R, DeltaBrightness);
  Inc(G, DeltaBrightness);
  Inc(B, DeltaBrightness);

  Result := teColor(R, G, B);
end;

function ChangeColor(Color: TteColor; Dr, Dg, Db: smallint; Da: smallint = 0): TteColor; overload;
begin
  with TteColorRec(Color) do
    Result := teColor(R + DR, G + DG, B + DB, A + DA);
end;

function ChangeColor(Color: TteColor; Dx: smallint): TteColor; overload;
begin
  Result := ChangeColor(Color, Dx, Dx, Dx);
end;

function StdChangeColor(Color: TColor; Dr, Dg, Db: smallint; Da: smallint = 0): TColor; overload;
begin
  with TteColorRec(Color) do
    Result := teColor(R + DR, G + DG, B + DB, A + DA);
end;

function StdChangeColor(Color: TColor; Dx: smallint): TColor; overload;
begin
  Result := ChangeColor(Color, Dx, Dx, Dx);
end;

function SunkenColor(Color: TteColor; Dr, Dg, Db: smallint; Da: smallint = 0): TteColor; overload;
begin
  Result := ChangeColor(Color, -Dr, -Dg, -Db, -Da);
end;

function SunkenColor(Color: TteColor; Dx: smallint): TteColor; overload;
begin
  Result := ChangeColor(Color, -Dx);
end;

function RaisedColor(Color: TteColor; Dr, Dg, Db: smallint; Da: smallint = 0): TteColor; overload;
begin
  Result := ChangeColor(Color, Dr, Dg, Db, Da);
end;

function RaisedColor(Color: TteColor; Dx: smallint): TteColor; overload;
begin
  Result := ChangeColor(Color, Dx);
end;

{ TteBitmap ===================================================================}

constructor TteBitmap.Create;
begin
  inherited Create;
  FDC := 0;
  {$IFNDEF KS_CLX}
  with FBitmapInfo.bmiHeader do
  begin
    biSize := SizeOf(TBitmapInfoHeader);
    biPlanes := 1;
    biBitCount := 32;
    biCompression := BI_RGB;
  end;
  {$ENDIF}
end;

destructor TteBitmap.Destroy;
begin
  RemoveBitmapFromList(Self);
  {$IFNDEF KS_CLX}
  if FDC <> 0 then DeleteDC(FDC);
  FDC := 0;
  if FHandle <> 0 then DeleteObject(FHandle);
  FHandle := 0;
  FBits := nil;
  {$ELSE}
  if FPainter <> nil then QPainter_destroy(FPainter);
  FPainter := nil;