moparisthebest/Simba
1
0
Fork 0
mirror of https://github.com/moparisthebest/Simba synced 2025-02-16 07:10:10 -05:00
Code Issues Releases Wiki Activity

Added several bitmap functions (Contrast, Brightness, Invert, Desaturate)

Browse Source 
git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@133 3f818213-9676-44b0-a9b4-5e4c4e03d09d
This commit is contained in:
Raymond 2009-10-17 14:14:47 +00:00
parent 4a65a1ffb1
commit 030aac3748
4 changed files with 548 additions and 265 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
Units/MMLAddon/PSInc/Wrappers/bitmap.inc
View File

@ -186,3 +186,44 @@ begin;
Bmp[Bitmap].RotateBitmap(angle,Bmp[result]); Bmp[Bitmap].RotateBitmap(angle,Bmp[result]);
end; end;
end; end;
function Desaturate(Bitmap : integer) : integer;
begin;
with CurrThread.Client.MBitmaps do
begin;
result := CreateBMP(0,0);
Bmp[Bitmap].Desaturate(Bmp[result]);
end;
end;
procedure InvertBitmap(Bitmap : integer);
begin;
CurrThread.Client.MBitmaps.Bmp[Bitmap].Invert;
end;
function CopyBitmap(Bitmap : integer) : integer;
begin;
result := Currthread.Client.MBitmaps.CopyBMP(bitmap);
end;
function GreyScaleBitmap(Bitmap : integer) : integer;
begin;
with CurrThread.Client.MBitmaps do
begin;
result := CreateBMP(0,0);
Bmp[Bitmap].GreyScale(Bmp[result]);
end;
end;
function BrightnessBitmap(Bitmap,br : integer) : integer;
begin;
with CurrThread.Client.MBitmaps do
begin;
result := CreateBMP(0,0);
Bmp[Bitmap].Brightness(Bmp[result],br);
end;
end;
function ContrastBitmap(bitmap : integer; co : extended) : integer;
begin;
with CurrThread.Client.MBitmaps do
begin;
result := CreateBMP(0,0);
Bmp[Bitmap].Contrast(Bmp[result],co);
end;
end;

6
Units/MMLAddon/PSInc/pscompile.inc
View File

