source: cprs/branches/tmg-cprs/m_files/TMGXGF.m@ 1742

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

Initial upload

File size: 5.9 KB
RevLine 
[796]1TMGXGF ;SFISC/VYD - Graphics Functions ;11/06/2002 11:10
2 ;;8.0;KERNEL;**269**;5/5/07 by kt
3 ;
4PREP ;prepair graphics environment
5 D PREP^XGSETUP
6 D CLRCLIP ;"//kt 5/5/07 added
7 Q
8 ;
9 ;
10IOXY(R,C) ;cursor positioning R:row, C:col
11 D ADJRC
12 ;"//kt 5/6/07 modification.
13 ;"Although this XGF system allows for off-screen coordinates, the underlying
14 ;" M systems will not. So trying to position cursor to (-4,-5) MUST result
15 ;" in cursor being put at (0,0). This may be worked around by not depending
16 ;" on the current $X,$Y for writing etc. Instead, always specify coordinates.
17 S:R<0 R=0 ;"//kt
18 S:C<0 C=0 ;"//kt
19 d CLIOXY^TMGXGS(R,C,"")
20 S $Y=R,$X=C
21 Q
22 ;
23 ;
24SAY(R,C,S,A) ;coordinate output instead of WRITE
25 D ADJRC
26 ;"//kt 5/6/07 mod. Clipping to occur in CLIOXY^TMGXGS()
27 ;"S:C+$L(S)>IOM S=$E(S,1,IOM-C) ;truncate if longer than screen
28 I $L($G(A)) S A=$$UP^XLFSTR(A) D SAY^TMGXGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1
29 E D SAY^TMGXGS(R,C,S)
30 Q
31 ;
32 ;
33VSAY(R,C,S,A) ;coordinate output instead of WRITE: Vertical write ;"//kt added 5/10/07
34 D ADJRC
35 I $L($G(A)) S A=$$UP^XLFSTR(A) D VSAY^TMGXGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1
36 E D VSAY^TMGXGS(R,C,S)
37 Q
38 ;
39 ;
40SAYU(R,C,S,A) ;coordinate output w/ underline instead of WRITE
41 D ADJRC
42 I $L($G(A)) S A=$$UP^XLFSTR(A) D SAYU^TMGXGS(R,C,S,$S($$ATRSYNTX(A):A,1:"")) I 1
43 E D SAYU^TMGXGS(R,C,S)
44 Q
45 ;
46 ;
47ADJRC ;adjust row and column R and C are assumed to exist
48 S R=$S($G(R)="":$Y,1:R),C=$S($G(C)="":$X,1:C) ;use current coords if none are passed
49 ;"//kt 5/6/07 modified. NOTE: it seems that code was written to allow coords
50 ;" to be specified as relative to $X,$Y. E.g. SAY(+4,-2,'HELLO').
51 ;" I must remove this functionality so that I can allow specifying coordinates that
52 ;" are offscreen. Thus if the left-hand part of a window is a bit off the left
53 ;" side of the screen, then C will be -2 etc.
54 ;"S:"+-"[$E(R) R=$Y+$S(R="+":1,R="-":-1,1:R) ;increment/decrement
55 ;"S:"+-"[$E(C) C=$X+$S(C="+":1,C="-":-1,1:C)
56 ;"S R=$S(R<0:0,1:R\1),C=$S(C<0:0,1:C\1) ;make sure only pos int
57 ;"//kt modified line below
58 S R=R\1,C=C\1 ;"make sure only integer values (clipping will occur in CLIOXY())
59 Q
60 ;
61 ;
62SETA(XGATR) ;set screen attribute(s) regardless of previous state
63 ;XGATR=1 char when converted to binary represents all new attr
64 N XGOLDX,XGOLDY
65 S XGOLDX=$X,XGOLDY=$Y ;save $X $Y
66 W $$SET^XGSA(XGATR)
67 S $X=XGOLDX,$Y=XGOLDY ;restore $X $Y
68 Q
69 ;
70 ;
71CHGA(XGATR) ;change screen attribute(s) w/ respect to previous state
72 ;XGNEWATR=string of attr to change eg. "B0U1" or "E1"
73 N XGOLDX,XGOLDY,XGSYNTX,XGACODE,%
74 S XGATR=$$UP^XLFSTR(XGATR) ;make sure all attr codes are in upper case
75 D:$$ATRSYNTX(XGATR)
76 . S XGOLDX=$X,XGOLDY=$Y ;save $X $Y
77 . W $$CHG^XGSA(XGATR)
78 . S $X=XGOLDX,$Y=XGOLDY ;restore $X $Y
79 Q
80 ;
81 ;
82ATRSYNTX(XGATR) ;check attribute code syntax
83 ;proper attr is 1 or more (char from {BIRGUE} concat w/ 1 or 0)
84 N XGSYNTX,%
85 S XGSYNTX=$S($L(XGATR)&($L(XGATR)#2=0):1,1:0) ;even # of chars
86 F %=1:2:$L(XGATR) S:"B1B0I1I0R1R0G1G0U1U0E1"'[$E(XGATR,%,%+1) XGSYNTX=0
87 Q XGSYNTX
88 ;
89 ;
90RESTORE(S) ;restore screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT
91 D RESTORE^TMGXGSW(S) Q
92 K @S
93 ;
94 ;
95SAVE(T,L,B,R,S) ;save screen region TOP,LEFT,BOTTOM,RIGHT,SAVE ROOT
96 D SAVE^TMGXGSW(T,L,B,R,S) Q
97 ;
98 ;
99WIN(T,L,B,R,S) ;put up a window TOP,LEFT,BOTTOM,RIGHT[,SAVE ROOT]
100 ;window style is not yet implemented
101 I $L($G(S)) D WIN^TMGXGSW(T,L,B,R,S) I 1
102 E D WIN^TMGXGSW(T,L,B,R)
103 Q
104 ;
105 ;
106FRAME(T,L,B,R) ;put a frame without clearing the inside TOP,LEFT,BOTTOM,RIGHT
107 D FRAME^TMGXSBOX(T,L,B,R) Q
108 ;
109 ;
110CLEAR(T,L,B,R) ;clear screen portion TOP,LEFT,BOTTOM,RIGHT
111 D CLEAR^TMGXSBOX(T,L,B,R) Q
112 ;
113 ;
114CLEAN ;clean up and destroy graphics environment
115 D CLEAN^XGSETUP Q
116 ;
117 ;
118INITKB(XGTRM) ;initialize keyboard
119 ;turn escape processing on, turn on passed terminators (if any)
120 D INIT^XGKB($G(XGTRM)) Q
121 ;
122 ;
123READ(XGCHARS,XGTO) ;read the keyboard
124 ;XGCHARS:number of chars to read, XGTO:timeout
125 ;"//kt 5/5/07 modified to allow putting characters back.
126 new TMGRESLT set TMGRESLT=""
127 if ($get(TMGWCBUF)="")&($get(TMGWXGRT)="") do
128 . set TMGRESLT=$$READ^XGKB($G(XGCHARS),$G(XGTO))
129 else do
130 . set TMGRESLT=$get(TMGWCBUF) set TMGWCBUF=""
131 . set XGRT=$get(TMGWXGRT) set TMGWXGRT=""
132 quit TMGRESLT
133 ;
134 ;
135UNREAD(XGCHARS,XGRT) ;"//kt 5/5/07 added.
136 ;Purpose: to put characters back into read stream after a READ
137 ; Note: may only be called once before a subsequent READ, or will overwrite
138 ;Input: XGCHARS -- the character(s) to put back into stream
139 ; XGRT -- the command characters to put back into stream (i.e. XGRT)
140 set TMGWCBUF=XGCHARS
141 set TMGWXGRT=XGRT
142 quit
143 ;
144 ;
145RESETKB ;reset keyboard(escape processing off, terminators off)
146 D EXIT^XGKB Q
147 ;
148 ;
149SETCLIP(T,L,B,R) ;"//kt 5/5/07 added
150 ;Pupose: define a clipping area. XGF writes clipped to area
151 ;Input: TOP,LEFT,BOTTOM,ROGHT
152 set TMGCLT=+$get(T),TMGCLL=$get(L)
153 set TMGCLB=+$get(B),TMGCLR=$get(R)
154 quit
155 ;
156 ;
157CLRCLIP ;"//kt 5/5/07 added
158 ;Pupose: clear clipping area.
159 set TMGCLT=0,TMGCLL=0
160 set TMGCLB=IOSL-1,TMGCLR=IOM-1
161 quit
Note: See TracBrowser for help on using the repository browser.