Superfast Netscape palette lookup formula

This is probably one of the fastest color lookup functions out there for converting 24/32 bit RGB values to an 8bit fixed palette (Netscape palette). I take for granted that you add stuff like your own exceptions and extract what you need from this code.

Netscape palette

Here we go (note: the exportColorObj method should be removed, it requires a different class not yet published):

TSLPaletteCustom = Class(TPersistent)
Protected
  Function  GetByteSize:Integer;virtual;
  Procedure GetItemQuad(Index:Integer;Var Data);virtual;abstract;
  Function  GetCount:Integer;virtual;abstract;
  Function  GetItem(index:Integer):TColor;virtual;abstract;
  Procedure SetItem(Index:Integer;Value:TColor);virtual;abstract;
  Function  GetReadOnly:Boolean;virtual;abstract;
Protected
  procedure AssignTo(Dest: TPersistent);Override;
Public
  Property  ReadOnly:Boolean read GetReadOnly;
  Property  Items[index:Integer]:TColor
            read GetItem write SetItem;
  Property  Count:Integer read GetCount;
  Property  Size:Integer read GetByteSize;

  Procedure ExportQuadArray(Const Target);
  Procedure ExportRGB(Const index:Integer;var R,G,B:Byte);virtual;
  function  ExportColorObj(Const index:Byte):TSLPaletteColor;

  Function  Match(r,g,b:Byte):Integer;overload;dynamic;abstract;
  Function  Match(Value:TColor):Integer;overload;dynamic;
End;

TSLPaletteNetScape = Class(TSLPaletteCustom)
Private
  FQuads:     TRGBQuadArray;
Protected
  Function    GetReadOnly:Boolean;override;
  Procedure   GetItemQuad(Index:Integer;Var Data);override;
  Function    GetCount:Integer;override;
  Function    GetItem(index:Integer):TColor;override;
  Procedure   SetItem(Index:Integer;Value:TColor);override;
Public
  Procedure   ExportRGB(Const index:Integer;var R,G,B:Byte);override;
  Function    Match(r,g,b:Byte):Integer;override;
  Constructor Create;virtual;
End;

//###########################################################################
//  TSLPaletteNetScape
//###########################################################################

Constructor TSLPaletteNetscape.Create;
var
  FIndex: Integer;
  r,g,b:  Byte;
begin
  inherited;
  for r:=0 to 5 do
  for g:=0 to 5 do
  for b:=0 to 5 do
  Begin
    FIndex:=b + g*6 + r*36;
    FQuads[FIndex].rgbRed:=r * 51;
    FQuads[FIndex].rgbGreen:=g * 51;
    FQuads[FIndex].rgbBlue:=b * 51;
  end;
end;

Procedure TSLPaletteNetScape.ExportRGB(Const index:Integer;var R,G,B:Byte);
Begin
  if (index>=0) and (index<CNT_SLPALETTE_NETSCAPE_COUNT) then
  Begin
    r:=FQuads[index].rgbRed;
    g:=FQuads[index].rgbGreen;
    b:=FQuads[index].rgbBlue;
  end else
  Raise ESLPalette.CreateFmt
  (ERR_SLPALETTE_INVALIDCOLORINDEX,[0,GetCount-1,index]);
end;

Function TSLPaletteNetScape.Match(r,g,b:Byte):Integer;
Begin
  R := (R+25) div 51;
  G := (G+25) div 51;
  B := (B+25) div 51;
  result:=(B + 6 * G + 36 * R);
end;

Function TSLPaletteNetScape.GetReadOnly:Boolean;
Begin
  result:=True;
end;

Procedure TSLPaletteNetScape.GetItemQuad(Index:Integer;Var Data);
Begin
  If (Index>=0) and (index<CNT_SLPALETTE_NETSCAPE_COUNT) then
  TRGBQuad(Data):=FQuads[index] else
  Raise ESLPalette.CreateFmt
  (ERR_SLPALETTE_INVALIDCOLORINDEX,[0,215,index]);
end;

Function TSLPaletteNetScape.GetCount:Integer;
Begin
  result:=CNT_SLPALETTE_NETSCAPE_COUNT;
end;

Function TSLPaletteNetScape.GetItem(index:Integer):TColor;
var
  FTemp:  PRGBQuad;
