[jlisp] / ui-swing.lisp

;;; -*-lisp-*-
;;;
;;; Pleasant Lisp interface to Swing functions
;;;
;;; (c) 2007 Mark Wooding
;;;

;;;----- Licensing notice ---------------------------------------------------
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2 of the License, or
;;; (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.

(in-package #:dep-ui)

;;;--------------------------------------------------------------------------
;;; Utilities.

(defun listify (thing)
  "Answer THING if it's a list, else a singleton list containing THING."
  (if (listp thing) thing (list thing)))

;;;--------------------------------------------------------------------------
;;; Basic stuff.

(defclass widget ()
  ((java :reader widget-java :initarg :java)))

(defmethod widget-java ((widget t)) widget)

(defmethod widget-insets ((widget t)) 2)

;;;--------------------------------------------------------------------------
;;; Grid-bag constraints.

(defun make-insets (&rest arguments)
  "Return a java.awt.*insets object from the given ARGUMENTS.  The forms
   accepted are:

     * (make-insets) -> (0, 0, 0, 0)

     * (make-insets N) -> (N, N, N, N)

     * (make-insets &key :left :right :top :bottom) -> obvious thing"
  (apply #'make :java.awt.*insets
	 (cond ((null arguments) '(0 0 0 0))
	       ((and (endp (cdr arguments))
		     (integerp (car arguments)))
		(make-list 4 :initial-element (car arguments)))
	       (t (destructuring-bind (&key (left 0) (right 0) (top 0)
					    (bottom 0)) arguments
		    (list top left bottom right))))))

(defun make-grid-bag-constraints
    (&key grid-x grid-y grid-width grid-height weight-x weight-y
     anchor fill insets internal-pad-x internal-pad-y)
  "Return a java.awt.*grind-bag-constraints object.  Arguments may be as
   follows.

     * GRID-X, GRID-Y -- an integer or :relative  [default :relative]

     * GRID-WIDTH, GRID-HEIGHT -- an integer, :relative or  :remainder
       [default 1]

     * WEIGHT-X, WEIGHT-Y -- a float in [0, 1]  [default 0.0]

     * ANCHOR -- one of :center, :north, :northeast :northwest, :west, :east,
       :south, :southwest, :southeast, :page-start, :line-start, :line-end,
       :page-end, :last-line-start, :last-line-end, :first-line-start,
       :first-line-end  [default :center]

     * FILL -- one of :none, :horizontal, :vertical, :both  [default :none]

     * INSETS -- something acceptable to make-insets (q.v.)  [default 0]

     * INTERNAL-PAD-X, INTERNAL-PAD-Y -- integers  [default 0]"

  (flet ((magic (x)
	   (if (keywordp x)
	       (magic-constant-case (x :java.awt.*grid-bag-constraints)
		 :first-line-start :first-line-end
		 :page-start :line-start :line-end :page-end
		 :last-line-start :last-line-end
		 :none :both :horizontal :vertical
		 :relative :remainder
		 :northwest :north :northeast
		 :west :center :east
		 :southwest :south :southeast)
	       x)))
  (make :java.awt.*grid-bag-constraints
	(magic (or grid-x :relative)) (magic (or grid-y :relative))
	(magic (or grid-width 1)) (magic (or grid-height 1))
	(or weight-x 0.0) (or weight-y 0.0)
	(magic (or anchor :center)) (magic (or fill :none))
	(apply #'make-insets (listify insets))
	(or internal-pad-x 0) (or internal-pad-y 0))))

;;;--------------------------------------------------------------------------
;;; Colours.

(let ((builtin-colours (make-hash-table)))

  ;; Build a table of standard Java colours.
  (dolist (colour '(:black :blue :cyan :dark-gray :gray :green :light-gray
		    :magenta :orange :pink :red :white :yellow))
    (setf (gethash colour builtin-colours)
	  (class-field :java.awt.*color
		       (substitute #\_ #\- (string-upcase colour)))))

  (defun make-colour (&rest arguments)
    "Return a newly constructed colour object.

     The ARGUMENTS may be one of the following.

       * nil -- return a null reference, rather than a colour.

       * JAVA-OBJECT -- return the JAVA-OBJECT unmolested.

       * KEYWORD -- return the standard colour named by KEYWORD.

       * STRING -- return the Java colour named by STRING.

       * RGB &optional ALPHAP -- interpret the integer RGB as a 3-byte packed
         RGB triple (logior (ash RED 16) (ash GREEN 8) (ash BLUE 0)); if
         ALPHA-P is nil (the default) then apply full alpha; if it's t, then
         read alpha from byte 3 of RGB; otherwise it's a raw alpha value (see
         below).

       * RED GREEN BLUE &optional (ALPHA 1.0) -- each of the RED, GREEN, BLUE
         and ALPHA arguments is a number, either an integer in [0, 256)"
    (let ((indicator (car arguments)))
      (etypecase indicator
	(null java-null)
	(java-object indicator)
	(keyword
	 (or (gethash indicator builtin-colours)
	     (error "Colour ~S not found." indicator)))
	(string
	 (send-class :java.awt.*color :get-color indicator))
	(number
	 (multiple-value-bind (red green blue alpha)
	     (if (and (integerp indicator) (null (cddr arguments)))
		 (destructuring-bind (rgb &key alpha) arguments
		   (values (ldb (byte 8 16) rgb)
			   (ldb (byte 8  8) rgb)
			   (ldb (byte 8  0) rgb)
			   (case alpha
			     ((t) (ldb (byte 8 24) rgb))
			     ((nil) 255)
			     (t alpha))))
		 (destructuring-bind (r g b &optional (a 1.0)) arguments
		   (values r g b a)))
	   (flet ((fixup (n)
		    (if (integerp n) n (round (* n 255)))))
	     (make :java.awt.*color
		   (fixup red)
		   (fixup green)
		   (fixup blue)
		   (fixup alpha)))))))))

;;;--------------------------------------------------------------------------
;;; Text fields.

(defun make-text-field (&key readonly notify)
  "Construct and reutrn a text entry field.

   If READONLY is non-nil then don't allow user edits.  If NOTIFY is non-nil,
   then assume that it's a function of one argument, and call (funcall NOTIFY
   FIELD) when the field's contents are changed."
  (let ((field (make :javax.swing.*j-text-field)))
    (when readonly
      (send field :set-editable java-false))
    (when notify
      (flet ((kick (&optional ev)
	       (declare (ignore ev))
	       (funcall notify field)))
	(send (send field :get-document) :add-document-listener
	      (jinterface-implementation
	        (java-name :javax.swing.event.*document-listener)
		(java-name :insert-update) #'kick
		(java-name :remove-update) #'kick
		(java-name :changed-update) #'kick))
	(kick)))
    field))

(defun field-text (field)
  "Return the contents of the text field FIELD.  This is a SETF-able place."
  (send field :get-text))
(defun (setf field-text) (text field)
  "Modify the contents of the text field FIELD."
  (send field :set-text text))

(let ((good-colour
       (send (make :javax.swing.*j-text-field) :get-background))
      (bad-colour (make-colour 1.0 0.4 0.4)))
  (defun set-field-highlight (field highlight)
    "Highlight the text field FIELD according to HIGHLIGHT.

     The HIGHLIGHT may currently be :good or :bad."
    (send field :set-background (ecase highlight
				  (:good good-colour)
				  (:bad bad-colour)))))

;;;--------------------------------------------------------------------------
;;; Labels.

(defun make-label (string)
  "Create and return a label widget showing the STRING.

   If an ampersand appears in the string, underline the following letter."
  (let* ((amp (position #\& string))
	 (text (if amp
		   (concatenate 'string
				(subseq string 0 amp)
				(subseq string (1+ amp)))
		   string))
	 (widget (make :javax.swing.*j-label text
		       (class-field :javax.swing.*j-label
				    :*trailing*))))
    (when amp
      (send widget :set-displayed-mnemonic-index amp))
    widget))

;;;--------------------------------------------------------------------------
;;; Group boxes.

(defun make-group (label)
  "Create and return a group box with a given LABEL (a string) as its title."
  (let ((group (make :javax.swing.*j-panel)))
    (send group :set-border
	  (make :javax.swing.border.*titled-border
		(make :javax.swing.border.*etched-border
		      (class-field :javax.swing.border.*etched-border
				   :*lowered*))
		label))
    (send group :set-layout (make :java.awt.*grid-bag-layout))
    group))

;;;--------------------------------------------------------------------------
;;; Radio buttons.

(defclass radio-group (widget)
  ((alist)))

(defmethod widget-insets ((widget radio-group)) 0)

(defun radio-notifier-hack (value notify)
  ;; This would be an FLET function in MAKE-RADIO-GROUP, but ABCL is buggy.
  (implementation :java.awt.event.*action-listener
    (action-performed (ev)
      (declare (ignore ev))
      (format t "notify: ~A~%" value)
      (funcall notify value))))

(defun make-radio-group (notify plist &key default)
  (let* ((button-group (make :javax.swing.*button-group))
	 (panel (make :javax.swing.*j-panel))
	 (alist (loop for (value label) on plist by #'cddr
		      for selectp = (jboolean (eq value default))
		      for button = (make :javax.swing.*j-radio-button
					 label selectp)
		      do (format t "establish ~A~%" value)
		         (send button :add-action-listener
			       (radio-notifier-hack value notify))
		         (send button-group :add button)
		         (send panel :add button
			       (make-grid-bag-constraints :fill :horizontal
							  :insets 2
							  :weight-x 1.0))
		      collect (cons value button))))
    (make-instance 'radio-group
		   :java panel
		   :alist alist)))

(defun radio-group-selected (group)
  (loop for (value . button) in (slot-value group 'alist)
        when (send button :is-selected) return value
        finally (return nil)))

(defun (setf radio-group-selected) (value group)
  (send (or (assoc value (slot-value group 'alist))
	    (error "Invalid value ~S for this radio group." value))
	:set-selected java-true)
  value)

;;;--------------------------------------------------------------------------
;;; Widget packing.

(defun pack-single-widget (panel widget)
  (send panel :add (widget-java widget)
	(make-grid-bag-constraints :fill :horizontal
				   :anchor :page-start
				   :insets (widget-insets widget)
				   :weight-x 1.0
				   :grid-width :remainder))
  widget)

(defun pack-labelled-widget (panel label widget)
  (let ((label-widget (make-label label))
	(other-widget (widget-java widget)))
    (send panel :add label-widget
	  (make-grid-bag-constraints :fill :horizontal
				     :anchor :north
				     :insets 2))
    (send panel :add other-widget
	  (make-grid-bag-constraints :fill :horizontal
				     :anchor :north
				     :weight-x 1.0
				     :insets 2
				     :grid-width :remainder))
    (send label-widget :set-label-for other-widget)
    widget))

;;;--------------------------------------------------------------------------
;;; Toplevel windows.

(defclass toplevel (widget)
  ((java :initform (make :javax.swing.*j-frame))))

(defmethod toplevel-closing ((widget toplevel))
  (send (widget-java widget) :set-visible java-false))
(defmethod toplevel-closed ((widget toplevel)) (drop-reason))
(defmethod toplevel-opened ((widget toplevel)) (add-reason))

(defmethod shared-initialize ((widget toplevel) slot-names &key title)
  (declare (ignore slot-names))
  (unless (slot-boundp widget 'java)
    (setf (slot-value widget 'java) (make :javax.swing.*j-frame)))
  (let ((window (widget-java widget)))
    (when title
      (send window :set-title title))
    (send window :set-layout (make :java.awt.*grid-bag-layout))
    (send window :set-default-close-operation
	  (class-field :javax.swing.*j-frame :*do-nothing-on-close*))
    (send window :add-window-listener
	  (implementation :java.awt.event.*window-listener
	    (:window-activated (ev) (declare (ignore ev)))
	    (:window-deactivated (ev) (declare (ignore ev)))
	    (:window-iconified (ev) (declare (ignore ev)))
	    (:window-deiconified (ev) (declare (ignore ev)))
	    (:window-opened (ev) (declare (ignore ev)))
	    (:window-closing (ev)
	      (declare (ignore ev))
	      (toplevel-closing widget))
	    (:window-closed (ev)
	      (declare (ignore ev))
	      (toplevel-closed widget))))))

(defun show-toplevel (widget)
  (let ((window (widget-java widget)))
    (unless (send window :is-showing)
      (toplevel-opened widget)
      (send window :set-visible java-true))))

(defun make-toplevel (title populate-func)
  (let* ((widget (make-instance 'toplevel :title title)))
    (let ((*panel* (widget-java widget)))
      (funcall populate-func)
      (send *panel* :pack))
    (show-toplevel widget)
    widget))

;;;--------------------------------------------------------------------------
;;; Other stuff.

(unless (fboundp 'exit)
  (defun exit (&optional (return-code 0))
    (send-class :java.lang.*system :exit return-code)))

;;;----- That's all, folks --------------------------------------------------
Commit	Line	Data
fc7489de MW	1	;;; --lisp--
	2	;;;
	3	;;; Pleasant Lisp interface to Swing functions
	4	;;;
	5	;;; (c) 2007 Mark Wooding
	6	;;;
	7
	8	;;;----- Licensing notice ---------------------------------------------------
	9	;;;
	10	;;; This program is free software; you can redistribute it and/or modify
	11	;;; it under the terms of the GNU General Public License as published by
	12	;;; the Free Software Foundation; either version 2 of the License, or
	13	;;; (at your option) any later version.
	14	;;;
	15	;;; This program is distributed in the hope that it will be useful,
	16	;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
	17	;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
	18	;;; GNU General Public License for more details.
	19	;;;
	20	;;; You should have received a copy of the GNU General Public License
	21	;;; along with this program; if not, write to the Free Software Foundation,
	22	;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
	23
	24	(in-package #:dep-ui)
	25
	26	;;;--------------------------------------------------------------------------
	27	;;; Utilities.
	28
	29	(defun listify (thing)
	30	"Answer THING if it's a list, else a singleton list containing THING."
	31	(if (listp thing) thing (list thing)))
	32
	33	;;;--------------------------------------------------------------------------
	34	;;; Basic stuff.
	35
	36	(defclass widget ()
	37	((java :reader widget-java :initarg :java)))
	38
	39	(defmethod widget-java ((widget t)) widget)
	40
	41	(defmethod widget-insets ((widget t)) 2)
	42
	43	;;;--------------------------------------------------------------------------
	44	;;; Grid-bag constraints.
	45
	46	(defun make-insets (&rest arguments)
	47	"Return a java.awt.*insets object from the given ARGUMENTS. The forms
	48	accepted are:
	49
	50	* (make-insets) -> (0, 0, 0, 0)
	51
	52	* (make-insets N) -> (N, N, N, N)
	53
	54	* (make-insets &key :left :right :top :bottom) -> obvious thing"
	55	(apply #'make :java.awt.*insets
	56	(cond ((null arguments) '(0 0 0 0))
	57	((and (endp (cdr arguments))
	58	(integerp (car arguments)))
	59	(make-list 4 :initial-element (car arguments)))
	60	(t (destructuring-bind (&key (left 0) (right 0) (top 0)
	61	(bottom 0)) arguments
	62	(list top left bottom right))))))
	63
	64	(defun make-grid-bag-constraints
65	(&key grid-x grid-y grid-width grid-height weight-x weight-y
66	anchor fill insets internal-pad-x internal-pad-y)
67	"Return a java.awt.*grind-bag-constraints object. Arguments may be as
68	follows.
69
70	* GRID-X, GRID-Y -- an integer or :relative [default :relative]
71
72	* GRID-WIDTH, GRID-HEIGHT -- an integer, :relative or :remainder
73	[default 1]
74
75	* WEIGHT-X, WEIGHT-Y -- a float in [0, 1] [default 0.0]
76
77	* ANCHOR -- one of :center, :north, :northeast :northwest, :west, :east,
78	:south, :southwest, :southeast, :page-start, :line-start, :line-end,
79	:page-end, :last-line-start, :last-line-end, :first-line-start,
80	:first-line-end [default :center]
81
82	* FILL -- one of :none, :horizontal, :vertical, :both [default :none]
83
84	* INSETS -- something acceptable to make-insets (q.v.) [default 0]
85
86	* INTERNAL-PAD-X, INTERNAL-PAD-Y -- integers [default 0]"
87
88	(flet ((magic (x)
89	(if (keywordp x)
90	(magic-constant-case (x :java.awt.*grid-bag-constraints)
91	:first-line-start :first-line-end
92	:page-start :line-start :line-end :page-end
93	:last-line-start :last-line-end
94	:none :both :horizontal :vertical
95	:relative :remainder
96	:northwest :north :northeast
97	:west :center :east
98	:southwest :south :southeast)
99	x)))
100	(make :java.awt.*grid-bag-constraints
101	(magic (or grid-x :relative)) (magic (or grid-y :relative))
102	(magic (or grid-width 1)) (magic (or grid-height 1))
103	(or weight-x 0.0) (or weight-y 0.0)
104	(magic (or anchor :center)) (magic (or fill :none))
105	(apply #'make-insets (listify insets))
106	(or internal-pad-x 0) (or internal-pad-y 0))))
107
108	;;;--------------------------------------------------------------------------
109	;;; Colours.
110
111	(let ((builtin-colours (make-hash-table)))
112
113	;; Build a table of standard Java colours.
114	(dolist (colour '(:black :blue :cyan :dark-gray :gray :green :light-gray
115	:magenta :orange :pink :red :white :yellow))
116	(setf (gethash colour builtin-colours)
117	(class-field :java.awt.*color
118	(substitute #\_ #\- (string-upcase colour)))))
119
120	(defun make-colour (&rest arguments)
121	"Return a newly constructed colour object.
122
123	The ARGUMENTS may be one of the following.
124
125	* nil -- return a null reference, rather than a colour.
126
127	* JAVA-OBJECT -- return the JAVA-OBJECT unmolested.
128
129	* KEYWORD -- return the standard colour named by KEYWORD.
130
131	* STRING -- return the Java colour named by STRING.
132
133	* RGB &optional ALPHAP -- interpret the integer RGB as a 3-byte packed
134	RGB triple (logior (ash RED 16) (ash GREEN 8) (ash BLUE 0)); if
135	ALPHA-P is nil (the default) then apply full alpha; if it's t, then
136	read alpha from byte 3 of RGB; otherwise it's a raw alpha value (see
137	below).
138
139	* RED GREEN BLUE &optional (ALPHA 1.0) -- each of the RED, GREEN, BLUE
140	and ALPHA arguments is a number, either an integer in [0, 256)"
141	(let ((indicator (car arguments)))
142	(etypecase indicator
143	(null java-null)
144	(java-object indicator)
145	(keyword
146	(or (gethash indicator builtin-colours)
147	(error "Colour ~S not found." indicator)))
148	(string
149	(send-class :java.awt.*color :get-color indicator))
150	(number
151	(multiple-value-bind (red green blue alpha)
152	(if (and (integerp indicator) (null (cddr arguments)))
153	(destructuring-bind (rgb &key alpha) arguments
154	(values (ldb (byte 8 16) rgb)
155	(ldb (byte 8 8) rgb)
156	(ldb (byte 8 0) rgb)
157	(case alpha
158	((t) (ldb (byte 8 24) rgb))
159	((nil) 255)
160	(t alpha))))
161	(destructuring-bind (r g b &optional (a 1.0)) arguments
162	(values r g b a)))
163	(flet ((fixup (n)
164	(if (integerp n) n (round (* n 255)))))
165	(make :java.awt.*color
166	(fixup red)
167	(fixup green)
168	(fixup blue)
169	(fixup alpha)))))))))
170
171	;;;--------------------------------------------------------------------------
172	;;; Text fields.
173
174	(defun make-text-field (&key readonly notify)
175	"Construct and reutrn a text entry field.
176
177	If READONLY is non-nil then don't allow user edits. If NOTIFY is non-nil,
178	then assume that it's a function of one argument, and call (funcall NOTIFY
179	FIELD) when the field's contents are changed."
180	(let ((field (make :javax.swing.*j-text-field)))
181	(when readonly
182	(send field :set-editable java-false))
183	(when notify
184	(flet ((kick (&optional ev)
185	(declare (ignore ev))
186	(funcall notify field)))
187	(send (send field :get-document) :add-document-listener
188	(jinterface-implementation
189	(java-name :javax.swing.event.*document-listener)
190	(java-name :insert-update) #'kick
191	(java-name :remove-update) #'kick
192	(java-name :changed-update) #'kick))
193	(kick)))
194	field))
195
196	(defun field-text (field)
197	"Return the contents of the text field FIELD. This is a SETF-able place."
198	(send field :get-text))
199	(defun (setf field-text) (text field)
200	"Modify the contents of the text field FIELD."
201	(send field :set-text text))
202
203	(let ((good-colour
204	(send (make :javax.swing.*j-text-field) :get-background))
205	(bad-colour (make-colour 1.0 0.4 0.4)))
206	(defun set-field-highlight (field highlight)
207	"Highlight the text field FIELD according to HIGHLIGHT.
208
209	The HIGHLIGHT may currently be :good or :bad."
210	(send field :set-background (ecase highlight
211	(:good good-colour)
212	(:bad bad-colour)))))
213
214	;;;--------------------------------------------------------------------------
215	;;; Labels.
216
217	(defun make-label (string)
218	"Create and return a label widget showing the STRING.
219
220	If an ampersand appears in the string, underline the following letter."
221	(let* ((amp (position #\& string))
222	(text (if amp
223	(concatenate 'string
224	(subseq string 0 amp)
225	(subseq string (1+ amp)))
226	string))
227	(widget (make :javax.swing.*j-label text
228	(class-field :javax.swing.*j-label
229	:trailing))))
230	(when amp
231	(send widget :set-displayed-mnemonic-index amp))
232	widget))
233
234	;;;--------------------------------------------------------------------------
235	;;; Group boxes.
236
237	(defun make-group (label)
238	"Create and return a group box with a given LABEL (a string) as its title."
239	(let ((group (make :javax.swing.*j-panel)))
240	(send group :set-border
241	(make :javax.swing.border.*titled-border
242	(make :javax.swing.border.*etched-border
243	(class-field :javax.swing.border.*etched-border
244	:lowered))
245	label))
246	(send group :set-layout (make :java.awt.*grid-bag-layout))
247	group))
248
249	;;;--------------------------------------------------------------------------
250	;;; Radio buttons.
251
252	(defclass radio-group (widget)
253	((alist)))
254
255	(defmethod widget-insets ((widget radio-group)) 0)
256
257	(defun radio-notifier-hack (value notify)
258	;; This would be an FLET function in MAKE-RADIO-GROUP, but ABCL is buggy.
259	(implementation :java.awt.event.*action-listener
260	(action-performed (ev)
261	(declare (ignore ev))
262	(format t "notify: ~A~%" value)
263	(funcall notify value))))
264
265	(defun make-radio-group (notify plist &key default)
266	(let* ((button-group (make :javax.swing.*button-group))
267	(panel (make :javax.swing.*j-panel))
268	(alist (loop for (value label) on plist by #'cddr
269	for selectp = (jboolean (eq value default))
270	for button = (make :javax.swing.*j-radio-button
271	label selectp)
272	do (format t "establish ~A~%" value)
273	(send button :add-action-listener
274	(radio-notifier-hack value notify))
275	(send button-group :add button)
276	(send panel :add button
277	(make-grid-bag-constraints :fill :horizontal
278	:insets 2
279	:weight-x 1.0))
280	collect (cons value button))))
281	(make-instance 'radio-group
282	:java panel
283	:alist alist)))
284
285	(defun radio-group-selected (group)
286	(loop for (value . button) in (slot-value group 'alist)
287	when (send button :is-selected) return value
288	finally (return nil)))
289
290	(defun (setf radio-group-selected) (value group)
291	(send (or (assoc value (slot-value group 'alist))
292	(error "Invalid value ~S for this radio group." value))
293	:set-selected java-true)
294	value)
295
296	;;;--------------------------------------------------------------------------
297	;;; Widget packing.
298
299	(defun pack-single-widget (panel widget)
300	(send panel :add (widget-java widget)
301	(make-grid-bag-constraints :fill :horizontal
302	:anchor :page-start
303	:insets (widget-insets widget)
304	:weight-x 1.0
305	:grid-width :remainder))
306	widget)
307
308	(defun pack-labelled-widget (panel label widget)
309	(let ((label-widget (make-label label))
310	(other-widget (widget-java widget)))
311	(send panel :add label-widget
312	(make-grid-bag-constraints :fill :horizontal
313	:anchor :north
314	:insets 2))
315	(send panel :add other-widget
316	(make-grid-bag-constraints :fill :horizontal
317	:anchor :north
318	:weight-x 1.0
319	:insets 2
320	:grid-width :remainder))
321	(send label-widget :set-label-for other-widget)
322	widget))
323
324	;;;--------------------------------------------------------------------------
325	;;; Toplevel windows.
326
327	(defclass toplevel (widget)
328	((java :initform (make :javax.swing.*j-frame))))
329
330	(defmethod toplevel-closing ((widget toplevel))
331	(send (widget-java widget) :set-visible java-false))
332	(defmethod toplevel-closed ((widget toplevel)) (drop-reason))
333	(defmethod toplevel-opened ((widget toplevel)) (add-reason))
334
335	(defmethod shared-initialize ((widget toplevel) slot-names &key title)
336	(declare (ignore slot-names))
337	(unless (slot-boundp widget 'java)
338	(setf (slot-value widget 'java) (make :javax.swing.*j-frame)))
339	(let ((window (widget-java widget)))
340	(when title
341	(send window :set-title title))
342	(send window :set-layout (make :java.awt.*grid-bag-layout))
343	(send window :set-default-close-operation
344	(class-field :javax.swing.j-frame :do-nothing-on-close*))
345	(send window :add-window-listener
346	(implementation :java.awt.event.*window-listener
347	(:window-activated (ev) (declare (ignore ev)))
348	(:window-deactivated (ev) (declare (ignore ev)))
349	(:window-iconified (ev) (declare (ignore ev)))
350	(:window-deiconified (ev) (declare (ignore ev)))
351	(:window-opened (ev) (declare (ignore ev)))
352	(:window-closing (ev)
353	(declare (ignore ev))
354	(toplevel-closing widget))
355	(:window-closed (ev)
356	(declare (ignore ev))
357	(toplevel-closed widget))))))
358
359	(defun show-toplevel (widget)
360	(let ((window (widget-java widget)))
361	(unless (send window :is-showing)
362	(toplevel-opened widget)
363	(send window :set-visible java-true))))
364
365	(defun make-toplevel (title populate-func)
366	(let* ((widget (make-instance 'toplevel :title title)))
367	(let ((panel (widget-java widget)))
368	(funcall populate-func)
369	(send panel :pack))
370	(show-toplevel widget)
371	widget))
372
373	;;;--------------------------------------------------------------------------
374	;;; Other stuff.
375
376	(unless (fboundp 'exit)
377	(defun exit (&optional (return-code 0))
378	(send-class :java.lang.*system :exit return-code)))
379
380	;;;----- That's all, folks --------------------------------------------------