171 |
(j_pack frame) |
(j_pack frame) |
172 |
(drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas)) |
(drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas)) |
173 |
(j_show frame) |
(j_show frame) |
174 |
(loop as obj = (j_nextaction) |
(do ((obj (j_nextaction) (j_nextaction))) |
175 |
while (and (not (= obj frame)) (not (= obj quit))) |
((or (= obj frame) (= obj quit)) t) |
176 |
do |
(when (= obj canvas) |
177 |
(when (= obj canvas) |
(j_setnamedcolorbg canvas J_WHITE) |
178 |
(j_setnamedcolorbg canvas J_WHITE) |
(drawgraphics canvas 10 10 |
179 |
(drawgraphics canvas 10 10 |
(- (j_getwidth canvas) 10) |
180 |
(- (j_getwidth canvas) 10) |
(- (j_getheight canvas) 10))) |
181 |
(- (j_getheight canvas) 10))) |
(when (= obj print) |
182 |
(when (= obj print) |
(let ((printer (j_printer frame))) |
183 |
(let ((printer (j_printer frame))) |
(when (> 0 printer) |
184 |
(when (> 0 printer) |
(drawgraphics printer 40 40 |
185 |
(drawgraphics printer 40 40 |
(- (j_getwidth printer) 80) |
186 |
(- (j_getwidth printer) 80) |
(- (j_getheight printer) 80)) |
187 |
(- (j_getheight printer) 80)) |
(j_print printer)))) |
188 |
(j_print printer)))) |
(when (= obj save) |
189 |
(when (= obj save) |
(let ((image (j_image 600 800))) |
190 |
(let ((image (j_image 600 800))) |
(drawgraphics image 0 0 600 800) |
191 |
(drawgraphics image 0 0 600 800) |
(when (= 0 (j_saveimage image "test.bmp" J_BMP)) |
192 |
(when (= 0 (j_saveimage image "test.bmp" J_BMP)) |
(j_alertbox frame "Problems" "Can't save the image" "OK"))))))))))))) |
193 |
(j_alertbox frame "Problems" "Can't save the image" "OK")))))))))))) |
;; Try some mouse handling |
194 |
;; Try some mouse handling |
(with-server |
195 |
|
("GCL Japi library test GUI 3" 0) |
196 |
(with-frame |
(with-frame |
197 |
(frame "Move and drag the mouse") |
(frame "Move and drag the mouse") |
198 |
(j_setsize frame 430 240) |
(j_setsize frame 430 240) |
216 |
(with-mouse-listener |
(with-mouse-listener |
217 |
(exited canvas2 J_EXITED) |
(exited canvas2 J_EXITED) |
218 |
(j_show frame) |
(j_show frame) |
219 |
;; Allocate immovable storage for passing data back from C land. |
;; Allocate immovable storage for passing data back from C land. |
220 |
;; Uses the GCL only make-array keyword :static |
;; Uses the GCL only make-array keyword :static |
221 |
(let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) |
(let* ((xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) |
222 |
(ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) |
(ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t)) |
230 |
(setf y (aref ya 0))))) |
(setf y (aref ya 0))))) |
231 |
(startx 0) |
(startx 0) |
232 |
(starty 0)) |
(starty 0)) |
233 |
(loop as obj = (j_nextaction) |
(do ((obj (j_nextaction) (j_nextaction))) |
234 |
while (not (= obj frame)) |
((= obj frame) t) |
235 |
do |
(when (= obj pressed) |
236 |
(when (= obj pressed) |
(funcall get-mouse-xy pressed) |
237 |
(funcall get-mouse-xy pressed) |
(setf startx x) |
238 |
(setf startx x) |
(setf starty y)) |
239 |
(setf starty y)) |
(when (= obj dragged) |
240 |
(when (= obj dragged) |
(funcall get-mouse-xy dragged) |
241 |
(funcall get-mouse-xy dragged) |
(j_drawrect canvas1 startx starty (- x startx) (- y starty))) |
242 |
(j_drawrect canvas1 startx starty (- x startx) (- y starty))) |
(when (= obj released) |
243 |
(when (= obj released) |
(funcall get-mouse-xy released) |
244 |
(funcall get-mouse-xy released) |
(j_drawrect canvas1 startx starty (- x startx) (- y starty))) |
245 |
(j_drawrect canvas1 startx starty (- x startx) (- y starty))) |
(when (= obj entered) |
246 |
(when (= obj entered) |
(funcall get-mouse-xy entered) |
247 |
(funcall get-mouse-xy entered) |
(setf startx x) |
248 |
(setf startx x) |
(setf starty y)) |
249 |
(setf starty y)) |
(when (= obj moved) |
250 |
(when (= obj moved) |
(funcall get-mouse-xy moved) |
251 |
(funcall get-mouse-xy moved) |
(j_drawline canvas2 startx starty x y)) |
252 |
(j_drawline canvas2 startx starty x y)) |
(setf startx x) |
253 |
(setf startx x) |
(setf starty y) |
254 |
(setf starty y) |
(when (= obj exited) |
255 |
(when (= obj exited) |
(funcall get-mouse-xy exited) |
256 |
(funcall get-mouse-xy exited) |
(j_drawline canvas2 startx starty x y)))))))))))))) |
|
(j_drawline canvas2 startx starty x y)))))))))))))) |
|
257 |
|
|