@ -106,4 +106,10 @@ Sender.AddFunction(@FindBitmapSpiral,'function FindBitmapSpiral(bitmap: Integer;
Sender.AddFunction(@FindBitmapsSpiralTolerance,'function FindBitmapsSpiralTolerance(bitmap: integer; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean;'); Sender.AddFunction(@FindBitmapsSpiralTolerance,'function FindBitmapsSpiralTolerance(bitmap: integer; x, y: Integer; var Points : TPointArray; xs, ys, xe, ye,tolerance: Integer): Boolean;');
Sender.AddFunction(@FindBitmapSpiralTolerance,'function FindBitmapSpiralTolerance(bitmap: integer; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean;'); Sender.AddFunction(@FindBitmapSpiralTolerance,'function FindBitmapSpiralTolerance(bitmap: integer; var x, y: Integer; xs, ys, xe, ye,tolerance : integer): Boolean;');
Sender.AddFunction(@RotateBitmap,'function RotateBitmap(bitmap: Integer; angle: Extended): Integer;'); Sender.AddFunction(@RotateBitmap,'function RotateBitmap(bitmap: Integer; angle: Extended): Integer;');
Sender.AddFunction(@Desaturate,'function DesaturateBitmap(Bitmap : integer) : integer;');
sender.AddFunction(@InvertBitmap,'procedure InvertBitmap(Bitmap : integer);');
Sender.AddFunction(@CopyBitmap,'function CopyBitmap(Bitmap: integer) : integer)');
Sender.AddFunction(@GreyScaleBitmap,'function GreyScaleBitmap(bitmap : integer) : integer');
Sender.AddFunction(@BrightnessBitmap,'function BrightnessBitmap(Bitmap,br : integer) : integer;');
Sender.AddFunction(@ContrastBitmap,'function ContrastBitmap(bitmap : integer; co : extended) : integer;');

202
Units/MMLCore/bitmaps.pas
View File

@ -60,6 +60,15 @@ type
procedure FastReplaceColor(OldColor, NewColor: TColor); procedure FastReplaceColor(OldColor, NewColor: TColor);
procedure CopyClientToBitmap(MWindow : TMWindow; xs, ys, xe, ye: Integer); procedure CopyClientToBitmap(MWindow : TMWindow; xs, ys, xe, ye: Integer);
procedure RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap ); procedure RotateBitmap(angle: Extended;TargetBitmap : TMufasaBitmap );
procedure Desaturate;overload;
procedure Desaturate(TargetBitmap : TMufasaBitmap); overload;
procedure GreyScale(TargetBitmap : TMufasaBitmap);overload;
procedure GreyScale;
procedure Brightness(br: integer);overload;
procedure Brightness(TargetBitmap : TMufasaBitmap; br : integer); overload;
procedure Contrast(co: Extended);overload;
procedure Contrast(TargetBitmap : TMufasaBitmap; co : Extended);overload;
procedure Invert;
constructor Create; constructor Create;
destructor Destroy;override; destructor Destroy;override;
end; end;
@ -76,6 +85,7 @@ type
function GetBMP(Index : integer) : TMufasaBitmap; function GetBMP(Index : integer) : TMufasaBitmap;
property Bmp[Index : integer]: TMufasaBitmap read GetBMP; property Bmp[Index : integer]: TMufasaBitmap read GetBMP;
function CreateBMP(w, h: integer): Integer; function CreateBMP(w, h: integer): Integer;
function CopyBMP( Bitmap : integer) : Integer;
function CreateMirroredBitmap(bitmap: Integer; MirrorStyle : TBmpMirrorStyle): Integer; function CreateMirroredBitmap(bitmap: Integer; MirrorStyle : TBmpMirrorStyle): Integer;
function CreateBMPFromFile(const Path : string) : integer; function CreateBMPFromFile(const Path : string) : integer;
function CreateBMPFromString(width,height : integer; Data : string) : integer;overload; function CreateBMPFromString(width,height : integer; Data : string) : integer;overload;
@ -89,7 +99,8 @@ type
implementation implementation
uses uses
Windowutil,paszlib,DCPbase64,mmath,math; Windowutil,paszlib,DCPbase64,mmath,math,
colour_conv;
function Min(a,b:integer) : integer; function Min(a,b:integer) : integer;
begin begin
@ -134,6 +145,17 @@ begin
BmpArray[Result].Index:= Result; BmpArray[Result].Index:= Result;
end; end;
function TMBitmaps.CopyBMP(Bitmap: integer): Integer;
var
InputBMP : TMufasaBitmap;
OutputBMP : TMUfasaBitmap;
begin
InputBMP := GetBMP(Bitmap);
Result := CreateBMP(InputBmp.w,InputBMP.h);
OutputBMP := GetBMP(Result);
Move(InputBMP.FData[0],OutPutBMP.FData[0],InputBMP.w * InputBMP.h * SizeOf(TRGB32));
end;
function TMBitmaps.CreateMirroredBitmap(bitmap: Integer; function TMBitmaps.CreateMirroredBitmap(bitmap: Integer;
MirrorStyle: TBmpMirrorStyle): Integer; MirrorStyle: TBmpMirrorStyle): Integer;
var var
@ -516,11 +538,181 @@ begin
if not ((Oldx <0) or (Oldx >= w) or (Oldy < 0) or (Oldy >= h)) then if not ((Oldx <0) or (Oldx >= w) or (Oldy < 0) or (Oldy >= h)) then
TargetBitmap.FData[ y * NewW + x] := Self.FData[OldY * W + OldX]; TargetBitmap.FData[ y * NewW + x] := Self.FData[OldY * W + OldX];
end; end;
end;
//NewX = Round(MiddlePoint.x + CosAngle * (x-MiddlePoint.x) - SinAngle * (y-MiddlePoint.y)) - MinX; procedure TMufasaBitmap.Desaturate;
//NewY = Round(MiddlePoint.y + SinAngle * (x-MiddlePoint.x) + CosAngle * (y-MiddlePoint.y)) - MinY; var
// Writeln(Format('(%d,%d) becomes (%d,%d)',[x,y,Round(MiddlePoint.x + CosAngle * (x-MiddlePoint.x) - SinAngle * (y-MiddlePoint.y)) - MinX, I : integer;
// Round(MiddlePoint.y + SinAngle * (x-MiddlePoint.x) + CosAngle * (y-MiddlePoint.y))])); He,Se,Le : extended;
Ptr : PRGB32;
begin
Ptr := FData;
for i := (h*w-1) downto 0 do
begin;
RGBToHSL(Ptr^.R,Ptr^.G,Ptr^.B,He,Se,Le);
HSLtoRGB(He,0.0,Le,Ptr^.R,Ptr^.G,Ptr^.B);
inc(ptr);
end;
end;
procedure TMufasaBitmap.Desaturate(TargetBitmap: TMufasaBitmap);
var
I : integer;
He,Se,Le : extended;
PtrOld,PtrNew : PRGB32;
begin
TargetBitmap.SetSize(w,h);
PtrOld := Self.FData;
PtrNew := TargetBitmap.FData;
for i := (h*w-1) downto 0 do
begin;
RGBToHSL(PtrOld^.R,PtrOld^.G,PtrOld^.B,He,Se,Le);
HSLtoRGB(He,0.0,Le,PtrNew^.R,PtrNew^.G,PtrNew^.B);
inc(ptrOld);
inc(PtrNew);
end;
end;
procedure TMufasaBitmap.GreyScale(TargetBitmap: TMufasaBitmap);
var
I : integer;
Lum : byte;
PtrOld,PtrNew : PRGB32;
begin
TargetBitmap.SetSize(w,h);
PtrOld := Self.FData;
PtrNew := TargetBitmap.FData;
for i := (h*w-1) downto 0 do
begin;
Lum := Round(PtrOld^.r * 0.3 + PtrOld^.g * 0.59 + PtrOld^.b * 0.11);
PtrNew^.r := Lum;
PtrNew^.g := Lum;
PtrNew^.b := Lum;
inc(ptrOld);
inc(PtrNew);
end;
end;
procedure TMufasaBitmap.GreyScale;
var
I : integer;
Lum : Byte;
Ptr: PRGB32;
begin
Ptr := Self.FData;
for i := (h*w-1) downto 0 do
begin;
Lum := Round(Ptr^.r * 0.3 + Ptr^.g * 0.59 + Ptr^.b * 0.11);
Ptr^.r := Lum;
Ptr^.g := Lum;
Ptr^.b := Lum;
inc(ptr);
end;
end;
function BrigthnessAdjust(Col: byte; br : integer): byte;inline;
var
temp : integer;
begin;
Temp := Col + Br;
if temp < 0 then
temp := 0
else if temp > 255 then
temp := 255;
result := temp;
end;
procedure TMufasaBitmap.Brightness(br: integer);
var
I : integer;
Ptr: PRGB32;
begin
Ptr := Self.FData;
for i := (h*w-1) downto 0 do
begin;
Ptr^.r := BrigthnessAdjust(Ptr^.r,br);
Ptr^.g := BrigthnessAdjust(Ptr^.g,br);
Ptr^.b := BrigthnessAdjust(Ptr^.b,br);
inc(ptr);
end;
end;
procedure TMufasaBitmap.Brightness(TargetBitmap: TMufasaBitmap; br: integer);
var
I : integer;
PtrOld,PtrNew : PRGB32;
begin
TargetBitmap.SetSize(w,h);
PtrOld := Self.FData;
PtrNew := TargetBitmap.FData;
for i := (h*w-1) downto 0 do
begin;
PtrNew^.r := BrigthnessAdjust(PtrOld^.r,br);
PtrNew^.g := BrigthnessAdjust(PtrOld^.g,br);
PtrNew^.b := BrigthnessAdjust(PtrOld^.b,br);
inc(ptrOld);
inc(PtrNew);
end;
end;
const
Grey = 128;
function ContrastAdjust(Col: byte; co : extended): byte;inline;
var
temp : integer;
begin;
Temp := floor((col - Grey) * co) + grey;
if temp < 0 then
temp := 0
else if temp > 255 then
temp := 255;
result := temp;
end;
procedure TMufasaBitmap.Contrast(co: Extended);
var
I : integer;
Ptr: PRGB32;
begin
Ptr := Self.FData;
for i := (h*w-1) downto 0 do
begin;
Ptr^.r := ContrastAdjust(Ptr^.r,co);
Ptr^.g := ContrastAdjust(Ptr^.g,co);
Ptr^.b := ContrastAdjust(Ptr^.b,co);
inc(ptr);
end;
end;
procedure TMufasaBitmap.Contrast(TargetBitmap: TMufasaBitmap; co: Extended);
var
I : integer;
PtrOld,PtrNew : PRGB32;
begin
TargetBitmap.SetSize(w,h);
PtrOld := Self.FData;
PtrNew := TargetBitmap.FData;
for i := (h*w-1) downto 0 do
begin;
PtrNew^.r := ContrastAdjust(PtrOld^.r,co);
PtrNew^.g := ContrastAdjust(PtrOld^.g,co);
PtrNew^.b := ContrastAdjust(PtrOld^.b,co);
inc(ptrOld);
inc(PtrNew);
end;
end;
procedure TMufasaBitmap.Invert;
var
Ptr : PRGB32;
i : integer;
begin
ptr := Self.FData;
for i := (h*w-1) downto 0 do
begin;
Self.FData[i].r := not Self.FData[i].r;
Self.FData[i].g := not Self.FData[i].g;
Self.Fdata[i].b := not Self.FData[i].b;
end;
end; end;
constructor TMBitmaps.Create(Owner: TObject); constructor TMBitmaps.Create(Owner: TObject);

