Commit | Line | Data |
---|---|---|
ee79a5f1 MW |
1 | ;;; -*-lisp-*- |
2 | ;;; | |
3 | ;;; Dependency-based user interfaces | |
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 | (defpackage #:dep-ui | |
25 | (:use #:common-lisp #:jj #:swing #:java #:dep #:extensions) | |
26 | (:export #:make-label #:make-input #:make-output #:make-group | |
27 | #:make-radio-dep #:within-group #:defwindow #:make-window | |
a2e7266a | 28 | #:add-reason #:drop-reason)) |
ee79a5f1 MW |
29 | |
30 | (in-package #:dep-ui) | |
31 | ||
32 | ;;;-------------------------------------------------------------------------- | |
33 | ||
34 | (defparameter bad-text-colour (make-colour 1.0 0.4 0.4)) | |
35 | (defparameter good-text-colour | |
36 | (let ((text (make :javax.swing.*j-text-field))) | |
37 | (send text :get-background))) | |
38 | ||
39 | (defun update-text-field-dep (field dep convert-func) | |
40 | (let ((text (send field :get-text))) | |
41 | (multiple-value-bind (value bogusp) (funcall convert-func text) | |
42 | (cond (bogusp | |
43 | (send field :set-background bad-text-colour) | |
44 | (dep-make-bad dep)) | |
45 | (t | |
46 | (unless (dep-goodp dep) | |
47 | (send field :set-background good-text-colour)) | |
48 | (setf (dep-value dep) value)))))) | |
49 | ||
50 | (defun make-text-field-with-dep (convert-func dep) | |
51 | (let* ((field (make :javax.swing.*j-text-field)) | |
52 | (doc (send field :get-document))) | |
53 | (flet ((kick (&optional ev) | |
54 | (declare (ignore ev)) | |
55 | (update-text-field-dep field dep convert-func))) | |
56 | (send doc :add-document-listener | |
57 | (jinterface-implementation | |
58 | (java-name :javax.swing.event.*document-listener) | |
59 | (java-name :insert-update) #'kick | |
60 | (java-name :remove-update) #'kick | |
61 | (java-name :changed-update) #'kick)) | |
62 | (kick)) | |
63 | field)) | |
64 | ||
65 | (defun update-dep-text-field (field dep convert-func) | |
66 | (cond ((dep-goodp dep) | |
67 | (send field :set-background good-text-colour) | |
68 | (send field :set-text (funcall convert-func (dep-value dep)))) | |
69 | (t | |
70 | (send field :set-background bad-text-colour) | |
71 | (send field :set-text "")))) | |
72 | ||
73 | (defun safe-read-from-string (string continuation) | |
74 | (with-input-from-string (stream string) | |
75 | (ignore-errors | |
76 | (let ((value (let ((*read-eval* nil)) (read stream)))) | |
77 | (if (peek-char t stream nil) | |
78 | (values nil :junk) | |
79 | (funcall continuation value)))))) | |
80 | ||
81 | (defun read-real-from-string (string) | |
82 | (safe-read-from-string string | |
83 | (lambda (value) | |
84 | (values value (not (realp value)))))) | |
85 | ||
86 | (defun make-dependent-text-field | |
87 | (dep &optional (convert-func #'princ-to-string)) | |
88 | (let ((field (make :javax.swing.*j-text-field))) | |
89 | (send field :set-editable java-false) | |
90 | (flet ((kicked (&optional ev) | |
91 | (declare (ignore ev)) | |
92 | (update-dep-text-field field dep convert-func))) | |
93 | (dep-add-listener dep #'kicked) | |
94 | (kicked)) | |
95 | field)) | |
96 | ||
97 | (defun make-label (string) | |
98 | (let* ((amp (position #\& string)) | |
99 | (text (if amp | |
100 | (concatenate 'string | |
101 | (subseq string 0 amp) | |
102 | (subseq string (1+ amp))) | |
103 | string)) | |
104 | (widget (make :javax.swing.*j-label text | |
105 | (class-field :javax.swing.*j-label | |
106 | :*trailing*)))) | |
107 | (when amp | |
108 | (send widget :set-displayed-mnemonic-index amp)) | |
109 | widget)) | |
110 | ||
111 | (defun add-text-and-label (panel label text) | |
112 | (let ((label-widget (make-label label))) | |
113 | (send panel :add label-widget | |
114 | (make-grid-bag-constraints :fill :horizontal | |
115 | :anchor :north | |
116 | :insets 2)) | |
117 | (send panel :add text | |
118 | (make-grid-bag-constraints :fill :horizontal | |
119 | :anchor :north | |
120 | :weight-x 1.0 | |
121 | :insets 2 | |
122 | :grid-width :remainder)) | |
123 | (send label-widget :set-label-for text))) | |
124 | ||
125 | (defvar *panel* nil) | |
126 | ||
127 | (defun make-input (label dep) | |
128 | (let ((text (make-text-field-with-dep #'read-real-from-string dep))) | |
129 | (add-text-and-label *panel* label text))) | |
130 | ||
131 | (defun make-output (label dep) | |
132 | (let ((text (make-dependent-text-field dep | |
133 | (lambda (value) | |
134 | (format nil "~,3F" value))))) | |
135 | (add-text-and-label *panel* label text))) | |
136 | ||
137 | (defun twiddle-dep-radio (button dep name) | |
138 | (send button :add-action-listener | |
139 | (implementation :java.awt.event.*action-listener | |
140 | (action-performed (ev) | |
141 | (declare (ignore ev)) | |
142 | (setf (dep-value dep) name))))) | |
143 | ||
144 | (defun make-radio-dep (dep &rest settings) | |
145 | (let ((button-group (make :javax.swing.*button-group)) | |
146 | (panel (make :javax.swing.*j-panel))) | |
147 | (send *panel* :add panel | |
148 | (make-grid-bag-constraints :fill :horizontal | |
149 | :anchor :north | |
150 | :insets 0 | |
151 | :weight-x 1.0 | |
152 | :grid-width :remainder)) | |
153 | (loop for (name label) on settings by #'cddr | |
154 | for selectp = (progn | |
155 | (unless (dep-goodp dep) | |
156 | (setf (dep-value dep) name)) | |
157 | (if (eq (dep-value dep) name) | |
158 | java-true | |
159 | java-false)) | |
160 | for button = (make :javax.swing.*j-radio-button label selectp) | |
161 | do (twiddle-dep-radio button dep name) | |
162 | do (send button-group :add button) | |
163 | do (send panel :add button | |
164 | (make-grid-bag-constraints :fill :horizontal | |
165 | :insets 2 | |
166 | :weight-x 1.0))))) | |
167 | ||
168 | (defun make-group (label) | |
169 | (let ((group (make-group-box label))) | |
170 | (send group :set-layout (make :java.awt.*grid-bag-layout)) | |
171 | (send *panel* :add group | |
172 | (make-grid-bag-constraints :fill :horizontal | |
173 | :anchor :page-start | |
174 | :insets 2 | |
175 | :weight-x 1.0 | |
176 | :grid-width :remainder)) | |
177 | group)) | |
178 | ||
179 | (defmacro within-group ((label) &body body) | |
180 | `(let ((*panel* (make-group ,label))) | |
181 | ,@body)) | |
182 | ||
ee79a5f1 MW |
183 | (let ((reasons 0)) |
184 | (defun add-reason () | |
185 | (incf reasons)) | |
186 | (defun drop-reason () | |
187 | (assert (plusp reasons)) | |
188 | (decf reasons) | |
189 | (when (zerop reasons) | |
190 | (send-class :java.lang.*system :exit 0)))) | |
191 | ||
192 | (defun make-window (title populate-func) | |
193 | (let ((window (make :javax.swing.*j-frame title))) | |
194 | (send window :set-layout (make :java.awt.*grid-bag-layout)) | |
195 | (let ((*panel* window)) | |
196 | (funcall populate-func)) | |
197 | (send window :pack) | |
198 | (send window :set-visible java-true) | |
199 | (add-reason) | |
200 | (send window :set-default-close-operation | |
201 | (class-field :javax.swing.*j-frame :*do-nothing-on-close*)) | |
202 | (send window :add-window-listener | |
203 | (implementation :java.awt.event.*window-listener | |
204 | (:window-activated (ev) (declare (ignore ev))) | |
205 | (:window-deactivated (ev) (declare (ignore ev))) | |
206 | (:window-iconified (ev) (declare (ignore ev))) | |
207 | (:window-deiconified (ev) (declare (ignore ev))) | |
208 | (:window-opened (ev) (declare (ignore ev))) | |
209 | (:window-closing (ev) | |
210 | (declare (ignore ev)) | |
211 | (send window :dispose)) | |
212 | (:window-closed (ev) | |
213 | (declare (ignore ev)) | |
214 | (drop-reason)))) | |
215 | window)) | |
216 | ||
217 | (defmacro defwindow (name bvl (title) &body body) | |
218 | `(defun ,name ,bvl | |
219 | (make-window ,title (lambda () ,@body)))) | |
220 | ||
221 | ;;;----- That's all, folks -------------------------------------------------- |