/[gcl]/gcl/japitest.lsp
ViewVC logotype

Diff of /gcl/japitest.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by mjthomas, Wed Mar 26 06:07:56 2003 UTC revision 1.5 by mjthomas, Wed Mar 26 07:26:30 2003 UTC
# Line 171  Line 171 
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)
# Line 215  Line 216 
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))
# Line 229  Line 230 
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    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26