Cohen-Sutherland line clipping algorithm in Delphi
This is a port of C code from wikipedia to Delphi. I also included a test application.
The code is for Delphi 7.
The test application can be used either by typing the line end-points coordinates
or by clicking two points in the form.
I did that port to use with graphics32, because the standard "Safe" clipping TBitmap32.LineToAS() doesn't work for large x, y (see this post). Download source code.
unit CohenSutherlandClipping.pas
unit CohenSutherlandClipping;
// line clipping to a rectangle
// Ported to Delphi from wikipedia C code by Omar Reis - 2012
// see http://en.wikipedia.org/wiki/Cohen%E2%80%93Sutherland
interface
// CohenSutherland_SetClippingRect() sets clipping rectangle corners
procedure CohenSutherland_SetClippingRect(const x0,y0,x1,y1:double);
// CohenSutherland_LineVisible() returns true if line visible
// vars x0,y0,x1,y1 return clipped line end points
function CohenSutherland_LineVisible(var x0,y0,x1,y1:double):boolean;
implementation //--------------------------------------------------
const
INSIDE = 0; // 0000
LEFT = 1; // 0001
RIGHT = 2; // 0010
BOTTOM = 4; // 0100
TOP = 8; // 1000
// Clipping rectangle corners
CRC_xmin:double=0; // CRC_xmin,CRC_ymin +----------------
CRC_ymin:double=0; // | |
CRC_xmax:double=2000; // | |
CRC_ymax:double=1000; // ----------------+ CRC_xmax,CRC_ymax
procedure CohenSutherland_SetClippingRect(const x0,y0,x1,y1:double);
begin
CRC_xmin:=x0;
CRC_ymin:=y0;
CRC_xmax:=x1;
CRC_ymax:=y1;
end;
// Compute the bit code for a point (x, y) using the clip rectangle
// bounded diagonally by (xmin, ymin), and (xmax, ymax)
// ASSUME THAT xmax , xmin , ymax and ymin are global constants.
function ComputeOutCode(const x,y:double):Integer;
var code:Integer;
begin
code := INSIDE; // initialised as being inside of clip window
if (x < CRC_xmin) then code := code or LEFT // to the left of clip window
else if (x > CRC_xmax) then code := code or RIGHT; // to the right of clip window
if (y < CRC_ymin) then code := code or BOTTOM // below the clip window
else if (y > CRC_ymax) then code := code or TOP; // above the clip window
Result := code;
end;
// Cohen–Sutherland clipping algorithm clips a line from
// P0 = (x0, y0) to P1 = (x1, y1) against a rectangle with
// diagonal from (xmin, ymin) to (xmax, ymax).
function CohenSutherland_LineVisible(var x0,y0,x1,y1:double):boolean; //returns true if line visible
var outcode0,outcode1,outcodeOut:Integer; accept:Boolean; x,y:Double;
begin
// compute outcodes for P0, P1, and whatever point lies outside the clip rectangle
outcode0 := ComputeOutCode(x0, y0);
outcode1 := ComputeOutCode(x1, y1);
accept := false;
x:=0; y:=0;
while (true) do
begin
if (outcode0 or outcode1 = 0 ) then // Bitwise OR is 0. Trivially accept and get out of loop
begin
accept := true;
break;
end
else if (outcode0 and outcode1<>0) then // Bitwise AND is not 0. Trivially reject and get out of loop
begin
break;
end
else begin
// failed both tests, so calculate the line segment to clip
// from an outside point to an intersection with clip edge
// At least one endpoint is outside the clip rectangle; pick it.
if (outcode0 <> 0) then outcodeOut:=outcode0
else outcodeOut:=outcode1; //outcodeOut = outcode0 ? outcode0 : outcode1;
// Now find the intersection point;
// use formulas y = y0 + slope * (x - x0), x = x0 + (1 / slope) * (y - y0)
if (outcodeOut and TOP <>0 ) then // point is above the clip rectangle
begin
x := x0 + (x1 - x0) * (CRC_ymax - y0) / (y1 - y0);
y := CRC_ymax;
end
else if (outcodeOut and BOTTOM <>0) then // point is below the clip rectangle
begin
x := x0 + (x1 - x0) * (CRC_ymin - y0) / (y1 - y0);
y := CRC_ymin;
end
else if (outcodeOut and RIGHT <>0) then // point is to the right of clip rectangle
begin
y := y0 + (y1 - y0) * (CRC_xmax - x0) / (x1 - x0);
x := CRC_xmax;
end
else if (outcodeOut and LEFT <>0) then // point is to the left of clip rectangle
begin
y := y0 + (y1 - y0) * (CRC_xmin - x0) / (x1 - x0);
x := CRC_xmin;
end;
(* NOTE:if you follow this algorithm exactly(at least for c#), then you will fall into an infinite loop
in case a line crosses more than two segments. to avoid that problem, leave out the last else
if(outcodeOut & LEFT) and just make it else *)
// Now we move outside point to intersection point to clip
// and get ready for next pass.
if (outcodeOut = outcode0) then
begin
x0 := x;
y0 := y;
outcode0 := ComputeOutCode(x0, y0);
end
else begin
x1 := x;
y1 := y;
outcode1 := ComputeOutCode(x1, y1);
end;
end;
end;
Result := accept;
end;
end.
|
fTestLineClipping.pas
unit fTestLineClipping;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls;
type
TForm1 = class(TForm)
lab1: TLabel;
edX0: TEdit;
lab2: TLabel;
edY0: TEdit;
lab3: TLabel;
edX1: TEdit;
lab4: TLabel;
edY1: TEdit;
btnClipAndDraw: TButton;
procedure btnClipAndDrawClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
private
public
mouseState:Integer;
end;
var
Form1: TForm1;
implementation
uses
CohenSutherlandClipping;
{$R *.dfm}
const
xmin=100; //my clipping rect corners
ymin=100;
xmax=600;
ymax=500;
{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
begin
mouseState:=0;
CohenSutherland_SetClippingRect(xmin, ymin, xmax, ymax ); //set clipping rect
end;
procedure TForm1.btnClipAndDrawClick(Sender: TObject);
var x0,y0,x1,y1:Double;
begin
x0:=StrToFloat(edX0.Text);
y0:=StrToFloat(edY0.Text);
x1:=StrToFloat(edX1.Text);
y1:=StrToFloat(edY1.Text);
Canvas.Rectangle(xmin, ymin, xmax, ymax );
if CohenSutherland_LineVisible(x0,y0,x1,y1) then
begin
Canvas.MoveTo( Trunc(x0), Trunc(y0) );
Canvas.LineTo( Trunc(x1), Trunc(y1) );
end
else MessageBeep(0);
end;
procedure TForm1.FormMouseDown(Sender: TObject; Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
if mouseState=0 then
begin
edX0.Text := IntToStr(x);
edY0.Text := IntToStr(y);
mouseState:=1;
end
else begin
edX1.Text := IntToStr(x);
edY1.Text := IntToStr(y);
btnClipAndDrawClick(nil);
mouseState:=0;
end;
end;
end.
|
form fTestLineClipping.dfm
object Form1: TForm1
Left = 489
Top = 122
Width = 721
Height = 539
Caption = 'Form1'
Color = clBtnFace
Font.Charset = DEFAULT_CHARSET
Font.Color = clWindowText
Font.Height = -11
Font.Name = 'MS Sans Serif'
Font.Style = []
OldCreateOrder = False
OnCreate = FormCreate
OnMouseDown = FormMouseDown
PixelsPerInch = 96
TextHeight = 13
object lab1: TLabel
Left = 120
Top = 16
Width = 14
Height = 13
Caption = 'x0:'
end
object lab2: TLabel
Left = 120
Top = 40
Width = 14
Height = 13
Caption = 'y0:'
end
object lab3: TLabel
Left = 232
Top = 16
Width = 14
Height = 13
Caption = 'x1:'
end
object lab4: TLabel
Left = 232
Top = 40
Width = 14
Height = 13
Caption = 'y1:'
end
object edX0: TEdit
Left = 142
Top = 12
Width = 67
Height = 19
Ctl3D = False
ParentCtl3D = False
TabOrder = 0
Text = '100'
end
object edY0: TEdit
Left = 142
Top = 36
Width = 67
Height = 19
Ctl3D = False
ParentCtl3D = False
TabOrder = 1
Text = '100'
end
object edX1: TEdit
Left = 254
Top = 12
Width = 67
Height = 19
Ctl3D = False
ParentCtl3D = False
TabOrder = 2
Text = '400'
end
object edY1: TEdit
Left = 254
Top = 36
Width = 67
Height = 19
Ctl3D = False
ParentCtl3D = False
TabOrder = 3
Text = '500'
end
object btnClipAndDraw: TButton
Left = 352
Top = 20
Width = 105
Height = 25
Caption = 'Clip n Draw'
TabOrder = 4
OnClick = btnClipAndDrawClick
end
end
|
project TestLineClipping.dpr
program TestLineClipping;
uses
Forms,
fTestLineClipping in 'fTestLineClipping.pas' {Form1},
CohenSutherlandClipping in 'CohenSutherlandClipping.pas';
{$R *.res}
begin
Application.Initialize;
Application.CreateForm(TForm1, Form1);
Application.Run;
end.
|
omar reis - ago/2012
|