/packages/fcl-image/src/clipping.pp

  1{
  2    This file is part of the Free Pascal run time library.
  3    Copyright (c) 2003 by the Free Pascal development team
  4
  5    Clipping support.
  6
  7    See the file COPYING.FPC, included in this distribution,
  8    for details about the copyright.
  9
 10    This program is distributed in the hope that it will be useful,
 11    but WITHOUT ANY WARRANTY; without even the implied warranty of
 12    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
 13
 14 **********************************************************************}
 15{$mode objfpc}{$h+}
 16unit Clipping;
 17
 18interface
 19
 20uses classes;
 21
 22procedure SortRect (var rect : TRect);
 23procedure SortRect (var left,top, right,bottom : integer);
 24function PointInside (const x,y:integer; bounds:TRect) : boolean;
 25
 26procedure CheckRectClipping (ClipRect:TRect; var Rect:Trect);
 27procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
 28procedure CheckLineClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
 29
 30implementation
 31
 32procedure SortRect (var rect : TRect);
 33begin
 34  with rect do
 35    SortRect (left,top, right,bottom);
 36end;
 37
 38procedure SortRect (var left,top, right,bottom : integer);
 39var r : integer;
 40begin
 41  if left > right then
 42    begin
 43    r := left;
 44    left := right;
 45    right := r;
 46    end;
 47  if top > bottom then
 48    begin
 49    r := top;
 50    top := bottom;
 51    bottom := r;
 52    end;
 53end;
 54
 55function PointInside (const x,y:integer; bounds:TRect) : boolean;
 56begin
 57  SortRect (bounds);
 58  with Bounds do
 59    result := (x >= left) and (x <= right) and
 60              (y >= bottom) and (y <= top);
 61end;
 62
 63procedure CheckRectClipping (ClipRect:TRect; var Rect:Trect);
 64begin
 65  with ClipRect do
 66    CheckRectClipping (ClipRect, left,top,right,bottom);
 67end;
 68
 69procedure CheckRectClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
 70  procedure ClearRect;
 71  begin
 72    x1 := -1;
 73    x2 := -1;
 74    y1 := -1;
 75    y2 := -1;
 76  end;
 77begin
 78  SortRect (ClipRect);
 79  SortRect (x1,y1, x2,y2);
 80  with ClipRect do
 81    begin
 82    if ( x1 < Left ) then // left side needs to be clipped
 83      x1 := left;
 84    if ( x2 > right ) then // right side needs to be clipped
 85      x2 := right;
 86    if ( y1 < top ) then // top side needs to be clipped
 87      y1 := top;
 88    if ( y2 > bottom ) then // bottom side needs to be clipped
 89      y2 := bottom;
 90    if (x1 > x2) or (y1 < y2) then
 91      ClearRect;
 92    end;
 93end;
 94
 95procedure CheckLineClipping (ClipRect:TRect; var x1,y1, x2,y2 : integer);
 96var a,b : single;
 97    Calculated : boolean;
 98    xdiff,n : integer;
 99  procedure CalcLine;
100    begin
101    if not Calculated then
102      begin
103      xdiff := (x1-x2);
104      a := (y1-y2) / xdiff;
105      b := (x1*y2 - x2*y1) / xdiff;
106      Calculated := true;
107      end;
108    end;
109  procedure ClearLine;
110    begin
111    x1 := -1;
112    y1 := -1;
113    x2 := -1;
114    y2 := -1;
115    end;
116begin
117  Calculated := false;
118  SortRect (ClipRect);
119  xdiff := (x1-x2);
120  with ClipRect do
121    if xdiff = 0 then
122      begin  // vertical line
123      if y1 > bottom then
124        y1 := bottom
125      else if y1 < top then
126        y1 := top;
127      if y2 > bottom then
128        y2 := bottom
129      else if y2 < top then
130        y2 := top;
131      end
132    else if (y1-y2) = 0 then
133      begin  // horizontal line
134      if x1 < left then
135        x1 := left
136      else if x1 > right then
137        x1 := right;
138      if x2 < left then
139        x2 := left
140      else if x2 > right then
141        x2 := right;
142      end
143    else
144      if ( (y1 < top) and (y2 < top) ) or
145         ( (y1 > bottom) and (y2 > bottom) ) or
146         ( (x1 > right) and (x2 > right) ) or
147         ( (x1 < left) and (x2 < left) ) then
148        ClearLine // completely outside ClipRect
149      else
150        begin
151        if (y1 < top) or (y2 < top) then
152          begin
153          CalcLine;
154          n := round ((top - b) / a);
155          if (n >= left) and (n <= right) then
156            if (y1 < top) then
157              begin
158              x1 := n;
159              y1 := top;
160              end
161            else
162              begin
163              x2 := n;
164              y2 := top;
165              end;
166          end;
167        if (y1 > bottom) or (y2 > bottom) then
168          begin
169          CalcLine;
170          n := round ((bottom - b) / a);
171          if (n >= left) and (n <= right) then
172            if (y1 > bottom) then
173              begin
174              x1 := n;
175              y1 := bottom;
176              end
177            else
178              begin
179              x2 := n;
180              y2 := bottom;
181              end;
182          end;
183        if (x1 < left) or (x2 < left) then
184          begin
185          CalcLine;
186          n := round ((left * a) + b);
187          if (n <= bottom) and (n >= top) then
188            if (x1 < left) then
189              begin
190              x1 := left;
191              y1 := n;
192              end
193            else
194              begin
195              x2 := left;
196              y2 := n;
197              end;
198          end;
199        if (x1 > right) or (x2 > right) then
200          begin
201          CalcLine;
202          n := round ((right * a) + b);
203          if (n <= bottom) and (n >= top) then
204            if (x1 > right) then
205              begin
206              x1 := right;
207              y1 := n;
208              end
209            else
210              begin
211              x2 := right;
212              y2 := n;
213              end;
214          end;
215        end;
216end;
217
218end.