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 (in-package #:dep-ui)
  25
  26 ;;;--------------------------------------------------------------------------
  27 ;;; Generic interface.
  28
  29 (defvar *live-deps*)
  30
  31 (defun update-text-field-dep (field dep convert-func)
  32   (let ((text (field-text field)))
  33     (multiple-value-bind (value bogusp) (funcall convert-func text)
  34       (cond (bogusp
  35              (set-field-highlight field :bad)
  36              (dep-make-bad dep))
  37             (t
  38              (unless (dep-goodp dep)
  39                (set-field-highlight field :good))
  40              (setf (dep-value dep) value))))))
  41
  42 (defun make-text-field-with-dep (convert-func dep)
  43   (make-text-field
  44    :notify (lambda (field)
  45              (update-text-field-dep field dep convert-func))))
  46
  47 (defun update-dep-text-field (field dep convert-func)
  48   (multiple-value-bind (highlight value)
  49       (if (dep-goodp dep)
  50           (values :good (dep-value dep))
  51           (values :bad ""))
  52     (set-field-highlight field highlight)
  53     (setf (field-text field) (funcall convert-func value))))
  54
  55 (defun make-dependent-text-field
  56     (dep &optional (convert-func #'princ-to-string))
  57   (let ((field (make-text-field :readonly t)))
  58     (flet ((kicked (&optional ev)
  59              (declare (ignore ev))
  60              (update-dep-text-field field dep convert-func)))
  61       (dep-add-listener dep #'kicked)
  62       (kicked))
  63     field))
  64
  65 (defun safe-read-from-string (string continuation)
  66   (with-input-from-string (stream string)
  67     (ignore-errors
  68       (let ((value (let ((*read-eval* nil)) (read stream))))
  69         (if (peek-char t stream nil)
  70             (values nil :junk)
  71             (funcall continuation value))))))
  72
  73 (defun read-real-from-string (string)
  74   (safe-read-from-string string
  75                          (lambda (value)
  76                            (values value (not (realp value))))))
  77
  78 (defun make-input (label dep &key (convert #'read-real-from-string))
  79   (let ((text (make-text-field-with-dep convert dep)))
  80     (pack-labelled-widget *panel* label text)))
  81
  82 (defun make-output (label dep &key (convert "~,3F"))
  83   (let ((text (make-dependent-text-field dep
  84                                          (etypecase convert
  85                                            (string
  86                                             (lambda (value)
  87                                               (format nil convert value)))
  88                                            ((or symbol function)
  89                                             convert)))))
  90     (pack-labelled-widget *panel* label text)))
  91
  92 (defun make-radio-dep (dep plist)
  93   (let ((group (make-radio-group
  94                 (lambda (value) (setf (dep-value dep) value))
  95                 plist
  96                 :default (if (dep-goodp dep)
  97                              (dep-value dep)
  98                              (setf (dep-value dep) (cadr plist))))))
  99     (pack-single-widget *panel* group)))
 100
 101
 102 (defmacro within-group ((label) &body body)
 103   `(let ((*panel* (pack-single-widget *panel* (make-group ,label))))
 104      ,@body))
 105
 106 (let ((reasons 0))
 107   (defun add-reason ()
 108     (incf reasons))
 109   (defun drop-reason ()
 110     (assert (plusp reasons))
 111     (decf reasons)
 112     (when (zerop reasons)
 113       (exit))))
 114
 115 (defmacro defwindow (name bvl (title) &body body)
 116   `(defun ,name ,bvl
 117      (make-toplevel ,title (lambda () ,@body))))
 118
 119 ;;;----- That's all, folks --------------------------------------------------