FastiImage.pas

Top  Previous  Next

unit FastImage;

 

//release 0.6;

 

//  Contributors:

//

//  Gordon Alex Cowie III (aka "GoRDy") <gfody@jps.net>

//  www.jps.net/gfody (currently down (jps sucks fat cock))

//  TFastBMP unit.

//

//  Andreas Goransson <andreas.goransson@epk.ericsson.se>

//   -Texture filter

//   -Added some optimizations here an there

//

//  Earl F. Glynn <earlglynn@att.net>

//   -Rotation optimizations

//   -Computer lab: www.infomaster.net/external/efg/

//

//  Vit Kovalcik <vkovalcik@iname.com>

//   -Optimized Resize method

//   -Check out UniDib for 4,8,16,24,32 bit dibs!

//   -www.geocities.com/SiliconValley/Hills/1335/

//

//  Anders Melander <anders@melander.dk>

//  David Ullrich <ullrich@hardy.math.okstate.edu>

//  Dale Schumacher

//   -Bitmap Resampler

 

//  "William W. Miller, Jr." <w2m@netheaven.com>

//  http://www.software.adirondack.ny.us

//  - rubberbanding and selections.

//  - Smooth rotating and scaling.

 

interface

 

uses

Windows, Classes, Controls, forms, dialogs,

ExtCtrls,filectrl,stdctrls,sysutils,fastBMP,graphics,clipbrd;

 

type

  PBytes = ^TBytes;

  TBytes = array [0..MaxInt-1] of Byte;

  type pBigBytes=^TBytes;

 

 

  TThreeBytes = array [0..2] of Byte;

 

type

TFastImage = class(TScrollBox)

private

        FBMP : TFastBMP;

        FPaintBox:TPaintBox;

        FFilename : string;

        FAutosize : Boolean;

        FStretch  : Boolean;

        FTiling   : Boolean;

        FFillColor: TFColor;

        FLineColor: TFColor;

        FSelection: Boolean;

        RLine,BLine,GLine,RFill,BFill,GFill:byte; 

        XOrigin,YOrigin,XFinal,YFinal : Integer;

        Timer1:TTimer;

        FCLWHITE,FCLRED:TFColor;

        procedure SetFileName(name:string);

        procedure SetWidth(value:integer);

        procedure SetHeight(value:integer);

        Function GetWidth:integer;      

        Function GetHeight:integer;

        procedure SetFillColor(color:TFColor);

        procedure SetLineColor(color:TFColor);

        function GetFillColor:TFColor;

        function GetLineColor:TFColor;

        procedure RemoveTheRect;

        procedure DrawTheRect;

public

       constructor Create(AOwner:TComponent);override;

       destructor Destroy;override;

