Initial revision.

[jlisp] / dep-ui.lisp

;;; -*-lisp-*-
;;;
;;; Dependency-based user interfaces
;;;
;;; (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 #: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
	   #:install-dep-syntax #:add-reason #:drop-reason))

(in-package #:dep-ui)

;;;--------------------------------------------------------------------------

(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)))

(defun update-text-field-dep (field dep convert-func)
  (let ((text (send field :get-text)))
    (multiple-value-bind (value bogusp) (funcall convert-func text)
      (cond (bogusp
	     (send field :set-background bad-text-colour)
	     (dep-make-bad dep))
	    (t
	     (unless (dep-goodp dep)
	       (send field :set-background good-text-colour))
	     (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))

(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 ""))))

(defun safe-read-from-string (string continuation)
  (with-input-from-string (stream string)
    (ignore-errors
      (let ((value (let ((*read-eval* nil)) (read stream))))
	(if (peek-char t stream nil)
	    (values nil :junk)
	    (funcall continuation value))))))

(defun read-real-from-string (string)
  (safe-read-from-string 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-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)
  (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))

(defmacro within-group ((label) &body body)
  `(let ((*panel* (make-group ,label)))
     ,@body))

(defun install-dep-syntax (&optional (readtable *readtable*))
  (set-macro-character #\?
		       (lambda (stream char)
			 (declare (ignore char))
			 (list 'dep-value (read stream t nil t)))
		       readtable)
  (set-syntax-from-char #\] #\) readtable readtable)
  (set-dispatch-macro-character #\# #\[
				(lambda (stream arg char)
				  (declare (ignore arg char))
				  `(make-dep (lambda ()
					       ,@(read-delimited-list #\]
								      stream
								      t))))
				readtable))

(let ((reasons 0))
  (defun add-reason ()
    (incf reasons))
  (defun drop-reason ()
    (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))

(defmacro defwindow (name bvl (title) &body body)
  `(defun ,name ,bvl
     (make-window ,title (lambda () ,@body))))

;;;----- That's all, folks --------------------------------------------------