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