Begin
  If (Index>=0) and (index<CNT_SLPALETTE_NETSCAPE_COUNT) then
  Begin
    FTemp:=@FQuads[index];
    Result := (FTemp^.rgbRed
    or (FTemp^.rgbGreen shl 8 )
    or (FTemp^.rgbBlue shl 16) );
  end else
  Raise ESLPalette.CreateFmt
  (ERR_SLPALETTE_INVALIDCOLORINDEX,[0,CNT_SLPALETTE_NETSCAPE_COUNT-1,index]);
end;

Procedure TSLPaletteNetScape.SetItem(Index:Integer;Value:TColor);
Begin
  Raise ESLPalette.Create(ERR_SLPALETTE_PALETTEREADONLY);
end;

//###########################################################################
//  TSLPaletteCustom
//###########################################################################

procedure TSLPaletteCustom.AssignTo(Dest: TPersistent);
var
  x:  Integer;
Begin
  If Dest<>NIL then
  Begin
    if (dest is TSLPaletteCustom) then
    Begin
      if not TSLPaletteCustom(dest).ReadOnly then
      Begin
        for x:=1 to GetCount do
        TSLPaletteCustom(dest).Items[x-1]:=Items[x-1];
      end else
      Raise ESLPalette.Create(ERR_SLPALETTE_ASSIGNToREADONLY);
    end else
    Inherited;
  end else
  Inherited;
end;

Function TSLPaletteCustom.GetByteSize:Integer;
Begin
  result:=SizeOf(TRGBQuad) * GetCount;
end;

Procedure TSLPaletteCustom.ExportRGB(Const index:Integer;var R,G,B:Byte);
var
  FTemp:  TColor;
Begin
  if (index>=0) and (index<GetCount) then
  Begin
    FTemp:=GetItem(index);
    R:=Byte(FTemp);
    G:=Byte(FTemp shr 8);
    B:=Byte(FTemp shr 16);
  end else
  Raise ESLPalette.CreateFmt
  (ERR_SLPALETTE_INVALIDCOLORINDEX,[0,GetCount-1,index]);
end;

function TSLPaletteCustom.ExportColorObj(const index:Byte):TSLPaletteColor;
Begin
  result:=TSLPaletteColor.Create;
  result.ColorRef:=Items[index];
end;

Procedure TSLPaletteCustom.ExportQuadArray(Const Target);
var
  x:      Integer;
  FCount: Integer;
  FData:  PRGBQuadArray;
Begin
  FData:=@Target;
  If FData<>NIl then
  Begin
    FCount:=GetCount;
    for x:=1 to FCount do
    GetItemQuad(x-1,FData^[x-1]);
  end;
end;

Function TSLPaletteCustom.Match(Value:TColor):Integer;
Begin
  (* If palette reference, convert to RGB color *)
  {$IFDEF SL_USE_WINDOWS}
  If (Value shr 24)=$FF then
  Value:=GetSysColor(Value and $000000FF);
  {$ENDIF}

  (* Look it up. It's up to the implementor of the class to at least
     be able to match colors by RGB *)
  result:=Match(Byte(value),Byte(value shr 8),Byte(value shr 16));
end;

What version of windows is running?

This simple function checks the current platform and recognized the most commonly used platforms: Windows XP, Windows Vista and Windows 7. It also recognized older systems like Windows 95/98/me and NT. And it should be easy enough to expand it to recognize windows 8 as well.

Notes

There are some radical differences between Windows XP (which is my favorite platform by the way) and Windows 7. Most notoriously is the changes in security and data storage. There are operations you can do under Windows XP that you can not (or should not) do under Windows 7. The following code simplifies the task of creating code that works on all 3 platforms (and older).

Type
TJLWinOSType = (otUnknown,otWin95,otWin98,otWinME,otWinNT,otWin2000,otWinXP,otVista,otWin7);

Function JL_GetOSType(out Value:TJLWinOSType):Boolean;
var
  FInfo: TOSVersionInfoA;
