Программная реализация алгоритма Кируса-бека

 

procedure TFormMain.PaintBox1Paint(Sender: TObject);

var

  Line : PLine;

begin

  with PaintBox1 do

  begin

    if Assigned(LineList) then

    begin

      if Mode = mLineP1 then

        Line := LineList.Next

      else

        Line := LineList;

      while Assigned(Line) do

      begin

        if Mode <> mClip then

        begin

          Canvas.Pen.Color := clBlack;

          Canvas.MoveTo(Line.P1.X, Line.P1.Y);

          Canvas.LineTo(Line.P2.X, Line.P2.Y);

        end

        else

        begin

          if Line.Vis = vPart then

          begin

            if Line.ExchangeLeftAndRight then

            begin

              Canvas.Pen.Color := cbOut.Selected; //ItemOutColor.Tag;

              Canvas.MoveTo(Line.P1.X, Line.P1.Y);

              Canvas.LineTo(Line.ClipP2.X, Line.ClipP2.Y);

              Canvas.MoveTo(Line.ClipP1.X, Line.ClipP1.Y);

              Canvas.LineTo(Line.P2.X, Line.P2.Y);

            end

            else

            begin

              Canvas.Pen.Color := cbOut.Selected; //ItemOutColor.Tag;

              Canvas.MoveTo(Line.P1.X, Line.P1.Y);

              Canvas.LineTo(Line.ClipP1.X, Line.ClipP1.Y);

              Canvas.MoveTo(Line.ClipP2.X, Line.ClipP2.Y);

              Canvas.LineTo(Line.P2.X, Line.P2.Y);

            end;

            Canvas.Pen.Color := cbIn.Selected;//ItemInColor.Tag;

            Canvas.MoveTo(Line.ClipP1.X, Line.ClipP1.Y);

            Canvas.LineTo(Line.ClipP2.X, Line.ClipP2.Y);

          end

          else if (Line.Vis = vFull) then

          begin

            Canvas.Pen.Color := cbIn.Selected;//ItemInColor.Tag;

            Canvas.MoveTo(Line.P1.X, Line.P1.Y);

            Canvas.LineTo(Line.P2.X, Line.P2.Y);

          end

          else

          begin

            Canvas.Pen.Color := cbOut.Selected;//ItemOutColor.Tag;

            Canvas.MoveTo(Line.P1.X, Line.P1.Y);

            Canvas.LineTo(Line.P2.X, Line.P2.Y);

          end;

        end;

        Line := Line.Next;

      end;

    end;

    Canvas.Brush.Style := bsClear;

    if Assigned(Rect) then

    begin

      Canvas.Pen.Color := cbRect.Selected;//ItemRectColor.Tag;

      Canvas.Rectangle

        (Classes.Rect(Rect.Left, Rect.Top, Rect.Right+1, Rect.Bottom+1));

    end;

  end;

end;

 

procedure TFormMain.DoClipping;

var

  Line : PLine;

  LP1, LP2: T2DPoint;

  R : T2DRect;

  T : Longint;

begin

  if Rect.Left > Rect.Right then

  begin

    T := Rect.Left;

    Rect.Left := Rect.Right;

    Rect.Right := T;

  end;

  if Rect.Top > Rect.Bottom then

  begin

    T := Rect.Top;

    Rect.Top := Rect.Bottom;

    Rect.Bottom := T;

  end;

  R.Left := Rect.Left; R.Right := Rect.Right;

  R.Top := Rect.Top; R.Bottom := Rect.Bottom;

  Line := LineList;

  while Assigned(Line) do

  begin

    LP1.X := Line.P1.X;  LP1.Y := Line.P1.Y;

    LP2.X := Line.P2.X;  LP2.Y := Line.P2.Y;

    Line.Vis := ClipLineWithRectangle(R, LP1, LP2, Line.ExchangeLeftAndRight);

    Line.ClipP1.X := Round(LP1.X);

    Line.ClipP1.Y := Round(LP1.Y);

    Line.ClipP2.X := Round(LP2.X);

    Line.ClipP2.Y := Round(LP2.Y);

    Line := Line.Next;

  end;