protected

       procedure paint(sender:TObject);

       procedure CheckSize(sender:TObject);

       procedure MouseDownOnPicture(Sender: TObject;

             Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

       procedure MouseMoveOnPicture(Sender: TObject; Shift: TShiftState; X, Y: Integer);

       procedure MouseUpOnPicture(Sender: TObject;

             Button: TMouseButton; Shift: TShiftState; X, Y: Integer);

published

       property Filename : string read FFilename write SetFilename;

       property Autosize : boolean read FAutosize write FAutosize;

       property Stretch  : boolean read FStretch write FStretch;

       property Selection  : boolean read FSelection write FSelection;

       property FastBMP  : TFastBMP read FBMP write FBMP;

       property Tiling  : Boolean read FTiling write FTiling;

       property PictureWidth: integer read GetWidth write SetWidth;

       property PictureHeight: integer read GetHeight write SetHeight;

       property FillColor:TFColor read GetFillColor write SetFillColor;

       property LineColor:TFColor read GetLineColor write SetLineColor;

       procedure Flip;

       procedure Mirror;

       procedure Rotate(degree:extended;Smooth:Boolean);

       procedure AddNoiseFilter(value:byte);

       procedure SandyFilter(value:byte);

       procedure SprayFilter(value:byte);

       procedure BlurFilter(value:byte);

       procedure WaveFilter(XDIV,YDIV,RatioVal:byte);

       procedure WaveWrapFilter(XDIV,YDIV,RatioVal:byte);

       procedure SmoothPoint(xk,yk:integer);

       procedure AntiAliasRect(XOrigin,YOrigin,XFinal,YFinal : Integer);

       procedure AntiAlias;

       procedure Sharpen;

       procedure DiscardColor;

       procedure SplitBlur(Amount:Integer);

       procedure GaussianBlur(Amount:Integer);

       procedure Resample(w,h:integer;Filter:TFilterProc;FWidth:Single);

       procedure Update;

       Procedure HorGradientLine(XOrigin,XFinal,y:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);

       Procedure Column(XOrigin,XFinal,YOrigin,YFinal:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);

       procedure Sphere(xcenter,a,ycenter,b:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);

       procedure GrayScale;

       procedure TurnCW;

       procedure TurnCCW;

       procedure HScroll(Amount:Integer);

       procedure VScroll(Amount:Integer);

       procedure HorLine(XOrigin,XFinal,y:Integer);

       procedure VertLine(x,YOrigin,YFinal:integer);

       procedure Rectangle(XOrigin,YOrigin,XFinal,YFinal:integer);

       procedure OpenPCD(filename:string;PCDsize:integer);

       procedure Timer(Sender: TObject);

       procedure RotatePicture(from_FastBMP, to_FastBMP : TFastBmp;theta : Single;

                 from_x1, from_y1, from_x2, from_y2 : Integer;

                 to_x1, to_y1, to_x2, to_y2 : Integer);

       procedure GetRotatedSize(theta : Single;old_width, old_height : Integer;

                 var new_width, new_height : Integer);

       procedure SmoothRotate(Angle:extended);

       procedure SmoothScale(scale:single);

       procedure ShrinkPicture(

                 from_FastBMP, to_FastBMP : TFastBMP;

                 from_x1, from_y1, from_x2, from_y2 : Integer;

                 to_x1, to_y1, to_x2, to_y2 : Integer);

       procedure EnlargePicture(

                 from_FastBMP, to_FastBMP : TFastBMP;

                 from_x1, from_y1, from_x2, from_y2 : Integer;

                 to_x1, to_y1, to_x2, to_y2 : Integer);

       procedure InterpolateRect(x1,y1,x2,y2:Integer;c00,c10,c01,c11:TFColor);

       procedure SelectAll;

       procedure Copy;

       procedure Contrast(Amount:Integer);

       procedure Saturation(Amount:Integer);

       procedure Lightness(Amount:Integer);

 

end;

 

procedure Register;

 

implementation

 

var

        Counter : Byte;

        CounterStart : Byte;

        Looper : LongInt;

 

constructor TFastImage.Create(AOwner:TComponent);

begin

inherited Create(AOwner);

Fautosize:=true;

width:=260;

height:=260;

FFillColor.r:=255;

FFillColor.g:=255;

FFillColor.b:=255;

RLine:=0;GLine:=0;BLine:=0;

RFill:=255;GFill:=255;BFill:=255;

FLineColor.r:=0;

FLineColor.g:=0;

FLineColor.b:=0;

FBMP:=TFastBMP.Create(256,256);

FPaintBox:=TPaintBox.Create(self);

FPaintBox.Width:=256;

FPaintBox.Height:=256;

FPaintBox.Top:=0;

FPaintBox.Left:=0;

FPaintBox.OnPaint:=paint;

insertcontrol(FPaintBox);

OnResize:=CheckSize;

 

XOrigin := 0; YOrigin := 0;

XFinal := 0; YFinal := 0;

FPaintBox.Canvas.Pen.Color := Color;

FPaintBox.Canvas.Brush.Color := Color;

FPaintBox.OnMouseDown:=mousedownOnPicture;

FPaintBox.OnMouseUp:=mouseUpOnPicture;

FPaintBox.OnMouseMove:=mouseMoveOnPicture;

CounterStart := 128;

Timer1:=TTimer.Create(self);

Timer1.Interval := 100;

Timer1.Enabled := True;

Looper := 0;

Timer1.OnTimer:=Timer;

FCLWHITE:=FRGB(255,255,255);

FCLRED:=FRGB(255,0,0);

end;

 

destructor TFastImage.Destroy;

begin

if Timer1<>nil then timer1.free;

if FBMP<>nil then FBMP.free;

if FPaintBox<>nil then FPaintBox.free;

inherited Destroy;

end;

 

 

{==============================================================================}

function NormalizeRect(R: TRect): TRect;

{==============================================================================}

begin

// This routine normalizes a rectangle. It makes sure that the Left,Top

// coords are always above and to the left of the Bottom,Right coords.

with R do

   if Left > Right then

     if Top > Bottom then

       Result := Rect(Right,Bottom,Left,Top)

     else

       Result := Rect(Right,Top,Left,Bottom)

   else

     if Top > Bottom then

       Result := Rect(Left,Bottom,Right,Top)

     else

       Result := Rect(Left,Top,Right,Bottom);

end;

 

 

 

{==============================================================================}

procedure TFastImage.RemoveTheRect;

{==============================================================================}

var

R : TRect;

begin

R := NormalizeRect(Rect(XOrigin,YOrigin,XFinal,YFinal));  // Rectangle might be flipped

InflateRect(R,1,1);                     // Make the rectangle 1 pixel larger

InvalidateRect(Handle,@R,True);         // Mark the area as invalid

InflateRect(R,-2,-2);                   // Now shrink the rectangle 2 pixels

ValidateRect(Handle,@R);                // And validate this new rectangle.

// This leaves a 2 pixel band all the way around

// the rectangle that will be erased & redrawn

UpdateWindow(Handle);

end;

 

{==============================================================================}

procedure MovingDots(X,Y: Integer; TheCanvas: TCanvas); stdcall;

{==============================================================================}

begin

Inc(Looper);

Counter := Counter shl 1;              // Shift the bit left one

if Counter = 0 then Counter := 1;      // If it shifts off left, reset it

if (Counter and 224) > 0 then          // Are any of the left 3 bits set?

   TheCanvas.Pixels[X,Y] := clWhite     // Erase the pixel

else

   TheCanvas.Pixels[X,Y] := clBlack;    // Draw the pixel

end;

 

 

{==============================================================================}

procedure TFastImage.DrawTheRect;

{==============================================================================}

var Y,X:integer;

begin

// Determines starting pixel color of Rect

Counter := CounterStart;

// Use LineDDA to draw each of the 4 edges of the rectangle 

Update;

LineDDA(XOrigin,YOrigin,XFinal,YOrigin,@MovingDots,LongInt(FPaintBox.Canvas));

LineDDA(XFinal,YOrigin,XFinal,YFinal,@MovingDots,LongInt(FPaintBox.Canvas));

LineDDA(XFinal,YFinal,XOrigin,YFinal,@MovingDots,LongInt(FPaintBox.Canvas));

LineDDA(XOrigin,YFinal,XOrigin,YOrigin,@MovingDots,LongInt(FPaintBox.Canvas));

end;

 

{==============================================================================}

procedure TFastImage.Timer(Sender: TObject);

{==============================================================================}

begin

CounterStart := CounterStart shr 2;           // Shl 1 will move rect slower

if CounterStart = 0 then CounterStart := 128; // If bit is lost, reset it

if selection then DrawTheRect;                                  // Draw the rectangle

end;

 

 

{==============================================================================}

procedure TFastImage.MouseDownOnPicture(Sender: TObject; Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

{==============================================================================}

begin

if FSelection then

   begin

   RemoveTheRect;                               // Erase any existing rectangle

   XOrigin := X; YOrigin := Y; XFinal := X; YFinal := Y;

   end;

end;

 

{==============================================================================}

procedure TFastImage.MouseUpOnPicture(Sender: TObject;Button: TMouseButton;

Shift: TShiftState; X, Y: Integer);

{==============================================================================}

begin

 

end;

 

{==============================================================================}

procedure TFastImage.MouseMoveOnPicture(Sender: TObject;Shift: TShiftState; X,

Y: Integer);

{==============================================================================}

begin

if (ssLeft in Shift) and selection then

   begin

     RemoveTheRect;         // Erase any existing rectangle

     XFinal := X; YFinal := Y;      // Save the new corner where the mouse is

     DrawTheRect;           // Draw the Rect now... don't wait for the timer!

   end;

end;

 

procedure TFastImage.SelectAll;

begin

XOrigin :=0;

YOrigin :=0;

XFinal := FBMP.Width-1;

YFinal := FBMP.Height-1;

end;

 

procedure TFastImage.Copy;

var FBMPCopy:TFastBMP;

   Line1,Line2:PLine;

   i,j:integer;

   bitmap:TBitmap;

   MyFormat : Word;

   AData,APalette : THandle;

 

begin

FBMPCopy:=TFastBmp.Create(XFinal-XOrigin+1,YFinal-YOrigin+1);

GetMem(Line1,FBMP.width*3);

GetMem(Line2,FBMPCopy.width*3);

for j:=0 to FBMPCopy.height-1 do

begin

FBMP.GetScanLine(j+Yorigin,Line1);

for i:=0 to FBMPCopy.width-1 do

      begin

      Line2^[i].r:=Line1^[i+Xorigin].r;

      Line2^[i].g:=Line1^[i+Xorigin].g;

      Line2^[i].b:=Line1^[i+Xorigin].b;

      end;

FBMPCopy.ScanLines[j]:=Line2;

end;

FreeMem(Line1,FBMP.width*3);

FreeMem(Line2,FBMPCopy.width*3);

bitmap:=TBitmap.Create;

bitmap.Width:=FBMPCopy.Width;

bitmap.height:=FBMPCopy.Height;

FBMPCopy.Draw(bitmap.Canvas.Handle,0,0);

FBMPCopy.Free;

bitmap.SaveToClipBoardFormat(MyFormat,AData,APalette);

ClipBoard.SetAsHandle(MyFormat,AData);

bitmap.Free;

end;

 

procedure TFastImage.SetWidth(value:integer);

begin

FBMP.Width:=value;

FPaintBox.Width:=value;

CheckSize(self);

end;

 

procedure TFastImage.SetFillColor(color:TFColor);

begin

FFillColor:=color;

RFill:=color.r;

GFill:=color.g;

BFill:=color.b;

end;

 

procedure TFastImage.SetLineColor(color:TFColor);

begin

FLineColor:=color;

RLine:=color.r;

GLine:=color.g;

BLine:=color.b;

end;

 

 

procedure TFastImage.Setheight(value:integer);

begin

FBMP.height:=value;

FPaintBox.height:=value;

CheckSize(self);

end;

 

function TFastImage.GetWidth:integer;

begin

result:=FBMP.width;

end;

 

function TFastImage.Getheight:integer;

begin

result:=FBMP.height;

end;

 

function TFastImage.GetFillColor:TFColor;

begin

result:=FFillColor;

end;

 

function TFastImage.GetLineColor:TFColor;

begin

result:=FLineColor;

end;

 

procedure TFastImage.Update;

begin

paint(self);

end;

 

 

procedure TFastImage.Resample(w,h:integer;Filter:TFilterProc;FWidth:Single);

var

Bit: TFastBmp;

begin

Bit:=TFastBmp.Create(w,h);

FBMP.Resample(Bit,filter,FWidth);

FBMP.Free;

FBMP:=TFastBmp.CreateCopy(Bit);

Bit.Free;

FPaintBox.Width:=w; 

FPaintBox.height:=h;

CheckSize(self);

Update;

end;

 

procedure TFastImage.AddNoiseFilter(value:byte);

begin

FBMP.AddColorNoise(value);

Update;

end;

 

procedure TFastImage.SandyFilter(value:byte);

begin

FBMP.AddMonoNoise(value);

Update;

end;

 

 

procedure TFastImage.SprayFilter(value:byte);

begin

FBMP.Spray(FBMP,value);

Update;

end;

 

procedure TFastImage.BlurFilter(value:byte);

begin

FBMP.SplitBlur(value);

Update;

end;

 

procedure TFastImage.WaveFilter(XDIV,YDIV,RatioVal:byte);

begin

FBMP.Wave(FBMP,XDIV,YDIV,RatioVal);

Update;

end;

 

procedure TFastImage.WaveWrapFilter(XDIV,YDIV,RatioVal:byte);

begin

FBMP.WaveWrap(FBMP,XDIV,YDIV,RatioVal);

Update;

end;

 

procedure TFastImage.SmoothPoint(xk,yk:integer);

var Bleu, Vert, Rouge: Integer;

  color:TFColor;

  BB,GG,RR: array[1..5] of Integer;

begin

if (xk>0) and (yk>0) and (xk<FBMP.width-1) and (yk<FBMP.height-1) then

    begin

    color:=FBMP.pixels[xk,yk-1];

    RR[1]:=color.r;

    GG[1]:=color.g;

    BB[1]:=color.b;

    color:=FBMP.pixels[xk+1,yk];

    RR[2]:=color.r;

    GG[2]:=color.g;

    BB[2]:=color.b;

    color:=FBMP.pixels[xk,yk+1];

    RR[3]:=color.r;

    GG[3]:=color.g;

    BB[3]:=color.b;

    color:=FBMP.pixels[xk-1,yk];

    RR[4]:=color.r;

    GG[4]:=color.g;

    BB[4]:=color.b;

    Bleu :=(BB[1]+(BB[2]+BB[3]+BB[4]))div 4;           (* Valeur moyenne *)

    Vert:=(GG[1]+(GG[2]+GG[3]+GG[4]))div 4;           (* en cours d'‚valuation        *)

    Rouge  :=(RR[1]+(RR[2]+RR[3]+RR[4]))div 4;

    color.r:=rouge;

    color.g:=vert;

    color.b:=bleu;

    FBMP.pixels[xk,yk]:=color;

    end;

end;

 

 

procedure TFastImage.AntiAliasRect(XOrigin,YOrigin,XFinal,YFinal : Integer);

var Memo,xk,yk: Integer; (* Composantes primaires des points environnants *)

begin

  if XFinal<XOrigin then begin Memo:=XOrigin; XOrigin:=XFinal; XFinal:=Memo; end;  (* Inversion des valeurs   *)

  if YFinal<YOrigin then begin Memo:=YOrigin; YOrigin:=YFinal; YFinal:=Memo; end;  (* si diff‚rence n‚gative*)

  XOrigin:=XOrigin-1;YOrigin:=YOrigin-1 ;  (* Lisser aussi les limites sup‚rieure et gauche du domaine    *)

  if XOrigin<1 then XOrigin:=1;       if YOrigin<1 then YOrigin:=1;         (* Limites du domaine  *)

  XFinal:=XFinal-1;  YFinal:=YFinal-1;

  for yk:=YOrigin to YFinal do                              (* Fonction Bloc    *)

   for xk:=XOrigin to XFinal do SmoothPoint(xk,yk);

end;

 

 

procedure TFastImage.AntiAlias;

begin

AntiAliasRect(0,0,FBMP.width-1,FBMP.height-1);

end;

 

procedure TFastImage.Sharpen;

begin

FBMP.Sharpen;

Update;

end;

 

procedure TFastImage.DiscardColor;

begin

FBMP.DiscardColor;

Update;

end;

 

procedure TFastImage.SplitBlur(Amount:Integer);

begin

FBMP.SplitBlur(Amount);

Update;

end;

 

procedure TFastImage.GaussianBlur(Amount:Integer);

begin

FBMP.GaussianBlur(Amount);

Update;

end;

 

procedure TFastImage.Flip;

begin

FBMP.Flop;

Update;

end;

 

 

procedure TFastImage.Mirror;

begin

FBMP.Flip;

Update;

end;

 

procedure TFastImage.Rotate(degree:extended;Smooth:Boolean);

var Bit:   TFastBmp;

begin

Bit:=TFastBmp.CreateCopy(FBMP);

Bit.RotateWrap(FBMP,degree,FBMP.Width div 2,FBMP.height div 2);

if smooth then AntiAlias;

Update;

end;

 

procedure TFastImage.SetFileName(name:string);

begin

FFilename:=name;

if extractfileext(FFilename)='.pcd' then OpenPCD(FFilename,3) else

FBMP.CreateFromFile(FFilename);

FPaintBox.width:=FBMP.width;

FPaintBox.height:=FBMP.height;

CheckSize(self);

Update;

end;

 

procedure TFastimage.Paint(sender:TObject);

begin

if FBMP<>nil then

  begin

  if not (FStretch and Ftiling) then FBMP.Draw(FPaintBox.Canvas.Handle,0,0) else

     if not FTiling then FBMP.Stretch(FPaintBox.Canvas.Handle,0,0,width-4,height-4) else FBMP.TileDraw(FPaintBox.Canvas.Handle,0,0,width-4,height-4);

  end;

 

end;

 

procedure TFastimage.CheckSize(sender:TObject);

begin

if FAutoSize and (align=alNone) then

     begin

     if width<>FBMP.width+4 then width:=FBMP.width+4;

     if height<>FBMP.height+4 then height:=FBMP.height+4;

     end;

end;

 

Procedure TFastimage.HorGradientLine(XOrigin,XFinal,y:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);

var r,g,b,i:integer;

   valueR,ValueG,ValueB,advalR,advalB,advalG:single;

   Line: PLine;

Begin

if (y>=0) and (y<FBMP.height) then

begin

if XOrigin>XFinal then

  begin

  i:=XOrigin;

  XOrigin:=XFinal;

  XFinal:=i;

  end;

if XFinal<>XOrigin then

  begin

  advalR:=(r2-r1)/(XFinal-XOrigin);

  advalG:=(g2-g1)/(XFinal-XOrigin);

  advalB:=(b2-b1)/(XFinal-XOrigin);

  end

else

  begin

  advalR:=0;

  advalG:=0;

  advalB:=0;

  end;

 

valueR:=r1;

valueG:=g1;

valueB:=b1;

GetMem(Line,FBMP.width*3);

FBMP.GetScanLine(y,Line);

for i:= XOrigin to XFinal do

   begin

   valueR:=valueR+advalR;

   r:=round(ValueR); if r>255 then r:=255; if r<0 then r:=0;

   valueG:=valueG+advalG;

   g:=round(ValueG); if g>255 then g:=255; if g<0 then g:=0;

   valueB:=valueB+advalB;

   b:=round(ValueB); if b>255 then b:=255; if b<0 then b:=0;

   if (i>=0) and (i<FBMP.width) then

      begin

      Line^[i].r:=r;

      Line^[i].g:=g;

      Line^[i].b:=b;

      end;

   end;

FBMP.ScanLines[y]:=Line;

FreeMem(Line,FBMP.width*3);

if smooth then

   begin

   SmoothPoint(XOrigin-1,y);

   SmoothPoint(XFinal+1,y);

   end;

end;

End;

 

Procedure TFastimage.Column(XOrigin,XFinal,YOrigin,YFinal:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);

var j:integer;

begin

for j:=YOrigin to YFinal do HorGradientLine(XOrigin,XFinal,j,r1,g1,b1,r2,g2,b2,smooth);

end;

 

procedure TFastimage.Sphere(xcenter,a,ycenter,b:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);

var                                        (* Dessine un disque color‚*)

  zz,xx,yy: Integer;                        (* par remplissage avec Couleur1-2 *)

  compt,x_ll,y_ll,x_ray,y_ray: Longint;

begin

  xx:=0; yy:=b;

  x_ray:= 2*a*a;y_ray:=2*b*b;

  x_ll:=1; y_ll:=x_ray *b-1 ;

  compt := y_ll div 2;

  while yy>=0 do begin

   HorGradientLine(xcenter-xx,xcenter+xx,ycenter+yy,r1,g1,b1,r2,g2,b2,smooth);

   HorGradientLine(xcenter-xx,xcenter+xx,ycenter-yy,r1,g1,b1,r2,g2,b2,smooth);

   if compt>=0 then begin

    x_ll:= x_ll + y_ray;

    compt:= compt-x_ll -1;

    xx:=xx+1;

   end;

   if compt<0 then begin

    y_ll:= y_ll - x_ray;

    compt:= compt+y_ll -1;

    yy:=yy-1;

   end;

  end;

end;

 

procedure TFastimage.GrayScale;

begin

FBMP.GrayScale;

Update;

end;

 

procedure TFastimage.TurnCW;

begin

FBMP.TurnCW;

Update;

end;

 

procedure TFastimage.TurnCCW;

begin

FBMP.TurnCCW;

Update;

end;

 

procedure TFastimage.HScroll(Amount:Integer);

begin

FBMP.VertRoll(amount);

Update;

end;

 

procedure TFastimage.VScroll(Amount:Integer);

begin

FBMP.HorzRoll(amount);

Update;

end;

 

procedure TFastimage.HorLine(XOrigin,XFinal,y:Integer);

var i:integer;

   Line:PLine;

begin

GetMem(Line,FBMP.width*3);

FBMP.GetScanLine(y,Line);

for i:=XOrigin to XFinal do

   begin

   Line^[i].r:=RLine;

   Line^[i].g:=GLine;

   Line^[i].b:=BLine;

   end;

FBMP.ScanLines[y]:=Line;

FreeMem(Line,FBMP.width*3);

end;

 

procedure TFastimage.VertLine(x,YOrigin,YFinal:integer);

var j:integer;

begin

for j:=YOrigin to YFinal do FBMP.Pixels[x,j]:=FLineColor;

end;

 

procedure TFastimage.Rectangle(XOrigin,YOrigin,XFinal,YFinal:integer);

var i,j:integer;

   Line:PLine;

begin

GetMem(Line,FBMP.width*3);

 

FBMP.GetScanLine(YOrigin,Line);

for i:=XOrigin to XFinal do

   begin

   Line^[i].r:=RLine;

   Line^[i].g:=GLine;

   Line^[i].b:=BLine;

   end;

FBMP.ScanLines[YOrigin]:=Line;

 

FBMP.GetScanLine(YFinal,Line);

for i:=XOrigin to XFinal do

   begin

   Line^[i].r:=RLine;

   Line^[i].g:=GLine;

   Line^[i].b:=BLine;

   end;

FBMP.ScanLines[YFinal]:=Line;

 

for j:= YOrigin+1 to YFinal-1 do

   begin

   FBMP.GetScanLine(j,Line);

   Line^[XOrigin].r:=RLine;

   Line^[XOrigin].g:=GLine;

   Line^[XOrigin].b:=BLine;   

   Line^[XFinal].r:=RLine;

   Line^[XFinal].g:=GLine;

   Line^[XFinal].b:=BLine;

   for i:=XOrigin+1 to XFinal-1 do

       begin

       Line^[i].r:=RFill;

       Line^[i].g:=GFill;

       Line^[i].b:=BFill;

       end;

   FBMP.ScanLines[j]:=Line;

   end;

FreeMem(Line,FBMP.width*3);

end;

 

Procedure YCbCr2RGB(Y,Cb,Cr:integer; Var r,g,b:integer);

Const C=256;

     c11:real= 0.0054980*C;

     c12:real= 0.0000000*C;

     c13:real= 0.0051681*C;

     c21:real= 0.0054980*C;

     c22:real=-0.0015446*C;

     c23:real=-0.0026325*C;

     c31:real= 0.0054980*C;

     c32:real= 0.0079533*C;

     c33:real= 0.0000000*C;

Begin

r:=round(c11*Y +c12*(Cb-156) +c13*(Cr-137));

g:=round(c21*Y +c22*(Cb-156) +c23*(Cr-137));

b:=round(c31*Y +c32*(Cb-156) +c33*(Cr-137));

If r<0   Then r:=0;

If g<0   Then g:=0;

If b<0   Then b:=0;

If r>255 Then r:=255;

If g>255 Then g:=255;

If b>255 Then b:=255;

End;

 

procedure TFastimage.OpenPCD(filename:string;PCDsize:integer);

var W,H,X,Y,R,G,B:integer;

   YOrigin,YFinal,CbCr:PBytes;

   Abort: Boolean;

   Stream:TFilestream;

   Line:PLine;

begin

Stream:=TFilestream.Create(filename,fmOpenReadWrite);

Case PCDsize Of

     1: Begin

          W:=192;

          H:=128;

          Stream.seek($2000,soFromBeginning);

        End;

     2: Begin

          W:=384;

          H:=256;

          Stream.seek($B800,soFromBeginning);

        End;

     3: Begin

          W:=768;

          H:=512;

          Stream.seek($30000,soFromBeginning);

        End;

   End;

try

FBMP.Free;

FBMP:=TFastBmp.Create(W, H);

GetMem(YOrigin, w);

GetMem(YFinal, w);

GetMem(CbCr, w);

GetMem(Line,FBMP.width*3);

try

For y:=0 To (h Div 2)-1 Do

   Begin

   Stream.ReadBuffer(YOrigin^, w);

   Stream.ReadBuffer(YFinal^, w);

   Stream.ReadBuffer(CbCr^, w);

   For x:=0 To w-1 Do

     Begin

       YCbCr2RGB(YOrigin^[x],CbCr^[x Div 2],CbCr^[(w Div 2)+(x Div 2)],r,g,b);

       Line^[x].r:=r;

       Line^[x].g:=g;

       Line^[x].b:=b;

     End;

   FBMP.ScanLines[y*2]:=Line;

   For x:=0 To w-1 Do

     Begin

       YCbCr2RGB(YFinal^[x],CbCr^[x Div 2],CbCr^[(w Div 2)+(x Div 2)],r,g,b);

       Line^[x].r:=r;

       Line^[x].g:=g;

       Line^[x].b:=b;

     End;

   FBMP.ScanLines[y*2+1]:=Line;

   end;

finally

end; // try/finally

finally

freemem(YOrigin);

freemem(YFinal);

freemem(CbCr);    

stream.Free;

FreeMem(Line,FBMP.width*3);

end; // try/finally

end;

 

 

// Calculate the height and width of the rotated picture.

procedure TFastimage.GetRotatedSize(

   theta : Single;

   old_width, old_height : Integer;

   var new_width, new_height : Integer);

begin

   new_width  := Round(

       Abs(old_width  * Cos(theta)) +

       Abs(old_height * Sin(theta)));

   new_height := Round(

       Abs(old_width  * Sin(theta)) +

       Abs(old_height * Cos(theta)));

end;

 

// Rotate the picture in from_canvas around its center

// through the angle theta in radians placing the result

// in the center of to_canvas.

procedure TFastimage.RotatePicture(

   from_FastBMP, to_FastBMP : TFastBmp;

   theta : Single;

   from_x1, from_y1, from_x2, from_y2 : Integer;

   to_x1, to_y1, to_x2, to_y2 : Integer);

var

   sin_theta, cos_theta   : Single;

   from_cx, from_cy       : Single;

   to_cx, to_cy           : Single;

   sfrom_y, sfrom_x       : Single;

   ifrom_y, ifrom_x       : Integer;

   to_y, to_x             : Integer;

   weight_x, weight_y     : array[0..1] of Single;

   weight                 : Single;

   new_red, new_green     : Integer;

   new_blue               : Integer;

   total_red, total_green : Single;

   total_blue             : Single;

   ix, iy                 : Integer;

   color                  :TFColor;   

   line:PLine;

begin

GetMem(Line,to_FastBMP.width*3);

   // Calculate the sine and cosine of theta for later.

   sin_theta := Sin(theta);

   cos_theta := Cos(theta);

 

   // Find the centers of the canvases.

   from_cx := (from_x2 - from_x1) / 2;

   from_cy := (from_y2 - from_y1) / 2;

   to_cx := (to_x2 - to_x1) / 2;

   to_cy := (to_y2 - to_y1) / 2;

 

   // Perform the rotation.

   for to_y := to_y1 to to_y2 do

   begin

   to_FastBMP.GetScanLine(to_y,Line);

       for to_x := to_x1 to to_x2 do

       begin

           // Find the location (from_x, from_y) that

           // rotates to position (to_x, to_y).

           sfrom_x := from_cx +

               (to_x - to_cx) * cos_theta -

               (to_y - to_cy) * sin_theta;

           ifrom_x := Trunc(sfrom_x);

 

           sfrom_y := from_cy +

               (to_x - to_cx) * sin_theta +

               (to_y - to_cy) * cos_theta;

           ifrom_y := Trunc(sfrom_y);

 

           // Only process this pixel if all four

           // adjacent input pixels are inside the

           // allowed input area.

           if (ifrom_x >= from_x1) and

              (ifrom_x <  from_x2) and

              (ifrom_y >= from_y1) and

              (ifrom_y <  from_y2) then

           begin

               // Calculate the weights.

               weight_y[1] := sfrom_y - ifrom_y;

               weight_y[0] := 1 - weight_y[1];

               weight_x[1] := sfrom_x - ifrom_x;

               weight_x[0] := 1 - weight_x[1];

 

               // Average the color components of the four

               // nearest pixels in from_canvas.

               total_red   := 0.0;

               total_green := 0.0;

               total_blue  := 0.0;

               for ix := 0 to 1 do

               begin

                   for iy := 0 to 1 do

                   begin

                   color:=from_FastBMP.Pixels[ifrom_x + ix, ifrom_y + iy];

                       weight := weight_x[ix] * weight_y[iy];

                       total_red   := total_red   + color.r   * weight;

                       total_green := total_green + color.g * weight;

                       total_blue  := total_blue  + color.b  * weight;

                   end;

               end;

 

               // Set the output pixel's value.

               Line^[to_x].r:=round(total_red);

               Line^[to_x].g:=round(total_green);

               Line^[to_x].b:=round(total_blue);

           end; // End if adjacent pixels in bounds.

       end; // End for to_x := to_x1 to to_x2 loop.

   to_FastBMP.ScanLines[to_y]:=Line;

   end; // End for to_y := to_y1 to to_y2 loop.      

FreeMem(Line,to_FastBMP.width*3);

end;

 

procedure TFastImage.SmoothRotate(Angle:extended);

var

   theta                 : Single;

   new_width, new_height : Integer;

   imgOutput:TFastBMP;

begin

   // Display the hourglass cursor.

   Screen.Cursor := crHourGlass;

 

   // Get the angle of rotation in radians.

   theta := Pi * angle / 180.0;

 

 

 

 

 

   // Resize the output image.

   GetRotatedSize(theta,

       FBMP.Width, FBMP.Height,

       new_width, new_height);

   // Create the output image.

   imgOutput := TFastbmp.create(new_width,new_height);

 

   // Rotate the image

   RotatePicture(FBMP, imgOutput,

       theta,

       0, 0,

       FBMP.Width - 1, FBMP.Height - 1,

       0, 0, new_width - 1, new_height - 1);

   FBMP.free;

   FBMP:=TFastBmp.CreateCopy(imgOutput);

   imgOutput.free;

   FPaintBox.Width:=FBMP.Width;

   FPaintBox.height:=FBMP.height;

   CheckSize(self);

   Update;

   // Restore the cursor.

   Screen.Cursor := crDefault;

end;

 

procedure TFastImage.SmoothScale(scale:single);

var

   new_width, new_height : Integer;

   imgOutput:TFastBMP;

begin

   // Display the hourglass cursor.

   Screen.Cursor := crHourGlass;

 

 

   // Resize the output image.

   new_width := Round(FBMP.Width * scale);

   new_height := Round(FBMP.Height * scale);

 

   // Create the output image.

   imgOutput := TFastBMP.Create(new_width,new_height);

 

   // Resize using ShrinkPicture or EnlargePicture.

   if (scale > 1.0) then

       EnlargePicture(FBMP, imgOutput,

           0, 0,

           FBMP.Width - 1, FBMP.Height - 1,

           0, 0, new_width - 1, new_height - 1)

   else

       ShrinkPicture(FBMP, imgOutput,

           0, 0,

           FBMP.Width - 1, FBMP.Height - 1,

           0, 0, new_width - 1, new_height - 1);

 

   FBMP.free;

   FBMP:=TFastBmp.CreateCopy(imgOutput);

   imgOutput.free;

   FPaintBox.Width:=FBMP.Width;

   FPaintBox.height:=FBMP.height;

   CheckSize(self);

   Update;

 

   // Restore the cursor.

   Screen.Cursor := crDefault;

 

end;

 

 

procedure TFastImage.EnlargePicture(

   from_FastBMP, to_FastBMP : TFastBMP;

   from_x1, from_y1, from_x2, from_y2 : Integer;

   to_x1, to_y1, to_x2, to_y2 : Integer);

var

   xscale, yscale         : Single;

   sfrom_y, sfrom_x       : Single;

   ifrom_y, ifrom_x       : Integer;

   to_y, to_x             : Integer;

   weight_x, weight_y     : array[0..1] of Single;

   weight                 : Single;

   new_red, new_green     : Integer;

   new_blue               : Integer;

   total_red, total_green : Single;

   total_blue             : Single;

   ix, iy                 : Integer;

   color:TFcolor; 

   line:PLine;

begin

   // Compute the scaling parameters. This is useful if

   // the image is not being scaled proportionally.

   xscale := (to_x2 - to_x1 + 1) / (from_x2 - from_x1);

   yscale := (to_y2 - to_y1 + 1) / (from_y2 - from_y1);

 

   // Perform the enlargement.

   for to_y := to_y1 to to_y2 do

   begin

       sfrom_y := (to_y - to_y1) / yscale + from_y1;

       ifrom_y := Trunc(sfrom_y);

       weight_y[1] := sfrom_y - ifrom_y;

       weight_y[0] := 1 - weight_y[1];

       for to_x := to_x1 to to_x2 do

       begin

           sfrom_x := (to_x - to_x1) / xscale + from_x1;

           ifrom_x := Trunc(sfrom_x);

           weight_x[1] := sfrom_x - ifrom_x;

           weight_x[0] := 1 - weight_x[1];

 

           // Average the color components of the four

           // nearest pixels in from_canvas.

           total_red   := 0.0;

           total_green := 0.0;

           total_blue  := 0.0;

           for ix := 0 to 1 do

           begin

               for iy := 0 to 1 do

               begin

               color:=from_FastBMP.Pixels[ifrom_x + ix, ifrom_y + iy];

 

                   weight := weight_x[ix] * weight_y[iy];

                   total_red   := total_red   + color.r   * weight;

                   total_green := total_green + color.g * weight;

                   total_blue  := total_blue  + color.b  * weight;

               end;

           end;

 

           // Set the output pixel's value.

           color.r:=round(total_red);

           color.r:=round(total_green);

           color.r:=round(total_blue);

           to_FastBMP.Pixels[to_x, to_y] :=color;

       end; // End for to_x := to_x1 to to_x2 loop.

   end; // End for to_y := to_y1 to to_y2 loop.

end;

 

// Shrink the picture in from_canvas and place it

// in to_canvas.

procedure TFastImage.ShrinkPicture(

   from_FastBMP, to_FastBMP : TFastBMP;

   from_x1, from_y1, from_x2, from_y2 : Integer;

   to_x1, to_y1, to_x2, to_y2 : Integer);

var

   xscale, yscale         : Single;

   to_y, to_x             : Integer;

   x1, x2, y1, y2         : Integer;

   ix, iy                 : Integer;

   new_red, new_green     : Integer;

   new_blue               : Integer;

   total_red, total_green : Single;

   total_blue             : Single;

   ratio                  : Single;

   color:TFColor;

   line:PLine;

begin

GetMem(Line,from_FastBMP.width*3);

   // Compute the scaling parameters. This is useful if

   // the image is not being scaled proportionally.

   xscale := (to_x2 - to_x1 + 1) / (from_x2 - from_x1);

   yscale := (to_y2 - to_y1 + 1) / (from_y2 - from_y1);

 

   // Perform the reduction.

   for to_y := to_y1 to to_y2 do

   begin

       y1 := Trunc((to_y - to_y1) / yscale + from_y1);

       y2 := Trunc((to_y + 1 - to_y1) / yscale + from_y1) - 1;

       for to_x := to_x1 to to_x2 do

       begin

           x1 := Trunc((to_x - to_x1) / xscale + from_x1);

           x2 := Trunc((to_x + 1 - to_x1) / xscale + from_x1) - 1;

 

           // Average the values in from_canvas within

           // the box (x1, y1) - (x2, y2).

           total_red   := 0;

           total_green := 0;

           total_blue  := 0;

           for iy := y1 to y2 do

           begin

           from_FastBMP.GetScanLine(iy,Line);

               for ix := x1 to x2 do

               begin

                   total_red   := total_red   + Line^[ix].r;

                   total_green := total_green + Line^[ix].g;

                   total_blue  := total_blue  + Line^[ix].b;

               end;

           end;

           ratio := 1 / (x2 - x1 + 1) / (y2 - y1 + 1);

           color.r:=Round(total_red   * ratio);

           color.g:=Round(total_green   * ratio);

           color.b:=Round(total_blue   * ratio);

           to_FastBMP.Pixels[to_x, to_y] := color;

       end; // End for to_x := to_x1 to to_x2 - 1 loop.

   end; // End for to_y := to_y1 to to_y2 - 1 loop.

FreeMem(Line,from_FastBMP.width*3);

end;

 

 

procedure TFastImage.InterpolateRect(x1,y1,x2,y2:Integer;c00,c10,c01,c11:TFColor);

begin

FBMP.InterpolateRect(x1,y1,x2,y2,c00,c10,c01,c11);

Update;

end;

 

procedure TFastImage.Contrast(Amount:Integer);

begin

FBMP.contrast(amount);

Update;

end;

 

procedure TFastImage.Saturation(Amount:Integer);

begin

FBMP.Saturation(amount);

Update;

end;

 

procedure TFastImage.Lightness(Amount:Integer);

begin

FBMP.Lightness(amount);

Update;

end;

 

procedure Register;

begin

RegisterComponents('FastDrawing', [TFastImage]);

end;

 

end.

.