chiark - git - mdw - jlisp/blob - dep-ui.lisp

   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
  28            #:add-reason #:drop-reason))
  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
 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 --------------------------------------------------