RECTANGL.LST 25 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587
  1. Listing:
  2. 1 IMPLEMENTATION MODULE Rectangles;
  3. 2 (*
  4. 3 * REPERTOIRE
  5. 4 * Release 1.6
  6. 5 * By Charles Bradford and Cole Brecheen
  7. 6 * (c) Copyright 1985-1992 PMI
  8. 7 * Green Bay, Wisconsin
  9. 8 * All rights reserved
  10. 9 * (414) 468-6040
  11. 10 *
  12. 11 * $Header: D:/logfiles/mods/rectangl.mov 1.5 10 Mar 1991 15:35:22 coleb $
  13. 12 *
  14. 13 *
  15. 14 * Adapted from an earlier version written and contributed
  16. 15 * by Martin Johnston of GTJ Consultants, New York, NY.
  17. 16 *
  18. 17 *)
  19. 18
  20. 19
  21. 20 IMPORT Numbers;
  22. 21
  23. 22 VAR
  24. 23 Initialized : BOOLEAN;
  25. 24
  26. 25 PROCEDURE Init();
  27. 26 BEGIN
  28. 27 IF Initialized THEN
  29. 28 RETURN;
  30. 29 ELSE
  31. 30 Initialized := TRUE;
  32. 31 END;
  33. 32 Numbers.Init();
  34. ***** ^ not supported yet
  35. ***** ^ not supported yet
  36. ***** ^ not supported yet
  37. 33 END Init;
  38. ***** ^ not supported yet
  39. 34
  40. 35
  41. 36 PROCEDURE PointInside( VAR p : APoint; VAR r : ARectangle) :
  42. ***** ^ undeclared identifier
  43. ***** ^ undeclared identifier
  44. 37 BOOLEAN;
  45. 38 BEGIN
  46. 39 RETURN (p.col >= r.col1) AND (p.col < r.col2) AND (p.row >= r.row1) AND
  47. ***** ^ not supported yet
  48. ***** ^ not supported yet
  49. ***** ^ not supported yet
  50. ***** ^ not supported yet
  51. ***** ^ not supported yet
  52. ***** ^ not supported yet
  53. ***** ^ not supported yet
  54. ***** ^ not supported yet
  55. ***** ^ not supported yet
  56. ***** ^ not supported yet
  57. ***** ^ not supported yet
  58. ***** ^ not supported yet
  59. 40 (p.row < r.row2);
  60. ***** ^ not supported yet
  61. ***** ^ not supported yet
  62. ***** ^ not supported yet
  63. ***** ^ not supported yet
  64. 41 END PointInside;
  65. ***** ^ not supported yet
  66. 42
  67. 43
  68. 44 PROCEDURE Distance(p1, p2 : APoint) : CARDINAL;
  69. ***** ^ undeclared identifier
  70. 45 VAR
  71. 46 colDiff, rowDiff : CARDINAL;
  72. 47
  73. 48 PROCEDURE IntToCardRange(n : INTEGER) : CARDINAL;
  74. 49 BEGIN
  75. 50 IF n >= 0 THEN
  76. 51 RETURN CARDINAL(n)+32767+1;
  77. ***** ^ not supported yet
  78. 52 ELSE
  79. 53 RETURN CARDINAL(n+32767+1);
  80. ***** ^ not supported yet
  81. 54 END;
  82. 55 END IntToCardRange;
  83. ***** ^ not supported yet
  84. 56
  85. 57 PROCEDURE dist(a, b : INTEGER) : CARDINAL;
  86. 58 BEGIN
  87. 59 IF a > b THEN
  88. 60 RETURN IntToCardRange(a) - IntToCardRange(b);
  89. ***** ^ not supported yet
  90. ***** ^ not supported yet
  91. ***** ^ not supported yet
  92. ***** ^ not supported yet
  93. 61 ELSE
  94. 62 RETURN IntToCardRange(b) - IntToCardRange(a);
  95. ***** ^ not supported yet
  96. ***** ^ not supported yet
  97. ***** ^ not supported yet
  98. ***** ^ not supported yet
  99. 63 END;
  100. 64 END dist;
  101. ***** ^ not supported yet
  102. 65
  103. 66 BEGIN
  104. 67 colDiff := dist(p1.col, p2.col);
  105. ***** ^ not supported yet
  106. ***** ^ not supported yet
  107. ***** ^ not supported yet
  108. ***** ^ not supported yet
  109. ***** ^ not supported yet
  110. 68 rowDiff := dist(p1.row, p2.row);
  111. ***** ^ not supported yet
  112. ***** ^ not supported yet
  113. ***** ^ not supported yet
  114. ***** ^ not supported yet
  115. ***** ^ not supported yet
  116. 69 RETURN Numbers.CardSqrt( (colDiff * colDiff) + (rowDiff * rowDiff) );
  117. ***** ^ not supported yet
  118. ***** ^ not supported yet
  119. ***** ^ not supported yet
  120. 70 END Distance;
  121. ***** ^ not supported yet
  122. 71
  123. 72
  124. 73 PROCEDURE RectsIntersect(VAR r1, r2, intersection : ARectangle) : BOOLEAN;
  125. ***** ^ undeclared identifier
  126. 74 BEGIN
  127. 75 IF r1.row1 > r2.row1 THEN
  128. ***** ^ not supported yet
  129. ***** ^ not supported yet
  130. ***** ^ not supported yet
  131. ***** ^ not supported yet
  132. 76 intersection.row1 := r1.row1;
  133. ***** ^ not supported yet
  134. ***** ^ not supported yet
  135. ***** ^ not supported yet
  136. ***** ^ not supported yet
  137. 77 ELSE
  138. 78 intersection.row1 := r2.row1;
  139. ***** ^ not supported yet
  140. ***** ^ not supported yet
  141. ***** ^ not supported yet
  142. ***** ^ not supported yet
  143. 79 END;
  144. 80 IF r1.row2 < r2.row2 THEN
  145. ***** ^ not supported yet
  146. ***** ^ not supported yet
  147. ***** ^ not supported yet
  148. ***** ^ not supported yet
  149. 81 intersection.row2 := r1.row2;
  150. ***** ^ not supported yet
  151. ***** ^ not supported yet
  152. ***** ^ not supported yet
  153. ***** ^ not supported yet
  154. 82 ELSE
  155. 83 intersection.row2 := r2.row2;
  156. ***** ^ not supported yet
  157. ***** ^ not supported yet
  158. ***** ^ not supported yet
  159. ***** ^ not supported yet
  160. 84 END;
  161. 85 IF r1.col1 > r2.col1 THEN
  162. ***** ^ not supported yet
  163. ***** ^ not supported yet
  164. ***** ^ not supported yet
  165. ***** ^ not supported yet
  166. 86 intersection.col1 := r1.col1;
  167. ***** ^ not supported yet
  168. ***** ^ not supported yet
  169. ***** ^ not supported yet
  170. ***** ^ not supported yet
  171. 87 ELSE
  172. 88 intersection.col1 := r2.col1;
  173. ***** ^ not supported yet
  174. ***** ^ not supported yet
  175. ***** ^ not supported yet
  176. ***** ^ not supported yet
  177. 89 END;
  178. 90 IF r1.col2 < r2.col2 THEN
  179. ***** ^ not supported yet
  180. ***** ^ not supported yet
  181. ***** ^ not supported yet
  182. ***** ^ not supported yet
  183. 91 intersection.col2 := r1.col2;
  184. ***** ^ not supported yet
  185. ***** ^ not supported yet
  186. ***** ^ not supported yet
  187. ***** ^ not supported yet
  188. 92 ELSE
  189. 93 intersection.col2 := r2.col2;
  190. ***** ^ not supported yet
  191. ***** ^ not supported yet
  192. ***** ^ not supported yet
  193. ***** ^ not supported yet
  194. 94 END;
  195. 95 RETURN (intersection.row1 <= intersection.row2) AND
  196. ***** ^ not supported yet
  197. ***** ^ not supported yet
  198. ***** ^ not supported yet
  199. ***** ^ not supported yet
  200. 96 (intersection.col1 <= intersection.col2);
  201. ***** ^ not supported yet
  202. ***** ^ not supported yet
  203. ***** ^ not supported yet
  204. ***** ^ not supported yet
  205. 97 END RectsIntersect;
  206. ***** ^ not supported yet
  207. 98
  208. 99
  209. 100 PROCEDURE FindRowOnCol(VAR col1, row1, col2, row2, col : INTEGER) : INTEGER;
  210. 101 VAR
  211. 102 dcol, rise, run : INTEGER;
  212. 103
  213. 104 PROCEDURE HalfPoint(xl, yl, xr, yr : INTEGER) : INTEGER;
  214. 105 VAR
  215. 106 syl, sxr, syr : INTEGER;
  216. 107 BEGIN
  217. 108 REPEAT
  218. 109 syl := yl;
  219. 110 sxr := xr;
  220. 111 syr := yr;
  221. 112 xr := (xl+xr) DIV 2;
  222. 113 yr := (yl+yr) DIV 2;
  223. 114 IF xr < col THEN
  224. 115 xl := xr;
  225. 116 yl := yr;
  226. 117 xr := sxr;
  227. 118 yr := syr;
  228. 119 END;
  229. 120 UNTIL ((syl=yl) AND (syr=yr));
  230. 121 RETURN yr;
  231. 122 END HalfPoint;
  232. ***** ^ not supported yet
  233. 123
  234. 124 BEGIN
  235. 125 IF row1 = row2 THEN
  236. 126 RETURN row1;
  237. 127 ELSE
  238. 128 rise := row2-row1;
  239. 129 run := col2-col1;
  240. 130 dcol := Numbers.LowestCommonDenom(rise, run);
  241. ***** ^ not supported yet
  242. ***** ^ not supported yet
  243. ***** ^ not supported yet
  244. 131 IF dcol # rise THEN
  245. 132 rise := rise DIV dcol;
  246. 133 run := run DIV dcol;
  247. 134 END;
  248. 135 dcol := col-col1;
  249. 136 IF (ABS(32767 DIV rise) < ABS(dcol)) OR ((32767 DIV ABS(dcol)) <
  250. ***** ^ undeclared identifier
  251. ***** ^ not supported yet
  252. ***** ^ undeclared identifier
  253. ***** ^ not supported yet
  254. ***** ^ undeclared identifier
  255. ***** ^ not supported yet
  256. 137 ABS(rise)) THEN
  257. ***** ^ undeclared identifier
  258. ***** ^ not supported yet
  259. 138 RETURN HalfPoint(col1, row1, col2, row2);
  260. ***** ^ not supported yet
  261. ***** ^ not supported yet
  262. 139 ELSE
  263. 140 RETURN ((rise*dcol) DIV run)+row1;
  264. 141 END;
  265. 142 END;
  266. 143 END FindRowOnCol;
  267. ***** ^ not supported yet
  268. 144
  269. 145
  270. 146 PROCEDURE LineInside(TheLine : ALine; r : ARectangle; VAR
  271. ***** ^ undeclared identifier
  272. ***** ^ undeclared identifier
  273. 147 intersection : ALine) : BOOLEAN;
  274. ***** ^ undeclared identifier
  275. 148
  276. 149 PROCEDURE order(VAR col1, col2, row1, row2 : INTEGER);
  277. 150 VAR
  278. 151 col : INTEGER;
  279. 152 BEGIN
  280. 153 IF col1 > col2 THEN
  281. 154 col := col1;
  282. 155 col1 := col2;
  283. 156 col2 := col;
  284. 157 col := row1;
  285. 158 row1 := row2;
  286. 159 row2 := col;
  287. 160 END;
  288. 161 END order;
  289. ***** ^ not supported yet
  290. 162
  291. 163 BEGIN
  292. 164 WITH TheLine DO
  293. ***** ^ not supported yet
  294. 165 order(p1.col, p2.col, p1.row, p2.row);
  295. ***** ^ not supported yet
  296. ***** ^ undeclared identifier
  297. ***** ^ not supported yet
  298. ***** ^ undeclared identifier
  299. ***** ^ not supported yet
  300. ***** ^ undeclared identifier
  301. ***** ^ not supported yet
  302. ***** ^ undeclared identifier
  303. ***** ^ not supported yet
  304. 166 IF (p1.col < r.col1) AND (p2.col > r.col1) THEN
  305. ***** ^ undeclared identifier
  306. ***** ^ not supported yet
  307. ***** ^ not supported yet
  308. ***** ^ not supported yet
  309. ***** ^ undeclared identifier
  310. ***** ^ not supported yet
  311. ***** ^ not supported yet
  312. ***** ^ not supported yet
  313. 167 p1.row := FindRowOnCol(p1.col, p1.row, p2.col, p2.row, r.col1);
  314. ***** ^ undeclared identifier
  315. ***** ^ not supported yet
  316. ***** ^ not supported yet
  317. ***** ^ undeclared identifier
  318. ***** ^ not supported yet
  319. ***** ^ undeclared identifier
  320. ***** ^ not supported yet
  321. ***** ^ undeclared identifier
  322. ***** ^ not supported yet
  323. ***** ^ undeclared identifier
  324. ***** ^ not supported yet
  325. ***** ^ not supported yet
  326. ***** ^ not supported yet
  327. 168 p1.col := r.col1;
  328. ***** ^ undeclared identifier
  329. ***** ^ not supported yet
  330. ***** ^ not supported yet
  331. ***** ^ not supported yet
  332. 169 END;
  333. 170 IF (p1.col < r.col2) AND (p2.col > r.col2) THEN
  334. ***** ^ undeclared identifier
  335. ***** ^ not supported yet
  336. ***** ^ not supported yet
  337. ***** ^ not supported yet
  338. ***** ^ undeclared identifier
  339. ***** ^ not supported yet
  340. ***** ^ not supported yet
  341. ***** ^ not supported yet
  342. 171 p2.row := FindRowOnCol(p1.col, p1.row, p2.col, p2.row, r.col2);
  343. ***** ^ undeclared identifier
  344. ***** ^ not supported yet
  345. ***** ^ not supported yet
  346. ***** ^ undeclared identifier
  347. ***** ^ not supported yet
  348. ***** ^ undeclared identifier
  349. ***** ^ not supported yet
  350. ***** ^ undeclared identifier
  351. ***** ^ not supported yet
  352. ***** ^ undeclared identifier
  353. ***** ^ not supported yet
  354. ***** ^ not supported yet
  355. ***** ^ not supported yet
  356. 172 p2.col := r.col2;
  357. ***** ^ undeclared identifier
  358. ***** ^ not supported yet
  359. ***** ^ not supported yet
  360. ***** ^ not supported yet
  361. 173 END;
  362. 174 order(p1.row, p2.row, p1.col, p2.col);
  363. ***** ^ not supported yet
  364. ***** ^ undeclared identifier
  365. ***** ^ not supported yet
  366. ***** ^ undeclared identifier
  367. ***** ^ not supported yet
  368. ***** ^ undeclared identifier
  369. ***** ^ not supported yet
  370. ***** ^ undeclared identifier
  371. ***** ^ not supported yet
  372. 175 IF (p1.row < r.row1) AND (p2.row > r.row1) THEN
  373. ***** ^ undeclared identifier
  374. ***** ^ not supported yet
  375. ***** ^ not supported yet
  376. ***** ^ not supported yet
  377. ***** ^ undeclared identifier
  378. ***** ^ not supported yet
  379. ***** ^ not supported yet
  380. ***** ^ not supported yet
  381. 176 p1.col := FindRowOnCol(p1.row, p1.col, p2.row, p2.col, r.row1);
  382. ***** ^ undeclared identifier
  383. ***** ^ not supported yet
  384. ***** ^ not supported yet
  385. ***** ^ undeclared identifier
  386. ***** ^ not supported yet
  387. ***** ^ undeclared identifier
  388. ***** ^ not supported yet
  389. ***** ^ undeclared identifier
  390. ***** ^ not supported yet
  391. ***** ^ undeclared identifier
  392. ***** ^ not supported yet
  393. ***** ^ not supported yet
  394. ***** ^ not supported yet
  395. 177 p1.row := r.row1;
  396. ***** ^ undeclared identifier
  397. ***** ^ not supported yet
  398. ***** ^ not supported yet
  399. ***** ^ not supported yet
  400. 178 END;
  401. 179 IF (p1.row < r.row2) AND (p2.row > r.row2) THEN
  402. ***** ^ undeclared identifier
  403. ***** ^ not supported yet
  404. ***** ^ not supported yet
  405. ***** ^ not supported yet
  406. ***** ^ undeclared identifier
  407. ***** ^ not supported yet
  408. ***** ^ not supported yet
  409. ***** ^ not supported yet
  410. 180 p2.col := FindRowOnCol(p1.row, p1.col, p2.row, p2.col, r.row2);
  411. ***** ^ undeclared identifier
  412. ***** ^ not supported yet
  413. ***** ^ not supported yet
  414. ***** ^ undeclared identifier
  415. ***** ^ not supported yet
  416. ***** ^ undeclared identifier
  417. ***** ^ not supported yet
  418. ***** ^ undeclared identifier
  419. ***** ^ not supported yet
  420. ***** ^ undeclared identifier
  421. ***** ^ not supported yet
  422. ***** ^ not supported yet
  423. ***** ^ not supported yet
  424. 181 p2.row := r.row2;
  425. ***** ^ undeclared identifier
  426. ***** ^ not supported yet
  427. ***** ^ not supported yet
  428. ***** ^ not supported yet
  429. 182 END;
  430. 183 IF PointInside(p1, r) AND PointInside(p2, r) THEN
  431. ***** ^ not supported yet
  432. ***** ^ undeclared identifier
  433. ***** ^ not supported yet
  434. ***** ^ not supported yet
  435. ***** ^ undeclared identifier
  436. ***** ^ not supported yet
  437. 184 intersection := TheLine;
  438. ***** ^ not supported yet
  439. ***** ^ not supported yet
  440. 185 RETURN TRUE;
  441. 186 ELSE
  442. 187 RETURN FALSE;
  443. 188 END;
  444. 189 END;
  445. ***** ^ not supported yet
  446. 190 END LineInside;
  447. ***** ^ not supported yet
  448. 191
  449. 192
  450. 193 PROCEDURE DefineRectangle(VAR r : ARectangle; col1, row1, col2, row2 :
  451. ***** ^ undeclared identifier
  452. 194 INTEGER);
  453. 195 BEGIN
  454. 196 r.col1 := col1;
  455. ***** ^ not supported yet
  456. ***** ^ not supported yet
  457. 197 r.row1 := row1;
  458. ***** ^ not supported yet
  459. ***** ^ not supported yet
  460. 198 r.col2 := col2;
  461. ***** ^ not supported yet
  462. ***** ^ not supported yet
  463. 199 r.row2 := row2;
  464. ***** ^ not supported yet
  465. ***** ^ not supported yet
  466. 200 END DefineRectangle;
  467. ***** ^ not supported yet
  468. 201
  469. 202
  470. 203 PROCEDURE DefineByPoints(VAR r : ARectangle; TopLeft, BottomRight
  471. ***** ^ undeclared identifier
  472. 204 : APoint);
  473. ***** ^ undeclared identifier
  474. 205 BEGIN
  475. 206 r.TopLeft := TopLeft;
  476. ***** ^ not supported yet
  477. ***** ^ not supported yet
  478. ***** ^ not supported yet
  479. 207 r.BottomRight := BottomRight;
  480. ***** ^ not supported yet
  481. ***** ^ not supported yet
  482. ***** ^ not supported yet
  483. 208 END DefineByPoints;
  484. ***** ^ not supported yet
  485. 209
  486. 210
  487. 211 PROCEDURE RectIsInside( VAR r1, r2 : ARectangle) : BOOLEAN;
  488. ***** ^ undeclared identifier
  489. 212 BEGIN
  490. 213 RETURN (r1.col1 >= r2.col1) AND (r1.col2 <= r2.col2) AND
  491. ***** ^ not supported yet
  492. ***** ^ not supported yet
  493. ***** ^ not supported yet
  494. ***** ^ not supported yet
  495. ***** ^ not supported yet
  496. ***** ^ not supported yet
  497. ***** ^ not supported yet
  498. ***** ^ not supported yet
  499. 214 (r1.row1 >= r2.row1) AND (r1.row2 <= r2.row2);
  500. ***** ^ not supported yet
  501. ***** ^ not supported yet
  502. ***** ^ not supported yet
  503. ***** ^ not supported yet
  504. ***** ^ not supported yet
  505. ***** ^ not supported yet
  506. ***** ^ not supported yet
  507. ***** ^ not supported yet
  508. 215 END RectIsInside;
  509. ***** ^ not supported yet
  510. 216
  511. 217
  512. 218 PROCEDURE ShrinkRect( VAR r : ARectangle );
  513. ***** ^ undeclared identifier
  514. 219 BEGIN
  515. 220 IF r.col2 > (r.col1 + 1) THEN
  516. ***** ^ not supported yet
  517. ***** ^ not supported yet
  518. ***** ^ not supported yet
  519. ***** ^ not supported yet
  520. 221 INC( r.col1 );
  521. ***** ^ undeclared identifier
  522. ***** ^ not supported yet
  523. ***** ^ not supported yet
  524. 222 DEC( r.col2 );
  525. ***** ^ undeclared identifier
  526. ***** ^ not supported yet
  527. ***** ^ not supported yet
  528. 223 END;
  529. 224 IF r.row2 > (r.row1 + 1) THEN
  530. ***** ^ not supported yet
  531. ***** ^ not supported yet
  532. ***** ^ not supported yet
  533. ***** ^ not supported yet
  534. 225 INC( r.row1 );
  535. ***** ^ undeclared identifier
  536. ***** ^ not supported yet
  537. ***** ^ not supported yet
  538. 226 DEC( r.row2 );
  539. ***** ^ undeclared identifier
  540. ***** ^ not supported yet
  541. ***** ^ not supported yet
  542. 227 END;
  543. 228 END ShrinkRect;
  544. ***** ^ not supported yet
  545. 229
  546. 230 PROCEDURE ExpandRect( VAR r : ARectangle );
  547. ***** ^ undeclared identifier
  548. 231 BEGIN
  549. 232 IF r.col1 > 1 THEN
  550. ***** ^ not supported yet
  551. ***** ^ not supported yet
  552. 233 DEC( r.col1 );
  553. ***** ^ undeclared identifier
  554. ***** ^ not supported yet
  555. ***** ^ not supported yet
  556. 234 END;
  557. 235 IF r.row1 > 1 THEN
  558. ***** ^ not supported yet
  559. ***** ^ not supported yet
  560. 236 DEC( r.row1 );
  561. ***** ^ undeclared identifier
  562. ***** ^ not supported yet
  563. ***** ^ not supported yet
  564. 237 END;
  565. 238 INC( r.col2 );
  566. ***** ^ undeclared identifier
  567. ***** ^ not supported yet
  568. ***** ^ not supported yet
  569. 239 INC( r.row2 );
  570. ***** ^ undeclared identifier
  571. ***** ^ not supported yet
  572. ***** ^ not supported yet
  573. 240 END ExpandRect;
  574. ***** ^ not supported yet
  575. 241
  576. 242 BEGIN
  577. 243 Initialized := FALSE;
  578. 244 Init();
  579. ***** ^ not supported yet
  580. ***** ^ not supported yet
  581. 245 END Rectangles.
  582. ***** ^ not supported yet
  583. 336 errors