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 |
|
|
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))))) |