+;;; -*-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 --------------------------------------------------