(*
  Name:             HTMLColors
  Copyright:        Copyright (C) 2003-2017 SIL International.
  Documentation:    
  Description:      
  Create Date:      8 Jun 2012

  Modified Date:    8 Jun 2012
  Authors:          mcdurdin
  Related Files:    
  Dependencies:     

  Bugs:             
  Todo:             
  Notes:            
  History:          08 Jun 2012 - mcdurdin - I3310 - V9.0 - Unicode in Delphi fixes
*)
unit HTMLColors;

interface

{$I mxs.inc}

uses
 SysUtils, Windows, Graphics{$IFDEF DELPHI_6_UP}, Variants{$ENDIF};

const
 SPECIAL_COUNT = 140;
 WEBSAFE_COUNT = 216;
 SYSTEM_COUNT = 28;
 BASIC_COUNT = 16;
 SPECIAL_HEX: array [0..139] of string = ('000000', 'FAEBD7', '00FFFF', '7FFFD4', 'F0FFFF', 'F5F5DC', 'FFE4C4',
                'F0F8FF', 'FFEBCD', '0000FF', '8A2BE2', 'A52A2A', 'DEB887', '5F9EA0',
                '7FFF00', 'D2691E', 'FF7F50', '6495ED', 'FFF8DC', 'DC143C', '00FFFF',
                '00008B', '008B8B', 'B8860B', 'A9A9A9', '006400', 'BDB76B', '8B008B',
                '556B2F', 'FF8C00', '9932CC', '8B0000', 'E9967A', '8FBC8B', '483D8B',
                '2F4F4F', '00CED1', '9400D3', 'FF1493', '00BFFF', '696969', '1E90FF',
                'B22222', 'FFFAF0', '228B22', 'FF00FF', 'DCDCDC', 'F8F8FF', 'FFD700',
                'DAA520', '808080', '008000', 'ADFF2F', 'F0FFF0', 'FF69B4', 'CD5C5C',
                '4B0082', 'FFFFF0', 'F0E68C', 'E6E6FA', 'FFF0F5', '7CFC00', 'FFFACD',
                'ADD8E6', 'F08080', 'E0FFFF', 'FAFAD2', '90EE90', 'D3D3D3', 'FFB6C1',
                'FFA07A', '20B2AA', '87CEFA', '778899', 'B0C4DE', 'FFFFE0', '00FF00',
                '32CD32', 'FAF0E6', 'FF00FF', '800000', '66CDAA', '0000CD', 'BA55D3',
                '9370DB', '3CB371', '7B68EE', '00FA9A', '48D1CC', 'C71585', '191970',
                'F5FFFA', 'FFE4E1', 'FFE4B5', 'FFDEAD', '000080', 'FDF5E6', '808000',
                '6B8E23', 'FFA500', 'FF4500', 'DA70D6', 'EEE8AA', '98FB98', 'AFEEEE',
                'DB7093', 'FFEFD5', 'FFDAB9', 'CD853F', 'FFC0CB', 'DDA0DD', 'B0E0E6',
                '800080', 'FF0000', 'BC8F8F', '4169E1', '8B4513', 'FA8072', 'F4A460',
                '2E8B57', 'FFF5EE', 'A0522D', 'C0C0C0', '87CEEB', '6A5ACD', '708090',
                'FFFAFA', '00FF7F', '4682B4', 'D2B48C', '008080', 'D8BFD8', 'FF6347',
                '40E0D0', 'EE82EE', 'F5DEB3', 'FFFFFF', 'F5F5F5', 'FFFF00', '9ACD32');
 SPECIAL_NAMES: array [0..139] of string = ('black', 'antiquewhite', 'aqua', 'aquamarine', 'azure', 'beige',
                'bisque', 'aliceblue', 'blanchedalmond', 'blue', 'blueviolet', 'brown',
                'burlywood', 'cadetblue', 'chartreuse', 'chocolate', 'coral',
                'cornflower', 'cornsilk', 'crimson', 'cyan', 'darkblue', 'darkcyan',
                'darkgoldenrod', 'darkgray', 'darkgreen', 'darkkhaki', 'darkmagenta',
                'darkolivegreen', 'darkorange', 'darkorchid', 'darkred', 'darksalmon',
                'darkseagreen', 'darkslateblue', 'darkslategray', 'darkturquoise',
                'darkviolet', 'deeppink', 'deepskyblue', 'dimgray', 'dodgerblue',
                'firebrick', 'floralwhite', 'forestgreen', 'fuchsia', 'gainsboro',
                'ghostwhite', 'gold', 'goldenrod', 'gray', 'green', 'greenyellow',
                'honeydew', 'hotpink', 'indianred', 'indigo', 'ivory', 'khaki', 'lavender',
                'lavenderblush', 'lawngreen', 'lemonchiffon', 'lightblue', 'lightcoral',
                'lightcyan', 'lightgoldenrodyellow', 'lightgreen', 'lightgray', 'lightpink',
                'lightsalmon', 'lightseagreen', 'lightskyblue', 'lightslategray',
                'lightsteelblue', 'lightyellow', 'lime', 'limegreen', 'linen', 'magenta',
                'maroon', 'mediumaquamarine', 'mediumblue', 'mediumorchid', 'mediumpurple',
                'mediumseagreen', 'mediumslateblue', 'mediumspringgreen', 'mediumturquoise',
                'mediumvioletred', 'midnightblue', 'mintcream', 'mistyrose', 'moccasin',
                'navajowhite', 'navy', 'oldlace', 'olive', 'olivedrab', 'orange', 'orangered',
                'orchid', 'palegoldenrod', 'palegreen', 'paleturquoise', 'palevioletred',
                'papayawhip', 'peachpuff', 'peru', 'pink', 'plum', 'powderblue', 'purple',
                'red', 'rosybrown', 'royalblue', 'saddlebrown', 'salmon', 'sandybrown',
                'seagreen', 'seashell', 'sienna', 'silver', 'skyblue', 'slateblue',
                'slategray', 'snow', 'springgreen', 'steelblue', 'tan', 'teal', 'thistle',
                'tomato', 'turquoise', 'violet', 'wheat', 'white', 'whitesmoke', 'yellow',
                'yellowgreen');
 WEBSAFE_HEX: array [0..215] of string = ('000000' ,'000033' ,'000066' ,'000099' ,'0000cc' ,'0000ff',
                '003300' ,'003333' ,'003366' ,'003399' ,'0033cc' ,'0033ff',
                '006600' ,'006633' ,'006666' ,'006699' ,'0066cc' ,'0066ff',
                '009900' ,'009933' ,'009966' ,'009999' ,'0099cc' ,'0099ff',
                '00cc00' ,'00cc33' ,'00cc66' ,'00cc99' ,'00cccc' ,'00ccff',
                '00ff00' ,'00ff33' ,'00ff66' ,'00ff99' ,'00ffcc' ,'00ffff',
                '330000' ,'330033' ,'330066' ,'330099' ,'3300cc' ,'3300ff',
                '333300' ,'333333' ,'333366' ,'333399' ,'3333cc' ,'3333ff',
                '336600' ,'336633' ,'336666' ,'336699' ,'3366cc' ,'3366ff',
                '339900' ,'339933' ,'339966' ,'339999' ,'3399cc' ,'3399ff',
                '33cc00' ,'33cc33' ,'33cc66' ,'33cc99' ,'33cccc' ,'33ccff',
                '33ff00' ,'33ff33' ,'33ff66' ,'33ff99' ,'33ffcc' ,'33ffff',
                '660000' ,'660033' ,'660066' ,'660099' ,'6600cc' ,'6600ff',
                '663300' ,'663333' ,'663366' ,'663399' ,'6633cc' ,'6633ff',
                '666600' ,'666633' ,'666666' ,'666699' ,'6666cc' ,'6666ff',
                '669900' ,'669933' ,'669966' ,'669999' ,'6699cc' ,'6699ff',
                '66cc00' ,'66cc33' ,'66cc66' ,'66cc99' ,'66cccc' ,'66ccff',
                '66ff00' ,'66ff33' ,'66ff66' ,'66ff99' ,'66ffcc' ,'66ffff',
                '990000' ,'990033' ,'990066' ,'990099' ,'9900cc' ,'9900ff',
                '993300' ,'993333' ,'993366' ,'993399' ,'9933cc' ,'9933ff',
                '996600' ,'996633' ,'996666' ,'996699' ,'9966cc' ,'9966ff',
                '999900' ,'999933' ,'999966' ,'999999' ,'9999cc' ,'9999ff',
                '99cc00' ,'99cc33' ,'99cc66' ,'99cc99' ,'99cccc' ,'99ccff',
                '99ff00' ,'99ff33' ,'99ff66' ,'99ff99' ,'99ffcc' ,'99ffff',
                'cc0000' ,'cc0033' ,'cc0066' ,'cc0099' ,'cc00cc' ,'cc00ff',
                'cc3300' ,'cc3333' ,'cc3366' ,'cc3399' ,'cc33cc' ,'cc33ff',
                'cc6600' ,'cc6633' ,'cc6666' ,'cc6699' ,'cc66cc' ,'cc66ff',
                'cc9900' ,'cc9933' ,'cc9966' ,'cc9999' ,'cc99cc' ,'cc99ff',
                'cccc00' ,'cccc33' ,'cccc66' ,'cccc99' ,'cccccc' ,'ccccff',
                'ccff00' ,'ccff33' ,'CCFF66' ,'ccff99' ,'ccffcc' ,'ccffff',
                'ff0000' ,'ff0033' ,'ff0066' ,'ff0099' ,'ff00cc' ,'ff00ff',
                'ff3300' ,'ff3333' ,'ff3366' ,'ff3399' ,'ff33cc' ,'ff33ff',
                'ff6600' ,'ff6633' ,'ff6666' ,'ff6699' ,'ff66cc' ,'ff66ff',
                'ff9900' ,'ff9933' ,'ff9966' ,'ff9999' ,'ff99cc' ,'ff99ff',
                'ffcc00' ,'ffcc33' ,'ffcc66' ,'ffcc99' ,'ffcccc' ,'ffccff',
                'ffff00' ,'ffff33' ,'ffff66' ,'ffff99' ,'ffffcc' ,'ffffff');
 SYSTEM_VALUES: array [0..27] of TColor = (clActiveBorder, clActiveCaption, clAppWorkspace, clBackground,
                clBtnFace, clBtnHighlight, clBtnShadow, clBtnText, clCaptionText,
                clGrayText, clHighlight, clHighlightText, clInactiveBorder,
                clInactiveCaption, clInactiveCaptionText, clInfoBk, clInfoText,
                clMenu, clMenuText, clScrollbar, cl3dDkShadow, cl3dLight,
                clBtnHighlight, clActiveBorder, clBtnShadow, clWindow,
                clWindowFrame, clWindowText);
 SYSTEM_NAMES: array [0..27] of string = ('activeborder', 'activecaption', 'appworkspace', 'background',
                'buttonface', 'buttonhighlight', 'buttonshadow', 'buttontext',
                'captiontext', 'graytext', 'highlight', 'highlighttext',
                'inactiveborder', 'inactivecaption', 'inactivecaptiontext',
                'infobackground', 'infotext', 'menu', 'menutext', 'scrollbar',
                'threeddarkshadow', 'threedface', 'threedhighlight',
                'threedlightshadow', 'threedshadow', 'window', 'windowframe',
                'windowtext');
 BASIC_VALUES: array [0..15] of TColor = (clBlack, clAqua, clBlue, clFuchsia, clGray, clGreen, clLime,
                clMaroon, clNavy, clOlive, clPurple, clRed, clSilver, clTeal,
                clWhite, clYellow);
 BASIC_NAMES: array [0..15] of string = ('black', 'aqua', 'blue', 'fuchsia', 'gray', 'green', 'lime',
               'maroon', 'navy', 'olive', 'purple', 'red', 'silver', 'teal',
               'white', 'yellow');