564
Units/MMLCore/colour_conv.pas
View File

@ -1,260 +1,304 @@
{ {
This file is part of the Mufasa Macro Library (MML) This file is part of the Mufasa Macro Library (MML)
Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer Copyright (c) 2009 by Raymond van Venetië and Merlijn Wajer
MML is free software: you can redistribute it and/or modify MML is free software: you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by it under the terms of the GNU General Public License as published by
the Free Software Foundation, either version 3 of the License, or the Free Software Foundation, either version 3 of the License, or
(at your option) any later version. (at your option) any later version.
MML is distributed in the hope that it will be useful, MML is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details. GNU General Public License for more details.
You should have received a copy of the GNU General Public License You should have received a copy of the GNU General Public License
along with MML. If not, see <http://www.gnu.org/licenses/>. along with MML. If not, see <http://www.gnu.org/licenses/>.
See the file COPYING, included in this distribution, See the file COPYING, included in this distribution,
for details about the copyright. for details about the copyright.
Colour Conversion Utilities for the Mufasa Macro Library Colour Conversion Utilities for the Mufasa Macro Library
} }
unit colour_conv; unit colour_conv;
{$mode objfpc}{$H+} {$mode objfpc}{$H+}
interface interface
uses uses
Classes, SysUtils, Classes, SysUtils,
Graphics, Graphics,
Math; Math;
Function RGBtoColor(r,g,b : byte) : TColor; overload; inline; Function RGBtoColor(r,g,b : byte) : TColor; overload; inline;
Function RGBtoColor(r,g,b : integer) : TColor; overload; inline; Function RGBtoColor(r,g,b : integer) : TColor; overload; inline;
Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline; Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline;
Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline; Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline;
Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline; Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline;
Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline; Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline;
Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline; Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline;
Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline; Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Byte); inline;overload;
Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline; Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline;overload;
Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline;
implementation
implementation
Const
OneDivThree = 1/3.0; Const
TwoDivThree = 2 / 3.0; OneDivThree = 1/3.0;
OneDivTwoPointFour = 1 / 2.4; TwoDivThree = 2 / 3.0;
OneDivTwoPointFour = 1 / 2.4;
Function RGBtoColor(r,g,b : byte): TColor; overload; inline;
begin; Function RGBtoColor(r,g,b : byte): TColor; overload; inline;
Result := R or g shl 8 or b shl 16; begin;
end; Result := R or g shl 8 or b shl 16;
end;
{/\
Translates the given Red (R), Green (G) and Blue (B) components to a TColor. {/\
R, G and B are integers. Translates the given Red (R), Green (G) and Blue (B) components to a TColor.
/\} R, G and B are integers.
/\}
Function RGBtoColor(r,g,b : integer): TColor; overload; inline;
begin; Function RGBtoColor(r,g,b : integer): TColor; overload; inline;
Result := R or g shl 8 or b shl 16; begin;
end; Result := R or g shl 8 or b shl 16;
end;
{/\
Translates the given win-32 color in the Red (R), Green (G) and Blue (B) {/\
components. R, G and B are bytes. Translates the given win-32 color in the Red (R), Green (G) and Blue (B)
/\} components. R, G and B are bytes.
/\}
Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline;
begin Procedure ColorToRGB(Color : integer;var r,g,b : byte); overload; inline;
R := Color and $ff; begin
G := Color shr 8 and $ff; R := Color and $ff;
B := Color shr 16 and $ff; G := Color shr 8 and $ff;
end; B := Color shr 16 and $ff;
end;
{/\
Translates the given win-32 color in the Red (R), Green (G) and Blue (B) {/\
components. R, G and B are integers. Translates the given win-32 color in the Red (R), Green (G) and Blue (B)
/\} components. R, G and B are integers.
/\}
Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline;
begin Procedure ColorToRGB(Color : integer;var r,g,b : integer); overload; inline;
R := Color and $ff; begin
G := Color shr 8 and $ff; R := Color and $ff;
B := Color shr 16 and $ff; G := Color shr 8 and $ff;
end; B := Color shr 16 and $ff;
end;
{/\
Translates the given Red (R), Green (G) and Blue (B) components to {/\
X, Y and Z components. Translates the given Red (R), Green (G) and Blue (B) components to
/\} X, Y and Z components.
/\}
Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline;
var Procedure RGBToXYZ(R,G,B : integer;var x,y,z : Extended); inline;
Red,Green,Blue : Extended; var
begin; Red,Green,Blue : Extended;
Red := R / 255; begin;
Green := G / 255; Red := R / 255;
Blue := B / 255; Green := G / 255;
if Red > 0.04045 then Blue := B / 255;
Red := Power( ( Red + 0.055 ) / 1.055 , 2.4) * 100 if Red > 0.04045 then
else Red := Power( ( Red + 0.055 ) / 1.055 , 2.4) * 100
Red := Red / 7.73994; else
if Green > 0.04045 then Red := Red / 7.73994;
Green := Power( ( Green + 0.055 ) / 1.055 , 2.4) * 100 if Green > 0.04045 then
else Green := Power( ( Green + 0.055 ) / 1.055 , 2.4) * 100
Green := Green / 7.73994; else
if Blue > 0.04045 then Green := Green / 7.73994;
Blue := Power( ( Blue + 0.055 ) / 1.055 , 2.4) * 100 if Blue > 0.04045 then
else Blue := Power( ( Blue + 0.055 ) / 1.055 , 2.4) * 100
Blue := Blue / 7.73994; else
X := Red * 0.4124 + Green * 0.3576 + Blue * 0.1805; Blue := Blue / 7.73994;
Y := Red * 0.2126 + Green * 0.7152 + Blue * 0.0722; X := Red * 0.4124 + Green * 0.3576 + Blue * 0.1805;
Z := Red * 0.0193 + Green * 0.1192 + Blue * 0.9505; Y := Red * 0.2126 + Green * 0.7152 + Blue * 0.0722;
end; Z := Red * 0.0193 + Green * 0.1192 + Blue * 0.9505;
end;
{/\
Translates the given X, Y and Z components to {/\
Red (R), Green (G) and Blue (B) components. Translates the given X, Y and Z components to
/\} Red (R), Green (G) and Blue (B) components.
/\}
Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline;
var Procedure XYZToRGB(X,Y,Z : Extended;var R,G,B: integer); inline;
TempR,TempG,TempB,Tempx,tempy,tempz : Extended; var
begin; TempR,TempG,TempB,Tempx,tempy,tempz : Extended;
Tempx := X / 100; begin;
tempy := Y / 100; Tempx := X / 100;
tempz := Z / 100; tempy := Y / 100;
TempR := Tempx * 3.2406 + tempy * -1.5372 + tempz * -0.4986; tempz := Z / 100;
TempG := Tempx * -0.9689 + tempy * 1.8758 + tempz * 0.0415; TempR := Tempx * 3.2406 + tempy * -1.5372 + tempz * -0.4986;
TempB := Tempx * 0.0557 + tempy * -0.2040 + tempz * 1.0570; TempG := Tempx * -0.9689 + tempy * 1.8758 + tempz * 0.0415;
if TempR > 0.0031308 then TempB := Tempx * 0.0557 + tempy * -0.2040 + tempz * 1.0570;
TempR := 1.055 * ( Power(TempR, (OneDivTwoPointFour)) ) - 0.055 if TempR > 0.0031308 then
else TempR := 1.055 * ( Power(TempR, (OneDivTwoPointFour)) ) - 0.055
TempR := 12.92 * TempR; else
if TempG > 0.0031308 then TempR := 12.92 * TempR;
TempG := 1.055 * ( Power(TempG, ( OneDivTwoPointFour)) ) - 0.055 if TempG > 0.0031308 then
else TempG := 1.055 * ( Power(TempG, ( OneDivTwoPointFour)) ) - 0.055
TempG := 12.92 * TempG; else
if TempB > 0.0031308 then TempG := 12.92 * TempG;
TempB := 1.055 * ( Power(TempB , ( OneDivTwoPointFour )) ) - 0.055 if TempB > 0.0031308 then
else TempB := 1.055 * ( Power(TempB , ( OneDivTwoPointFour )) ) - 0.055
TempB := 12.92 * TempB; else
R := Round(TempR * 255); TempB := 12.92 * TempB;
G := Round(TempG * 255); R := Round(TempR * 255);
B := Round(TempB * 255); G := Round(TempG * 255);
end; B := Round(TempB * 255);
end;
{/\
Translates the given Red (R), Green (G) and Blue (B) components to {/\
H (Hue), S (Saturation) and L (Luminance) components. Translates the given Red (R), Green (G) and Blue (B) components to
/\} H (Hue), S (Saturation) and L (Luminance) components.
/\}
Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline;
var Procedure RGBToHSL(RR,GG,BB : integer;var H,S,L : Extended); inline;
R, G, B, D, Cmax, Cmin: Extended; var
begin R, G, B, D, Cmax, Cmin: Extended;
R := RR / 255; begin
G := GG / 255; R := RR / 255;
B := BB / 255; G := GG / 255;
CMin := R; B := BB / 255;
if G < Cmin then Cmin := G; CMin := R;
if B < Cmin then Cmin := B; if G < Cmin then Cmin := G;
CMax := R; if B < Cmin then Cmin := B;
if G > Cmax then Cmax := G; CMax := R;
if B > Cmax then Cmax := B; if G > Cmax then Cmax := G;
L := 0.5 * (Cmax + Cmin); if B > Cmax then Cmax := B;
if Cmax = Cmin then L := 0.5 * (Cmax + Cmin);
begin if Cmax = Cmin then
H := 0; begin
S := 0; H := 0;
end else S := 0;
begin; end else
D := Cmax - Cmin; begin;
if L < 0.5 then D := Cmax - Cmin;
S := D / (Cmax + Cmin) if L < 0.5 then
else S := D / (Cmax + Cmin)
S := D / (2 - Cmax - Cmin); else
if R = Cmax then S := D / (2 - Cmax - Cmin);
H := (G - B) / D if R = Cmax then
else H := (G - B) / D
if G = Cmax then else
H := 2 + (B - R) / D if G = Cmax then
else H := 2 + (B - R) / D
H := 4 + (R - G) / D; else
H := H / 6; H := 4 + (R - G) / D;
if H < 0 then H := H / 6;
H := H + 1; if H < 0 then
end; H := H + 1;
H := H * 100; end;
S := S * 100; H := H * 100;
L := L * 100; S := S * 100;
end; L := L * 100;
end;
{/\
Translates the given H (Hue), S (Saturation) and L (Luminance) components to {/\
Red (R), Green (G) and Blue (B) components. Translates the given H (Hue), S (Saturation) and L (Luminance) components to
/\} Red (R), Green (G) and Blue (B) components.
/\}
Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline;
var procedure HSLtoRGB(H, S, L: extended; var R, G, B: Byte); inline; overload;
Temp,Temp2 : Extended; var
//begin Temp,Temp2 : Extended;
//begin
Function Hue2RGB(TempHue : Extended) : integer;
begin; Function Hue2RGB(TempHue : Extended) : integer;
if TempHue < 0 then begin;
TempHue := TempHue + 1 if TempHue < 0 then
else if TempHue > 1 then TempHue := TempHue + 1
TempHue := TempHue - 1; else if TempHue > 1 then
if ( ( 6 * TempHue ) < 1 ) then TempHue := TempHue - 1;
Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue ))) if ( ( 6 * TempHue ) < 1 ) then
else if ( ( 2 * TempHue ) < 1 ) then Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue )))
Result :=Round(255 * Temp2) else if ( ( 2 * TempHue ) < 1 ) then
else if ( ( 3 * TempHue ) < 2 ) then Result :=Round(255 * Temp2)
Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6)) else if ( ( 3 * TempHue ) < 2 ) then
else Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6))
Result :=Round(255 * Temp); else
end; Result :=Round(255 * Temp);
end;
begin;
H := H / 100; begin;
S := S / 100; H := H / 100;
L := L / 100; S := S / 100;
if s = 0 then L := L / 100;
begin; if s = 0 then
R := Round(L * 255); begin;
G := R; R := Byte(Round(L * 255));
B := R; G := R;
end else B := R;
begin; end else
if (L < 0.5) then begin;
Temp2 := L * ( 1 + S ) if (L < 0.5) then
else Temp2 := L * ( 1 + S )
Temp2 := (L + S) - ( S * L); else
Temp := 2 * L - Temp2; Temp2 := (L + S) - ( S * L);
R := Hue2RGB( H + ( OneDivThree ) ); Temp := 2 * L - Temp2;
G := Hue2RGB( H ); R := Hue2RGB( H + ( OneDivThree ) );
B := Hue2RGB( H - ( OneDivThree ) ); G := Hue2RGB( H );
end; B := Hue2RGB( H - ( OneDivThree ) );
end; end;
end;
{/\
Split the Given Color col in H, S, L components. Procedure HSLtoRGB(H,S,L : extended;var R,G,B : Integer); inline;
/\} var
Temp,Temp2 : Extended;
Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline; //begin
Var
R, G, B: Integer; Function Hue2RGB(TempHue : Extended) : integer;
Begin begin;
ColorToRGB(Col, R, G, B); if TempHue < 0 then
RGBToHSL(R, G, B, H, S, L); TempHue := TempHue + 1
End; else if TempHue > 1 then
TempHue := TempHue - 1;
end. if ( ( 6 * TempHue ) < 1 ) then
Result :=Round(255 * (( Temp + ( Temp2 - Temp ) * 6 * TempHue )))
else if ( ( 2 * TempHue ) < 1 ) then
Result :=Round(255 * Temp2)
else if ( ( 3 * TempHue ) < 2 ) then
Result :=Round(255 * (Temp + ( Temp2 - Temp ) * ( ( TwoDivThree ) - TempHue ) * 6))
else
Result :=Round(255 * Temp);
end;
begin;
H := H / 100;
S := S / 100;
L := L / 100;
if s = 0 then
begin;
R := Round(L * 255);
G := R;
B := R;
end else
begin;
if (L < 0.5) then
Temp2 := L * ( 1 + S )
else
Temp2 := (L + S) - ( S * L);
Temp := 2 * L - Temp2;
R := Hue2RGB( H + ( OneDivThree ) );
G := Hue2RGB( H );
B := Hue2RGB( H - ( OneDivThree ) );
end;
end;
{/\
Split the Given Color col in H, S, L components.
/\}
Procedure ColorToHSL(Col: Integer; var h, s, l: Extended); inline;
Var
R, G, B: Integer;
Begin
ColorToRGB(Col, R, G, B);
RGBToHSL(R, G, B, H, S, L);
End;
end.