source: cprs/branches/tmg-cprs/m_files/TMGWGOJ.m@ 1085

Last change on this file since 1085 was 796, checked in by Kevin Toppenberg, 14 years ago

Initial upload
File size: 51.9 KB
Line 
1TMGWGOJ ;TMG/kst/OO Graphic Object ;04/18/07
2 ;;1.0;TMG-LIB;**1**;04/18/07
3
4 ;"Kevin Toppenberg MD
5 ;"GNU General Public License (GPL) applies
6 ;"------------------------------------------
7 ;"Object oriented window object setup code below
8 ;"------------------------------------------
9
10Constructor(instanceName) ;"Module MUST have 'Constructor' procedure
11 ;"Purpose -- A constructor for object Window
12 ;"Input: instanceName -- the NAME of the type of the object to be defined.
13 ;" This should be a variable (global or otherwise) of the object.
14 ;"Note: This function should NOT be called directly, but instead is called
15 ;" via new^TMGOOL
16 ;"Result: none <--- REQUIRED TO NOT RETURN A RESULT
17
18 ;"Here we define the default values for vars and functions.
19
20 ;"----------------All constructors should copy this format --------------------
21 new TMGthis set TMGthis=instanceName
22
23 ;"do inheritFrom^TMGOOL(instanceName,"TMGWSCR")
24
25 ;"Examples of use: PROCEDURES/FUNCTIONS
26 ;"Note: to evoke a procedure/function, use this format:
27 ;" do proc^TMGOOL(instanceName,"SET TOP",MyTopVar),!
28 ;" set MyTop=$$fn^TMGOOL(instanceName,"GET TOP")
29
30 ;"---------------------------------------------------------
31 ;"register PROCEDURES/FUNCTIONS
32 do regFn^TMGOOL(TMGthis,"PAINT","Paint^TMGWGOJ()")
33 do regFn^TMGOOL(TMGthis,"MOVE TO","MoveTo^TMGWGOJ(Top,Left)") ;"note parameter variables are placeholders
34 do regFn^TMGOOL(TMGthis,"SET TLBR","setTLBR^TMGWGOJ(Top,Left,Bottom,Right)") ;"note parameter variables are placeholders
35 do regFn^TMGOOL(TMGthis,"SET TLHW","setTLHW^TMGWGOJ(Top,Left,Height,Width)") ;"note parameter variables are placeholders
36 do regFn^TMGOOL(TMGthis,"MOVE OBJ","MoveObj^TMGWGOJ(cmdKey)")
37 do regFn^TMGOOL(TMGthis,"RESIZE OBJ","ResizeObj^TMGWGOJ(flags,cmdKey)")
38 do regFn^TMGOOL(TMGthis,"CLIP TO PARENT","ClipToParent^TMGWGOJ(TMGthis)")
39
40 do regFn^TMGOOL(TMGthis,"GET SCREEN","GetScrn^TMGWGOJ()")
41 do regFn^TMGOOL(TMGthis,"ACCEPT CHILD","AcceptChild^TMGWGOJ(Child)")
42 do regFn^TMGOOL(TMGthis,"SET FOCUSED","setFocused^TMGWGOJ(child)")
43 do regFn^TMGOOL(TMGthis,"IS FOCUSED","IsFocused^TMGWGOJ(child)")
44 do regFn^TMGOOL(TMGthis,"GET FOCUSED","getFocused^TMGWGOJ()")
45 do regFn^TMGOOL(TMGthis,"UNFOCUS CURRENT FOCUSED","UnfocusCur^TMGWGOJ()")
46 do regFn^TMGOOL(TMGthis,"FLUSH SCREEN SAVE","FlushScrnSave^TMGWGOJ()")
47 do regFn^TMGOOL(TMGthis,"FLUSH MOUSE SAVE","FlushMouseBuffer^TMGWGOJ()")
48 do regFn^TMGOOL(TMGthis,"CONTAINS COORDS","Contains^TMGWGOJ(LOC)")
49 do regFn^TMGOOL(TMGthis,"GET CONTAINED","GetContained^TMGWGOJ(LOC)")
50 do regFn^TMGOOL(TMGthis,"CONVERT TO FRAME","Conv2Frame^TMGWGOJ(LOC,TargetFrame)")
51
52 ;"---------------------------------------------------------------------
53 ;"Register Event Handlers
54 do regEvent^TMGOOL(TMGthis,"MSG","HandleMsg^TMGWGOJ(cmdKey)")
55 do regEvent^TMGOOL(TMGthis,"ALPHA KEY","HandleAlpha^TMGWGOJ(key)")
56 do regEvent^TMGOOL(TMGthis,"CLICK","HandleClick^TMGWGOJ(LOC)")
57 do regEvent^TMGOOL(TMGthis,"FRAME CLICK","FmClick^TMGWGOJ(LOC,Flags)")
58 do regEvent^TMGOOL(TMGthis,"SHIFT-CLICK","HandleSClick^TMGWGOJ(LOC)")
59 do regEvent^TMGOOL(TMGthis,"MOVE REQUEST","HndlMMove^TMGWGOJ(cmdKey)")
60 do regEvent^TMGOOL(TMGthis,"LOOSING FOCUS","") ;"<--- implement later
61
62 ;"---------------------------------------------------------------------
63 ;"Register Properties
64
65 do regProp^TMGOOL(TMGthis,"LOC","","","$$getLOC^TMGWGOJ") ;"actually holds T,L,W,H,S,F below
66 do regProp^TMGOOL(TMGthis,"TOP",0,"setTop^TMGWGOJ","$$getTop^TMGWGOJ")
67 do regProp^TMGOOL(TMGthis,"LEFT",0,"setLeft^TMGWGOJ","$$getLeft^TMGWGOJ")
68 do regProp^TMGOOL(TMGthis,"WIDTH",10,"setWidth^TMGWGOJ","$$getWidth^TMGWGOJ")
69 do regProp^TMGOOL(TMGthis,"HEIGHT",10,"setHeight^TMGWGOJ","$$getHeight^TMGWGOJ")
70 do regProp^TMGOOL(TMGthis,"ALIGN","NONE","","","NONE^TOP^LEFT^BOTTOM^RIGHT")
71
72 do regProp^TMGOOL(TMGthis,"FRAME","SOLID","","","NONE^SOLID^SIZABLE")
73 do regProp^TMGOOL(TMGthis,"NEEDS REPAINT",0,"","$$getNeedsRepaint^TMGWGOJ","0^1")
74 do regProp^TMGOOL(TMGthis,"RESIZING FLAGS","","","","^[TBLR]") ;"current resizing mode
75 do regProp^TMGOOL(TMGthis,"TITLE","") ;"default null title
76 do regProp^TMGOOL(TMGthis,"PARENT","","setParent^TMGWGOJ","$$getParent^TMGWGOJ")
77 do regProp^TMGOOL(TMGthis,"STATE",0,"setState^TMGWGOJ","$$getState^TMGWGOJ","SELECTED^0")
78 do regProp^TMGOOL(TMGthis,"FOCUSED",0,"","","0^1")
79 do regProp^TMGOOL(TMGthis,"LAST DRAW","")
80 do regProp^TMGOOL(TMGthis,"SCREEN","")
81
82 ;"---------------------------------------------------------------------
83 ;"Optional initialization of some instance-specific variables.
84
85 ;"--------------------------------------------------------------------------------
86 ;"Startup code here...
87
88 quit
89
90
91Destructor(instanceName) ;"Module MUST have 'Destructor' procedure
92 ;"Purpose: A destructor for object Widget
93 ;" any needed clean up code would go here first.
94 ;"Input: instanceName -- the name of the object instance to be deleted.
95 ;" This should be the value returned from defWidget
96 ;"Note: Don't actually delete the object here. Just perform code needed to
97 ;" save the object variables etc. Anything neeed before the object
98 ;" is deleted by delete^TMGOOL
99
100 ;"-----------------
101
102 ;" Here I put code that needs to be called before destruction of the object.
103
104 ;"-----------------
105
106 ;"Here I delete any children (and they can delete their children)
107 new num set num=""
108 for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do
109 . new child set child=$order(@TMGthis@("CHILDREN",num,""))
110 . if child="" quit
111 . do delete^TMGOOL(child)
112
113 quit
114
115
116 ;"------------------------------------------
117 ;"Object member functions below
118 ;"------------------------------------------
119
120 ;"Note: A variable (with global scope) TMGthis is available as a 'this' pointer (this instance)
121 ;"Note: ALL members must have QUIT xx (even if xx is meaningless, as in a procedure)
122
123Paint()
124 ;"Purpose: To paint the current window (and all children windows)
125 ;"Input: instanceName -- the name/ref of this instance
126
127 new T,L,H,W,B,R,LOC
128 new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
129 set scrap=$$Conv2Frame(.LOC,"SCREEN")
130 set T=+$get(LOC("TOP")),L=+$get(LOC("LEFT"))
131 set B=+$get(LOC("BOTTOM")),R=+$get(LOC("RIGHT"))
132
133 if $data(@TMGthis@("screen save")) do
134 . do CLRCLIP^TMGXGF
135 . do RESTORE^TMGXGF($name(@TMGthis@("screen save")))
136 . ;"note: tell children to flush their saved screens."
137 . new num set num=""
138 . for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do
139 . . new child set child=$order(@TMGthis@("CHILDREN",num,""))
140 . . if child="" quit
141 . . do proc^TMGOOL(child,"FLUSH SCREEN SAVE")
142
143 new selected,focused
144 set selected=($$getProp^TMGOOL(TMGthis,"STATE")="SELECTED")
145 ;"new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
146 ;"set focused=$$fn^TMGOOL(parent,"IS FOCUSED",TMGthis)
147 set focused=$$fn^TMGOOL(TMGthis,"IS FOCUSED")
148 new rflags set rflags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS")
149
150 do proc^TMGOOL(TMGthis,"CLIP TO PARENT",TMGthis)
151
152 if selected do CHGA^TMGXGF("I1")
153 do WIN^TMGXGF(T,L,B,R,$name(@TMGthis@("screen save")))
154 if (rflags'="") do
155 . do CHGA^TMGXGF("R1")
156 . do FRAME^TMGXGF(T,L,B,R)
157 . do CHGA^TMGXGF("R0")
158 else if ('selected)&(focused) do
159 . do CHGA^TMGXGF("I1")
160 . do FRAME^TMGXGF(T,L,B,R)
161 if (selected)!(focused) do CHGA^TMGXGF("I0")
162
163 if rflags'="" do ;"goto P2
164PMV . new msg set msg=" ["
165 . if rflags="T" set msg=msg_"MOVING"
166 . else set msg=msg_"RESIZING"
167 . set msg=msg_". Press ENTER to stop] "
168 . set W=+$get(LOC("WIDTH"))
169 . set msg=$extract(msg,1,W-1)
170 . do SAY^TMGXGF(T+1,L+1,msg,"")
171 . do setProp^TMGOOL($$GetScrn(),"NEEDS REPAINT",1) ;"flag full screen repaint needed next time
172
173 ;"Here I paint any children (and they can paint their children)
174 new num set num=""
175 for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do
176X2 . new child set child=$order(@TMGthis@("CHILDREN",num,""))
177 . if child="" quit
178 . do proc^TMGOOL(child,"PAINT")
179
180P2
181 do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",0) ;"flag as painted.
182
183 quit 0
184
185
186MoveObj(cmdKey)
187 ;"Purpose: To move (drag) the object based on mouse movement
188 ;"Input: cmdKey. PASS BY REFERENCE. An array with following structure
189 ;" cmdKey="xxx" <--- ignored
190 ;" cmdKey("DELTA","TOP") <-- delta Y
191 ;" cmdKey("DELTA","LEFT") <-- delta X
192 ;"Output: returns result in cmdKey('RESULT'): -1=failure, 1=success
193
194 new T,L,LOC,PLOC,dT,dL,csrT,csrL
195 new result set result=0
196 new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
197
198 set dT=+$get(cmdKey("DELTA","TOP")),dL=+$get(cmdKey("DELTA","LEFT"))
199 set csrT=+$get(cmdKey("GLOBAL COORDS","TOP"))
200 set csrL=+$get(cmdKey("GLOBAL COORDS","LEFT"))
201 new PT,PL,PB,PR
202 do getPCoords(TMGthis,.PT,.PL,.PB,.PR) ;"get parent coordinates (in SCREEN frame of refernce)
203 if (dT<0)&(csrT<PT) set result=-1
204 if (dT>0)&(csrT>PB) set result=-1
205 if (dL<0)&(csrL<PL) set result=-1
206 if (dL>0)&(csrL>PR) set result=-1
207 if result=-1 goto MOL2
208
209 set T=$get(LOC("TOP"))+dT
210 set L=$get(LOC("LEFT"))+dL
211 set result=$$fn^TMGOOL(TMGthis,"MOVE TO",.T,.L)
212MOL2
213 if result>0 do
214 . new scrap set scrap=$$FlushMouseBuffer()
215 . do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1) ;"flag repaint of entire screen
216 . set cmdKey("RESULT")=1
217 else do
218 . set cmdKey("RESULT")=-1
219 quit result
220
221
222ResizeObj(flags,cmdKey)
223 ;"Purpose: to resize the object based on mouse movement.
224 ;"Input: flags
225 ;" "T" if on top of frame ; <--- shouldn't be called here with just T
226 ;" "B" if on bottom of frame
227 ;" "L" if on left of frame
228 ;" "R" if on right of frame
229 ;" "TL","TR","BL","BR" for the corners
230 ;" cmdKey. PASS BY REFERENCE. An array with following structure
231 ;" cmdKey="xxx" <--- ignored
232 ;" cmdKey("DELTA","TOP") <-- delta Y
233 ;" cmdKey("DELTA","LEFT") <-- delta X
234 ;"Results: none
235 ;"Output: cmdKey("RESULT")=-1 if failure
236
237 new T,L,W,H,LOC
238 new scrap set scrap=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
239 set T=$get(LOC("TOP")),L=$get(LOC("LEFT"))
240 set H=$get(LOC("HEIGHT")),W=$get(LOC("WIDTH"))
241 new dX,dY
242 set dX=$get(cmdKey("DELTA","LEFT"))
243 set dY=$get(cmdKey("DELTA","TOP"))
244
245 if flags["T" do
246 . set T=T+dY
247 . set H=H-dY
248 if flags["L" do
249 . set L=L+dX
250 . set W=W-dX
251 if flags["B" do
252 . set H=H+dY
253 if flags["R" do
254 . set W=W+dX
255
256 new success set success=$$setTLHW(T,L,H,W)
257 if success=0 do
258RO1 . set cmdKey("RESULT")=-1 ;"failure signal.
259 else new scrap set scrap=$$FlushMouseBuffer()
260
261 quit 0
262
263
264MoveTo(Top,Left)
265 ;"Purpose: position object
266 ;"Results: 1 if change made, 0 if not change made
267 new result set result=0
268 new LOC set LOC=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
269 if $get(LOC("TOP"))'=Top do
270 . do setProp^TMGOOL(TMGthis,"TOP",.Top)
271 . if $$getProp^TMGOOL(TMGthis,"TOP")'=Top quit ;" set failed
272 . set result=1
273 if $get(LOC("LEFT"))'=Left do
274 . do setProp^TMGOOL(TMGthis,"LEFT",.Left)
275 . if $$getProp^TMGOOL(TMGthis,"LEFT")'=Left quit ;" set failed
276 . set result=1
277 ;"do setProp^TMGOOL(TMGthis,"TOP",.Top)
278 ;"do setProp^TMGOOL(TMGthis,"LEFT",.Left)
279 quit result
280
281
282AcceptChild(Child)
283 ;"Purpose: to add a child to list of managed children
284 ;"Input: Child -- name/ref of child to add
285
286 ;"Note: this num will be used as a 'z-order'. Can reorder later
287 new num set num=""
288 for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'=num)
289 set num=$order(@TMGthis@("CHILDREN",num),-1) ;"get last used number
290 set num=num+1
291 set @TMGthis@("CHILDREN",num,Child)=""
292 quit 0
293
294
295FlushScrnSave()
296 ;"Purpose: To flush the saved text from under this window
297 kill @TMGthis@("screen save")
298 quit 0
299
300
301Contains(LOC)
302 ;"Purpose: To see if some coordinates are located inside this window
303 ;"Input: LOC -- a location array. Pass by reference
304 ;" LOC("TOP")=top
305 ;" LOC("LEFT")=left
306 ;" Coordinates (in parent's frame of reference)
307 ;"Results: 1 if coordinates are contained, 0 otherwise
308
309 new result set result=0
310 ;"new temp set temp=$$Conv2Local(.LOC)
311 ;"new temp set temp=$$Conv2Frame(.LOC,TMGthis)
312 ;"Reemmber, THISs' coordinates are in parent's frame of ref
313 new thisLOC set thisLOC=$$getProp^TMGOOL(TMGthis,"LOC",.thisLOC)
314 if (LOC("TOP")<$get(thisLOC("TOP")))!(LOC("LEFT")<$get(thisLOC("LEFT"))) goto CDone
315 if LOC("TOP")>($get(thisLOC("TOP"))+$get(thisLOC("HEIGHT"))) goto CDone
316 if LOC("LEFT")>($get(thisLOC("LEFT"))+$get(thisLOC("WIDTH"))) goto CDone
317 set result=1
318CDone
319 quit result
320
321
322Conv2Frame(LOC,targetFrame)
323 ;"Purpose: convert LOC to targetFrame's coordinate system.
324 ;" Note: initially, targetFrame may only be the name/ref of a parent,
325 ;" or child of TMGthis, or the word 'SCREEN' to indicate
326 ;" a desired targetFrame to be in screen coordinates.
327 ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
328 ;" LOC("TOP")=
329 ;" LOC("LEFT")=
330 ;" LOC("HEIGHT")= ;"optional
331 ;" LOC("WIDTH")= ;"optional
332 ;" LOC("BOTTOM")=
333 ;" LOC("RIGHT")=
334 ;" LOC("FRAME")=Frame of reference for these coordinates
335 ;" Note: frame should typically be the same as
336 ;" the PARENT of the current object
337 ;" targetFrame=the frame of refernce to change to.
338 ;"Results: none
339 ;"Output: Input variables are modified as OUT PARAMETERS
340 ;" LOC("TOP") is modified
341 ;" LOC("LEFT") is modified
342 ;" LOC("HEIGHT")=unchanged
343 ;" LOC("WIDTH")=unchanged
344 ;" LOC("BOTTOM") is updated
345 ;" LOC("RIGHT") is updated
346
347 new pathArray
348 do getPath(.LOC,targetFrame,.pathArray)
349 do convPath(.LOC,.pathArray)
350
351C2FDone
352 quit 0
353
354
355GetScrn()
356 ;"Purpose: to get a ref/name/pointer to Screen.
357 ;" Note: because all graphic objects have to have the Screen as the
358 ;" ultimate parent, this will be found by recursively searching for parents
359 ;"results: returns ref to Screen
360
361 new result set result=""
362 new curObj set curObj=TMGthis
363 for do quit:(curObj="")!(result'="")
364 . set result=$$getProp^TMGOOL(curObj,"SCREEN")
365 . set curObj=$$getProp^TMGOOL(curObj,"PARENT")
366
367 quit result
368
369
370ClipToParent(TMGthis,extraT,extraL,extraB,extraR)
371 ;"Purpose: to set the clipping boundries to the parent frame of TMGthis
372 ;"Note: because the parent frame might be partly off screen, this will also
373 ;" clip to the screen to prevent off-screen writing.
374 ;"Input: TMGthis -- the THIS pointer to have the clipping to
375 ;" extraT,extraL,extraB,extraR -- OPTIONAL -- NOT IMPLEMENTED (YET)
376 ;" was to allow shrinking of the clip area by extra amounts.
377 new PT,PL,PB,PR
378 do getPCoords(TMGthis,.PT,.PL,.PB,.PR) ;"get parent coordinates
379 new pScrn set pScrn=$$GetScrn()
380 new ST,SL,SB,SR,SLOC
381 set SLOC=$$getProp^TMGOOL(pScrn,"LOC",.SLOC) ;"get screen coordinates
382 set ST=+$get(SLOC("TOP"))
383 set SL=+$get(SLOC("LEFT"))
384 set SR=SL+$get(SLOC("WIDTH"))
385 set SB=ST+$get(SLOC("HEIGHT"))
386 if PT<ST set PT=ST
387 if PB'<SB set PB=SB
388 if PL<SL set PL=SL
389 if PR'<SR set PR=SR
390 do SETCLIP^TMGXGF(PT,PL,PB,PR) ;"clip to parent's window
391 quit 0
392
393
394FlushMouseBuffer()
395 ;"Purpose: to flush mouse buffer so false trail isn't laid down after object change
396
397 new pScrn set pScrn=$$GetScrn()
398 set pScrn=$$getProp^TMGOOL(pScrn,"MOUSE HOLDER")
399 if pScrn'="" kill @pScrn@("MOUSE","SAVE") ;"flush mouse save buffer
400 quit 0
401
402 ;"------------------------------------------
403 ;"Event handlers below
404 ;"------------------------------------------
405
406HandleAlpha(key)
407 ;"Purpose: Accept an alpha-numeric character, and process as implemented
408 ;"Note: This will be one key at a time, EXCEPT if an enter/return has
409 ;" been pressed. In that case, key=CR
410 ;"input: key -- the one letter alpha-numeric entered by user
411
412 ;"I will add functionality here later...
413
414 quit ;"<-- required: NO return value for event handler
415
416
417HandleMsg(cmdKey)
418 ;"Purpose: Accept a command character, and process as implemented
419 ;"Input: cmdKey -- the command input. Examples:
420 ;" **MESSAGES**
421 ;" For messages, cmdKey='MESSAGE TEXT'
422 ;" All messages will include mouse locations:
423 ;" cmdKey("TOP"), and cmdKey("LEFT") <-- in parent's coordinates frame of reference
424 ;" Note: Because the top,left are in the parent's frame of reference,
425 ;" a call to Conv2Local to get local frame. For example,
426 ;" if a control on a window was located at 10,10 and it gets clicked
427 ;" at 12,15, then a call Conv2Local will convert this to 2,5, and
428 ;" this will make sense for the child
429 ;" COMMAND Details stored in ("KEY") node: e.g.
430 ;" UP, DOWN, LEFT, RIGHT
431 ;" NEXT (page down), PREV (page up)
432 ;" REMOVE (for delete)
433 ;" note: HOME and END are NOT returned from READ^TMGXGF.
434 ;" F1, F2, ...
435 ;" ^A, ^B (ctrl-A, ctrl-B etc.)
436 ;" TAB
437 ;" ESC (maybe)
438 ;" MOUSE-CLICK -- includes mouse location
439 ;" MOUSE-SHIFT-CLICK -- includes mouse location
440 ;" MOVE REQUEST
441 ;" ("DELTA","TOP")=deltaTop
442 ;" ("DELTA","LEFT")=deltaLeft
443 ;" i.e. TOP=1,LEFT=1 would mean that the mouse moved downward 1 and rightward 1
444 ;" CHECK PAINT, FULL PAINT
445 ;"Result: none. To pass back a result, set:
446 ;" cmdKey("RESULT")=result
447 ;" -1 ==> failure
448 ;" 0 ==> OK
449 ;" 1 ==> handled
450
451 new result set result=0
452 set cmdKey=$get(cmdKey)
453 set cmdKey("RESULT")=result
454 new child set child=""
455 new temp set temp=$$Conv2Frame(.cmdKey,TMGthis) ;"convert coordinates to TMGthis's frame
456
457 if cmdKey="FULL PAINT" do
458 . ;"Draw a frame to white out entire screen.
459 . ;"do CLEAR^TMGXGF(0,0,IOSL,IOM) ;"clear screen portion TOP,LEFT,BOTTOM,RIGHT
460 . new scrap set scrap=$$FlushScrnSave()
461 . do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1)
462 . set cmdKey="CHECK PAINT"
463
464 if cmdKey="CHECK PAINT" do goto AMDone
465 . do CheckPaint ;"note only MainWindow should be getting this event, from Screen
466
467 ;"NOTE: If a CLICK occurs, check to pass the message on to newly chosen child
468 ;" Otherwise message should go to focused child.
469 if cmdKey["CLICK" do goto:(child'="") AMDone
470 . ;"First find out if click should belong to a child window. If so, pass it on.
471 . set child=$$GetContained(.cmdKey)
472 . if child="" do UnfocusCur() quit ;"ignore click
473 . else do FocusThis()
474 . do fireEvent^TMGOOL(child,"MSG",.cmdKey)
475
476 new focused set focused=$$getFocused()
477 if focused'="" do goto AMDone
478 . do fireEvent^TMGOOL(focused,"MSG",.cmdKey) ;"pass message to focused and quit
479
480 ;"Message belongs to this object, so handle messages below:
481 ;"--------------------------------------------------------
482 do FocusThis()
483 if cmdKey="MOUSE-CLICK" do
484 . set cmdKey("RESULT")=1
485 . do fireEvent^TMGOOL(TMGthis,"CLICK",.cmdKey)
486 else if cmdKey="MOUSE-SHIFT-CLICK" do
487 . do fireEvent^TMGOOL(TMGthis,"SHIFT-CLICK",.cmdKey)
488 . set cmdKey("RESULT")=1
489 else if cmdKey="MOVE REQUEST" do
490AMMM . new flags set flags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS")
491 . if flags="" do fireEvent^TMGOOL(TMGthis,"MOVE REQUEST",.cmdKey) quit
492 . new pScrn set pScrn=$$GetScrn()
493 . do setProp^TMGOOL(pScrn,"NEEDS REPAINT",1)
494 . new scrap set scrap=$$FlushMouseBuffer()
495 . if flags="T" do quit
496 . . do proc^TMGOOL(TMGthis,"MOVE OBJ",.cmdKey) ;"returns result in cmdKey
497 . do proc^TMGOOL(TMGthis,"RESIZE OBJ",flags,.cmdKey) quit
498
499AMDone
500 quit ;"<-- required: NO return value for event handler
501
502
503HndlMMove(cmdKey) ;"Handle MouseMove request
504 ;"Purpose: Handle Mouse Move
505 ;"Input: cmdKey -- the command input.
506 ;" MOVE REQUEST
507 ;" ("TOP")=Current Top
508 ;" ("LEFT")=Current Left
509 ;" ("DELTA","TOP")=deltaTop
510 ;" ("DELTA","LEFT")=deltaLeft
511 ;" i.e. TOP=1,LEFT=1 would mean that the mouse moved downward 1 and rightward 1
512 ;"Result: None, but result is put into cmdKey("RESULT")
513 ;" -1 ==> failure
514 ;" 0 ==> OK
515 ;" 1 ==> handled
516
517 new abort set abort=0
518 set cmdKey("RESULT")=0
519 new temp set temp=$$Conv2Frame(.cmdKey,TMGthis) ;"ensure coordinates in TMGthis's frame
520 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT") ;"if null, then this is MainWindow
521 new newT,newL
522 set newT=+$get(cmdKey("TOP"))+$get(cmdKey("DELTA","TOP"))
523 set newL=+$get(cmdKey("LEFT"))+$get(cmdKey("DELTA","LEFT"))
524 set LOC=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
525
526 if (newT<0)!(newT>$get(LOC("HEIGHT")))!(newL<0)!(newL>$get(LOC("WIDTH"))) do
527 . if parent="SCREEN" do quit ;"don't allow mouse to go off screen.
528 . . set result=-1,abort=1
529 . do fireEvent^TMGOOL(TMGthis,"LOOSING FOCUS",.cmdKey)
530 if abort goto HMMDone
531
532HMM new flags set flags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS")
533 if flags="" goto HMMDone
534 if flags="T" do proc^TMGOOL(TMGthis,"MOVE OBJ",.cmdKey) goto HMMDone
535 do proc^TMGOOL(TMGthis,"RESIZE OBJ",flags,.cmdKey) goto HMMDone
536HMMDone
537 set cmdKey("RESULT")=result
538 quit ;"<-- required: NO return value for event handler
539
540
541HandleClick(LOC)
542 ;"Purpose: do something here with a mouse click. Note: descendents can
543 ;" overwrite this function to customize their control.
544 ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
545 ;" coordinates in LOCAL frame of refeernces.
546 ;" LOC("TOP")=
547 ;" LOC("LEFT")=
548 ;" LOC("HEIGHT")= ;"optional
549 ;" LOC("WIDTH")= ;"optional
550 ;" LOC("BOTTOM")= ;"optional
551 ;" LOC("RIGHT")= ;"optional
552 ;"Note: It has already been determined that the click belongs to this window
553 ;" (and not a child of this window), so it should be handled here.)
554
555 ;"Click belongs to this window, so handle it.
556
557 ;"Put default click handler code here...
558 do FocusThis()
559 new temp set temp=$$Conv2Frame(.LOC,TMGthis) ;"ensure coordinates in TMGthis's frame
560
561 new checkFrame set checkFrame=$$ClickOnFrame(.LOC)
562 if checkFrame'="" do goto HCDone
563 . do fireEvent^TMGOOL(TMGthis,"FRAME CLICK",.LOC,.checkFrame)
564
565HCDone
566 quit ;"<-- required: NO return value for event handler
567
568
569
570HandleSClick(LOC)
571 ;"Purpose: do something here with a mouse shift click. Note: descendents can
572 ;" overwrite this function to customize their control.
573 ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
574 ;" coordinates in LOCAL frame of refeernces.
575 ;" LOC("TOP")=
576 ;" LOC("LEFT")=
577 ;" LOC("HEIGHT")= ;"optional
578 ;" LOC("WIDTH")= ;"optional
579 ;" LOC("BOTTOM")= ;"optional
580 ;" LOC("RIGHT")= ;"optional
581 ;"Note: It has already been determined that the click belongs to this window
582 ;" (and not a child of this window), so it should be handled here.)
583
584 ;"Click belongs to this window, so handle it.
585
586 ;"Put default click handler code here...
587 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
588 do proc^TMGOOL(parent,"SET FOCUSED",TMGthis)
589
590 if $$getProp^TMGOOL(TMGthis,"STATE")="SELECTED" do
591 . do setProp^TMGOOL(TMGthis,"STATE",0)
592 else do setProp^TMGOOL(TMGthis,"STATE","SELECTED")
593
594ADCDone
595 quit ;"<-- required: NO return value for event handler
596
597
598FmClick(LOC,flags)
599 ;"Purpose: Handle a click on the frame.
600 ;" This sets RESIZING FLAGS property for later
601 ;" interpretation during window paints and mouse moves
602 ;"Input: LOC -- the coordinates of the triggering click.
603 ;" flags, containing:
604 ;" "T" if on top of frame
605 ;" "B" if on bottom of frame
606 ;" "L" if on left of frame
607 ;" "R" if on right of frame
608 ;" "TL","TR","BL","BR" for the corners
609 ;" note: no gaurantee regarding order: "TL" vs "LT"
610
611 if $get(flags)="" goto AFMCDone
612 if $$getProp^TMGOOL(TMGthis,"FRAME")'="SIZABLE" goto AFMCDone ;"If not resizable, abort
613
614 new curFlags set curFlags=$$getProp^TMGOOL(TMGthis,"RESIZING FLAGS")
615 if (curFlags'="") set flags="" ;"i.e. 2nd click on frame drops resizing
616 do setProp^TMGOOL(TMGthis,"RESIZING FLAGS",flags)
617 do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",1)
618 new scrap set scrap=$$FlushMouseBuffer()
619
620AFMCDone
621 quit
622
623
624
625 ;"------------------------------------------
626 ;"Property Getters & Setters below
627 ;"------------------------------------------
628
629getLOC(TMGthis,PropName,outArray)
630 ;"Purpose: to get LOC coordinates array of window
631 ;"Input: TMGthis -- a this pointer for properter setter.
632 ;" PropName -- the name of the property -- not used here
633 ;" outArray -- PASSED BY REFERENCE. An standardized output array
634 ;"Note: because sometimes the getters do special things, I will alter
635 ;" this function so it doesn't bypass that code
636 set outArray("TOP")=+$$getProp^TMGOOL(TMGthis,"TOP")
637 set outArray("LEFT")=+$$getProp^TMGOOL(TMGthis,"LEFT")
638 set outArray("WIDTH")=+$$getProp^TMGOOL(TMGthis,"WIDTH")
639 set outArray("HEIGHT")=+$$getProp^TMGOOL(TMGthis,"HEIGHT")
640 set outArray("STATE")=+$$getProp^TMGOOL(TMGthis,"STATE")
641 ;"merge outArray=@TMGthis@("PROP","LOC")
642 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
643 set outArray("FRAME")=parent
644 quit 0 ;"discarable result.
645
646setTop(TMGthis,PropName,Top)
647 ;"Purpose: to set TOP coordinates of window
648 ;"Input: TMGthis -- a this pointer for properter setter.
649 ;" PropName -- the name of the property -- not used here
650 ;" Top -- the coordinates of the TOP. 0 is top of screen
651 set Top=$get(Top,0)
652 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
653 new height
654 if parent'="SCREEN" set height=$$getProp^TMGOOL(parent,"HEIGHT")
655 else set height=9999
656 if (Top>-1)&(Top'>height) do
657 . set @TMGthis@("PROP","LOC","TOP")=Top
658 quit ;"<-- required not return value for property setter.
659
660getTop(TMGthis,PropName,outArray)
661 ;"Purpose: to get TOP coordinates of window
662 ;"Input: TMGthis -- a this pointer for properter setter.
663 ;" PropName -- the name of the property -- not used here
664 ;" outArray -- PASSED BY REFERENCE. An standardized output array
665 new result set result=""
666 new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN")
667 if (align="TOP")!(align="LEFT")!(align="RIGHT") do
668 . set result=1
669 else if (align="BOTTOM") do
670 . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
671 . new PH set PH=$$getProp^TMGOOL(parent,"HEIGHT")
672 . new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT")
673 . set result=(PH-1)-H
674 else do
675 . set result=$get(@TMGthis@("PROP","LOC","TOP"))
676
677 set outArray=result
678 quit result
679
680setLeft(TMGthis,PropName,Left)
681 ;"Window member function (with no return value, i.e. a procedure)
682 ;"Purpose: to set LEFT coordinates of window
683 ;"Input: TMGthis -- a this pointer for properter setter.
684 ;" PropName -- the name of the property -- not used here
685 ;" Left -- the coordinates of the LEFT. 0 is left of screen
686 set Left=$get(Left,0)
687 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
688 new width
689 if parent'="SCREEN" set width=$$getProp^TMGOOL(parent,"WIDTH")
690 else set width=9999
691 ;"if (Left>-1)&(Left<IOM) do
692 if (Left<width) do
693 . set @TMGthis@("PROP","LOC","LEFT")=Left
694 quit ;"<-- required not return value for property setter.
695
696getLeft(TMGthis,PropName,outArray)
697 ;"Purpose: to get LEFT coordinates of window
698 ;"Input: TMGthis -- a this pointer for properter setter.
699 ;" PropName -- the name of the property -- not used here
700 ;" outArray -- PASSED BY REFERENCE. An standardized output array
701
702 new result set result=""
703 new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN")
704 if (align="TOP")!(align="LEFT")!(align="BOTTOM") do
705 . set result=1
706 else if (align="RIGHT") do
707 . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
708 . new PW set PW=$$getProp^TMGOOL(parent,"WIDTH")
709 . new W set W=$$getProp^TMGOOL(TMGthis,"WIDTH")
710 . set result=(PW-1)-W
711 else do
712 . set result=$get(@TMGthis@("PROP","LOC","LEFT"))
713
714 set outArray=result
715 quit result
716
717
718setWidth(TMGthis,PropName,Width)
719 ;"Window member function (with no return value, i.e. a procedure)
720 ;"Purpose: to set WIDTH coordinates of window
721 ;"Input: TMGthis -- a this pointer for properter setter.
722 ;" PropName -- the name of the property -- not used here
723 ;" Width -- the coordinates of the WIDTH.
724 ;"Note: Width means ADDITIONAL columns of size in addition to left column.
725 ;" Thus a vertical sizer bar has a height of '0', which really
726 ;" displays as a single column. Confusing, but necessary
727 set Width=$get(Width,0)
728 if (Width>-1) do
729 . set @TMGthis@("PROP","LOC","WIDTH")=Width
730 quit ;"<-- required not return value for property setter.
731
732
733getWidth(TMGthis,PropName,outArray)
734 ;"Purpose: to get WIDTH coordinates of window
735 ;"Input: TMGthis -- a this pointer for properter setter.
736 ;" PropName -- the name of the property -- not used here
737 ;" outArray -- PASSED BY REFERENCE. An standardized output array
738
739 ;"NOTE: this doesn't account for overlapping alignments. For example, when
740 ;" A Hscroll is aligned to the bottom, and a Vscroller is alligned to
741 ;" the right, then they both think that they occupy the bottom-right
742 ;" corner. I need to fix this later. It will need to take into account
743 ;" the z-order (or something) of the children.
744
745 new result set result=""
746 new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN")
747 if (align="TOP")!(align="BOTTOM") do
748 . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
749 . set result=$$getProp^TMGOOL(parent,"WIDTH")
750 . set result=result-1 ;"shrink inside parent's frame (yes, 1 is correct)
751 else do ;"(align="NONE")!(align="LEFT")!(align="RIGHT")
752 . set result=$get(@TMGthis@("PROP","LOC","WIDTH"))
753
754 set outArray=result
755 quit result
756
757
758setHeight(TMGthis,PropName,Height)
759 ;"Window member function (with no return value, i.e. a procedure)
760 ;"Purpose: to set WIDTH coordinates of window
761 ;"Input: TMGthis -- a this pointer for properter setter.
762 ;" PropName -- the name of the property -- not used here
763 ;" Height -- the coordinates of the HEIGHT.
764 ;"Note: Height means ADDITIONAL rows of size in addition to top row.
765 ;" Thus a horizontal sizer bar has a height of '0', which really
766 ;" displays as a single row. Confusing, but necessary
767 set Height=$get(Height)
768 if (Height>-1) do
769 . set @TMGthis@("PROP","LOC","HEIGHT")=Height
770 quit ;"<-- required not return value for property setter.
771
772
773getHeight(TMGthis,PropName,outArray)
774 ;"Purpose: to get HEIGHT coordinates of window
775 ;"Input: TMGthis -- a this pointer for properter setter.
776 ;" PropName -- the name of the property -- not used here
777 ;" outArray -- PASSED BY REFERENCE. An standardized output array
778 new result set result=""
779 new align set align=$$getProp^TMGOOL(TMGthis,"ALIGN")
780 if (align="LEFT")!(align="RIGHT") do
781 . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
782 . new PH set PH=$$getProp^TMGOOL(parent,"HEIGHT")
783 . ;"new H set H=$$getProp^TMGOOL(TMGthis,"HEIGHT")
784 . ;"set result=PH-H-1
785 . set result=PH-1
786 else do ;"(align="NONE")!(align="TOP")!(align="BOTTOM")
787 . set result=$get(@TMGthis@("PROP","LOC","HEIGHT"))
788
789 set outArray=result
790 quit result
791
792
793setTLBR(Top,Left,Bottom,Right)
794 ;"Purpose to set the Top,Left,Bottom,Right vales for object
795 new width,height
796 set width=Right-Left
797 set height=Bottom-Top
798 new scrap set scrap=$$setTLHW(.Top,.Left,.height,.width)
799 quit 0
800
801setTLHW(Top,Left,Height,Width)
802 ;"Purpose: to set the Top,Left,Height,Width values for object
803 ;"Results: 1 if change made, 0 if not change made
804 new result set result=0
805 if +$get(Width)<1 set Width=1
806 if +$get(Height)<1 set Height=1
807 new LOC set LOC=$$getProp^TMGOOL(TMGthis,"LOC",.LOC)
808 if $get(LOC("TOP"))'=Top do setProp^TMGOOL(TMGthis,"TOP",.Top) set result=1
809 if $get(LOC("LEFT"))'=Left do setProp^TMGOOL(TMGthis,"LEFT",.Left) set result=1
810 if $get(LOC("WIDTH"))'=Width do setProp^TMGOOL(TMGthis,"WIDTH",Width) set result=1
811 if $get(LOC("HEIGHT"))'=Height do setProp^TMGOOL(TMGthis,"HEIGHT",Height) set result=1
812 quit result
813
814setState(TMGthis,PropName,State)
815 ;"Purpose: to set STATE property of window
816 ;"Input: TMGthis -- a this pointer for properter setter.
817 ;" PropName -- the name of the property -- not used here
818 ;" State -- object State
819 set @TMGthis@("PROP","LOC","STATE")=$get(State)
820 quit ;"<-- required not return value for property setter.
821
822getState(TMGthis,PropName,outArray)
823 ;"Purpose: to get TOP coordinates of window
824 ;"Input: TMGthis -- a this pointer for properter setter.
825 ;" PropName -- the name of the property -- not used here
826 ;" outArray -- PASSED BY REFERENCE. An standardized output array
827 set outArray=$get(@TMGthis@("PROP","LOC","STATE"))
828 quit $get(@TMGthis@("PROP","LOC","STATE"))
829
830
831setParent(TMGthis,PropName,Parent)
832 ;"Purpose: to link this object to a parent object, setting PARENT property
833 ;"Note: Do NOT set PARENT directly. Use this function, which will
834 ;" perform additional tasks associated with linking.
835 ;" Parents will OWN child (i.e. be responsible for their destruction), and
836 ;" also manage the placement and painting of the children.
837 ;"Input: Parent -- the NAME (e.g. pWin) of parent to link to
838 do proc^TMGOOL(Parent,"ACCEPT CHILD",TMGthis)
839 set @TMGthis@("PROP","PARENT")=Parent
840 quit ;"<-- required not return value for property setter.
841
842
843getParent(TMGthis,PropName,outArray)
844 ;"Purpose: to get TOP coordinates of window
845 ;"Input: TMGthis -- a this pointer for properter setter.
846 ;" PropName -- the name of the property -- not used here
847 ;" outArray -- PASSED BY REFERENCE. An standardized output array
848 set outArray=$get(@TMGthis@("PROP","PARENT"))
849 if outArray="" set outArray="SCREEN"
850 quit outArray
851
852
853getNeedsRepaint(TMGthis,PropName,outArray)
854 ;"Purpose: To determine if this object, or any of it's children need repainting
855 ;"results: 1 if TMGthis needs repainting. 2 if a child needs repainting.
856
857 new result set result=""
858 new num set num=""
859 set result=$get(@TMGthis@("PROP","NEEDS REPAINT"))
860 if result=1 set outArray(TMGthis)=1 goto GNRPDone
861 ;"Here query any children and see if they need repainting
862 for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0)!(+result>0) do
863 . new child set child=$order(@TMGthis@("CHILDREN",num,""))
864 . if child="" quit
865 . new tempResult
866 . set tempResult=$$getNeedsRepaint(child,"NEEDS REPAINT",.outArray)
867 . if tempResult>0 set result=2
868 . if result>0 set outArray(child)=1
869
870GNRPDone
871 set outArray=result
872 quit result
873
874 ;"------------------------------------------
875 ;"Private functions below
876 ;"------------------------------------------
877
878setLOC(LOC,T,L,W,H)
879 ;"Purpose: to create a LOC array from T (top), L(left) ... coords
880 ;"Input: LOC -- pass by reference. The output array
881 ;" T --> "TOP" etc.
882 ;"results: none
883 kill LOC
884 set LOC("TOP")=+$get(T)
885 set LOC("LEFT")=+$get(L)
886 set LOC("WIDTH")=+$get(W)
887 set LOC("HEIGHT")=+$get(H)
888 set LOC("BOTTOM")=+$get(T)++$get(H)
889 set LOC("RIGHT")=+$get(L)++$get(W)
890 quit
891
892
893getPCoords(TMGthis,PT,PL,PB,PR)
894 ;"Purpose: to get, in screen coordinates, the coordinates of the parent of TMGthis
895 ;"Input: TMGthis : the THIS reference
896 ;" PT,PL,PR,PB -- PASS BY REFERENCE, these are OUT PARAMETERS
897 ;" note: these coordinates are in the SCREEN frame of reference
898 ;"results: none
899
900 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
901 new pScrn set pScrn=$$GetScrn()
902 set scrap=$$getProp^TMGOOL(parent,"LOC",.PLOC)
903 set scrap=$$Conv2Frame(.PLOC,"SCREEN")
904
905 set PT=+$get(PLOC("TOP")),PL=+$get(PLOC("LEFT"))
906 set PR=+$get(PLOC("RIGHT")),PB=$get(PLOC("BOTTOM"))
907 if parent'=pScrn do ;"scrink to INSIDE parent
908 . set PT=PT+1,PL=PL+1,PR=PR-1,PB=PB-1
909 if PT<0 set PT=0
910 if PL<0 set PL=0
911 quit
912
913ClickOnFrame(LOC)
914 ;"Purpose: to determine IF click occured on the boundries (frame) of this object
915 ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
916 ;" coordinates in LOCAL frame of refeernces.
917 ;" LOC("TOP")=
918 ;" LOC("LEFT")=
919 ;" LOC("HEIGHT")= ;"optional
920 ;" LOC("WIDTH")= ;"optional
921 ;" LOC("BOTTOM")= ;"optional
922 ;" LOC("RIGHT")= ;"optional
923 ;"Results: "" = not on frame
924 ;" "T" if on top of frame
925 ;" "B" if on bottom of frame
926 ;" "L" if on left of frame
927 ;" "R" if on right of frame
928 ;" "TL","TR","BL","BR" for the corners
929 ;" note: no gaurantee regarding order: "TL" vs "LT"
930
931 ;"new scrap set scrap=$$ConvInsideSelf(.LOC)
932 set result=""
933 if LOC("TOP")=0 set result=result_"T"
934 if LOC("TOP")=$$getProp^TMGOOL(TMGthis,"HEIGHT") set result=result_"B"
935 if LOC("LEFT")=0 set result=result_"L"
936 if LOC("LEFT")=$$getProp^TMGOOL(TMGthis,"WIDTH") set result=result_"R"
937
938 quit result
939
940IsFocused(child)
941 ;"Purpose: to determine if the specified child is the focused child
942 ;"Input: child -- OPTIONAL. the name/ref of the child to compare
943 ;" If child="" then function will return if TMGthis is focused
944 ;" in parent's child list.
945 ;"Results: 1 if child is currently the focused child, 0 otherwise.
946 ;" if child="", then 1 if TMGthis is focused, 0 otherwise
947
948 ;"Note: so there are two types of use:
949 ;" $$IsFocused(child) <-- is child focused for TMGthis
950 ;" $$IsFocused() <---- is TMGthis focused for it's parent
951
952 set child=$get(child,"")
953 new result set result=""
954 if child="" do
955 . new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
956 . set child=TMGthis
957 . new TMGthis set TMGthis=parent
958 . set result=$$IsFocused(child)
959 else do
960 . set result=($$getFocused()=child)
961
962 quit result
963
964
965setFocused(child)
966 ;"Purpose: to set a child's status to focused, and effect it ensure visible
967 ;" by bringing it to the top of the z-order
968 ;"Input: child -- the name/ref of the child to set as focused
969
970 if $get(child)="" goto SFDone
971 if $$getFocused()=child goto SFDone ;"don't refocus if there already.
972 do UnfocusCur()
973
974 new curZ set curZ=$$GetNumChild(child)
975 if curZ'>0 goto SFDone
976
977 new num set num=""
978 new lastValid set lastValid=0
979 for do quit:(+num'>0)
980 . set lastValid=+num
981 . set num=$order(@TMGthis@("CHILDREN",num))
982 set @TMGthis@("CHILDREN",lastValid+1,child)=""
983 kill @TMGthis@("CHILDREN",curZ)
984 do ListPack^TMGMISC($name(@TMGthis@("CHILDREN")))
985 set @TMGthis@("CHILDREN","FOCUSED")=$$GetNumChild(child)
986 do setProp^TMGOOL(child,"NEEDS REPAINT",1)
987SFDone
988 quit 0
989
990
991getFocused()
992 ;"returns currently focused child name/ref
993 new focusNum
994 set focusNum=+$get(@TMGthis@("CHILDREN","FOCUSED"))
995 quit $$GetChild(focusNum)
996
997
998FocusThis()
999 ;"Purpose: to set TMGthis as focused for parent
1000 new parent set parent=$$getProp^TMGOOL(TMGthis,"PARENT")
1001 do proc^TMGOOL(parent,"SET FOCUSED",TMGthis)
1002 quit
1003
1004
1005UnfocusCur()
1006 ;"returns: unfocuses currently focused object
1007 new focusNum
1008 set focusNum=+$get(@TMGthis@("CHILDREN","FOCUSED"))
1009 if focusNum>0 do
1010 . new child set child=$$GetChild(focusNum)
1011 . do setProp^TMGOOL(child,"NEEDS REPAINT",1)
1012 . set @TMGthis@("CHILDREN","FOCUSED")=""
1013 quit
1014
1015
1016GetNumChild(child,objectName)
1017 ;"Returns the z-order for the given child
1018 ;"Input: child -- the name/ref of the child to seek
1019 ;" objectName -- OPTIONAL. Default is 'TMGthis'
1020 ;" The name of the object holding children
1021 ;"Results: the z-order, or 0 if not found
1022
1023 new num set num=""
1024 new done set done=0
1025 set objectName=$get(objectName,TMGthis)
1026 if (objectName="")!(+objectName=objectName) do goto GNCDone
1027X1 . new temp set temp=1
1028 for set num=$order(@objectName@("CHILDREN",num)) quit:(+num'>0) do quit:(done=1)
1029 . if child=$order(@objectName@("CHILDREN",num,"")) set done=1
1030GNCDone
1031 quit +num
1032
1033
1034GetChild(num)
1035 ;"Returns child ref/name at num z-order
1036 quit $order(@TMGthis@("CHILDREN",num,""))
1037
1038
1039GetContained(LOC)
1040 ;"Purpose: To get the name/ref of the child containing coordinates
1041 ;"Input: LOC -- a location array:
1042 ;" LOC("TOP")=top
1043 ;" LOC("LEFT")=left
1044 ;"results: name/ref of the child containing coordinates
1045
1046 new result set result=""
1047 new num set num=""
1048 for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0)
1049 ;"Now count backward
1050 for set num=$order(@TMGthis@("CHILDREN",num),-1) quit:(+num'>0)!(result'="") do
1051 . new child set child=$order(@TMGthis@("CHILDREN",num,""))
1052 . if child="" quit
1053 . if $$fn^TMGOOL(child,"CONTAINS COORDS",.LOC)=0 quit
1054 . set result=child
1055
1056 quit result
1057
1058
1059CheckPaint
1060 ;"Purpose: to see if any children need repainting. If so, repaint.
1061 ;"Note: Only MainWindow should be getting to this point.
1062 ;" Also, Paint is not called for MainWindow (i.e. don't put a border on the main screen)
1063
1064 ;"do SETCLIP^TMGXGF(0,0,IOSL,IOM)
1065
1066 new paintAllChildren set paintAllChildren=0
1067 ;"Note: Every time THIS is painted, all children are also painted.
1068 ;" But there may be times with THIS doesn't need repainting, but
1069 ;" just one of the children will need painting alone.
1070 if $$getProp^TMGOOL(TMGthis,"NEEDS REPAINT")=1 do ;"1=paint this, 2=paint a child
1071 . set paintAllChildren=1
1072 . ;"Draw a frame to white out entire screen.
1073 . do CLEAR^TMGXGF(0,0,IOSL,IOM) ;"clear screen portion TOP,LEFT,BOTTOM,RIGHT
1074 . do setProp^TMGOOL(TMGthis,"NEEDS REPAINT",0) ;"flag screen as total repainted
1075
1076 ;"Note: 0=back-most window (bigger numbers painted last)
1077 new num set num=""
1078 for set num=$order(@TMGthis@("CHILDREN",num)) quit:(+num'>0) do
1079 . new child set child=$order(@TMGthis@("CHILDREN",num,""))
1080 . if child="" quit
1081 . new sameLoc,LOC,ldArray
1082 . new scrap set scrap=$$getProp^TMGOOL(child,"LOC",.LOC)
1083 . set scrap=$$getProp^TMGOOL(child,"LAST DRAW",.ldArray)
1084 . set sameLoc=$$CompArray^TMGMISC("LOC","ldArray")
1085 . new tempWho
1086 . new needsPaint set needsPaint=$$getProp^TMGOOL(child,"NEEDS REPAINT",.tempWho)
1087 . if (sameLoc=0)!(needsPaint>0)!(paintAllChildren=1) do
1088CP2 . . do proc^TMGOOL(child,"PAINT")
1089 . . do setProp^TMGOOL(child,"LAST DRAW",.LOC)
1090
1091 quit
1092
1093
1094parentPath(fromFrame,toFrame,outArray)
1095 ;"Purpose: to enumerate the successive parent when going from 'from' frame
1096 ;" to the 'to' frame.
1097 ;"Input: fromFrame,toFrame -- the name/ref of TMGWGOJ objects for frames
1098 ;" outArray -- PASS BY REFERENCE. See format below:
1099 ;"Output: outArray is filled as below:
1100 ;" outArray(1,fromFrame)=""
1101 ;" outArray(2,parent of fromFrame)=""
1102 ;" outArray(3,grandparent of fromFrame)=""
1103 ;" outArray(4,greatgrandparent of fromFrame)=""
1104 ;" ...
1105 ;"results: none
1106
1107 kill outArray
1108 new num set num=2
1109 new toFound set toFound=0
1110 new curFrame set curFrame=fromFrame
1111 for do quit:(curFrame="")!(curFrame=toFrame)!(curFrame="SCREEN")
1112 . set curFrame=$$getProp^TMGOOL(curFrame,"PARENT")
1113 . if curFrame="" quit
1114 . if curFrame=toFrame set toFound=1
1115 . set outArray(num,curFrame)="",num=num+1
1116 if toFound=0 kill outArray
1117 if $data(outArray)>0 set outArray(1,fromFrame)=""
1118 quit
1119
1120
1121convPath(LOC,pathArray)
1122 ;"Purpose: to succesively translate coordinate systems for each entry in the
1123 ;" path array (as prepaired by parentPath)
1124 ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
1125 ;" LOC("TOP")=
1126 ;" LOC("LEFT")=
1127 ;" LOC("HEIGHT")= ;"optional
1128 ;" LOC("WIDTH")= ;"optional
1129 ;" LOC("BOTTOM")=
1130 ;" LOC("RIGHT")=
1131 ;" LOC("FRAME")=Frame of reference for these coordinates
1132 ;" Note: frame should typically be the same as
1133 ;" the PARENT of the current object
1134 ;" targetFrame=the frame of refernce to change to.
1135 ;"Input: pathArray -- PASS BY REFERENCE. format:
1136 ;" pathArray(1,initialFrame)=""
1137 ;" pathArray(2,parent of fromFrame)=""
1138 ;" pathArray(3,grandparent of fromFrame)=""
1139 ;" pathArray(4,greatgrandparent of fromFrame)=""
1140 ;" ...
1141 ;" ALSO: pathArray=direction (1 or -1) to effect translations
1142 ;" towards a parent frame (1) vs. a child frame (-1)
1143 ;"Results: none
1144 ;"Output: Input variables are modified as OUT PARAMETERS
1145 ;" LOC("TOP") is modified
1146 ;" LOC("LEFT") is modified
1147 ;" LOC("HEIGHT")=unchanged
1148 ;" LOC("WIDTH")=unchanged
1149 ;" LOC("BOTTOM") is updated
1150 ;" LOC("RIGHT") is updated
1151 ;" LOC("FRAME") is updated
1152
1153 new curFrame set curFrame=$get(LOC("FRAME"))
1154 if curFrame="" goto CpDone ;"unable to convert if not initial frame specified.
1155 new direction set direction=+$get(pathArray)
1156 if direction=0 goto CpDone
1157
1158 new Top set Top=+$get(LOC("TOP"))
1159 new Left set Left=+$get(LOC("LEFT"))
1160
1161 new num set num=1
1162 if direction=-1 set num=$order(pathArray(""),-1)
1163 if $order(pathArray(num,""))'=curFrame goto CpStore ;"not in correct initial frame
1164
1165 new lfTop,lfLeft,loopFrame
1166 for do quit:(loopFrame="")
1167 . set loopFrame=$order(pathArray(num,"")),num=num+direction
1168 . if (loopFrame="") quit
1169 . if (direction=-1)&(loopFrame=curFrame) quit
1170 . set lfTop=$$getProp^TMGOOL(loopFrame,"TOP")*direction
1171 . set lfLeft=$$getProp^TMGOOL(loopFrame,"LEFT")*direction
1172 . set Top=Top+lfTop
1173 . set Left=Left+lfLeft
1174 . set LOC("FRAME")=loopFrame
1175
1176CpStore
1177 ;"Store data back into array
1178 set LOC("TOP")=Top
1179 set LOC("LEFT")=Left
1180 set LOC("BOTTOM")=Top+$get(LOC("HEIGHT"))
1181 set LOC("RIGHT")=Left+$get(LOC("WIDTH"))
1182
1183CpDone
1184 quit
1185
1186
1187getPath(LOC,targetFrame,pathArray)
1188 ;"Purpose: to create a pathArray from current frame (stored in LOC) to
1189 ;" the targetFrame. targetFrame may be an ancestor, or descendent
1190 ;" of the current frame.
1191 ;"Input: LOC -- PASS BY REFERNCE. Expected input format:
1192 ;" LOC("TOP")=
1193 ;" LOC("LEFT")=
1194 ;" LOC("HEIGHT")= ;"optional
1195 ;" LOC("WIDTH")= ;"optional
1196 ;" LOC("BOTTOM")=
1197 ;" LOC("RIGHT")=
1198 ;" LOC("FRAME")=Frame of reference for these coordinates
1199 ;" Note: frame should typically be the same as
1200 ;" the PARENT of the current object
1201 ;" targetFrame=the frame of refernce to change to.
1202 ;" outArray -- PASS BY REFERENCE. See format below:
1203 ;"Output: pathArray is filled as below:
1204 ;" pathArray(1,curFrame)=""
1205 ;" pathArray(2,next translation frame (child/parent of current))=""
1206 ;" pathArray(3,next translation frame (child/parent of current))=""
1207 ;" ...
1208
1209 new curFrame set curFrame=$get(LOC("FRAME"))
1210 if curFrame="" goto gpDone
1211 ;"First see if targetFrame is an ancestor of curFrame
1212 do parentPath(curFrame,targetFrame,.pathArray)
1213 if ($data(pathArray)>0)!(curFrame=targetFrame) do goto gpDone ;"success
1214 . set pathArray=1
1215 ;"Now see if targetFrame is a descendent of curFrame
1216 do parentPath(targetFrame,curFrame,.pathArray)
1217 if $data(pathArray)=0 goto gpDone ;"failure
1218 set pathArray=-1 ;"reverse direction
1219gpDone
1220 quit
1221
1222
1223
Note: See TracBrowser for help on using the repository browser.