procedure MakeIntoHex(var s: string);
function IsMember(a: array of string; n: integer; s: string): boolean;
function IsSpecialColor(s: string): boolean;
function FormatHexColor(S: string): string;
function ColorToHex(Color: TColor): string;
function HexToTColor(s: OleVariant): TColor;
function GetHexFromName(s: string): string;
function GetValueFromName(s: string): TColor;
function IsWebSafe(s: string): boolean; overload;
function IsWebSafe(c: TColor): boolean; overload;
function GetWebSafe(C: TColor): TColor;

implementation

var
 WS: array [0..255] of byte;

//------------------------------------------------------------------------------

//checks membership of a string array
function IsMember(a: array of string; n: integer; s: string): boolean;
var
 i: integer;
begin
 Result := false;
 for i := 0 to n - 1 do
  if SameText(s, a[i]) then
   Result := true;
end;

//------------------------------------------------------------------------------

//checks if the color's nam was used instead of hex
function IsSpecialColor(s: string): boolean;
begin
 Result := IsMember(BASIC_NAMES, BASIC_COUNT, s) or IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) or IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s);
end;

//------------------------------------------------------------------------------

//is hex was used then remove the wrong characters
procedure MakeIntoHex(var s: string);
var
 i: integer;
begin
if s <> '' then
 for i := 1 to Length(s) do
  if not CharInSet(s[i], ['0'..'9', 'A'..'F', 'a'..'f']) then  // I3310
   s[i] := '0';
