-ABCL_JAR = /usr/local/src/abcl-0.0.10/abcl.jar
+ABCL_JAR = /home/mdw/src/abcl/abcl.jar
JAVAC = javac
JAR = jar
GPL = /usr/share/common-licenses/GPL-2
INSTALLER = setup-dep-ui.exe
-VERSION = 1.1.0
+VERSION = 1.2.0
all: dep-ui.jar
mv tmp.jar $@
rm -rf tmp.jar tmp
-jj.abcl swing.abcl queue.abcl dep.abcl:: dep-ui.abcl
-dep-ui.abcl: build.lisp \
- jj.lisp swing.lisp queue.lisp dep.lisp dep-ui.lisp
- abcl --load build.lisp
+jj.abcl ui-swing.abcl queue.abcl dep.abcl:: dep-ui.abcl
+dep-ui.abcl: dep-ui.asd jj.lisp ui-swing.lisp queue.lisp dep.lisp dep-ui.lisp
+ abcl --eval "(require :asdf)" \
+ --eval "(let ((sys:*compile-file-zip* nil)) (asdf:oos 'asdf:load-op :dep-ui) (exit))"
GPL.dostxt:
cp $(GPL) $@.new
--- /dev/null
+;;;
+
+(cl:defpackage #:dep-ui.asdf
+ (:use #:cl #:asdf))
+(cl:in-package #:dep-ui.asdf)
+
+(defsystem #:dep-ui
+ :description "User interface built from dependencies"
+ :version "1.2.0"
+ :author "Mark Wooding <mdw@distorted.org.uk>"
+ :depends-on (#+(or cmu sbcl clisp) "clg")
+ :components ((:file "queue")
+ (:file "weak")
+ (:file "dep" :depends-on ("queue" "weak"))
+ #+abcl (:file "jj")
+ (:file "package" :depends-on ("dep" #+abcl "jj"))
+ #+abcl (:file "ui-swing" :depends-on ("package"))
+ (:file "dep-ui"
+ :depends-on ("dep" "package" #+abcl "ui-swing"))))
;;; along with this program; if not, write to the Free Software Foundation,
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
-(defpackage #:dep-ui
- (:use #:common-lisp #:jj #:swing #:java #:dep #:extensions)
- (:export #:make-label #:make-input #:make-output #:make-group
- #:make-radio-dep #:within-group #:defwindow #:make-window
- #:add-reason #:drop-reason))
-
(in-package #:dep-ui)
;;;--------------------------------------------------------------------------
+;;; Generic interface.
-(defparameter bad-text-colour (make-colour 1.0 0.4 0.4))
-(defparameter good-text-colour
- (let ((text (make :javax.swing.*j-text-field)))
- (send text :get-background)))
+(defvar *live-deps*)
(defun update-text-field-dep (field dep convert-func)
- (let ((text (send field :get-text)))
+ (let ((text (field-text field)))
(multiple-value-bind (value bogusp) (funcall convert-func text)
(cond (bogusp
- (send field :set-background bad-text-colour)
+ (set-field-highlight field :bad)
(dep-make-bad dep))
(t
(unless (dep-goodp dep)
- (send field :set-background good-text-colour))
+ (set-field-highlight field :good))
(setf (dep-value dep) value))))))
(defun make-text-field-with-dep (convert-func dep)
- (let* ((field (make :javax.swing.*j-text-field))
- (doc (send field :get-document)))
- (flet ((kick (&optional ev)
- (declare (ignore ev))
- (update-text-field-dep field dep convert-func)))
- (send doc :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))
+ (make-text-field
+ :notify (lambda (field)
+ (update-text-field-dep field dep convert-func))))
(defun update-dep-text-field (field dep convert-func)
- (cond ((dep-goodp dep)
- (send field :set-background good-text-colour)
- (send field :set-text (funcall convert-func (dep-value dep))))
- (t
- (send field :set-background bad-text-colour)
- (send field :set-text ""))))
+ (multiple-value-bind (highlight value)
+ (if (dep-goodp dep)
+ (values :good (dep-value dep))
+ (values :bad ""))
+ (set-field-highlight field highlight)
+ (setf (field-text field) (funcall convert-func value))))
+
+(defun make-dependent-text-field
+ (dep &optional (convert-func #'princ-to-string))
+ (let ((field (make-text-field :readonly t)))
+ (flet ((kicked (&optional ev)
+ (declare (ignore ev))
+ (update-dep-text-field field dep convert-func)))
+ (dep-add-listener dep #'kicked)
+ (kicked))
+ field))
(defun safe-read-from-string (string continuation)
(with-input-from-string (stream string)
(lambda (value)
(values value (not (realp value))))))
-(defun make-dependent-text-field
- (dep &optional (convert-func #'princ-to-string))
- (let ((field (make :javax.swing.*j-text-field)))
- (send field :set-editable java-false)
- (flet ((kicked (&optional ev)
- (declare (ignore ev))
- (update-dep-text-field field dep convert-func)))
- (dep-add-listener dep #'kicked)
- (kicked))
- field))
+(defun make-input (label dep &key (convert #'read-real-from-string))
+ (let ((text (make-text-field-with-dep convert dep)))
+ (pack-labelled-widget *panel* label text)))
-(defun make-label (string)
- (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))
-
-(defun add-text-and-label (panel label text)
- (let ((label-widget (make-label label)))
- (send panel :add label-widget
- (make-grid-bag-constraints :fill :horizontal
- :anchor :north
- :insets 2))
- (send panel :add text
- (make-grid-bag-constraints :fill :horizontal
- :anchor :north
- :weight-x 1.0
- :insets 2
- :grid-width :remainder))
- (send label-widget :set-label-for text)))
-
-(defvar *panel* nil)
-
-(defun make-input (label dep)
- (let ((text (make-text-field-with-dep #'read-real-from-string dep)))
- (add-text-and-label *panel* label text)))
-
-(defun make-output (label dep)
+(defun make-output (label dep &key (convert "~,3F"))
(let ((text (make-dependent-text-field dep
- (lambda (value)
- (format nil "~,3F" value)))))
- (add-text-and-label *panel* label text)))
-
-(defun twiddle-dep-radio (button dep name)
- (send button :add-action-listener
- (implementation :java.awt.event.*action-listener
- (action-performed (ev)
- (declare (ignore ev))
- (setf (dep-value dep) name)))))
-
-(defun make-radio-dep (dep &rest settings)
- (let ((button-group (make :javax.swing.*button-group))
- (panel (make :javax.swing.*j-panel)))
- (send *panel* :add panel
- (make-grid-bag-constraints :fill :horizontal
- :anchor :north
- :insets 0
- :weight-x 1.0
- :grid-width :remainder))
- (loop for (name label) on settings by #'cddr
- for selectp = (progn
- (unless (dep-goodp dep)
- (setf (dep-value dep) name))
- (if (eq (dep-value dep) name)
- java-true
- java-false))
- for button = (make :javax.swing.*j-radio-button label selectp)
- do (twiddle-dep-radio button dep name)
- do (send button-group :add button)
- do (send panel :add button
- (make-grid-bag-constraints :fill :horizontal
- :insets 2
- :weight-x 1.0)))))
-
-(defun make-group (label)
- (let ((group (make-group-box label)))
- (send group :set-layout (make :java.awt.*grid-bag-layout))
- (send *panel* :add group
- (make-grid-bag-constraints :fill :horizontal
- :anchor :page-start
- :insets 2
- :weight-x 1.0
- :grid-width :remainder))
- group))
+ (etypecase convert
+ (string
+ (lambda (value)
+ (format nil convert value)))
+ ((or symbol function)
+ convert)))))
+ (pack-labelled-widget *panel* label text)))
+
+(defun make-radio-dep (dep plist)
+ (let ((group (make-radio-group
+ (lambda (value) (setf (dep-value dep) value))
+ plist
+ :default (if (dep-goodp dep)
+ (dep-value dep)
+ (setf (dep-value dep) (cadr plist))))))
+ (pack-single-widget *panel* group)))
+
(defmacro within-group ((label) &body body)
- `(let ((*panel* (make-group ,label)))
+ `(let ((*panel* (pack-single-widget *panel* (make-group ,label))))
,@body))
(let ((reasons 0))
(assert (plusp reasons))
(decf reasons)
(when (zerop reasons)
- (send-class :java.lang.*system :exit 0))))
-
-(defun make-window (title populate-func)
- (let ((window (make :javax.swing.*j-frame title)))
- (send window :set-layout (make :java.awt.*grid-bag-layout))
- (let ((*panel* window))
- (funcall populate-func))
- (send window :pack)
- (send window :set-visible java-true)
- (add-reason)
- (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))
- (send window :dispose))
- (:window-closed (ev)
- (declare (ignore ev))
- (drop-reason))))
- window))
+ (exit))))
(defmacro defwindow (name bvl (title) &body body)
`(defun ,name ,bvl
- (make-window ,title (lambda () ,@body))))
+ (make-toplevel ,title (lambda () ,@body))))
;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+(require :asdf)
+(asdf:oos 'asdf:load-op :dep-ui)
+(use-package '(:dep :dep-ui))
+
(defpackage #:jj
(:use #:common-lisp #:java)
(:export #:java-name #:lisp-name
- #:java-true #:java-false #:java-null
+ #:java-true #:java-false #:java-null #:jboolean
#:send #:send-class #:make #:make-java-array #:java-array
#:field #:class-field
#:magic-constant-case
(defconstant java-null (make-immediate-object nil :ref)
"A Java null reference.")
+(defun jboolean (thing)
+ "Return JAVA-TRUE if THING is non-nil, JAVA-FALSE if THING is nil."
+ (if thing java-true java-false))
+
(defmacro define-java-method (lisp-name class method &body args)
"Define a Lisp function LISP-NAME to call the named METHOD of CLASS on the
given arguments. The CLASS may be a string or symbol (it is converted by
(list (java-class-name java-class)
(cons :constructors
(expand-java-method (ensure-java-constructor java-class)))
- (loop for name being the hash-keys
- of (ensure-java-method-table java-class)
- using (hash-value method)
- collect (cons name (expand-java-method method)))))
+ (sort (loop for name being the hash-keys
+ of (ensure-java-method-table java-class)
+ using (hash-value method)
+ collect (cons name (expand-java-method method)))
+ (lambda (x y) (string< (car x) (car y))))))
(defparameter *conversions*
(let ((raw '((java.lang.*object boolean)
(defun jclass-convertible-p (from to)
"Return whether there is an automatic conversion between FROM and TO. This
can be considered a partial order on types."
- (or (jclass-superclass-p to from)
+ (or (null from)
+ (jclass-superclass-p to from)
(member from (assoc to *conversions* :test #'equal)
:test #'equal)))
(t (and (jclass-convertible-p (car first) (car second))
(argument-list-betterp (cdr first) (cdr second))))))
-(defun get-jmethod-for-argument-types (java-method argument-types)
+(defun get-jmethod-for-argument-types (java-class java-method argument-types)
"Given a JAVA-METHOD structure, return the best match overload for the
given list of ARGUMENT-TYPES.
(format t "*** chosen = ~S~%"
(expand-methodlist chosen)))
(cond ((null chosen)
- (error "No match found.~% method = ~A, args = ~A"
+ (error "No match found.~% ~
+ class = ~A, method = ~A~% ~
+ args = ~A"
+ (java-class-name java-class)
(java-method-name java-method)
(expand-arglist argument-types)))
((cdr chosen)
(defun find-jmethod (class name arg-types)
"Given a CLASS, a method NAME, and a list of ARG-TYPES, return the Java
method object for the best matching overload of the method."
- (get-jmethod-for-argument-types (find-java-method class name)
- (argument-type-list-from-names arg-types)))
+ (let ((java-class (find-java-class class)))
+ (get-jmethod-for-argument-types
+ java-class
+ (find-java-method java-class name)
+ (argument-type-list-from-names arg-types))))
(defun find-jconstructor (class arg-types)
"Given a CLASS and a list of ARG-TYPES, return the Java constructor object
for the best matching constructor overload."
- (get-jmethod-for-argument-types (find-java-constructor class)
- (argument-type-list-from-names arg-types)))
+ (let ((java-class (find-java-class class)))
+ (get-jmethod-for-argument-types
+ java-class
+ (find-java-constructor java-class)
+ (argument-type-list-from-names arg-types))))
(defun send (object message &rest arguments)
"Given an OBJECT, a MESSAGE name (Lisp symbol or Java name string) and
(let ((jargs (mapcar #'make-immediate-object arguments)))
(apply #'jcall
(find-jmethod (jobject-class object) message
- (mapcar (lambda (jarg) (jobject-class jarg)) jargs))
+ (mapcar (lambda (jarg)
+ (if (equal jarg java-null)
+ nil
+ (jobject-class jarg)))
+ jargs))
object
jargs)))
--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Package definition for dep-ui
+;;;
+;;; (c) 2008 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.
+
+(cl:defpackage #:dep-ui
+ (:use #:common-lisp #:dep .
+ #+abcl (#:jj #:java #:extensions))
+ (:export #:make-label #:make-input #:make-output #:make-group
+ #:make-radio-dep #:within-group #:defwindow #:make-window
+ #:add-reason #:drop-reason))
+
+(cl:in-package #:dep-ui)
+(defvar *panel* nil)
+
+;;;----- That's all, folks --------------------------------------------------
(make-output "Length:" start-length))
(within-group ("Initial stock")
(make-radio-dep stock-type
- :round "Round section"
- :square "Square section")
+ '(:round "Round section"
+ :square "Square section"))
(make-input "Stock size:" stock-size)
(make-output "Stock length:" stock-length))
#+ no
+++ /dev/null
-;;; -*-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.
-
-(defpackage #:swing
- (:use #:common-lisp #:jj)
- (:export #:make-insets #:make-grid-bag-constraints #:make-colour
- #:make-group-box))
-
-(in-package #:swing)
-
-;;;--------------------------------------------------------------------------
-;;; Utilities.
-
-(defun listify (thing)
- (if (listp thing) thing (list thing)))
-
-;;;--------------------------------------------------------------------------
-;;; 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))))
-
-(let ((builtin-colours (make-hash-table)))
- (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)
- (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) (not (numberp (cadr 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)))))))))
-
-(defun make-group-box (title)
- (let ((frame (make :javax.swing.*j-panel)))
- (send frame :set-border
- (make :javax.swing.border.*titled-border
- (make :javax.swing.border.*etched-border
- (class-field :javax.swing.border.*etched-border
- :*lowered*))
- title))
- frame))
-
-;;;----- That's all, folks --------------------------------------------------
--- /dev/null
+(defun test()
+ (let ((list nil))
+ (flet ((func (i)
+ (jj:implementation java.lang.*runnable
+ (run () (format t "running ~A~%" i)))))
+ (mapc (lambda (j)
+ (jj:send j :run))
+ (loop for i in '(a b c d)
+ collect (func i))))))
--- /dev/null
+;;; -*-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 --------------------------------------------------
~mdw / jlisp / commitdiff