end;

 

procedure TFormMain.PaintBox1MouseUp(Sender: TObject; Button: TMouseButton;

  Shift: TShiftState; X, Y: Integer);

begin

  case Mode of

  mLineP1:

    begin

      LineList.P1.X := X;

      LineList.P1.Y := Y;

      LineList.P2.X := X;

      LineList.P2.Y := Y;

      SetMode(mLineP2);

    end;

  mRectP1:

    begin

      New(Rect);

      Rect.Left := X;

      Rect.Top := Y;

      Rect.Right := X;

      Rect.Bottom := Y;

      SetMode(mRectP2);

    end;

  mRectP2:

    SetMode(mView);

  mLineP2:

    SetMode(mLineP1);

  end;

end;

 

procedure TFormMain.PaintBox1MouseMove(Sender: TObject; Shift: TShiftState;

  X, Y: Integer);

begin

  //StatusBar1.Panels[1].Text := Format('%d : %d', [X, Y]);

  case Mode of

  mLineP2:

    begin

      if ssCtrl in Shift then

      begin

        if Abs(X - LineList.P1.X) > Abs(Y - LineList.P1.Y) then

          Y := LineList.P1.Y

        else

          X := LineList.P1.X;

      end;

      with PaintBox1.Canvas do

      begin

        LineList.P2.X := X;

        LineList.P2.Y := Y;

        InvalidateRect(PanelView.Handle, nil, False);

      end;

    end;

  mRectP2:

    begin

      Rect.Right := X;

      Rect.Bottom := Y;

      InvalidateRect(PanelView.Handle, nil, False);

    end;

  end;

end;

 

procedure TFormMain.ButtonLineClick(Sender: TObject);

begin

  SetMode(mLineP1);

end;

 

procedure TFormMain.FormDestroy(Sender: TObject);

begin

  if Assigned(Rect) then Dispose(Rect);

  ClearListOfLines;

end;

 

procedure TFormMain.ButtonRectClick(Sender: TObject);

begin

  SetMode(mRectP1);

end;

 

procedure TFormMain.FormCreate(Sender: TObject);

begin

  //ItemInColor.Tag := cbIn.Selected;

  //ItemOutColor.Tag := cbOut.Selected;

  //ItemRectColor.Tag := cbRect.Selected;

end;

 

procedure TFormMain.ItemColorDrawItem(Sender: TObject; ACanvas: TCanvas;

  ARect: TRect; Selected: Boolean);

begin

  with Sender as TMenuItem do

  begin

    if Selected then

      ACanvas.Brush.Color := (not Tag) and $00FFFFFF

    else

      ACanvas.Brush.Color := Tag;

    ACanvas.Font.Color := UseBWForContrast(ACanvas.Brush.Color);

    ACanvas.Rectangle(ARect);

    ACanvas.TextOut(ARect.Left+3, ARect.Top+3, Caption);

  end;

end;

 

procedure TFormMain.ItemColorClick(Sender: TObject);

begin

  {if Sender = cbRect then

    ItemRectColor.Tag := cbRect.Selected;

  if Sender = cbOut then

    ItemOutColor.Tag := cbOut.Selected;

  if Sender = cbIn then

    ItemInColor.Tag := cbIn.Selected;}

  InvalidateRect(PanelView.Handle, nil, False);

end;

 

procedure TFormMain.FileExitExecute(Sender: TObject);

begin

  Close;

end;

 

procedure TFormMain.ButtonClipClick(Sender: TObject);

begin

  if Assigned(Rect) then SetMode(mClip);

end;

 

procedure TFormMain.ButtonClearClick(Sender: TObject);

begin

  SetMode(mView);

  ClearListOfLines;

  InvalidateRect(PanelView.Handle, nil, False);

end;

 

procedure TFormMain.chbOutClick(Sender: TObject);

begin

  if chbOut.Checked then

    begin

      cbOut.Enabled := True;

      cbOut.Selected := clNavy;

    end

  else

    begin

      cbOut.Enabled := False;

      cbOut.Selected := clWhite;

    end

