;;; 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 --------------------------------------------------
~mdw / jlisp / blobdiff