tchart

最新推荐文章于 2019-08-01 04:06:19 发布

nextop88

最新推荐文章于 2019-08-01 04:06:19 发布

阅读量563

点赞数

分类专栏： DELPHI开发

DELPHI开发专栏收录该内容

194 篇文章 4 订阅

订阅专栏

{**********************************************}
{ TeeChart and TeeTree Image Filters }
{ }
{**********************************************}
unit TeeFilters ;
{$I TeeDefs.inc}
{$R-}
interface
uses
{$IFNDEF LINUX}
Windows ,
{$ENDIF}
Classes ,
{$IFDEF D6}
Types ,
{$ENDIF}
{$IFDEF CLX}
Qt , QControls , QGraphics , QStdCtrls , QExtCtrls ,
{$ELSE}
Controls , Graphics , StdCtrls , ExtCtrls ,
{$ENDIF}
TeCanvas ;
{$IFDEF CLR}
{$UNSAFECODE ON}
{$ENDIF}
type
TResizeFilter = class (TTeeFilter )
private
FWidth : Integer ;
FHeight : Integer ;
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Width : Integer read FWidth write FWidth default 0 ;
property Height : Integer read FHeight write FHeight default 0 ;
end ;
TCropFilter = class (TResizeFilter )
private
FLeft : Integer ;
FSmooth : Boolean ;
FTop : Integer ;
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Left : Integer read FLeft write FLeft default 0 ;
property Smooth : Boolean read FSmooth write FSmooth default False ;
property Top : Integer read FTop write FTop default 0 ;
end ;
TInvertFilter = class (TTeeFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TGrayMethod = (gmSimple , gmEye , gmEye2 ) ;
TGrayScaleFilter = class (TTeeFilter )
private
FMethod : TGrayMethod ;
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Method :TGrayMethod read FMethod write FMethod default gmSimple ;
end ;
TFlipFilter = class (TTeeFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TReverseFilter = class (TTeeFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TAmountFilter = class (TTeeFilter )
private
FAmount : Integer ;
FPercent : Boolean ;
FScrollBar : TScrollBar ;
IOnlyPositive : Boolean ;
procedure ResetScroll (Sender : TObject ) ;
function ScrollMin : Integer ;
function ScrollMax : Integer ;
public
Constructor Create (Collection :TCollection ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
published
property Percent : Boolean read FPercent write FPercent default True ;
property Amount : Integer read FAmount write FAmount default 5 ;
end ;
TMosaicFilter = class (TAmountFilter )
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TBrightnessFilter = class (TAmountFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TContrastFilter = class (TAmountFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TColorFilter = class (TTeeFilter )
private
FBlue : Integer ;
FGreen : Integer ;
FRed : Integer ;
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Red : Integer read FRed write FRed default 0 ;
property Green : Integer read FGreen write FGreen default 0 ;
property Blue : Integer read FBlue write FBlue default 0 ;
end ;
THueLumSatFilter = class (TTeeFilter )
private
FHue : Integer ;
FLum : Integer ;
FSat : Integer ;
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Hue : Integer read FHue write FHue default 0 ;
property Luminance : Integer read FLum write FLum default 0 ;
property Saturation : Integer read FSat write FSat default 0 ;
end ;
TSharpenFilter = class (TConvolveFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TEmbossFilter = class (TConvolveFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TSoftenFilter = class (TConvolveFilter )
public
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
end ;
TGammaCorrectionFilter = class (TAmountFilter )
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
class function Description : String ; override ;
published
property Amount default 70 ;
end ;
TRotateFilter = class (TTeeFilter )
private
FAngle : Double ;
FAutoSize : Boolean ;
FBackColor : TColor ;
procedure SetAngle ( const Value : Double ) ;
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Angle : Double read FAngle write SetAngle ;
property AutoSize : Boolean read FAutoSize write FAutoSize default True ;
property BackColor :TColor read FBackColor write FBackColor default clWhite ;
end ;
TMirrorDirection = (mdDown , mdUp , mdRight , mdLeft ) ;
TMirrorFilter = class (TTeeFilter )
private
FDirection : TMirrorDirection ;
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Direction :TMirrorDirection read FDirection write FDirection
default mdDown ;
end ;
TTileFilter = class (TTeeFilter )
private
FNumCols : Integer ;
FNumRows : Integer ;
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap :TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property NumCols : Integer read FNumCols write FNumCols default 3 ;
property NumRows : Integer read FNumRows write FNumRows default 3 ;
end ;
TBevelFilter = class (TTeeFilter )
private
FBright : Integer ;
FSize : Integer ;
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap : TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Bright : Integer read FBright write FBright default 64 ;
property Size : Integer read FSize write FSize default 15 ;
end ;
TZoomFilter = class (TTeeFilter )
private
FPercent : Double ;
FSmooth : Boolean ;
public
Constructor Create (Collection :TCollection ) ; override ;
procedure Apply (Bitmap : TBitmap ; const R :TRect ) ; override ;
procedure CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ; override ;
class function Description : String ; override ;
published
property Percent : Double read FPercent write FPercent ;
property Smooth : Boolean read FSmooth write FSmooth default False ;
end ;
TImageFiltered = class (TImage )
private
FFilters : TFilterItems ;
function FiltersStored : Boolean ;
procedure ReadFilters (Reader : TReader ) ;
procedure SetFilters ( const Value : TFilterItems ) ;
procedure WriteFilters (Writer : TWriter ) ;
protected
procedure DefineProperties (Filer :TFiler ) ; override ;
procedure Paint ; override ;
public
Constructor Create (AOwner :TComponent ) ; override ;
Destructor Destroy ; override ;
function Filtered :TBitmap ;
published
property Filters :TFilterItems read FFilters write SetFilters stored False ;
end ;
var
FilterClasses : TList ;
procedure TeeRegisterFilters ( const FilterList : Array of TFilterClass ) ;
procedure TeeUnRegisterFilters ( const FilterList : Array of TFilterClass ) ;
procedure ColorToHLS (Color : TColor ; out Hue , Luminance , Saturation : Word ) ;
procedure RGBToHLS ( const Color : TRGB ; out Hue , Luminance , Saturation : Word ) ;
procedure HLSToRGB (Hue , Luminance , Saturation : Word ; out rgb : TRGB ) ;
function HLSToColor (Hue , Luminance , Saturation : Word ) :TColor ;
// Converts ABitmap pixels into Gray Scale (levels of gray) v5.02 (v8 moved from TeCanvas.pas)
Procedure TeeGrayScale (ABitmap :TBitmap ; Inverted : Boolean ; AMethod : Integer ) ;
implementation
uses
Math , SysUtils , TypInfo , TeeConst ;
procedure TeeRegisterFilters ( const FilterList : Array of TFilterClass ) ;
var t : Integer ;
begin
if not Assigned (FilterClasses ) then
FilterClasses : =TList . Create ;
for t : = Low (FilterList ) to High (FilterList ) do
if FilterClasses . IndexOf ( {$IFDEF CLR}TObject{$ENDIF} (FilterList [t ] ) ) =- 1 then
begin
FilterClasses . Add ( {$IFDEF CLR}TObject{$ENDIF} (FilterList [t ] ) ) ;
RegisterClass (FilterList [t ] ) ;
end ;
end ;
procedure TeeUnRegisterFilters ( const FilterList : Array of TFilterClass ) ;
var t : Integer ;
begin
if Assigned (FilterClasses ) then
for t : = Low (FilterList ) to High (FilterList ) do
FilterClasses . Remove ( {$IFDEF CLR}TObject{$ENDIF} (FilterList [t ] ) ) ;
end ;
{ TResizeFilter }
function SmoothBitmap (Bitmap :TBitmap ; Width ,Height : Integer ) :TBitmap ;
begin
result : =TBitmap . Create ;
TeeSetBitmapSize (result ,Width ,Height ) ;
SmoothStretch (Bitmap ,result ) ;
end ;
procedure TResizeFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
var tmp : TBitmap ;
begin
if (Width> 0 ) and (Height> 0 ) then
begin
tmp : =SmoothBitmap (Bitmap ,Width ,Height ) ;
try
TeeSetBitmapSize (Bitmap ,Width ,Height ) ;
Bitmap . Canvas . Draw ( 0 , 0 ,tmp ) ;
finally
tmp . Free ;
end ;
end ;
// Do not call inherited;
end ;
procedure TResizeFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddInteger ( 'Width' ,TeeMsg_Width , 0 , 10000 ) ; // Do not localize
Creator . AddInteger ( 'Height' ,TeeMsg_Height , 0 , 10000 ) ; // Do not localize
end ;
class function TResizeFilter . Description : String ;
begin
result : =TeeMsg_Resize ;
end ;
{ TCropFilter }
procedure TCropFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
var tmp : TBitmap ;
begin
if (Width> 0 ) and (Height> 0 ) then
begin
tmp : =TBitmap . Create ;
try
tmp . PixelFormat : =Bitmap . PixelFormat ;
TeeSetBitmapSize (tmp ,Width ,Height ) ;
tmp . Canvas . CopyRect (TeeRect ( 0 , 0 ,tmp . Width ,tmp . Height ) ,
Bitmap . Canvas ,TeeRect (Left ,Top ,Left +Width - 1 ,Top +Height - 1 ) ) ;
if FSmooth then
SmoothStretch (tmp ,Bitmap )
else
Bitmap . Canvas . StretchDraw (TeeRect ( 0 , 0 ,Bitmap . Width - 1 ,Bitmap . Height - 1 ) ,tmp ) ;
finally
tmp . Free ;
end ;
end ;
// Do not call inherited;
end ;
procedure TCropFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddInteger ( 'Left' ,TeeMsg_Left , 0 , 10000 ) ; // Do not localize
Creator . AddInteger ( 'Top' ,TeeMsg_Top , 0 , 10000 ) ; // Do not localize
Creator . AddCheckBox ( 'Smooth' ,TeeMsg_Smooth ) ; // Do not localize
end ;
class function TCropFilter . Description : String ;
begin
result : =TeeMsg_Crop ;
end ;
{ TInvertFilter }
procedure TInvertFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
var x ,y : Integer ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
Blue : = 255 -Blue ;
Green : = 255 -Green ;
Red : = 255 -Red ;
end ;
end ;
class function TInvertFilter . Description : String ;
begin
result : =TeeMsg_Invert ;
end ;
{ TGrayScaleFilter }
procedure TGrayScaleFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
var x ,y : Integer ;
tmp : Byte ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
case Method of
gmSimple : for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
tmp : = (Blue +Green +Red ) div 3 ;
Blue : =tmp ;
Green : =tmp ;
Red : =tmp ;
end ;
gmEye : for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
tmp : = Round ( ( 0.30 *Red ) +
( 0.59 *Green ) +
( 0.11 *Blue ) ) ;
Blue : =tmp ;
Green : =tmp ;
Red : =tmp ;
end ;
gmEye2 : for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
tmp : = ( 11 *Red + 16 *Green + 5 *Blue ) div 32 ;
Blue : =tmp ;
Green : =tmp ;
Red : =tmp ;
end ;
end ;
end ;
procedure TGrayScaleFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddCombo ( 'Method' ) ; // Do not localize
end ;
class function TGrayScaleFilter . Description : String ;
begin
result : =TeeMsg_GrayScale ;
end ;
{ TMosaicFilter }
constructor TMosaicFilter . Create (Collection :TCollection ) ;
begin
inherited ;
FAmount : = 8 ;
IOnlyPositive : = True ;
end ;
procedure TMosaicFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
var
tmpAmountX : Integer ;
tmpAmountY : Integer ;
tmpDims : Single ;
procedure DoMosaic ( const tmpX ,tmpY : Integer ) ; {$IFDEF CLR}unsafe;{$ENDIF}
var ar ,
ag ,
ab : Integer ;
xx ,
yy : Integer ;
a : TRGB ;
Line : PRGBs ;
begin
ar : = 0 ;
ag : = 0 ;
ab : = 0 ;
for yy : = 0 to tmpAmountY do
begin
Line : =Lines [tmpY +yy ] ;
for xx : = 0 to tmpAmountX do
with Line [tmpX +xx ] do
begin
Inc (ar ,Red ) ;
Inc (ag ,Green ) ;
Inc (ab ,Blue ) ;
end ;
end ;
a . Red : = Round (ar *tmpDims ) ;
a . Green : = Round (ag *tmpDims ) ;
a . Blue : = Round (ab *tmpDims ) ;
for yy : = 0 to tmpAmountY do
begin
Line : =Lines [tmpY +yy ] ;
for xx : = 0 to tmpAmountX do
Line [tmpX +xx ] : =a ;
end ;
end ;
procedure DoMosaicRow ( const tmpY : Integer ) ;
var tmpX : Integer ;
begin
tmpX : =R . Left ;
while tmpX<R . Right -Amount do
begin
DoMosaic (tmpX ,tmpY ) ;
Inc (tmpX ,Amount ) ;
end ;
// Remainder horizontal mosaic cell
if tmpX<R . Right then
begin
tmpAmountX : =R . Right -tmpX ;
tmpDims : = 1.0 / ( Succ (tmpAmountX ) * Succ (tmpAmountY ) ) ;
DoMosaic (tmpX ,tmpY ) ;
tmpAmountX : =tmpAmountY ;
tmpDims : = 1.0 / Sqr (Amount ) ;
end ;
end ;
var tmpY : Integer ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
if Amount> 0 then
begin
tmpDims : = 1.0 / Sqr (Amount ) ;
tmpAmountX : =Amount - 1 ;
tmpAmountY : =tmpAmountX ;
tmpY : =R . Top ;
while tmpY<R . Bottom -Amount do
begin
DoMosaicRow (tmpY ) ;
Inc (tmpY ,Amount ) ;
end ;
// Remainder vertical mosaic row cells
if tmpY<R . Bottom then
begin
tmpAmountY : =R . Bottom -tmpY - 1 ;
tmpDims : = 1.0 / ( Succ (tmpAmountX ) * Succ (tmpAmountY ) ) ;
DoMosaicRow (tmpY ) ;
end ;
end ;
end ;
class function TMosaicFilter . Description : String ;
begin
result : =TeeMsg_Mosaic ;
end ;
{ TFlipFilter }
procedure TFlipFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
var tmp : TRGB ;
tmpH ,
tmpY ,
x ,y : Integer ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
tmpH : =R . Bottom -R . Top ;
for y : =R . Top to R . Top + (tmpH div 2 ) - 1 do
for x : =R . Left to R . Right do
begin
tmp : =Lines [y ,x ] ;
tmpY : =tmpH -y ;
Lines [y ,x ] : =Lines [tmpY ,x ] ;
Lines [tmpY ,x ] : =tmp ;
end ;
end ;
class function TFlipFilter . Description : String ;
begin
result : =TeeMsg_Flip ;
end ;
{ TReverseFilter }
procedure TReverseFilter . Apply (Bitmap :TBitmap ; const R :TRect ) ;
var tmp : TRGB ;
tmpW ,
tmpX ,
x ,y : Integer ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
tmpW : =R . Right -R . Left ;
for x : =R . Left to R . Left + (tmpW div 2 ) - 1 do
for y : =R . Top to R . Bottom do
begin
tmp : =Lines [y ,x ] ;
tmpX : =tmpW -x ;
Lines [y ,x ] : =Lines [y ,tmpX ] ;
Lines [y ,tmpX ] : =tmp ;
end ;
end ;
class function TReverseFilter . Description : String ;
begin
result : =TeeMsg_Reverse ;
end ;
{ TAmountFilter }
Constructor TAmountFilter . Create (Collection :TCollection ) ;
begin
inherited ;
FPercent : = True ;
FAmount : = 5 ; // %
end ;
function TAmountFilter . ScrollMin : Integer ;
begin
if FPercent then
if IOnlyPositive then result : = 0 else result : =- 100
else
if IOnlyPositive then result : = 0 else result : =- 255 ;
end ;
function TAmountFilter . ScrollMax : Integer ;
begin
if FPercent then result : = 100
else result : = 255 ;
end ;
procedure TAmountFilter . ResetScroll (Sender : TObject ) ;
begin
FScrollBar . Min : =ScrollMin ;
FScrollBar . Max : =ScrollMax ;
end ;
procedure TAmountFilter . CreateEditor (Creator :IFormCreator ; AChanged :TNotifyEvent ) ;
begin
inherited ;
FScrollBar : =Creator . AddScroll ( 'Amount' ,ScrollMin ,ScrollMax ) ; // Do not localize
Creator . AddCheckBox ( 'Percent' ,TeeMsg_Percent ,ResetScroll ) ; // Do not localize
end ;
{ TBrightnessFilter }
procedure TBrightnessFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
var x ,y ,l : Integer ;
IPercent : Single ;
begin
if Amount = 0 then
Exit ;
inherited ;
if Length (Lines ) = 0 then
Exit ;
if Percent then
begin
IPercent : =FAmount * 0.01 ;
for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
l : =Red + Round ( 255 *IPercent ) ;
if l< 0 then Red : = 0 else if l> 255 then Red : = 255 else Red : =l ;
l : =Green + Round ( 255 *IPercent ) ;
if l< 0 then Green : = 0 else if l> 255 then Green : = 255 else Green : =l ;
l : =Blue + Round ( 255 *IPercent ) ;
if l< 0 then Blue : = 0 else if l> 255 then Blue : = 255 else Blue : =l ;
end ;
end
else
for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
l : =Red +Amount ;
if l< 0 then Red : = 0 else if l> 255 then Red : = 255 else Red : =l ;
l : =Green +Amount ;
if l< 0 then Green : = 0 else if l> 255 then Green : = 255 else Green : =l ;
l : =Blue +Amount ;
if l< 0 then Blue : = 0 else if l> 255 then Blue : = 255 else Blue : =l ;
end ;
end ;
class function TBrightnessFilter . Description : String ;
begin
result : =TeeMsg_Brightness ;
end ;
procedure ColorToHLS (Color : TColor ; out Hue , Luminance , Saturation : Word ) ;
var tmp : TRGB ;
begin
Color : =ColorToRGB (Color ) ;
tmp . Red : =GetRValue (Color ) ;
tmp . Green : =GetGValue (Color ) ;
tmp . Blue : =GetBValue (Color ) ;
RGBToHLS (tmp ,Hue ,Luminance ,Saturation ) ;
end ;
type
Float = Single ;
const
// HLSMAX BEST IF DIVISIBLE BY 6. RGBMAX, HLSMAX must each fit in a byte.
HLSMAX = 240 ; // H,L, and S vary over 0-HLSMAX
RGBMAX = 255 ; // R,G, and B vary over 0-RGBMAX
RGBMAX2 = 2.0 *RGBMAX ;
InvRGBMAX2 = 1.0 /RGBMAX2 ;
HLSMAXDiv2 =HLSMAX / 2 ;
HLSMAXDiv3 =HLSMAX / 3 ;
HLSMAXDiv6 =HLSMAX / 6 ;
HLSMAXDiv12 =HLSMAX / 12 ;
HLSMAX2 =HLSMAX * 2 ;
HLSMAX3 =HLSMAX * 3 ;
HLSMAX2Div3 =HLSMAX2 / 3 ;
{ Hue is undefined if Saturation is 0 (grey-scale)
This value determines where the Hue scrollbar is
initially set for achromatic colors }
HLSUndefined = 160 ; // HLSMAX2Div3;
procedure RGBToHLS ( const Color : TRGB ; out Hue , Luminance , Saturation : Word ) ;
var
H , L , S : Float ;
R , G , B : Word ;
dif : Integer ;
sum , cMax , cMin : Word ;
Rdelta , Gdelta , Bdelta : Extended ; { intermediate value: % of spread from max }
begin
R : =Color . Red ;
G : =Color . Green ;
B : =Color . Blue ;
{ calculate lightness }
if R>G then
if R>B then cMax : =R else cMax : =B
else
if G>B then cMax : =G else cMax : =B ;
if R<G then
if R<B then cMin : =R else cMin : =B
else
if G<B then cMin : =G else cMin : =B ;
sum : = (cMax + cMin ) ;
L : = ( ( sum * HLSMAX ) + RGBMAX ) / ( 2 * RGBMAX ) ;
if cMax = cMin then { r=g=b --> achromatic case }
begin { saturation }
Hue : = Round (HLSUndefined ) ;
// pwHue := 160; { MS ColoroHLS always defaults to 160 in this case }
Luminance : = Round (L ) ;
Saturation : = 0 ;
end
else { chromatic case }
begin
dif : =cMax -cMin ;
{ saturation }
if L < = HLSMAXDiv2 then
S : = ( (dif *HLSMAX ) + ( sum * 0.5 ) ) / sum
else
S : = ( (dif *HLSMAX ) + ( RGBMAX - ( sum * 0.5 ) ) ) / ( 2 *RGBMAX - sum ) ;
{ hue }
Rdelta : = ( ( (cMax -R ) *HLSMAXDiv6 ) + (dif * 0.5 ) ) / dif ;
Gdelta : = ( ( (cMax -G ) *HLSMAXDiv6 ) + (dif * 0.5 ) ) / dif ;
Bdelta : = ( ( (cMax -B ) *HLSMAXDiv6 ) + (dif * 0.5 ) ) / dif ;
if R = cMax then
H : = Bdelta - Gdelta
else
if G = cMax then
H : = HLSMAX3 + Rdelta - Bdelta
else // B == cMax
H : = HLSUndefined + Gdelta - Rdelta ;
if H < 0 then H : = H + HLSMAX
else
if H > HLSMAX then H : = H - HLSMAX ;
Hue : = Round (H ) ;
Luminance : = Round (L ) ;
Saturation : = Round (S ) ;
end ;
end ;
function HLSToColor (Hue , Luminance , Saturation : Word ) :TColor ;
var tmp : TRGB ;
begin
HLSToRGB (Hue ,Luminance ,Saturation ,tmp ) ;
result : =RGB (tmp . Red ,tmp . Green ,tmp . Blue ) ;
end ;
procedure HLSToRGB (Hue , Luminance , Saturation : Word ; out rgb : TRGB ) ;
function HueToRGB ( const Lum , Sat :Float ; Hue : Float ) : Integer ;
begin
{ range check: note values passed add/subtract thirds of range }
if hue < 0 then hue : =hue +HLSMAX ;
if hue > HLSMAX then hue : =hue -HLSMAX ;
{ return r,g, or b value from this tridrant }
if hue < HLSMAXDiv6 then
Result : = Round ( Lum + ( ( (Sat -Lum ) *hue +HLSMAXDiv12 ) /HLSMAXDiv6 ) )
else
if hue < HLSMAXDiv2 then
Result : = Round ( Sat )
else
if hue < HLSMAX2Div3 then
Result : = Round ( Lum + ( ( (Sat -Lum ) * (HLSMAX2Div3 -hue ) +HLSMAXDiv12 ) /HLSMAXDiv6 ) )
else
Result : = Round ( Lum ) ;
end ;
function RoundColor ( const Value : Integer ) : Integer ;
begin
if Value > 255 then Result : = 255 else Result : = Round (Value ) ;
end ;
var
Magic1 , Magic2 : Float ; { calculated magic numbers (really!) }
function RoundColor2 ( const Hue : Float ) : Integer ;
begin
result : =RoundColor ( Round ( (HueToRGB (Magic1 ,Magic2 ,Hue ) *RGBMAX + HLSMAXDiv2 ) /HLSMAX ) ) ;
end ;
begin
if Saturation = 0 then
with rgb do
begin { achromatic case }
Red : = RoundColor ( Round ( (Luminance * RGBMAX ) /HLSMAX ) ) ;
Green : =Red ;
Blue : =Green ;
if Hue <> HLSUndefined then ; { ERROR }
end
else
begin { chromatic case }
{ set up magic numbers }
if Luminance < = HLSMAXDiv2 then
Magic2 : = (Luminance * (HLSMAX + Saturation ) + HLSMAXDiv2 ) / HLSMAX
else
Magic2 : = Luminance + Saturation - ( (Luminance * Saturation ) + HLSMAXDiv2 ) / HLSMAX ;
Magic1 : = 2 * Luminance - Magic2 ;
{ get RGB, change units from HLSMAX to RGBMAX }
rgb . Red : =RoundColor2 (Hue +HLSMAXDiv3 ) ;
rgb . Green : =RoundColor2 (Hue ) ;
rgb . Blue : =RoundColor2 (Hue -HLSMAXDiv3 ) ;
end ;
end ;
{ TColorFilter }
procedure TColorFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
var x ,y : Integer ;
tmpInt : Integer ;
Line : PRGBs ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
if (Red<> 0 ) or (Green<> 0 ) or (Blue<> 0 ) then
for y : =R . Top to R . Bottom do
begin
Line : =Lines [y ] ;
for x : =R . Left to R . Right do
with Line [x ] do
begin
if Self . FRed<> 0 then
begin
tmpInt : =Red + Self . FRed ;
if tmpInt< 0 then Red : = 0 else
if tmpInt> 255 then Red : = 255 else
Red : =tmpInt ;
end ;
if Self . FGreen<> 0 then
begin
tmpInt : =Green + Self . FGreen ;
if tmpInt< 0 then Green : = 0 else
if tmpInt> 255 then Green : = 255 else
Green : =tmpInt ;
end ;
if Self . FBlue<> 0 then
begin
tmpInt : =Blue + Self . FBlue ;
if tmpInt< 0 then Blue : = 0 else
if tmpInt> 255 then Blue : = 255 else
Blue : =tmpInt ;
end ;
end ;
end ;
end ;
procedure TColorFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddScroll ( 'Red' , - 255 , 255 ) ; // Do not localize
Creator . AddScroll ( 'Green' , - 255 , 255 ) ; // Do not localize
Creator . AddScroll ( 'Blue' , - 255 , 255 ) ; // Do not localize
end ;
class function TColorFilter . Description : String ;
begin
result : =TeeMsg_Color ;
end ;
{ THueLumSatFilter }
procedure THueLumSatFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
var x ,y : Integer ;
tmpInt : Integer ;
tmpHue : Word ;
tmpLum : Word ;
tmpSat : Word ;
Line : PRGBs ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
if (FHue<> 0 ) or (FLum<> 0 ) or (FSat<> 0 ) then
for y : =R . Top to R . Bottom do
begin
Line : =Lines [y ] ;
for x : =R . Left to R . Right do
begin
RGBToHLS (Line [x ] ,tmpHue ,tmpLum ,tmpSat ) ;
if Self . FHue<> 0 then
begin
tmpInt : =tmpHue + Self . FHue ;
if tmpInt< 0 then tmpHue : = 0 else
if tmpInt> 255 then tmpHue : = 255 else
tmpHue : =tmpInt ;
end ;
if Self . FLum<> 0 then
begin
tmpInt : =tmpLum + Self . FLum ;
if tmpInt< 0 then tmpLum : = 0 else
if tmpInt> 255 then tmpLum : = 255 else
tmpLum : =tmpInt ;
end ;
if Self . FSat<> 0 then
begin
tmpInt : =tmpSat + Self . FSat ;
if tmpInt< 0 then tmpSat : = 0 else
if tmpInt> 255 then tmpSat : = 255 else
tmpSat : =tmpInt ;
end ;
HLSToRGB (tmpHue ,tmpLum ,tmpSat ,Line [x ] ) ;
end ;
end ;
end ;
procedure THueLumSatFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddScroll ( 'Hue' , - 255 , 255 ) ; // Do not localize
Creator . AddScroll ( 'Luminance' , - 255 , 255 ) ; // Do not localize
Creator . AddScroll ( 'Saturation' , - 255 , 255 ) ; // Do not localize
end ;
class function THueLumSatFilter . Description : String ;
begin
result : =TeeMsg_HueLumSat ;
end ;
{ TSharpenFilter }
procedure TSharpenFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
const Center = 2.0 ;
Pix =- ( (Center - 1 ) / 8.0 ) ;
begin
Weights [ - 1 , - 1 ] : =Pix ; Weights [ - 1 , 0 ] : =Pix ; Weights [ - 1 , 1 ] : =Pix ;
Weights [ 0 , - 1 ] : =Pix ; Weights [ 0 , 0 ] : =Center ; Weights [ 0 , 1 ] : =Pix ;
Weights [ 1 , - 1 ] : =Pix ; Weights [ 1 , 0 ] : =Pix ; Weights [ 1 , 1 ] : =Pix ;
InvTotalWeight : = 1.0 / 16.0 ;
inherited ;
end ;
class function TSharpenFilter . Description : String ;
begin
result : =TeeMsg_Sharpen ;
end ;
{ TGammaCorrectionFilter }
Constructor TGammaCorrectionFilter . Create (Collection :TCollection ) ;
begin
inherited ;
FAmount : = 70 ;
IOnlyPositive : = True ;
end ;
procedure TGammaCorrectionFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
var t ,
x ,y : Integer ;
IGamma : Array [ 0 .. 255 ] of Byte ;
tmp : Single ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
tmp : = Max ( 0.001 , Abs (Amount ) * 0.01 ) ;
IGamma [ 0 ] : = 0 ;
for t : = 1 to 255 do
IGamma [t ] : = Round ( Exp ( Ln (t / 255.0 ) /tmp ) * 255.0 ) ;
for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
Red : =IGamma [Red ] ;
Green : =IGamma [Green ] ;
Blue : =IGamma [Blue ] ;
end ;
end ;
class function TGammaCorrectionFilter . Description : String ;
begin
result : =TeeMsg_GammaCorrection ;
end ;
{ TEmbossFilter }
procedure TEmbossFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
begin
Weights [ - 1 , - 1 ] : = 0 ; Weights [ - 1 , 0 ] : =- 1 ; Weights [ - 1 , 1 ] : = 0 ;
Weights [ 0 , - 1 ] : =- 1 ; Weights [ 0 , 0 ] : = 1 ; Weights [ 0 , 1 ] : = 1 ;
Weights [ 1 , - 1 ] : = 0 ; Weights [ 1 , 0 ] : =- 1 ; Weights [ 1 , 1 ] : = 0 ;
InvTotalWeight : = 1.0 / 1.0 ;
inherited ;
end ;
class function TEmbossFilter . Description : String ;
begin
result : =TeeMsg_Emboss ;
end ;
{ TContrastFilter }
procedure TContrastFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
var x ,y ,l : Integer ;
IPercent : Single ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
if Percent then
IPercent : =FAmount * 0.01
else
IPercent : = 1 ;
for y : =R . Top to R . Bottom do
for x : =R . Left to R . Right do
with Lines [y ,x ] do
begin
if Percent then l : =Red + ( Round (Red *IPercent ) * (Red - 128 ) div 256 )
else l : =Red + (Amount * (Red - 128 ) div 256 ) ;
if l< 0 then Red : = 0 else if l> 255 then Red : = 255 else Red : =l ;
if Percent then l : =Green + ( Round (Green *IPercent ) * (Green - 128 ) div 256 )
else l : =Green + (Amount * (Green - 128 ) div 256 ) ;
if l< 0 then Green : = 0 else if l> 255 then Green : = 255 else Green : =l ;
if Percent then l : =Blue + ( Round (Blue *IPercent ) * (Blue - 128 ) div 256 )
else l : =Blue + (Amount * (Blue - 128 ) div 256 ) ;
if l< 0 then Blue : = 0 else if l> 255 then Blue : = 255 else Blue : =l ;
end ;
end ;
class function TContrastFilter . Description : String ;
begin
result : =TeeMsg_Contrast ;
end ;
{ TSoftenFilter }
procedure TSoftenFilter . Apply (Bitmap :TBitmap ; const R : TRect ) ;
begin
Weights [ - 1 , - 1 ] : = 0 ; Weights [ - 1 , 0 ] : = 0 ; Weights [ - 1 , 1 ] : = 0 ;
Weights [ 0 , - 1 ] : = 0 ; Weights [ 0 , 0 ] : = 1 ; Weights [ 0 , 1 ] : = 1 ;
Weights [ 1 , - 1 ] : = 0 ; Weights [ 1 , 0 ] : = 1 ; Weights [ 1 , 1 ] : = 1 ;
InvTotalWeight : = 1.0 / 4.0 ;
inherited ;
end ;
class function TSoftenFilter . Description : String ;
begin
result : =TeeMsg_AntiAlias ;
end ;
{ TImageFiltered }
Constructor TImageFiltered . Create (AOwner : TComponent ) ;
begin
inherited ;
FFilters : =TFilterItems . Create ( Self ,TTeeFilter ) ;
end ;
Destructor TImageFiltered . Destroy ;
begin
FFilters . Free ;
inherited ;
end ;
function TImageFiltered . Filtered :TBitmap ;
var tmpDest : TBitmap ;
tmpR : TRect ;
tmpW : Integer ;
tmpH : Integer ;
begin
result : =TBitmap . Create ;
result . Assign (Picture . Graphic ) ;
tmpR : =DestRect ;
tmpW : =tmpR . Right -tmpR . Left ;
tmpH : =tmpR . Bottom -tmpR . Top ;
if (tmpW<>result . Width ) or (tmpH<>result . Height ) then
begin
tmpDest : =SmoothBitmap (result ,tmpW ,tmpH ) ;
result . Free ;
result : =tmpDest ;
end ;
FFilters . ApplyTo (result ) ;
end ;
procedure TImageFiltered . SetFilters ( const Value : TFilterItems ) ;
begin
FFilters . Assign (Value ) ;
end ;
procedure TImageFiltered . Paint ;
var tmpCanvas : TCanvas ;
tmp : TGraphic ;
begin
tmp : =Filtered ;
try
tmpCanvas : =TControlCanvas . Create ;
try
TControlCanvas (tmpCanvas ) . Control : = Self ;
tmpCanvas . Draw ( 0 , 0 ,tmp ) ;
if csDesigning in ComponentState then
with tmpCanvas do
begin
Pen . Style : =psDash ;
Brush . Style : =bsClear ;
{$IFDEF CLX}
Start ;
QPainter_setBackgroundMode (Handle ,BGMode_TransparentMode ) ;
Stop ;
{$ELSE}
SetBkMode (Handle ,Windows . TRANSPARENT ) ;
{$ENDIF}
with ClientRect do
Rectangle (Left ,Top ,Right ,Bottom ) ;
end ;
finally
tmpCanvas . Free ;
end ;
finally
tmp . Free ;
end ;
end ;
procedure TImageFiltered . ReadFilters (Reader : TReader ) ;
begin
TTeePicture . ReadFilters (Reader ,Filters ) ;
end ;
procedure TImageFiltered . WriteFilters (Writer : TWriter ) ;
begin
TTeePicture . WriteFilters (Writer ,Filters ) ;
end ;
function TImageFiltered . FiltersStored : Boolean ;
begin
result : = Assigned (FFilters ) and (FFilters . Count> 0 ) ;
end ;
procedure TImageFiltered . DefineProperties (Filer : TFiler ) ;
begin
inherited ;
Filer . DefineProperty ( 'FilterItems' ,ReadFilters ,WriteFilters ,FiltersStored ) ; // Do not localize
end ;
{ TRotateFilter }
Constructor TRotateFilter . Create (Collection :TCollection ) ;
begin
inherited ;
FBackColor : =clWhite ;
FAutoSize : = True ;
end ;
procedure TRotateFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ; {$IFDEF CLR}unsafe;{$ENDIF}
const
TeePiStep : Single = Pi / 180.0 ;
var tmp : TBitmap ;
x ,
y ,
xc ,
yc ,
xxc ,
yyc ,
tmpY ,
tmpX ,
h ,
w : Integer ;
f2 : TTeeFilter ;
f2Lines : PRGBs ;
xx ,
yy : Integer ;
tmpSin ,
tmpCos ,
tmpYSin ,
tmpYCos : Single ;
Sin ,
Cos : Extended ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
while Angle> 360 do
FAngle : =Angle - 360 ;
if Angle = 180 then
begin
TFlipFilter . ApplyTo (Bitmap ) ;
TReverseFilter . ApplyTo (Bitmap ) ;
end
else
if Angle<> 0 then
begin
tmp : =TBitmap . Create ;
try
h : =Bitmap . Height ;
w : =Bitmap . Width ;
if (Angle = 90 ) or (Angle = 270 ) then
TeeSetBitmapSize (tmp ,h ,w )
else
begin
SinCos ( ( 360 -Angle ) *TeePiStep , Sin , Cos ) ;
if AutoSize then
begin
if Sin *Cos> 0 then
TeeSetBitmapSize (tmp , Abs ( Round (w * Cos +h * Sin ) ) ,
Abs ( Round (w * Sin +h * Cos ) ) )
else
TeeSetBitmapSize (tmp , Abs ( Round (w *Cos -h * Sin ) ) ,
Abs ( Round (w *Sin -h * Cos ) ) ) ;
end
else
TeeSetBitmapSize (tmp ,w ,h ) ;
end ;
if (w> 1 ) and (h> 1 ) then
begin
if BackColor =clNone then
tmp . Transparent : = True
else
if BackColor<>clWhite then
with tmp . Canvas do
begin
Brush . Style : =bsSolid ;
Brush . Color : =FBackColor ;
FillRect (TeeRect ( 0 , 0 ,tmp . Width ,tmp . Height ) ) ;
end ;
f2 : =TTeeFilter . Create ( nil ) ;
try
f2 . Apply (tmp ) ;
if Angle = 90 then
begin
for y : = 0 to h - 1 do
for x : = 0 to w - 1 do
f2 . Lines [x ,h -y - 1 ] : =Lines [y ,x ] ;
end
else
if Angle = 270 then
begin
for y : = 0 to h - 1 do
for x : = 0 to w - 1 do
f2 . Lines [w -x - 1 ,y ] : =Lines [y ,x ] ;
end
else
begin
xxc : =tmp . Width div 2 ;
yyc : =tmp . Height div 2 ;
xc : =w div 2 ;
yc : =h div 2 ;
tmpSin : = Sin ;
tmpCos : = Cos ;
tmpY : =-yyc - 1 ;
for y : = 0 to tmp . Height - 1 do
begin
Inc (tmpY ) ;
tmpYSin : = (tmpY *tmpSin ) -xc ;
tmpYCos : = (tmpY *tmpCos ) +yc ;
f2Lines : =f2 . Lines [y ] ;
tmpX : =-xxc - 1 ;
for x : = 0 to tmp . Width - 1 do
begin
Inc (tmpX ) ;
xx : = Round (tmpX *tmpCos -tmpYSin ) ;
if (xx> = 0 ) and (xx<w ) then
begin
yy : = Round (tmpX *tmpSin +tmpYCos ) ;
if (yy> = 0 ) and (yy<h ) then
f2Lines [x ] : =Lines [yy ,xx ] ;
end ;
end ;
end ;
end ;
Bitmap . FreeImage ;
Bitmap . Assign (tmp ) ;
finally
f2 . Free ;
end ;
end ;
finally
tmp . Free ;
end ;
end ;
end ;
class function TRotateFilter . Description : String ;
begin
result : =TeeMsg_Rotate ;
end ;
procedure TRotateFilter . SetAngle ( const Value : Double ) ;
begin
if FAngle<>Value then
begin
FAngle : =Value ;
// Repaint;
end ;
end ;
procedure TRotateFilter . CreateEditor (Creator :IFormCreator ; AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddScroll ( 'Angle' , 0 , 360 ) ; // Do not localize
Creator . AddColor ( 'BackColor' ,TeeMsg_Back ) ; // Do not localize
Creator . AddCheckBox ( 'AutoSize' ,TeeMsg_Autosize ) ; // Do not localize
end ;
{ TMirrorFilter }
Constructor TMirrorFilter . Create (Collection : TCollection ) ;
begin
inherited ;
AllowRegion : = False ;
end ;
procedure TMirrorFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
var tmp : TBitmap ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
tmp : =TBitmap . Create ;
try
if (Direction =mdDown ) or (Direction =mdUp ) then
begin
TeeSetBitmapSize (tmp ,Bitmap . Width ,Bitmap . Height * 2 ) ;
if Direction =mdDown then
tmp . Canvas . Draw ( 0 , 0 ,Bitmap )
else
tmp . Canvas . Draw ( 0 ,Bitmap . Height ,Bitmap ) ;
TFlipFilter . ApplyTo (Bitmap ) ;
if Direction =mdDown then
tmp . Canvas . Draw ( 0 ,Bitmap . Height ,Bitmap )
else
tmp . Canvas . Draw ( 0 , 0 ,Bitmap ) ;
Bitmap . Height : =Bitmap . Height * 2 ;
end
else
begin
TeeSetBitmapSize (tmp ,Bitmap . Width * 2 ,Bitmap . Height ) ;
if Direction =mdRight then
tmp . Canvas . Draw ( 0 , 0 ,Bitmap )
else
tmp . Canvas . Draw (Bitmap . Width , 0 ,Bitmap ) ;
TReverseFilter . ApplyTo (Bitmap ) ;
if Direction =mdRight then
tmp . Canvas . Draw (Bitmap . Width , 0 ,Bitmap )
else
tmp . Canvas . Draw ( 0 , 0 ,Bitmap ) ;
Bitmap . Width : =Bitmap . Width * 2 ;
end ;
Bitmap . Canvas . Draw ( 0 , 0 ,tmp ) ;
finally
tmp . Free ;
end ;
end ;
procedure TMirrorFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddCombo ( 'Direction' ) ; // Do not localize
end ;
class function TMirrorFilter . Description : String ;
begin
result : =TeeMsg_Mirror ;
end ;
{ TTileFilter }
Constructor TTileFilter . Create (Collection : TCollection ) ;
begin
inherited ;
FNumCols : = 3 ;
FNumRows : = 3 ;
end ;
procedure TTileFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
var tmpCol ,
tmpRow ,
tmpW ,
tmpH : Integer ;
tmp : TBitmap ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
if FNumCols< 1 then FNumCols : = 1 ;
if FNumRows< 1 then FNumRows : = 1 ;
tmpW : = (R . Right -R . Left ) div FNumCols ;
tmpH : = (R . Bottom -R . Top ) div FNumRows ;
if (tmpW> 0 ) and (tmpH> 0 ) then
begin
tmp : =SmoothBitmap (Bitmap ,tmpW ,tmpH ) ;
try
for tmpCol : = 0 to FNumCols - 1 do
for tmpRow : = 0 to FNumRows - 1 do
Bitmap . Canvas . Draw (tmpCol *tmpW ,tmpRow *tmpH ,tmp ) ;
finally
tmp . Free ;
end ;
end ;
end ;
procedure TTileFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddInteger ( 'NumCols' ,TeeMsg_Columns , 1 , 1000 ) ; // Do not localize
Creator . AddInteger ( 'NumRows' ,TeeMsg_Rows , 1 , 1000 ) ; // Do not localize
end ;
class function TTileFilter . Description : String ;
begin
result : =TeeMsg_Tile ;
end ;
{ TBevelFilter }
Constructor TBevelFilter . Create (Collection : TCollection ) ;
begin
inherited ;
FBright : = 64 ;
FSize : = 15 ;
end ;
procedure TBevelFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
var t ,
x ,y ,
h2 ,w2 ,
x1 ,x2 ,
y1 ,y2 : Integer ;
begin
inherited ;
if Length (Lines ) = 0 then
Exit ;
x1 : =R . Left ;
x2 : =R . Right ;
y1 : =R . Top ;
y2 : =R . Bottom ;
w2 : = (R . Right -R . Left ) div 2 ;
h2 : = (R . Bottom -R . Top ) div 2 ;
for t : = 0 to FSize - 1 do
begin
if t<h2 then
for x : =R . Left +t to R . Right -t do
begin
with Lines [y1 ,x ] do
begin
if Red +Bright> 255 then Red : = 255
else Inc (Red ,Bright ) ;
if Green +Bright> 255 then Green : = 255
else Inc (Green ,Bright ) ;
if Blue +Bright> 255 then Blue : = 255
else Inc (Blue ,Bright ) ;
end ;
with Lines [y2 ,x ] do
begin
if Red -Bright< 0 then Red : = 0
else Dec (Red ,Bright ) ;
if Green -Bright< 0 then Green : = 0
else Dec (Green ,Bright ) ;
if Blue -Bright< 0 then Blue : = 0
else Dec (Blue ,Bright ) ;
end ;
end ;
Inc (y1 ) ;
Dec (y2 ) ;
if t<w2 then
for y : =R . Top +t + 1 to R . Bottom -t do
begin
with Lines [y ,x1 ] do
begin
if Red +Bright> 255 then Red : = 255
else Inc (Red ,Bright ) ;
if Green +Bright> 255 then Green : = 255
else Inc (Green ,Bright ) ;
if Blue +Bright> 255 then Blue : = 255
else Inc (Blue ,Bright ) ;
end ;
with Lines [y ,x2 ] do
begin
if Red -Bright< 0 then Red : = 0
else Dec (Red ,Bright ) ;
if Green -Bright< 0 then Green : = 0
else Dec (Green ,Bright ) ;
if Blue -Bright< 0 then Blue : = 0
else Dec (Blue ,Bright ) ;
end ;
end ;
Inc (x1 ) ;
Dec (x2 ) ;
end ;
end ;
procedure TBevelFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddScroll ( 'Bright' , 1 , 255 ) ; // Do not localize
Creator . AddScroll ( 'Size' , 1 , 1000 ) ; // Do not localize
end ;
class function TBevelFilter . Description : String ;
begin
result : =TeeMsg_Bevel ;
end ;
{ TZoomFilter }
Constructor TZoomFilter . Create (Collection : TCollection ) ;
begin
inherited ;
FPercent : = 10 ;
end ;
procedure TZoomFilter . Apply (Bitmap : TBitmap ; const R : TRect ) ;
var w ,h ,
wp ,hp : Integer ;
procedure DoCrop (ALeft ,ATop : Integer ; ABitmap :TBitmap ) ;
begin
with TCropFilter . Create ( nil ) do
try
Left : =ALeft +wp ;
Top : =ATop +hp ;
Width : = Max ( 1 ,w - 2 *wp ) ;
Height : = Max ( 1 ,h - 2 *hp ) ;
Smooth : = Self . Smooth ;
Apply (ABitmap ,R ) ;
finally
Free ;
end ;
end ;
var tmp : TBitmap ;
begin
w : =R . Right -R . Left + 1 ;
h : =R . Bottom -R . Top + 1 ;
wp : = Round (FPercent *w * 0.005 ) ;
hp : = Round (FPercent *h * 0.005 ) ;
if (Bitmap . Width =w ) and (Bitmap . Height =h ) then
DoCrop (R . Left ,R . Top ,Bitmap )
else
begin
tmp : =TBitmap . Create ;
try
TeeSetBitmapSize (tmp ,w ,h ) ;
tmp . Canvas . CopyRect (TeeRect ( 0 , 0 ,w ,h ) ,Bitmap . Canvas ,R ) ;
DoCrop ( 0 , 0 ,tmp ) ;
Bitmap . Canvas . Draw (R . Left ,R . Top ,tmp ) ;
finally
tmp . Free ;
end ;
end ;
end ;
procedure TZoomFilter . CreateEditor (Creator : IFormCreator ;
AChanged : TNotifyEvent ) ;
begin
inherited ;
Creator . AddScroll ( 'Percent' , 0 , 100 ) ; // Do not localize
Creator . AddCheckBox ( 'Smooth' ,TeeMsg_Smooth ) ; // Do not localize
end ;
class function TZoomFilter . Description : String ;
begin
result : =TeeMsg_Zoom ;
end ;
procedure RotateGradient (Gradient :TCustomTeeGradient ; ABitmap :TBitmap ) ;
begin
with TRotateFilter . Create ( nil ) do
try
Angle : =Gradient . Angle ;
Apply (ABitmap ) ;
finally
Free ;
end ;
end ;
// This procedure will convert all pixels in ABitmap to levels of gray
Procedure TeeGrayScale (ABitmap :TBitmap ; Inverted : Boolean ; AMethod : Integer ) ;
var tmp : TGrayScaleFilter ;
begin
tmp : =TGrayScaleFilter . Create ( nil ) ;
try
if AMethod<> 0 then tmp . Method : =gmEye ;
tmp . Apply (ABitmap ) ;
finally
tmp . Free ;
end ;
if Inverted then
TInvertFilter . ApplyTo (ABitmap ) ;
end ;
initialization
TeeRegisterFilters ( [ TInvertFilter ,
TGrayScaleFilter ,
TMosaicFilter ,
TFlipFilter ,
TReverseFilter ,
TBrightnessFilter ,
TContrastFilter ,
TColorFilter ,
THueLumSatFilter ,
TBlurFilter ,
TSharpenFilter ,
TGammaCorrectionFilter ,
TEmbossFilter ,
TSoftenFilter ,
TCropFilter ,
TResizeFilter ,
TRotateFilter ,
TMirrorFilter ,
TTileFilter ,
TBevelFilter ,
TZoomFilter ] ) ;
TeeGradientRotate : =RotateGradient ;
finalization
TeeGradientRotate : = nil ;
FreeAndNil (FilterClasses ) ;
end .