begin
  (* default to unknown *)
  Value:=otUnknown;

  (* prepare version-info call *)
  fillchar(FInfo,SizeOf(FInfo),#0);
  FInfo.dwOSVersionInfoSize:=sizeof(FInfo);

  (* Call OS to get info *)
  result:=GetVersionExA(FInfo);
  If result then
  Begin
    Case FInfo.dwPlatformId of
    VER_PLATFORM_WIN32_NT:
      Begin
        if FInfo.dwMajorVersion <= 4 then
        Value:=otWinNT else

        if (FInfo.dwMajorVersion = 5)
        and (FInfo.dwMinorVersion = 0) then
        Value:=otWin2000 else

        if (FInfo.dwMajorVersion = 5)
        and (FInfo.dwMinorVersion = 1) then
        Value:=otWinXP else

        if (FInfo.dwMajorVersion = 6)
        and (FInfo.dwMinorVersion=0) then
        Value:=otVista;
      end;
    VER_PLATFORM_WIN32_WINDOWS:
      Begin
       if (FInfo.dwMajorVersion = 4)
       and (FInfo.dwMinorVersion = 0) then
       Value:=otWin95 else

       if (FInfo.dwMajorVersion = 4)
       and (FInfo.dwMinorVersion = 10) then
       Value:=otWin98 else

       if (FInfo.dwMajorVersion = 4)
       and (FInfo.dwMinorVersion = 90) then
       Value:=otWinME;
      end;
    end;
  End;
End;

Proportional thumbnails

This is a routine I have used a lot in different graphics applications. It was designed to scale down DIBS quickly to thumbnail and preview which was later pushed to a database. But I have also used it in my thumbnail browser and in a few image viewers and a graphics library I wrote. Tried and tested by time.

Notes

It attempts to center the resulting rectangle within the bounds of “newwidth / newheight”.

Function  JLReScale(aWidth,aHeight:Integer;
          NewWidth,NewHeight:Integer;
          var outRect:TRect):Boolean;
var
  x,y:    Integer;
  x1,y1:  Real;
  wd,hd:  Integer;
Begin
  result:=False;
  if (aWidth>1) and (aHeight>1) then
  Begin
    If (NewWidth>1) and (NewHeight>1) then
    Begin
      x1:=(NewWidth/aWidth);
      y1:=(NewHeight/aHeight);
      if x1 > y1 then
      begin
        outRect.top:=0;
        outRect.bottom:=NewHeight;
        x:=trunc(aWidth*y1);
        outRect.left:=(NewWidth-x) shr 1;
        outRect.right:=outRect.left+x;
      end else
      begin
        outRect.left:=0;
        outRect.right:=NewWidth;
        y:=trunc(aHeight*x1);
        outRect.top:=(NewHeight-y) shr 1;
        outRect.bottom:=outRect.top+y;
      end;
      result:=True;
    end;
  end;
end;

RLE compression made simple

This is my implementation of the good old RLE compression methods. I originally found some code for this in an old SWAG PDF and decided to extract and salvage what I could – so I cannot take full credit for these procedures, although almost every aspect of the code has been modernized. I also extended the prefetch to include byte, word, triplets and longwords (it was bytes only in the original code).

Notes

Added support for different data sizes. While the original code only supported bytes (ansi characters), this code can now compress datatypes ut to 4 bytes per sample. It works great on things such as Bitmap masks and 8bit bitmaps that include a lot of transparent or single color pixels.

uses math;

type
PJLTriple =^TJLTriple;
TJLTriple = Packed Record
  a,b,c:Byte;
End;

//#########################################################################
//  Method:     JL_RLEDeCompress()
//  Purpose:    De-Compress memory segment using the Run Length scheme
//  Returns:    Length of de-compressed data
//
//  Parameters:
//              Source:     PTR to input data
//              Target:     PTR to output data
//              TargetSize: Length of target buffer
//              Fetch:      Bytes per element
//
//  Comments:   See JL_RLECompress() for more info
//  Warning:    See JL_RLECompress() for more info
//#########################################################################
function  JL_RLEDecompress(const Source,Target;
          TargetSize:Longword;Fetch:Byte):Longword;
var
  I: Integer;
  SourcePtr,
  TargetPtr:  PByte;
  RunLength:  Longword;
  Counter:    Longword;

begin
  Result := 0;
  Counter := 0;
  TargetPtr := @Target;
  SourcePtr := @Source;

  While Counter<TargetSize do
  Begin
    RunLength := 1 + (SourcePtr^ and $7F);
    if SourcePtr^ > $7F then
    begin
      (* decode RLE packed byte *)
      Inc(SourcePtr);
      for I := 0 to RunLength - 1 do
      begin
        Case Fetch of
        1:  TargetPtr^:=SourcePtr^;
        2:  PWord(TargetPtr)^:=PWord(SourcePtr)^;
        3:  PJLTriple(TargetPtr)^:=PJLTriple(SourcePtr)^;
        4:  PLongword(TargetPtr)^:=PLongword(SourcePTR)^;
        end;
        Inc(TargetPtr,Fetch);
      end;
      Inc(SourcePtr, Fetch);
      Inc(Result, Fetch + 1);
    end else
    begin
      (* decode NON-RLE packet *)
      Inc(SourcePtr);
      Move(SourcePtr^,targetptr^,RunLength);
      inc(targetptr,RunLength);
      inc(sourceptr,RunLength);
      Inc(Result, RunLength + 1)
    end;
    Inc(Counter, RunLength);
  end;
end;

//#########################################################################
//  Method:     JLRLECompress()
//  Purpose:    Compress memory segment using the Run Length scheme
//  Returns:    Length of compressed data
//
//  Parameters:
//              Source: PTR to input data
//              Target: PTR to output data
//              Size:   Length of input data
//              Fetch:  Bytes per element (see comments below)
//
//  Comments:   RLE "compress" data by finding sequences of data
//              that contains the same value. The collection of sequences
//              is called a dictionary.
//              In order to build such a dictionary, the compressor needs
//              to know the size of each element being compressed.
//              With images, this is typically 1..4 bytes, depenting on
//              the pixel format (8bit=1, 15|16bit=2, 24Bit=3, 32Bit=4)
//              repeated sequences of information, such as bitmaps and
//  Warning:
//              RLE is not suitable for all types of data. In some cases
//              the output will be larger than input!
//              AS A RULE, Calculate the size of the output
//              buffer as: (input size*2 + 1)
//#########################################################################

function  JL_RLECompress(const Source,Target;
          SourceSize:Longword;Fetch:Byte):Longword;
var
  DiffCount:  Integer;
  SameCount:  Integer;
  SourcePtr:  PByte;
  TargetPtr:  PByte;

  Procedure GetElement(Const src;var outValue);
  begin
    Case Fetch of
    1:  PByte(@outValue)^:=PByte(@src)^;
    2:  PWord(@outValue)^:=PWord(@src)^;
    3:  PJLTriple(@outValue)^:=PJLTriple(@src)^;
    4:  PLongword(@outValue)^:=PLongword(@src)^;
    end;
  end;

  function CountUniqueElements(P:PByte;Count:Integer):Integer;
  var
    N:            Integer;
    Element:      Longword;
    NextElement:  Longword;
  begin
      N:=0;
      Element:=0;
      NextElement:=0;
    If Count=1 then
    result:=Count else
    Begin
      GetElement(P^,Element);
      while Count>1 do
      begin
        Inc(P,Fetch);
        GetElement(P^,NextElement);
        If NextElement=Element then
        Break;
        Element:=NextElement;
        inc(N);
        Dec(Count);
      end;
      if NextElement=Element then
      result:=N else
      result:=N + 1;
    end;
  end;

  function CountEqualElements(P:PByte;Count:Integer):Integer;
  var
    Element,
    NextElement: Cardinal;
  begin
    Result:=1;
    Element:=0;
    NextElement:=0;
    GetElement(P^,Element);
    Dec(Count);
    while Count>0 do
    begin
      Inc(P, Fetch);
      GetElement(P^,NextElement);
      if NextElement<>Element then
      Break;
      Inc(Result);
      Dec(Count);
    end;
  end;

begin
  Result:=0;
  SourcePtr := @Source;
  TargetPtr := @Target;
  while SourceSize > 0 do
  begin
    DiffCount := CountUniqueElements(SourcePtr,SourceSize);
    DiffCount:=math.EnsureRange(DiffCount,0,128);
    if DiffCount > 0 then
    begin
      (* create a raw, unaltered packet *)
      TargetPtr^:=DiffCount-1;
      Inc(TargetPtr);
      Dec(SourceSize, DiffCount);
      Move(targetPTR^,sourcePTR^,DiffCount);
      inc(SourcePtr,DiffCount);
      inc(TargetPTR,DiffCount);
      Inc(Result, (DiffCount * Fetch) + 1);
    end;

    SameCount := CountEqualElements(SourcePtr,SourceSize);
    SameCount:=math.EnsureRange(SameCount,0,128);
    if SameCount > 1 then
    begin
      (* create a RLE packet *)
      TargetPtr^ := (SameCount - 1) or $80; Inc(TargetPtr);
      Dec(SourceSize, SameCount);
      Inc(SourcePtr, (SameCount - 1) * Fetch);
      Inc(Result, Fetch + 1);

      TargetPtr^ := SourcePtr^;
      Inc(SourcePtr);
      Inc(TargetPtr);

      (* NOTE: We have already moved one byte, see above *)
      Case (Fetch-1) of
      1:  PByte(TargetPtr)^:=PByte(SourcePtr)^;
      2:  PWord(TargetPtr)^:=PWord(SourcePtr)^;
      3:  PJLTriple(TargetPtr)^:=PJLTriple(SourcePtr)^;
      end;

      inc(SourcePtr,Fetch-1);
      inc(TargetPTR,Fetch-1);
    end;
  end;
end;

Are we connected to the internet?

I have found at least 10 different solutions for this, but to date this is the only version that actually does the job correctly. Checking and verifying that your application has access to the Internet is not as straight forward as it may seem. The current connection can be registered in Windows as active when it’s really not. You may be connected to your router but the IP is invalid (cable from router unplugged) or the gateway may refuse your winsock dispatcher access (forgot to pay your bill?). The following code checks all 3 scenarios and makes absolutely sure you have access.

Note

If you want to simulate network detection (so your app is network aware), place the verification call inside a timer, and activate the timer whenever you get service/socket level exceptions from Indy.

uses WinInet, winsock;

  (* Dont call this one, it's used by the proc below! *)
  Function JL_VerifyIPAddr:Boolean;
  type
    TaPInAddr = Array[0..10] of PInAddr;
    PaPInAddr = ^TaPInAddr;
  var
    phe:        PHostEnt;
    pptr:       PaPInAddr;
    Buffer:     Array[0..63] of Char;
    I:          Integer;
    GInitData:  TWSAData;
    IP:         AnsiString;
    FInit:      Boolean;
  Begin
    (* Default to false *)
    Result := False;

    (* Initialize Windows sockets. The reason we
       dont explicitly act on the results is because WSA
       is "per process". In other words, indy might have
       initialized WSA already. *)
    FInit:=WSAStartup($101, GInitData)=0;
    try
      (* Get the local hostname *)
      if GetHostName(Buffer, SizeOf(Buffer))=0 then
      Begin
        (* Get host structure by name *)
        phe := GetHostByName(buffer);
        if phe<>NIL then
        Begin
          (* Get a PTR to adress list *)
          pPtr := PaPInAddr(phe^.h_addr_list);
          if pPtr<>NIL then
          Begin
            (* Build IP from list *)
            I := 0;
            while pPtr^[I] <> nil do
            begin
              IP := inet_ntoa(pptr^[I]^);
              Inc(I);
            end;

            (* Check IP *)
            Result := (IP <> '')
            and (IP <> '127.0.0.1');
          end;
        end;
      end;
    finally
      If FInit then
      WSACleanup;
    end;
  end;

  function JL_VerifyInternetConnection: boolean;
  const
    FLAG_ICC_FORCE_CONNECTION      = 1;
    INTERNET_CONNECTION_OFFLINE    = 32;
  var
    dwConnectionTypes : DWORD;
  begin
    (* default to negative *)
    result:=False;

    (* check what windows in general is saying. This is the correct
    way to call this API method. The typical examples elsewhere screw this up.
    See: http://msdn.microsoft.com/en-us/library/aa384702%28VS.85%29.aspx *)
    dwConnectionTypes:=0;
    InternetGetConnectedState(@dwConnectionTypes,0);
    If (dwConnectionTypes and INTERNET_CONNECTION_OFFLINE)
    =INTERNET_CONNECTION_OFFLINE then
    exit;

    (* check that we actually have an IP adresse *)
    If JL_VerifyIPAddr=false then
    exit;

    (* try to ping an URL that we know exists *)
    result:=InternetCheckConnection('http://www.microsoft.com',
    FLAG_ICC_FORCE_CONNECTION,0);
end;