Listing: 1 IMPLEMENTATION MODULE Rectangles; 2 (* 3 * REPERTOIRE 4 * Release 1.6 5 * By Charles Bradford and Cole Brecheen 6 * (c) Copyright 1985-1992 PMI 7 * Green Bay, Wisconsin 8 * All rights reserved 9 * (414) 468-6040 10 * 11 * $Header: D:/logfiles/mods/rectangl.mov 1.5 10 Mar 1991 15:35:22 coleb $ 12 * 13 * 14 * Adapted from an earlier version written and contributed 15 * by Martin Johnston of GTJ Consultants, New York, NY. 16 * 17 *) 18 19 20 IMPORT Numbers; 21 22 VAR 23 Initialized : BOOLEAN; 24 25 PROCEDURE Init(); 26 BEGIN 27 IF Initialized THEN 28 RETURN; 29 ELSE 30 Initialized := TRUE; 31 END; 32 Numbers.Init(); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 33 END Init; ***** ^ not supported yet 34 35 36 PROCEDURE PointInside( VAR p : APoint; VAR r : ARectangle) : ***** ^ undeclared identifier ***** ^ undeclared identifier 37 BOOLEAN; 38 BEGIN 39 RETURN (p.col >= r.col1) AND (p.col < r.col2) AND (p.row >= r.row1) AND ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 40 (p.row < r.row2); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 41 END PointInside; ***** ^ not supported yet 42 43 44 PROCEDURE Distance(p1, p2 : APoint) : CARDINAL; ***** ^ undeclared identifier 45 VAR 46 colDiff, rowDiff : CARDINAL; 47 48 PROCEDURE IntToCardRange(n : INTEGER) : CARDINAL; 49 BEGIN 50 IF n >= 0 THEN 51 RETURN CARDINAL(n)+32767+1; ***** ^ not supported yet 52 ELSE 53 RETURN CARDINAL(n+32767+1); ***** ^ not supported yet 54 END; 55 END IntToCardRange; ***** ^ not supported yet 56 57 PROCEDURE dist(a, b : INTEGER) : CARDINAL; 58 BEGIN 59 IF a > b THEN 60 RETURN IntToCardRange(a) - IntToCardRange(b); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 61 ELSE 62 RETURN IntToCardRange(b) - IntToCardRange(a); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 63 END; 64 END dist; ***** ^ not supported yet 65 66 BEGIN 67 colDiff := dist(p1.col, p2.col); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 68 rowDiff := dist(p1.row, p2.row); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 69 RETURN Numbers.CardSqrt( (colDiff * colDiff) + (rowDiff * rowDiff) ); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 70 END Distance; ***** ^ not supported yet 71 72 73 PROCEDURE RectsIntersect(VAR r1, r2, intersection : ARectangle) : BOOLEAN; ***** ^ undeclared identifier 74 BEGIN 75 IF r1.row1 > r2.row1 THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 76 intersection.row1 := r1.row1; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 77 ELSE 78 intersection.row1 := r2.row1; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 79 END; 80 IF r1.row2 < r2.row2 THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 81 intersection.row2 := r1.row2; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 82 ELSE 83 intersection.row2 := r2.row2; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 84 END; 85 IF r1.col1 > r2.col1 THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 86 intersection.col1 := r1.col1; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 87 ELSE 88 intersection.col1 := r2.col1; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 89 END; 90 IF r1.col2 < r2.col2 THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 91 intersection.col2 := r1.col2; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 92 ELSE 93 intersection.col2 := r2.col2; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 94 END; 95 RETURN (intersection.row1 <= intersection.row2) AND ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 96 (intersection.col1 <= intersection.col2); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 97 END RectsIntersect; ***** ^ not supported yet 98 99 100 PROCEDURE FindRowOnCol(VAR col1, row1, col2, row2, col : INTEGER) : INTEGER; 101 VAR 102 dcol, rise, run : INTEGER; 103 104 PROCEDURE HalfPoint(xl, yl, xr, yr : INTEGER) : INTEGER; 105 VAR 106 syl, sxr, syr : INTEGER; 107 BEGIN 108 REPEAT 109 syl := yl; 110 sxr := xr; 111 syr := yr; 112 xr := (xl+xr) DIV 2; 113 yr := (yl+yr) DIV 2; 114 IF xr < col THEN 115 xl := xr; 116 yl := yr; 117 xr := sxr; 118 yr := syr; 119 END; 120 UNTIL ((syl=yl) AND (syr=yr)); 121 RETURN yr; 122 END HalfPoint; ***** ^ not supported yet 123 124 BEGIN 125 IF row1 = row2 THEN 126 RETURN row1; 127 ELSE 128 rise := row2-row1; 129 run := col2-col1; 130 dcol := Numbers.LowestCommonDenom(rise, run); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 131 IF dcol # rise THEN 132 rise := rise DIV dcol; 133 run := run DIV dcol; 134 END; 135 dcol := col-col1; 136 IF (ABS(32767 DIV rise) < ABS(dcol)) OR ((32767 DIV ABS(dcol)) < ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 137 ABS(rise)) THEN ***** ^ undeclared identifier ***** ^ not supported yet 138 RETURN HalfPoint(col1, row1, col2, row2); ***** ^ not supported yet ***** ^ not supported yet 139 ELSE 140 RETURN ((rise*dcol) DIV run)+row1; 141 END; 142 END; 143 END FindRowOnCol; ***** ^ not supported yet 144 145 146 PROCEDURE LineInside(TheLine : ALine; r : ARectangle; VAR ***** ^ undeclared identifier ***** ^ undeclared identifier 147 intersection : ALine) : BOOLEAN; ***** ^ undeclared identifier 148 149 PROCEDURE order(VAR col1, col2, row1, row2 : INTEGER); 150 VAR 151 col : INTEGER; 152 BEGIN 153 IF col1 > col2 THEN 154 col := col1; 155 col1 := col2; 156 col2 := col; 157 col := row1; 158 row1 := row2; 159 row2 := col; 160 END; 161 END order; ***** ^ not supported yet 162 163 BEGIN 164 WITH TheLine DO ***** ^ not supported yet 165 order(p1.col, p2.col, p1.row, p2.row); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 166 IF (p1.col < r.col1) AND (p2.col > r.col1) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 167 p1.row := FindRowOnCol(p1.col, p1.row, p2.col, p2.row, r.col1); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 168 p1.col := r.col1; ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 169 END; 170 IF (p1.col < r.col2) AND (p2.col > r.col2) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 171 p2.row := FindRowOnCol(p1.col, p1.row, p2.col, p2.row, r.col2); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 172 p2.col := r.col2; ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 173 END; 174 order(p1.row, p2.row, p1.col, p2.col); ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 175 IF (p1.row < r.row1) AND (p2.row > r.row1) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 176 p1.col := FindRowOnCol(p1.row, p1.col, p2.row, p2.col, r.row1); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 177 p1.row := r.row1; ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 178 END; 179 IF (p1.row < r.row2) AND (p2.row > r.row2) THEN ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 180 p2.col := FindRowOnCol(p1.row, p1.col, p2.row, p2.col, r.row2); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 181 p2.row := r.row2; ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 182 END; 183 IF PointInside(p1, r) AND PointInside(p2, r) THEN ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet ***** ^ undeclared identifier ***** ^ not supported yet 184 intersection := TheLine; ***** ^ not supported yet ***** ^ not supported yet 185 RETURN TRUE; 186 ELSE 187 RETURN FALSE; 188 END; 189 END; ***** ^ not supported yet 190 END LineInside; ***** ^ not supported yet 191 192 193 PROCEDURE DefineRectangle(VAR r : ARectangle; col1, row1, col2, row2 : ***** ^ undeclared identifier 194 INTEGER); 195 BEGIN 196 r.col1 := col1; ***** ^ not supported yet ***** ^ not supported yet 197 r.row1 := row1; ***** ^ not supported yet ***** ^ not supported yet 198 r.col2 := col2; ***** ^ not supported yet ***** ^ not supported yet 199 r.row2 := row2; ***** ^ not supported yet ***** ^ not supported yet 200 END DefineRectangle; ***** ^ not supported yet 201 202 203 PROCEDURE DefineByPoints(VAR r : ARectangle; TopLeft, BottomRight ***** ^ undeclared identifier 204 : APoint); ***** ^ undeclared identifier 205 BEGIN 206 r.TopLeft := TopLeft; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 207 r.BottomRight := BottomRight; ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 208 END DefineByPoints; ***** ^ not supported yet 209 210 211 PROCEDURE RectIsInside( VAR r1, r2 : ARectangle) : BOOLEAN; ***** ^ undeclared identifier 212 BEGIN 213 RETURN (r1.col1 >= r2.col1) AND (r1.col2 <= r2.col2) AND ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 214 (r1.row1 >= r2.row1) AND (r1.row2 <= r2.row2); ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 215 END RectIsInside; ***** ^ not supported yet 216 217 218 PROCEDURE ShrinkRect( VAR r : ARectangle ); ***** ^ undeclared identifier 219 BEGIN 220 IF r.col2 > (r.col1 + 1) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 221 INC( r.col1 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 222 DEC( r.col2 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 223 END; 224 IF r.row2 > (r.row1 + 1) THEN ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet ***** ^ not supported yet 225 INC( r.row1 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 226 DEC( r.row2 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 227 END; 228 END ShrinkRect; ***** ^ not supported yet 229 230 PROCEDURE ExpandRect( VAR r : ARectangle ); ***** ^ undeclared identifier 231 BEGIN 232 IF r.col1 > 1 THEN ***** ^ not supported yet ***** ^ not supported yet 233 DEC( r.col1 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 234 END; 235 IF r.row1 > 1 THEN ***** ^ not supported yet ***** ^ not supported yet 236 DEC( r.row1 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 237 END; 238 INC( r.col2 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 239 INC( r.row2 ); ***** ^ undeclared identifier ***** ^ not supported yet ***** ^ not supported yet 240 END ExpandRect; ***** ^ not supported yet 241 242 BEGIN 243 Initialized := FALSE; 244 Init(); ***** ^ not supported yet ***** ^ not supported yet 245 END Rectangles. ***** ^ not supported yet 336 errors