end;

//------------------------------------------------------------------------------

//formats entered text into a true hex value
function FormatHexColor(S: string): string;
var
 c: string;
 i: integer;
begin
 c := '';
 if not IsSpecialColor(s) then
  begin
   if (s <> '') and (s[1] = '#') then
    Delete(s, 1, 1);

   if s <> '' then
    begin
     MakeIntoHex(c);
     if Length(c) = 6 then
      Result := c
     else
      begin
       if Length(c) > 6 then
        c := Copy(c, 1, 6);
       if Length(c) < 6 then
        for i := 0 to 6 - Length(c) - 1 do
          c := '0' + c;
       Result := c;
      end;
    end
   else
    Result := '000000';
  end
 else
  Result := s;
end;

//------------------------------------------------------------------------------

//gets a hex value from a color name from special colors
function GetHexFromName(s: string): string;
var
 i, k: integer;
begin
 k := 0;
 for i := 0 to SPECIAL_COUNT - 1 do
  if SameText(s, SPECIAL_NAMES[i]) then
   begin
    k := i;
    Break;
   end;
 Result := SPECIAL_HEX[k];
end;

//------------------------------------------------------------------------------

// gets a TColor value from a color name from basic or system colors
function GetValueFromName(s: string): TColor;
var
 i, k: integer;
