|
1 " |
|
2 COPYRIGHT (c) 1992-93 by Claus Gittinger |
|
3 All Rights Reserved |
|
4 |
|
5 This software is furnished under a license and may be used |
|
6 only in accordance with the terms of that license and with the |
|
7 inclusion of the above copyright notice. This software may not |
|
8 be provided or otherwise made available to, or used by, any |
|
9 other person. No title to or ownership of the software is |
|
10 hereby transferred. |
|
11 " |
|
12 |
|
13 Object subclass:#Cursor |
|
14 instanceVariableNames:'shape sourceForm maskForm hotX hotY |
|
15 device cursorId' |
|
16 classVariableNames: 'lobby |
|
17 DefaultFgColor DefaultBgColor |
|
18 |
|
19 NormalCursor HandCursor ArrowCursor |
|
20 ReadCursor WriteCursor WaitCursor |
|
21 XeqCursor CrossHairCursor OriginCursor |
|
22 CornerCursor SquareCursor FourWayCursor |
|
23 UpDownArrowCursor LeftRightArrowCursor' |
|
24 poolDictionaries:'' |
|
25 category:'Graphics-Support' |
|
26 ! |
|
27 |
|
28 Cursor comment:' |
|
29 |
|
30 COPYRIGHT (c) 1992-93 by Claus Gittinger |
|
31 All Rights Reserved |
|
32 |
|
33 %W% %E% |
|
34 |
|
35 see Cursor class documentation for info. |
|
36 |
|
37 rewritten from XCursor summer 92 by claus |
|
38 '! |
|
39 |
|
40 !Cursor class methodsFor:'documentation'! |
|
41 |
|
42 documentation |
|
43 " |
|
44 I represents cursors in a device independent manner. |
|
45 |
|
46 Instance variables: |
|
47 |
|
48 shape <Symbol> a shape (i.e. #arrow, #hand, ...) or nil |
|
49 sourceForm <Form> if shape is nil, the source bits |
|
50 maskForm <Form> if shape is nil, the mask bits |
|
51 hotX <SmallInteger> if shape is nil, the hotSpot x of the cursor |
|
52 hotY <SmallInteger> if shape is nil, the hotSpot y of the cursor |
|
53 device <aDevice> the device, if associated to one |
|
54 cursorId <anObject> the device-specific id if device is nonNil |
|
55 |
|
56 class variables: |
|
57 |
|
58 lobby <Registry> keeps track of known cursors |
|
59 |
|
60 DefaultFgColor <Color> default foreground color for cursors (usually black) |
|
61 DefaultBgColor <Color> default background color for cursors (usually white) |
|
62 |
|
63 NormalCursor <Cursor> cached instance of normal (arrow) cursor |
|
64 ... |
|
65 |
|
66 " |
|
67 ! ! |
|
68 |
|
69 !Cursor class methodsFor:'initialization'! |
|
70 |
|
71 initialize |
|
72 lobby isNil ifTrue:[ |
|
73 lobby := Registry new. |
|
74 |
|
75 "want to be informed when returning from snapshot" |
|
76 ObjectMemory addDependent:self |
|
77 ] |
|
78 ! |
|
79 |
|
80 flushDeviceCursors |
|
81 "unassign all cursors from their device" |
|
82 |
|
83 lobby contentsDo:[:aCursor | |
|
84 aCursor resetDevice. |
|
85 lobby changed:aCursor |
|
86 ] |
|
87 ! |
|
88 |
|
89 update:something |
|
90 "sent when restarted after a snapIn" |
|
91 |
|
92 (something == #restarted) ifTrue:[ |
|
93 self flushDeviceCursors |
|
94 ] |
|
95 ! ! |
|
96 |
|
97 !Cursor class methodsFor:'default access'! |
|
98 |
|
99 defaultFgColor:fgColor defaultBgColor:bgColor |
|
100 "set the default colors used for cursors" |
|
101 |
|
102 DefaultFgColor := fgColor. |
|
103 DefaultBgColor := bgColor |
|
104 ! ! |
|
105 |
|
106 !Cursor class methodsFor:'instance creation'! |
|
107 |
|
108 extent:extent fromArray:array offset:offset |
|
109 "create a new bitmap cursor from bits in the array argument |
|
110 - ST-80 compatibility" |
|
111 |
|
112 |sourceForm| |
|
113 |
|
114 sourceForm := Form extent:extent fromArray:array offset:offset. |
|
115 ^ self sourceForm:sourceForm maskForm:sourceForm hotSpot:(offset negated) |
|
116 ! |
|
117 |
|
118 extent:extent sourceArray:sourceArray maskArray:maskArray offset:offset |
|
119 "create a new bitmap cursor with mask from bits in sourceArray and |
|
120 maskArray" |
|
121 |
|
122 |sourceForm maskForm| |
|
123 |
|
124 sourceForm := Form extent:extent fromArray:sourceArray offset:offset. |
|
125 maskForm := Form extent:extent fromArray:maskArray offset:offset. |
|
126 ^ self sourceForm:sourceForm maskForm:maskForm hotSpot:(offset negated) |
|
127 ! |
|
128 |
|
129 sourceForm:aForm |
|
130 "return a new cursor. |
|
131 Source- and mask-Bits are taken from aForm; hotSpot is center" |
|
132 |
|
133 ^ self sourceForm:aForm |
|
134 maskForm:aForm |
|
135 hotX:(aForm width // 2) |
|
136 hotY:(aForm height // 2) |
|
137 ! |
|
138 |
|
139 sourceForm:sourceForm maskForm:maskForm |
|
140 "return a new cursor. hotSpot is center" |
|
141 |
|
142 ^ self sourceForm:sourceForm |
|
143 maskForm:maskForm |
|
144 hotX:(sourceForm width // 2) |
|
145 hotY:(sourceForm height // 2) |
|
146 ! |
|
147 |
|
148 sourceForm:sourceForm maskForm:maskForm hotSpot:aPoint |
|
149 "return a new cursor" |
|
150 |
|
151 ^ self sourceForm:sourceForm |
|
152 maskForm:maskForm |
|
153 hotX:(aPoint x) |
|
154 hotY:(aPoint y) |
|
155 ! |
|
156 |
|
157 sourceForm:sourceForm maskForm:maskForm hotX:hotX hotY:hotY |
|
158 "return a new cursor" |
|
159 |
|
160 |newCursor| |
|
161 |
|
162 "first look if not already known" |
|
163 lobby contentsDo:[:aCursor | |
|
164 (aCursor sourceForm == sourceForm) ifTrue:[ |
|
165 (aCursor maskForm == maskForm) ifTrue:[ |
|
166 (aCursor hotX == hotX) ifTrue:[ |
|
167 (aCursor hotY == hotY) ifTrue:[ |
|
168 ^ aCursor |
|
169 ] |
|
170 ] |
|
171 ] |
|
172 ] |
|
173 ]. |
|
174 newCursor := self basicNew sourceForm:sourceForm maskForm:maskForm |
|
175 hotX:hotX hotY:hotY on:nil. |
|
176 lobby register:newCursor. |
|
177 ^ newCursor |
|
178 ! |
|
179 |
|
180 shape:aShape |
|
181 "return one of the standard cursors. |
|
182 Each display may offer different shapes - see for example XWorkstation |
|
183 for details (however a basic minimum set should be supported by all)" |
|
184 |
|
185 |newCursor| |
|
186 |
|
187 "first look if not already known" |
|
188 lobby contentsDo:[:aCursor | |
|
189 (aCursor shape == aShape) ifTrue:[ |
|
190 ^ aCursor |
|
191 ] |
|
192 ]. |
|
193 newCursor := self basicNew shape:aShape on:nil. |
|
194 lobby register:newCursor. |
|
195 ^ newCursor |
|
196 ! |
|
197 |
|
198 fileCursorNamed:cursorName |
|
199 "return a cursor read from the files 'cursorName_bits.bit' and |
|
200 'cursorName_mask.bit' - return nil if file does not exist" |
|
201 |
|
202 |cursorBits maskBits| |
|
203 |
|
204 cursorBits := Form fromFile:(cursorName , '_bits.bit'). |
|
205 cursorBits notNil ifTrue:[ |
|
206 maskBits := Form fromFile:(cursorName , '_mask.bit'). |
|
207 maskBits notNil ifTrue:[ |
|
208 ^ self sourceForm:cursorBits maskForm:maskBits |
|
209 ] |
|
210 ]. |
|
211 ^ nil |
|
212 ! ! |
|
213 |
|
214 !Cursor class methodsFor:'standard cursors'! |
|
215 |
|
216 normal |
|
217 "return the normal cursor; an arrow. |
|
218 for ST-80 compatibility" |
|
219 |
|
220 NormalCursor isNil ifTrue:[ |
|
221 NormalCursor := self arrow |
|
222 ]. |
|
223 ^ NormalCursor |
|
224 ! |
|
225 |
|
226 hand |
|
227 "return a hand cursor" |
|
228 |
|
229 HandCursor isNil ifTrue:[ |
|
230 HandCursor := self shape:#upRightHand |
|
231 ]. |
|
232 ^ HandCursor |
|
233 ! |
|
234 |
|
235 upRightHand |
|
236 "return an up-right-hand cursor" |
|
237 |
|
238 ^ self shape:#upRightHand |
|
239 ! |
|
240 |
|
241 leftHand |
|
242 "return a left-hand cursor" |
|
243 |
|
244 ^ self shape:#leftHand |
|
245 ! |
|
246 |
|
247 upDownArrow |
|
248 "return an up-down-arrow cursor" |
|
249 |
|
250 UpDownArrowCursor isNil ifTrue:[ |
|
251 UpDownArrowCursor := self shape:#upDownArrow |
|
252 ]. |
|
253 ^ UpDownArrowCursor |
|
254 ! |
|
255 |
|
256 leftRightArrow |
|
257 "return a left-right-arrow cursor" |
|
258 |
|
259 LeftRightArrowCursor isNil ifTrue:[ |
|
260 LeftRightArrowCursor := self shape:#leftRightArrow |
|
261 ]. |
|
262 ^ LeftRightArrowCursor |
|
263 ! |
|
264 |
|
265 upLimitArrow |
|
266 "return an up-arrow-to-limit cursor" |
|
267 |
|
268 ^ self shape:#upLimitArrow |
|
269 ! |
|
270 |
|
271 downLimitArrow |
|
272 "return a down-arrow-to-limit cursor" |
|
273 |
|
274 ^ self shape:#downLimitArrow |
|
275 ! |
|
276 |
|
277 leftLimitArrow |
|
278 "return a left-arrow-to-limit cursor" |
|
279 |
|
280 ^ self shape:#leftLimitArrow |
|
281 ! |
|
282 |
|
283 rightLimitArrowOn |
|
284 "return a right-arrow-to-limit cursor" |
|
285 |
|
286 ^ self shape:#rightLimitArrow |
|
287 ! |
|
288 |
|
289 text |
|
290 "return a text-cursor" |
|
291 |
|
292 ^ self shape:#text |
|
293 ! |
|
294 |
|
295 arrow |
|
296 "return an arrow (up-left-arrow) cursor" |
|
297 |
|
298 ^ self shape:#upLeftArrow |
|
299 ! |
|
300 |
|
301 upLeftArrow |
|
302 "return an up-right-arrow cursor" |
|
303 |
|
304 ^ self shape:#upLeftArrow |
|
305 ! |
|
306 |
|
307 upRightArrow |
|
308 "return an up-right-arrow cursor" |
|
309 |
|
310 ^ self shape:#upRightArrow |
|
311 ! |
|
312 |
|
313 questionMark |
|
314 "return a question-mark cursor" |
|
315 |
|
316 ^ self shape:#questionMark |
|
317 ! |
|
318 |
|
319 cross |
|
320 "return a cross cursor" |
|
321 |
|
322 ^ self shape:#cross |
|
323 ! |
|
324 |
|
325 origin |
|
326 "return an origin cursor" |
|
327 |
|
328 OriginCursor isNil ifTrue:[ |
|
329 OriginCursor := self shape:#origin |
|
330 ]. |
|
331 ^ OriginCursor |
|
332 ! |
|
333 |
|
334 corner |
|
335 "return a corner cursor" |
|
336 |
|
337 CornerCursor isNil ifTrue:[ |
|
338 CornerCursor := self shape:#corner |
|
339 ]. |
|
340 ^ CornerCursor |
|
341 ! |
|
342 |
|
343 crossHair |
|
344 "return a crossHair cursor" |
|
345 |
|
346 CrossHairCursor isNil ifTrue:[ |
|
347 CrossHairCursor := self shape:#crossHair |
|
348 ]. |
|
349 ^ CrossHairCursor |
|
350 ! |
|
351 |
|
352 fourWay |
|
353 "return a four-way arrow cursor" |
|
354 |
|
355 FourWayCursor isNil ifTrue:[ |
|
356 FourWayCursor := self shape:#fourWay |
|
357 ]. |
|
358 ^ FourWayCursor |
|
359 ! |
|
360 |
|
361 wait |
|
362 "return a wait cursor" |
|
363 |
|
364 WaitCursor isNil ifTrue:[ |
|
365 WaitCursor := self shape:#wait |
|
366 ]. |
|
367 ^ WaitCursor |
|
368 ! |
|
369 |
|
370 read |
|
371 "return a reading-file cursor" |
|
372 |
|
373 ReadCursor isNil ifTrue:[ |
|
374 ReadCursor := self shape:#wait |
|
375 ]. |
|
376 ^ ReadCursor |
|
377 ! |
|
378 |
|
379 write |
|
380 "return a writing-file cursor" |
|
381 |
|
382 WriteCursor isNil ifTrue:[ |
|
383 WriteCursor := self shape:#wait |
|
384 ]. |
|
385 ^ WriteCursor |
|
386 ! |
|
387 |
|
388 execute |
|
389 "return a execute cursor - ST-80 compatibility" |
|
390 |
|
391 XeqCursor isNil ifTrue:[ |
|
392 XeqCursor := self shape:#wait |
|
393 ]. |
|
394 ^ XeqCursor |
|
395 ! ! |
|
396 |
|
397 !Cursor methodsFor:'instance release'! |
|
398 |
|
399 disposed |
|
400 "some Cursor has been collected - tell it to the x-server" |
|
401 |
|
402 cursorId notNil ifTrue:[ |
|
403 device destroyCursor:cursorId. |
|
404 ] |
|
405 ! ! |
|
406 |
|
407 !Cursor methodsFor:'accessing'! |
|
408 |
|
409 id |
|
410 "return the cursors deviceId" |
|
411 |
|
412 ^ cursorId |
|
413 ! |
|
414 |
|
415 device |
|
416 "return the device I am associated with" |
|
417 |
|
418 ^ device |
|
419 ! |
|
420 |
|
421 shape |
|
422 "return the shape" |
|
423 |
|
424 ^ shape |
|
425 ! |
|
426 |
|
427 shape:aShapeSymbol on:aDevice |
|
428 "set the shape and device of the receiver" |
|
429 |
|
430 shape := aShapeSymbol. |
|
431 device := aDevice |
|
432 ! |
|
433 |
|
434 sourceForm:sForm maskForm:mForm hotX:hx hotY:hy on:aDevice |
|
435 "set the forms, hotspot and device of the receiver" |
|
436 |
|
437 sourceForm := sForm. |
|
438 maskForm := mForm. |
|
439 hotX := hx. |
|
440 hotY := hy. |
|
441 device := aDevice |
|
442 ! |
|
443 |
|
444 sourceForm |
|
445 "return the source-form of the receiver" |
|
446 |
|
447 ^ sourceForm |
|
448 ! |
|
449 |
|
450 sourceForm:aForm |
|
451 "set the source-form of the receiver" |
|
452 |
|
453 sourceForm := aForm |
|
454 ! |
|
455 |
|
456 maskForm |
|
457 "return the mask-form of the receiver" |
|
458 |
|
459 ^ maskForm |
|
460 ! |
|
461 |
|
462 maskForm:aForm |
|
463 "set the mask-form of the receiver" |
|
464 |
|
465 maskForm := aForm |
|
466 ! |
|
467 |
|
468 hotX |
|
469 "return the hotspots x-coordinate of the receiver" |
|
470 |
|
471 ^ hotX |
|
472 ! |
|
473 |
|
474 hotX:aNumber |
|
475 "set the hotspots x-coordinate of the receiver" |
|
476 |
|
477 hotX := aNumber |
|
478 ! |
|
479 |
|
480 hotY |
|
481 "return the hotspots y-coordinate of the receiver" |
|
482 |
|
483 ^ hotY |
|
484 ! |
|
485 |
|
486 hotY:aNumber |
|
487 "set the hotspots y-coordinate of the receiver" |
|
488 |
|
489 hotY := aNumber |
|
490 ! |
|
491 |
|
492 foreground:fgColor background:bgColor |
|
493 "set the cursor colors" |
|
494 |
|
495 device colorCursor:cursorId foreground:fgColor background:bgColor |
|
496 ! ! |
|
497 |
|
498 !Cursor methodsFor:'creating a device cursor'! |
|
499 |
|
500 on:aDevice |
|
501 "create a new Cursor representing the same cursor as |
|
502 myself on aDevice; if one already exists, return the one" |
|
503 |
|
504 |newCursor index id| |
|
505 |
|
506 aDevice isNil ifTrue:[ |
|
507 "this may not happen" |
|
508 self error:'nil device' |
|
509 ]. |
|
510 |
|
511 "if Iam already assigned to that device ..." |
|
512 (device == aDevice) ifTrue:[^ self]. |
|
513 |
|
514 "first look if not already there" |
|
515 lobby contentsDo:[:aCursor | |
|
516 (aCursor device == aDevice) ifTrue:[ |
|
517 shape notNil ifTrue:[ |
|
518 (aCursor shape == shape) ifTrue:[ |
|
519 ^ aCursor |
|
520 ] |
|
521 ] ifFalse:[ |
|
522 (aCursor sourceForm == sourceForm) ifTrue:[ |
|
523 (aCursor maskForm == maskForm) ifTrue:[ |
|
524 (aCursor hotX == hotX) ifTrue:[ |
|
525 (aCursor hotY == hotY) ifTrue:[ |
|
526 ^ aCursor |
|
527 ] |
|
528 ] |
|
529 ] |
|
530 ] |
|
531 ] |
|
532 ] |
|
533 ]. |
|
534 |
|
535 "ask that device for the cursor" |
|
536 shape notNil ifTrue:[ |
|
537 id := aDevice createCursorShape:shape |
|
538 ] ifFalse:[ |
|
539 id := aDevice createCursorSourceForm:sourceForm |
|
540 maskForm:maskForm |
|
541 hotX:hotX |
|
542 hotY:hotY |
|
543 ]. |
|
544 id isNil ifTrue:[ |
|
545 "no such cursor on this device" |
|
546 'no cursor with shape:' print. shape printNewline. |
|
547 ^ nil |
|
548 ]. |
|
549 |
|
550 "goody for IRIXs red cursor" |
|
551 DefaultFgColor notNil ifTrue:[ |
|
552 aDevice colorCursor:id foreground:DefaultFgColor |
|
553 background:DefaultBgColor |
|
554 ]. |
|
555 |
|
556 device isNil ifTrue:[ |
|
557 "receiver was not associated - do it now" |
|
558 device := aDevice. |
|
559 cursorId := id. |
|
560 |
|
561 "must unregister, the old registration had a nil cursorId in it" |
|
562 lobby changed:self. |
|
563 ^ self |
|
564 ]. |
|
565 |
|
566 "receiver was already associated to another device - need a new cursor" |
|
567 shape notNil ifTrue:[ |
|
568 newCursor := (self class basicNew) shape:shape on:aDevice |
|
569 ] ifFalse:[ |
|
570 newCursor := (self class basicNew) sourceForm:sourceForm |
|
571 maskForm:maskForm |
|
572 hotX:hotX |
|
573 hotY:hotY |
|
574 on:aDevice |
|
575 ]. |
|
576 newCursor id:id. |
|
577 lobby register:newCursor. |
|
578 ^ newCursor |
|
579 ! ! |
|
580 |
|
581 !Cursor methodsFor:'private'! |
|
582 |
|
583 device:aDevice |
|
584 device := aDevice |
|
585 ! |
|
586 |
|
587 id:anId |
|
588 "set the cursors deviceId" |
|
589 |
|
590 cursorId := anId |
|
591 ! |
|
592 |
|
593 resetDevice |
|
594 "set both device and id" |
|
595 |
|
596 device := nil. |
|
597 cursorId := nil |
|
598 ! ! |
|
599 |
|
600 !Cursor methodsFor:'displaying'! |
|
601 |
|
602 showIn:aView |
|
603 aView cursor:self |
|
604 ! |
|
605 |
|
606 showIn:aView while:aBlock |
|
607 |savedCursor| |
|
608 |
|
609 savedCursor := aView cursor. |
|
610 aView cursor:self. |
|
611 [ |
|
612 aBlock value. |
|
613 ] valueNowOrOnUnwindDo:[ |
|
614 aView cursor:savedCursor |
|
615 ] |
|
616 ! |
|
617 |
|
618 showWhile:aBlock |
|
619 "change all views cursors to the receiver. |
|
620 In X this seems to be very slow" |
|
621 |
|
622 |v| |
|
623 |
|
624 Display setCursors:self. |
|
625 "ModalDisplay setCursors:self." |
|
626 v := aBlock valueNowOrOnUnwindDo:[ |
|
627 Display restoreCursors. |
|
628 "ModalDisplay restoreCursors" |
|
629 ]. |
|
630 ^ v |
|
631 ! |
|
632 |
|
633 displayOn:aGC at:origin clippingBox:aRectangle rule:aRule mask:aMask |
|
634 "ST-80 compatibility; |
|
635 limited functionality: can only display bitmap cursors (yet)" |
|
636 |
|
637 sourceForm notNil ifTrue:[ |
|
638 sourceForm displayOn:aGC at:origin clippingBox:aRectangle |
|
639 rule:aRule mask:aMask |
|
640 ] |
|
641 ! ! |