Work in progress.

[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.

(in-package #:dep-ui)

;;;--------------------------------------------------------------------------
;;; Generic interface.

(defvar *live-deps*)

(defun update-text-field-dep (field dep convert-func)
  (let ((text (field-text field)))
    (multiple-value-bind (value bogusp) (funcall convert-func text)
      (cond (bogusp
	     (set-field-highlight field :bad)
	     (dep-make-bad dep))
	    (t
	     (unless (dep-goodp dep)
	       (set-field-highlight field :good))
	     (setf (dep-value dep) value))))))

(defun make-text-field-with-dep (convert-func dep)
  (make-text-field
   :notify (lambda (field)
	     (update-text-field-dep field dep convert-func))))

(defun update-dep-text-field (field dep convert-func)
  (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)
    (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-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-output (label dep &key (convert "~,3F"))
  (let ((text (make-dependent-text-field dep
					 (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* (pack-single-widget *panel* (make-group ,label))))
     ,@body))

(let ((reasons 0))
  (defun add-reason ()
    (incf reasons))
  (defun drop-reason ()
    (assert (plusp reasons))
    (decf reasons)
    (when (zerop reasons)
      (exit))))

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

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