clipping.pp 5.2 KB

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