chiark - git - mdw - jlisp/blob - ui-swing.lisp

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