X-Git-Url: https://git.distorted.org.uk/~mdw/jlisp/blobdiff_plain/a2e7266a20fff562054c0f546e4a49c03b93ce20..fc7489de87bbf0cfadf10f6f441c049d7b2bece1:/dep-ui.lisp

diff --git a/dep-ui.lisp b/dep-ui.lisp
index d6e483c..6641ce7 100644
--- a/dep-ui.lisp
+++ b/dep-ui.lisp
@@ -21,54 +21,46 @@
 ;;; 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)
@@ -83,101 +75,32 @@
 			 (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))
@@ -187,35 +110,10 @@
     (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 --------------------------------------------------