begin
 k := 0;
 s := LowerCase(s);
 if IsMember(BASIC_NAMES, BASIC_COUNT, s) then
  begin
   for i := 0 to BASIC_COUNT - 1 do
    if SameText(s, BASIC_NAMES[i]) then
     begin
      k := i;
      Break;
     end;
   Result := BASIC_VALUES[k];
  end
 else
  if IsMember(SYSTEM_NAMES, SYSTEM_COUNT, s) then
   begin
    for i := 0 to SYSTEM_COUNT - 1 do
     if SameText(s, SYSTEM_NAMES[i]) then
      begin
       k := i;
       Break;
      end;
    Result := SYSTEM_VALUES[k];
   end
  else
   Result := clNone;
end;

//------------------------------------------------------------------------------

//converts a TColor value to a hex value
function ColorToHex(Color: TColor): string;
begin
 if Color <> $ then
  Result := IntToHex(GetRValue(Color), 2) + IntToHex(GetGValue(Color), 2) + IntToHex(GetBValue(Color), 2)
 else
  Result := '000000';
end;

//------------------------------------------------------------------------------

//converts a hex value to a TColor
function HexToTColor(s: OleVariant): TColor;
begin
 if s <> null then
  begin
   if not IsSpecialColor(s) then
    begin
     s := FormatHexColor(s);
     if s <> '' then
      Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)))
     else
      Result := clNone;
    end
   else
    if IsMember(SPECIAL_NAMES, SPECIAL_COUNT, s) then
     begin
      s := GetHexFromName(s);
      Result := RGB(StrToInt('$'+Copy(S, 1, 2)), StrToInt('$'+Copy(S, 3, 2)), StrToInt('$'+Copy(S, 5, 2)));
     end
    else
     Result := GetValueFromName(s);
  end
 else
  Result := clNone;
end;

//------------------------------------------------------------------------------

//checks if a hex value belongs to the websafe palette
function IsWebSafe(s: string): boolean;
begin
 s := FormatHexColor(s);
 Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end;

//------------------------------------------------------------------------------

//checks if a color belongs to the websafe palette
function IsWebSafe(c: TColor): boolean;
var
 s: string;
begin
 s  := ColorToHex(c);
 Result := IsMember(WEBSAFE_HEX, WEBSAFE_COUNT, s);
end;

//------------------------------------------------------------------------------

//initializes the websafe comparison array
procedure InitializeWS;
 var
   i: integer;
 begin
  for i := 0 to 255 do
   WS[I] := ((i + $19) div $33) * $33;
 end;

//------------------------------------------------------------------------------

//returns the closest web safe color to the one given
function GetWebSafe(C: TColor): TColor;
begin
 Result := RGB(WS[GetRValue(C)], WS[GetGValue(C)], WS[GetBValue(C)]);
end;

//------------------------------------------------------------------------------

initialization
 InitializeWS;

end.