end;

 

procedure TFormMain.chbInClick(Sender: TObject);

begin

  if chbIn.Checked then

    begin

      cbIn.Enabled := True;

      cbIn.Selected := clRed;

    end

  else

    begin

      cbIn.Enabled := False;

      cbIn.Selected := clWhite;

    end

end;

end.

 

unit ClippingRoutines;

interface

 

type

  T2DPoint = packed record

   case Integer of

      0: (X, Y : Real);

      1: (V : array [0..1] of Real);

  end;

  P2DPoint = ^T2DPoint;

 

  T2DRect = packed record

   case Integer of

      0: (Left, Right, Bottom, Top: Longint);

      2: (P : array [0..3] of Longint);

  end;

  P2DRect = ^T2DRect;

 

  TVisibility = (vNone, vPart, vFull);   // Видимость: нет, частичная, полная

 

function ClipLineWithRectangle(const Rect : T2DRect; var P1, P2 : T2DPoint; var Exchange : Boolean) : TVisibility;

 

implementation

 

{---------------------------------------------------------}

// Отсечение отрезка регулярным  отсекателем.

// Реализация алгоритма Кируса - Бека

 

function ClipLineWithRectangle(const Rect : T2DRect; var P1, P2 : T2DPoint; var Exchange : Boolean) : TVisibility;

 

  type

    TViewCode = Byte;  // Из 8-и используются 4 бита: (остальные нули)

                       //   #0 -- точка левее окна ; #1 -- точка правее окна

                       //   #2 -- точка ниже окна ; #3 -- точка выше окна

 

    TLineKind = (lCustom, lHorizontal, lVertical);

 

  // Определить код видимости  для точки

  function CalcViewCode (var P : T2DPoint) : TViewCode;

  begin

    Result := 0;

    if P.X < Rect.Left then Result := Result or $1;

    if P.X > Rect.Right then Result := Result or $2;

    if P.Y > Rect.Bottom then Result := Result or $4;

    if P.Y < Rect.Top then Result := Result or $8;

  end;

 

var

  LK : TLineKind;

  I : Integer;

  Mask : Byte;

  Temp : T2DPoint;

  VC1, VC2 : TViewCode;

  DX : Real;

  Flag : Boolean;

  M : Real;   // Тангенс угла наклона

begin

  Assert(Rect.Left <= Rect.Right);

  Assert(Rect.Top <= Rect.Bottom);

  DX := P2.X - P1.X;

  M := 0;

  if DX = 0 then

    LK := lVertical

  else

  begin

    M := (P2.Y - P1.Y) / DX;

    if M = 0 then LK := lHorizontal else LK := lCustom;

  end;

  I := 0;

  Mask := $1;

  Flag := False;

  Exchange := False;

  repeat

    VC1 := CalcViewCode(P1);

    VC2 := CalcViewCode(P2);

    if (VC1 = 0) and (VC2 = 0) then

      Result := vFull

    else if (VC1 and VC2) <> 0 then

      Result := vNone

    else

    begin

      Flag := True;

      Result := vPart;

      if (VC1 and Mask) <> (VC2 and Mask) then

      begin

        // Если P1 внутри окна

        if VC1 and Mask = 0 then

        begin

          Temp := P2;

          P2 := P1;

          P1 := Temp;

          Exchange := not Exchange;

        end;

        if (I <= 1) and (LK <> lVertical) then

        begin

          P1.Y := M * (Rect.P[I] - P1.X) + P1.Y;   // Здесь фигурирует старый P1.X

          P1.X := Rect.P[I];

        end

        else if LK <> lHorizontal then

        begin

          if LK <> lVertical then

            P1.X := (Rect.P[I] - P1.Y)/M + P1.X;

          P1.Y := Rect.P[I];

        end;

      end;

    end;

    Inc(I);

    Mask := Mask shl 1;

  until (I = 4) or (Result <> vPart);

  if Flag and (Result = vFull) then Result := vPart;

end;

end.