| 1 |
greg |
1.2 |
% SCCSid "$SunId$ LBL" |
| 2 |
greg |
1.1 |
|
| 3 |
|
|
% |
| 4 |
|
|
% By Isaac Kuo |
| 5 |
|
|
% |
| 6 |
|
|
|
| 7 |
|
|
#include "newsconstants.h" |
| 8 |
greg |
1.2 |
|
| 9 |
greg |
1.1 |
cdef cps_clear() |
| 10 |
|
|
textbackground setcolor clippath fill |
| 11 |
|
|
cdef initcanvas(x,y,width,height,mb1key,mb2key,mb3key) |
| 12 |
greg |
1.2 |
% a couple of definitions of commands in Sun NeWS but not in |
| 13 |
|
|
% SiliconGraphics NeWS |
| 14 |
|
|
|
| 15 |
|
|
currentdict /createcanvas known not % check if they're defined or not |
| 16 |
|
|
{ |
| 17 |
|
|
/createcanvas |
| 18 |
|
|
{ |
| 19 |
|
|
3 2 roll newcanvas /newcan exch def |
| 20 |
|
|
0 0 4 2 roll newpath rectpath |
| 21 |
|
|
newcan reshapecanvas newpath |
| 22 |
|
|
newcan |
| 23 |
|
|
} def |
| 24 |
|
|
/mapcanvas |
| 25 |
|
|
{ |
| 26 |
|
|
/Mapped true put |
| 27 |
|
|
} def |
| 28 |
|
|
} if |
| 29 |
|
|
|
| 30 |
|
|
% terrific, wasn't it? |
| 31 |
|
|
|
| 32 |
greg |
1.1 |
/Can framebuffer width height createcanvas def |
| 33 |
|
|
Can /Retained true put |
| 34 |
|
|
Can setcanvas x y movecanvas currentcanvas mapcanvas |
| 35 |
|
|
clippath pathbbox pop pop translate |
| 36 |
|
|
1.0 .75 .3 setrgbcolor clippath fill |
| 37 |
|
|
/scrollheight textareaheight fontheight sub def |
| 38 |
|
|
thefont findfont fontheight scalefont setfont |
| 39 |
|
|
/textbackground textbackgroundRED textbackgroundGREEN |
| 40 |
|
|
textbackgroundBLUE rgbcolor def |
| 41 |
|
|
/MB1key mb1key def |
| 42 |
|
|
/MB2key mb2key def |
| 43 |
|
|
/MB3key mb3key def |
| 44 |
|
|
|
| 45 |
|
|
% scroll scrolls the text area |
| 46 |
|
|
/scroll |
| 47 |
|
|
{ |
| 48 |
|
|
newpath |
| 49 |
|
|
0 0 width scrollheight points2rect rectpath |
| 50 |
|
|
0 fontheight copyarea % Scroll the text area |
| 51 |
|
|
newpath textbackground setcolor |
| 52 |
|
|
0 0 width fontheight points2rect rectpath |
| 53 |
|
|
fill |
| 54 |
|
|
/textcursorposition 0 def |
| 55 |
|
|
} def |
| 56 |
|
|
scroll scroll |
| 57 |
|
|
|
| 58 |
|
|
% myshow takes a string and prints it at the current cursor location |
| 59 |
|
|
/myshow |
| 60 |
|
|
{ |
| 61 |
|
|
textshadowgray setgray |
| 62 |
|
|
textcursorposition 1 sub textbottom 1 sub moveto dup show |
| 63 |
|
|
0 setgray |
| 64 |
|
|
textcursorposition textbottom moveto show |
| 65 |
|
|
/textcursorposition currentpoint pop def |
| 66 |
|
|
} def |
| 67 |
|
|
|
| 68 |
|
|
% mydel takes a string and deletes it from the current cursor location |
| 69 |
|
|
/mydel |
| 70 |
|
|
{ |
| 71 |
|
|
textbackground setcolor |
| 72 |
|
|
dup stringwidth pop textcursorposition exch sub |
| 73 |
|
|
dup /textcursorposition exch def |
| 74 |
|
|
1 sub textbottom 1 sub moveto dup show textcursorposition % |
| 75 |
|
|
textbottom moveto show |
| 76 |
|
|
} def |
| 77 |
|
|
|
| 78 |
|
|
/normalcursor |
| 79 |
|
|
{ |
| 80 |
|
|
/xcurs /xcurs_m Can setstandardcursor |
| 81 |
|
|
} def |
| 82 |
|
|
normalcursor |
| 83 |
|
|
|
| 84 |
|
|
% get this canvas ready for input |
| 85 |
|
|
/buttonevent createevent def |
| 86 |
|
|
buttonevent /Name [/LeftMouseButton /MiddleMouseButton /RightMouseButton] put |
| 87 |
|
|
buttonevent /Action /UpTransition put |
| 88 |
|
|
buttonevent /Canvas Can put |
| 89 |
|
|
/keyevent Can addkbdinterests aload /EVENTS exch |
| 90 |
|
|
def revokeinterest revokeinterest def |
| 91 |
|
|
/dumevent createevent def % dumevent is used by the input checker |
| 92 |
|
|
dumevent /Name 32 put % to insure awaitevent returns an answer |
| 93 |
|
|
dumevent /Action 13 put % immediately; if it is the first one |
| 94 |
|
|
dumevent /Canvas Can put % returned, then no keyboard events |
| 95 |
|
|
dumevent expressinterest % were waiting. |
| 96 |
|
|
/kdevent createevent def % kdevent is used by the input checker |
| 97 |
|
|
kdevent /Action 666 put % to replace waiting keyboard events with |
| 98 |
|
|
kdevent /Canvas Can put % something which acts interchangably with |
| 99 |
|
|
kdevent expressinterest % a normal keyboard event. |
| 100 |
|
|
|
| 101 |
|
|
cdef box(x1,y1,x2,y2,float r,float g,float b) |
| 102 |
|
|
% Draw a filled box at x,y in pixels with color r,g,b |
| 103 |
|
|
r g b setrgbcolor newpath |
| 104 |
|
|
x1 y1 x2 y2 points2rect rectpath fill |
| 105 |
|
|
#define tag 1990 |
| 106 |
|
|
cdef cps_cleanup() => tag() |
| 107 |
|
|
% Clean up just enough stuff so the window will die quietly |
| 108 |
|
|
keyevent revokeinterest |
| 109 |
|
|
kdevent revokeinterest |
| 110 |
|
|
EVENTS Can revokekbdinterests |
| 111 |
|
|
dumevent revokeinterest |
| 112 |
|
|
/Can currentcanvas def |
| 113 |
|
|
Can /EventsConsumed /NoEvents put |
| 114 |
|
|
Can /Transparent true put |
| 115 |
|
|
Can /Mapped false put |
| 116 |
|
|
Can /Retained false put |
| 117 |
|
|
tag tagprint |
| 118 |
|
|
cdef getthebox(X,Y,W,H) => tag(X,Y,W,H) |
| 119 |
|
|
% Get the coordinates of the box from the user |
| 120 |
greg |
1.2 |
|
| 121 |
|
|
% While Sun NeWS coordinates default to pixels, Silicon Graphics NeWS |
| 122 |
|
|
% defaults to "points", which are 4/3 the size of pixels in both directions. |
| 123 |
|
|
% Silicon Graphics NeWS does not have "createcanvas" defined, so it is |
| 124 |
|
|
% used to determine whether the coordinates should be translated. |
| 125 |
|
|
|
| 126 |
|
|
currentcanvas createoverlay setcanvas |
| 127 |
|
|
currentdict /createcanvas known not |
| 128 |
|
|
{ |
| 129 |
|
|
.75 .75 scale |
| 130 |
|
|
} if |
| 131 |
|
|
getwholerect waitprocess |
| 132 |
greg |
1.1 |
aload pop /y1 exch def /x1 exch def /y0 exch def /x0 exch def |
| 133 |
|
|
x0 x1 gt { /x x1 def /w x0 x1 sub def } |
| 134 |
|
|
{ /x x0 def /w x1 x0 sub def } ifelse |
| 135 |
|
|
y0 y1 gt { /y y1 def /h y0 y1 sub def } |
| 136 |
|
|
{ /y y0 def /h y1 y0 sub def } ifelse |
| 137 |
|
|
h w y x tag tagprint typedprint typedprint typedprint typedprint |
| 138 |
|
|
cdef printout(string message) |
| 139 |
|
|
% print message without scrolling the text "window" up |
| 140 |
|
|
message myshow |
| 141 |
|
|
cdef linefeed(string message) |
| 142 |
|
|
% print message and scroll |
| 143 |
|
|
message myshow scroll |
| 144 |
|
|
cdef getclick(x,y,key) => tag(key,y,x) |
| 145 |
|
|
% get a cursor position marked by click or key |
| 146 |
|
|
buttonevent expressinterest |
| 147 |
|
|
/beye_m /xhair_m Can setstandardcursor |
| 148 |
|
|
/theclick awaitevent def |
| 149 |
|
|
currentcursorlocation textareaheight sub |
| 150 |
|
|
normalcursor |
| 151 |
|
|
buttonevent revokeinterest |
| 152 |
|
|
|
| 153 |
|
|
theclick /Name get |
| 154 |
|
|
% Translate mouse clicks if necessary |
| 155 |
|
|
dup /LeftMouseButton eq |
| 156 |
|
|
{pop MB1key} if |
| 157 |
|
|
dup /MiddleMouseButton eq |
| 158 |
|
|
{pop MB2key} if |
| 159 |
|
|
dup /RightMouseButton eq |
| 160 |
|
|
{pop MB3key} if |
| 161 |
|
|
cvi |
| 162 |
|
|
tag tagprint typedprint typedprint typedprint |
| 163 |
|
|
cdef isready(keyread) => tag(keyread) |
| 164 |
|
|
% tells whether character input is ready |
| 165 |
|
|
0 % default output |
| 166 |
|
|
dumevent createevent copy sendevent |
| 167 |
|
|
{ |
| 168 |
|
|
/theevent awaitevent def |
| 169 |
|
|
theevent /Action get 13 eq |
| 170 |
|
|
{ exit } if |
| 171 |
|
|
pop 1 |
| 172 |
|
|
/newevent kdevent createevent copy def |
| 173 |
|
|
newevent /Name theevent /Name get put |
| 174 |
|
|
newevent sendevent |
| 175 |
|
|
} loop |
| 176 |
|
|
tag tagprint typedprint |
| 177 |
|
|
cdef startcomin() |
| 178 |
|
|
% get ready for execution of comin |
| 179 |
|
|
/nouse /nouse_m Can setstandardcursor |
| 180 |
|
|
cdef endcomin() |
| 181 |
|
|
% get ready for normal execution |
| 182 |
|
|
normalcursor |
| 183 |
|
|
cdef getkey(key) => tag(key) |
| 184 |
|
|
% get a keypress |
| 185 |
|
|
textcursor myshow awaitevent /Name get cvi |
| 186 |
|
|
textcursor mydel tag tagprint typedprint |
| 187 |
|
|
cdef delete(string s) |
| 188 |
|
|
% delete the string s |
| 189 |
|
|
s mydel |
