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

Diff of /gcl/japitest.lsp

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

revision 1.2 by mjthomas, Wed Mar 26 00:00:49 2003 UTC revision 1.3 by mjthomas, Wed Mar 26 04:17:10 2003 UTC
# Line 11  Line 11 
11  ;;; however that so far no binding (APART FROM J_PRINT) has gone wrong of those  ;;; however that so far no binding (APART FROM J_PRINT) has gone wrong of those
12  ;;; tested so far!  ;;; tested so far!
13  ;;;  ;;;
 ;;; Mike Thomas, 21 March 2003  
14  ;;;  ;;;
15  ;;; (load "c:/cvs/gcl/japitest.lsp")  ;;; HOW TO USE THIS FILE
16    ;;;
17    ;;; (compile-file "c:/cvs/gcl/japitest.lsp")
18    ;;; (load "c:/cvs/gcl/japitest.o")
19    ;;;
20    ;;; Requires either "java" or "jre" in the path to work.
21  ;;;  ;;;
22    
23  (in-package :japi-primitives)  (in-package :japi-primitives)
24    
25  ;;;----------------------------------------------------------------------  ;; Start up the Japi server (needs to find either "java" or "jre" in your path
26  ;;; General routines.  (defmacro with-japi-server ((app-name debug-level) . body)
27  (defCfun "static void* int_ptr(object s)" 0    (multiple-value-bind (ds b)
28  " return(&fix(s));")        (si::find-declarations body)
29  (defentry int-ptr (object) (int "int_ptr"))      `(if (= 0 (j_start))
30           (format t (format nil "~S can't connect to the Japi GUI server." ,app-name))
31           (progn
32             (j_setdebug ,debug-level)
33             ,@ds
34             (unwind-protect
35                 (progn ,@b)
36               (j_quit))))))
37    
38    (defmacro with-frame ((frame-var-name title) . body)
39      (multiple-value-bind (ds b)
40          (si::find-declarations body)
41        `(let ((,frame-var-name (j_frame ,title)))
42           ,@ds
43           (unwind-protect
44             (progn ,@b)
45             (j_dispose ,frame-var-name)))))
46    
47    (defmacro with-canvas ((canvas-var-name frame-obj x-size y-size) . body)
48      (multiple-value-bind (ds b)
49          (si::find-declarations body)
50        `(let ((,canvas-var-name (j_canvas ,frame-obj ,x-size ,y-size)))
51           ,@ds
52           (unwind-protect
53             (progn ,@b)
54             (j_dispose ,canvas-var-name)))))
55    
56    (defmacro event-loop (frame-name &rest body)
57      `(loop as obj = (j_nextaction)
58             while (not (= obj ,frame-name))
59             do (,@body)))
60    
61    (with-japi-server ("GCL Japi library test GUI 1" 2)
62          (with-frame (frame "Five Second Blank Test Frame")
63                      (j_show frame)
64                      (j_sleep 5000)))
65    
66    ;; Get a pointer to an array of ints
67  (defCfun "static void* inta_ptr(object s)" 0  (defCfun "static void* inta_ptr(object s)" 0
68  " return(s->fixa.fixa_self);")  " return(s->fixa.fixa_self);")
69  (defentry inta-ptr (object) (int "inta_ptr"))  (defentry inta-ptr (object) (int "inta_ptr"))
70    
71    ;; Draw function
 ;; Turn Japi system debug tracing on  
 ;(j_setdebug 2)  
   
 ;; Start up the Japi server (needs to find either "java" or "jre" in your path  
 (j_start)  
   
 ;; Start up a Window frame and then show it  
 (setf frame (j_frame "GCL Japi binding Test and Demo Program"))  
 (j_show frame)  
   
 ;; Simple message box, no buttons  
 (setf alert (j_messagebox frame "label1" "label2"))  
 (j_sleep 2000)  
 (j_dispose alert)  
   
 ;; Message box variations with 1, 2 and 3 buttons  
 (setf alert (j_alertbox frame "label1" "label2" "OK"))  
 (setf alert (j_choicebox2 frame "label1" "label2" "Yes" "No"))  
 (setf alert (j_choicebox3 frame "label1" "label2" "Yes" "No" "Cancel"))  
   
   
72  (defun drawgraphics (drawable xmin ymin xmax ymax)  (defun drawgraphics (drawable xmin ymin xmax ymax)
73    (let* ((fntsize 10)    (let* ((fntsize 10)
74           (tmpstrx (format nil "XMax = ~D" xmax))           (tmpstrx (format nil "XMax = ~D" xmax))
75           (tmpstry (format nil "YMax = ~D" ymax))           (tmpstry (format nil "YMax = ~D" ymax))
76           (tmpstrwidx (j_getstringwidth drawable tmpstrx))           (tmpstrwidx (j_getstringwidth drawable tmpstrx)))
          (tmpstrwidy (j_getstringwidth drawable tmpstry)))  
77      (j_setfontsize drawable fntsize)      (j_setfontsize drawable fntsize)
78      (j_setnamedcolor drawable J_RED)      (j_setnamedcolor drawable J_RED)
79    
# Line 86  Line 105 
105                (setf y (+ y (j_getfontheight drawable)))                (setf y (+ y (j_getfontheight drawable)))
106                (j_drawstring drawable x y teststr))))))                (j_drawstring drawable x y teststr))))))
107    
   
 (j_setborderlayout frame)  
   
 (setf menubar (j_menubar frame))  
 (setf file    (j_menu menubar "File"))  
 (setf print   (j_menuitem file "Print"))  
 (setf save    (j_menuitem file "Save BMP"))  
 (setf quit    (j_menuitem file "Quit"))  
 (setf canvas  (j_canvas frame 400 600))  
 (j_pack frame)  
 (j_show frame)  
   
 (drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas))  
   
 (loop as obj = (j_nextaction)  
       while (and (not (= obj frame)) (not (= obj quit)))  
       do  
       (when (= obj canvas)  
         (j_setnamedcolorbg canvas J_WHITE)  
         (drawgraphics canvas 10 10 (- (j_getwidth canvas) 10) (- (j_getheight canvas) 10)))  
       (when (= obj print)  
         (let ((printer (j_printer frame)))  
           (when (> 0 printer)  
             (drawgraphics printer 40 40 (- (j_getwidth printer) 80) (- (j_getheight printer) 80))  
             (j_print printer))))  
       (when (= obj save)  
         (let ((image (j_image 600 800)))  
           (drawgraphics image 0 0 600 800)  
           (when (= 0 (j_saveimage image "test.bmp" J_BMP))  
             (j_alertbox frame "Problems" "Can't save the image" "OK")))))  
   
 (j_dispose canvas)  
 (j_dispose menubar)  
 (j_dispose file)  
 (j_dispose print)  
 (j_dispose save)  
 (j_dispose quit)  
 (j_dispose frame)  
   
 ;; Try some mouse handling  
 (setf frame (j_frame "Move and drag the mouse"))  
 (j_setsize frame 430 240)  
 (j_setnamedcolorbg frame J_LIGHT_GRAY)  
   
 (setf canvas1 (j_canvas frame 200 200))  
 (setf canvas2 (j_canvas frame 200 200))  
   
 (j_setpos canvas1 10 30)  
 (j_setpos canvas2 220 30)  
   
 (setf pressed (j_mouselistener canvas1 J_PRESSED))  
 (setf dragged (j_mouselistener canvas1 J_DRAGGED))  
 (setf released (j_mouselistener canvas1 J_RELEASED))  
 (setf entered (j_mouselistener canvas2 J_ENTERERD))  
 (setf moved (j_mouselistener canvas2 J_MOVED))  
 (setf exited (j_mouselistener canvas2 J_EXITED))  
   
 (j_show frame)  
   
 ; (defentry j_getmousepos1 ( int string string ) ( void "j_getmousepos" ))  
   
 (let ((xa (make-array 1 :initial-element 0 :element-type 'fixnum))  
       (ya (make-array 1 :initial-element 0 :element-type 'fixnum))  
       (x 0)  
       (y 0)  
       (startx 0)  
       (starty 0))  
   
   (loop as obj = (j_nextaction)  
         while (and (not (= obj frame)) (not (= obj quit)))  
         do  
         (when (= obj pressed)  
           (j_getmousepos pressed (inta-ptr xa) (inta-ptr ya))  
           (setf x (aref xa 0))  
           (setf y (aref ya 0))  
           (setf startx x)  
           (setf starty y))  
         (when (= obj dragged)  
           (j_getmousepos dragged (inta-ptr xa) (inta-ptr ya))  
           (setf x (aref xa 0))  
           (setf y (aref ya 0))  
           (j_drawrect canvas1 startx starty (- x startx) (- y starty)))  
         (when (= obj released)  
           (j_getmousepos released (inta-ptr xa) (inta-ptr ya))  
           (setf x (aref xa 0))  
           (setf y (aref ya 0))  
           (j_drawrect canvas1 startx starty (- x startx) (- y starty)))  
         (when (= obj entered)  
           (j_getmousepos entered (inta-ptr xa) (inta-ptr ya))  
           (setf x (aref xa 0))  
           (setf y (aref ya 0))  
           (setf startx x)  
           (setf starty y))  
         (when (= obj moved)  
           (j_getmousepos moved (inta-ptr xa) (inta-ptr ya))  
           (setf x (aref xa 0))  
           (setf y (aref ya 0))  
           (setf startx x)  
           (setf starty y)  
           (j_drawline canvas2 startx starty x y))  
         (when (= obj exited)  
           (j_getmousepos exited (inta-ptr xa) (inta-ptr ya))  
           (setf x (aref xa 0))  
           (setf y (aref ya 0))  
           (j_drawline canvas2 startx starty x y))))  
   
   
 ;; Kill the Japi GUI server  
 (j_quit)  
108    (with-japi-server ("GCL Japi library test GUI 2" 2)
109          (with-frame (frame "Draw")
110                      (j_show frame)
111                      (let ((alert (j_messagebox frame "label1" "label2")))
112                        (j_sleep 2000)
113                        (j_dispose alert))
114                      (let ((result1 (j_alertbox frame "label1" "label2" "OK"))
115                            (result2 (j_choicebox2 frame "label1" "label2" "Yes" "No"))
116                            (result3 (j_choicebox3 frame "label1" "label2" "Yes" "No" "Cancel")))
117                        (format t "Requestor results were: ~D, ~D, ~D~%" result1 result2 result3))
118                      (j_setborderlayout frame)
119                      (let* ((menubar (j_menubar frame))
120                             (file    (j_menu menubar "File"))
121                             (print   (j_menuitem file "Print"))
122                             (save    (j_menuitem file "Save BMP"))
123                             (quit    (j_menuitem file "Quit")))
124                        (with-canvas  (canvas frame 400 600)
125                                      (j_pack frame)
126                                      (drawgraphics canvas 0 0 (j_getwidth canvas) (j_getheight canvas))
127                                      (j_show frame)
128                                      (loop as obj = (j_nextaction)
129                                            while (and (not (= obj frame)) (not (= obj quit)))
130                                            do
131                                            (when (= obj canvas)
132                                              (j_setnamedcolorbg canvas J_WHITE)
133                                              (drawgraphics canvas 10 10
134                                                            (- (j_getwidth canvas) 10)
135                                                            (- (j_getheight canvas) 10)))
136                                            (when (= obj print)
137                                              (let ((printer (j_printer frame)))
138                                                (when (> 0 printer)
139                                                  (drawgraphics printer 40 40
140                                                                (- (j_getwidth printer) 80)
141                                                                (- (j_getheight printer) 80))
142                                                  (j_print printer))))
143                                            (when (= obj save)
144                                              (let ((image (j_image 600 800)))
145                                                (drawgraphics image 0 0 600 800)
146                                                (when (= 0 (j_saveimage image "test.bmp" J_BMP))
147                                                  (j_alertbox frame "Problems" "Can't save the image" "OK"))))))
148                             (j_dispose menubar)
149                             (j_dispose file)
150                             (j_dispose print)
151                             (j_dispose save)
152                             (j_dispose quit)))
153          ;; Try some mouse handling
154          (with-frame (frame "Move and drag the mouse")
155                      (j_setsize frame 430 240)
156                      (j_setnamedcolorbg frame J_LIGHT_GRAY)
157                      (with-canvas (canvas1 frame 200 200)
158                                   (with-canvas (canvas2 frame 200 200)
159                                                (j_setpos canvas1 10 30)
160                                                (j_setpos canvas2 220 30)
161                                                (let ((pressed (j_mouselistener canvas1 J_PRESSED))
162                                                      (dragged (j_mouselistener canvas1 J_DRAGGED))
163                                                      (released (j_mouselistener canvas1 J_RELEASED))
164                                                      (entered (j_mouselistener canvas2 J_ENTERERD))
165                                                      (moved (j_mouselistener canvas2 J_MOVED))
166                                                      (exited (j_mouselistener canvas2 J_EXITED))
167                                                  ;; First allocate some unmovable storage for passing data back from C land.
168                                                  ;; This uses the GCL make-array specific keyword :static to freeze
169                                                  ;; the array.
170                                                      (xa (make-array 1 :initial-element 0 :element-type 'fixnum :static t))
171                                                      (ya (make-array 1 :initial-element 0 :element-type 'fixnum :static t))
172                                                      (x 0)
173                                                      (y 0)
174                                                      (startx 0)
175                                                      (starty 0))
176                                                  (j_show frame)
177                                                  (loop as obj = (j_nextaction)
178                                                        while (and (not (= obj frame)) (not (= obj quit)))
179                                                        do
180                                                        (when (= obj pressed)
181                                                          (j_getmousepos pressed (inta-ptr xa) (inta-ptr ya))
182                                                          (setf x (aref xa 0))
183                                                          (setf y (aref ya 0))
184                                                          (setf startx x)
185                                                          (setf starty y))
186                                                        (when (= obj dragged)
187                                                          (j_getmousepos dragged (inta-ptr xa) (inta-ptr ya))
188                                                          (setf x (aref xa 0))
189                                                          (setf y (aref ya 0))
190                                                          (j_drawrect canvas1 startx starty (- x startx) (- y starty)))
191                                                        (when (= obj released)
192                                                          (j_getmousepos released (inta-ptr xa) (inta-ptr ya))
193                                                          (setf x (aref xa 0))
194                                                          (setf y (aref ya 0))
195                                                          (j_drawrect canvas1 startx starty (- x startx) (- y starty)))
196                                                        (when (= obj entered)
197                                                          (j_getmousepos entered (inta-ptr xa) (inta-ptr ya))
198                                                          (setf x (aref xa 0))
199                                                          (setf y (aref ya 0))
200                                                          (setf startx x)
201                                                          (setf starty y))
202                                                        (when (= obj moved)
203                                                          (j_getmousepos moved (inta-ptr xa) (inta-ptr ya))
204                                                          (setf x (aref xa 0))
205                                                          (setf y (aref ya 0))
206                                                          (setf startx x)
207                                                          (setf starty y)
208                                                          (j_drawline canvas2 startx starty x y))
209                                                        (when (= obj exited)
210                                                          (j_getmousepos exited (inta-ptr xa) (inta-ptr ya))
211                                                          (setf x (aref xa 0))
212                                                          (setf y (aref ya 0))
213                                                          (j_drawline canvas2 startx starty x y))))
214                                                (j_dispose pressed)
215                                                (j_dispose dragged)
216                                                (j_dispose released)
217                                                (j_dispose entered)
218                                                (j_dispose moved)
219                                                (j_dispose exited)))))

Legend:
Removed from v.1.2  
changed lines
  Added in v.1.3

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