src/lsp/dialogs.lsp

   1 ;;;;
   2 ;;;; graphics.lsp XLISP-STAT custom dialog objects and functions
   3 ;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
   4 ;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
   5 ;;;; You may give out copies of this software; for conditions see the file
   6 ;;;; COPYING included with this distribution.
   7 ;;;;
   8
   9 (in-package "XLISP")
  10 (provide "dialogs")
  11 (export '(num-to-string ok-or-cancel-dialog-proto ok-or-cancel-dialog
  12           message-dialog-proto message-dialog
  13           get-string-dialog-proto get-string-dialog get-value-dialog
  14           choose-item-dialog-proto choose-item-dialog
  15           choose-subset-dialog-proto choose-subset-dialog
  16           sequence-scroll-item-proto sequence-slider-dialog-proto
  17                   sequence-slider-dialog
  18           interval-scroll-item-proto interval-slider-dialog-proto
  19                   interval-slider-dialog))
  20
  21 (defun num-to-string (n) (prin1-to-string n))
  22
  23 ;;;;
  24 ;;;;
  25 ;;;; OK-or-Cancel Dialog Prototype
  26 ;;;;
  27 ;;;;
  28
  29 (defproto ok-or-cancel-dialog-proto
  30   '(ok-button cancel-button) () modal-dialog-proto)
  31
  32 (defmeth ok-or-cancel-dialog-proto :isnew (items &rest args
  33                                                  &key (ok-default t)
  34                                                  (ok-action #'(lambda () t))
  35                                                  (cancel-action
  36                                                   #'(lambda () nil)))
  37   (let ((items (if (consp items) items (list items)))
  38         (ok-button (send modal-button-proto :new "OK"
  39                          :action ok-action))
  40         (cancel-button (send modal-button-proto :new "Cancel"
  41                              :action cancel-action)))
  42     (setf items (mapcar #'(lambda (x)
  43                                   (if (stringp x)
  44                                       (send text-item-proto :new x)
  45                                       x))
  46                         items))
  47     (setf (slot-value 'ok-button) ok-button)
  48     (setf (slot-value 'cancel-button) cancel-button)
  49     (apply #'call-next-method
  50            (append items (list (list ok-button cancel-button)))
  51            args)
  52     (send self :default-button (if ok-default ok-button cancel-button))))
  53
  54 (defun ok-or-cancel-dialog (s &optional (ok-default t) &rest args)
  55 "Args: (s &optional (ok-default t) &rest args)
  56 Open modal dialog with string S and OK, Cancel buttons. Returns T for
  57 OK, NIL for Cancel. S can contain format directives, which are filled
  58 from the remaining arguments."
  59   (let ((d (send ok-or-cancel-dialog-proto :new
  60                  (apply #'format nil s args) :ok-default ok-default)))
  61     (send d :modal-dialog)))
  62
  63 ;;;;
  64 ;;;;
  65 ;;;; Message Dialog Prototype
  66 ;;;;
  67 ;;;;
  68
  69 (defproto message-dialog-proto '() () modal-dialog-proto)
  70
  71 (defmeth message-dialog-proto :isnew (s)
  72   (let ((text (if (consp s) s (list s)))
  73         (ok-button (send modal-button-proto :new "OK")))
  74     (call-next-method (append text (list ok-button)))
  75     (send self :default-button ok-button)))
  76
  77 (defun message-dialog (&rest args)
  78 "Args: (s &rest args)
  79 Open modal dialog with string S and OK buttons. Returns NIL. S can contain
  80 format directives, which are filled from the remaining arguments."
  81   (let ((d (send message-dialog-proto :new (apply #'format nil args))))
  82      (send d :modal-dialog)))
  83
  84 ;;;;
  85 ;;;;
  86 ;;;; Get String/Value Dialog Prototype
  87 ;;;;
  88 ;;;;
  89
  90 (defproto get-string-dialog-proto () () ok-or-cancel-dialog-proto)
  91
  92 (defmeth get-string-dialog-proto :isnew (s &rest args &key (initial nil has-init))
  93   (let* ((prompt-item (send text-item-proto :new s))
  94          (edit-item (send edit-text-item-proto :new
  95                           (if has-init (format nil "~a" initial) "")
  96                           :text-length 20)))
  97     (apply #'call-next-method
  98            (list prompt-item edit-item)
  99            :ok-action #'(lambda () (send edit-item :text))
 100            args)))
 101
 102 (defun get-string-dialog (&rest args)
 103 "Args: (s &key initial)
 104 Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
 105 INITIAL is converted to a string with ~A format directive. Returns string
 106 of text field content on OK, NIL on cancel."
 107   (let ((d (apply #'send get-string-dialog-proto :new args)))
 108     (send d :modal-dialog)))
 109
 110 (defun get-value-dialog (prompt &rest args &key (initial "" supplied))
 111 "Args: (s &key initial)
 112 Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
 113 INITIAL is converted to a string with ~S format directive. On Cancel returns
 114 NIL. ON OK Returns list of result of reading and eval'ing the text field's
 115 content."
 116   (let* ((initial (if supplied
 117                       (format nil "~s" initial)
 118                       initial))
 119          (s (apply #'get-string-dialog prompt :initial initial args)))
 120     (if s (list (eval (read (make-string-input-stream s) nil))))))
 121
 122 ;;;;
 123 ;;;;
 124 ;;;; Choose string/value dialog prototype
 125 ;;;;
 126 ;;;;
 127
 128 (defproto choose-item-dialog-proto () () ok-or-cancel-dialog-proto)
 129
 130 (defmeth choose-item-dialog-proto :isnew (s strings &rest args
 131                                             &key (initial 0))
 132   (let* ((prompt-item (send text-item-proto :new s))
 133          (string-item (send choice-item-proto :new strings :value initial)))
 134     (apply #'call-next-method (list prompt-item string-item)
 135            :ok-action #'(lambda () (send string-item :value))
 136            args)))
 137
 138 (defun choose-item-dialog (&rest args)
 139 "Args: (s strings &key initial)
 140 Opens modal dialog with prompt S, a choice item for list of strings STRINGS
 141 and OK, Cancel buttons. Returns chosen string on OK, NIL on cancel."
 142   (let ((d (apply #'send choose-item-dialog-proto :new args)))
 143     (send d :modal-dialog)))
 144
 145 ;;;;
 146 ;;;;
 147 ;;;; Choose string/value dialog prototype
 148 ;;;;
 149 ;;;;
 150
 151 (defproto choose-subset-dialog-proto () () ok-or-cancel-dialog-proto)
 152
 153 (defmeth choose-subset-dialog-proto :isnew (s strings &rest args
 154                                               &key (initial nil))
 155   (let ((prompt-item (send text-item-proto :new s))
 156         (subset-items (mapcar #'(lambda (x y)
 157                                   (send toggle-item-proto
 158                                         :new x :value (member y initial)))
 159                               strings (iseq 0 (- (length strings) 1)))))
 160     (apply #'call-next-method (cons prompt-item subset-items)
 161            :ok-action #'(lambda ()
 162                           (list (which (mapcar #'(lambda (x) (send x :value))
 163                                                subset-items))))
 164            args)))
 165
 166 (defun choose-subset-dialog (&rest args)
 167 "Args: (s strings &key initial)
 168 Opens modal dialog with prompt S, a set of toggle items for list of
 169 strings STRINGS, and OK, Cancel buttons. Returns list of list of indices
 170 of chosen items on OK, NIL on cancel."
 171   (let ((d (apply #'send choose-subset-dialog-proto :new args)))
 172     (send d :modal-dialog)))
 173
 174 ;;;;
 175 ;;;;
 176 ;;;; Sequence Scroll Bar Item Prototype
 177 ;;;;
 178 ;;;;
 179
 180 (defproto sequence-scroll-item-proto
 181   '(sequence display-sequence value-text-item) () scroll-item-proto)
 182
 183 (defmeth sequence-scroll-item-proto :isnew
 184   (x &key text-item (size '(180 16)) location action display)
 185   (let* ((sequence (coerce x 'vector))
 186          (display (if display (coerce display 'vector) sequence)))
 187     (setf (slot-value 'sequence) sequence)
 188     (setf (slot-value 'display-sequence) display)
 189     (setf (slot-value 'value-text-item) text-item)
 190     (call-next-method :size size
 191                       :location location
 192                       :min-value 0 :max-value (1- (length sequence))
 193                       :page-increment 5
 194                       :action action)))
 195
 196 (defmeth sequence-scroll-item-proto :scroll-action ()
 197   (send self :display-value)
 198   (send self :user-action))
 199
 200 (defmeth sequence-scroll-item-proto :do-action ()
 201   (send self :display-value)
 202   (send self :user-action))
 203
 204 (defmeth sequence-scroll-item-proto :value (&optional (val nil set))
 205   (when set (call-next-method val) (send self :display-value))
 206   (call-next-method))
 207
 208 (defmeth sequence-scroll-item-proto :display-value ()
 209   (if (slot-value 'value-text-item)
 210       (send (slot-value 'value-text-item) :text
 211             (format nil "~s"
 212                     (elt (slot-value 'display-sequence)
 213                          (send self :value))))))
 214
 215 (defmeth sequence-scroll-item-proto :user-action ()
 216   (if (slot-value 'action)
 217       (funcall (slot-value 'action)
 218                (elt (slot-value 'sequence) (send self :value)))))
 219
 220 ;;;;
 221 ;;;;
 222 ;;;; Sequence Slider Dialog Prototype
 223 ;;;;
 224 ;;;;
 225
 226 (defproto sequence-slider-dialog-proto () () dialog-proto)
 227
 228 (defmeth sequence-slider-dialog-proto :isnew
 229   (data &key (text "Value") (title "Slider") action display)
 230   (let* ((name-item (send text-item-proto :new text))
 231          (value-item (send text-item-proto :new "          "
 232                            :location '(100 5)))
 233          (scroll-item (send sequence-scroll-item-proto :new data
 234                             :text-item value-item
 235                             :action action :display display)))
 236     (call-next-method (list name-item value-item scroll-item) :title title)
 237     (send scroll-item :display-value)))
 238
 239 (defmeth sequence-slider-dialog-proto :value (&rest args)
 240   (apply #'send (nth 2 (slot-value 'items)) :value args))
 241
 242 (defun sequence-slider-dialog (&rest args)
 243 "Args: (data &key (text \"Value\") (title \"Slider\") action display)
 244 Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
 245 scrollbar. The scrollbar scrolls through the DATA sequence and displays the
 246 corresponding element of the DISPLAY sequence. When a scroll event occurs
 247 ACTION is called with the current value of DATA as argument."
 248   (apply #'send sequence-slider-dialog-proto :new args))
 249
 250
 251 ;;;;
 252 ;;;;
 253 ;;;; Interval Scroll Bar Item Prototype
 254 ;;;;
 255 ;;;;
 256
 257 (defproto interval-scroll-item-proto
 258   '(interval num-points value-text-item) () scroll-item-proto)
 259
 260 (defmeth interval-scroll-item-proto :isnew
 261   (x &key text-item (size '(180 16)) location action
 262           (points (nth 2 (get-nice-range (nth 0 x) (nth 1 x) 50))))
 263   (setf (slot-value 'interval) x)
 264   (setf (slot-value 'num-points) points)
 265   (setf (slot-value 'value-text-item) text-item)
 266   (call-next-method :size size :location location :min-value 0
 267                     :max-value (1- points)
 268                     :action action))
 269
 270 (defmeth interval-scroll-item-proto :value (&optional (val nil set))
 271   (let ((interval (slot-value 'interval))
 272         (num-points (slot-value 'num-points)))
 273     (if set
 274         (let* ((min (elt interval 0))
 275                (max (elt interval 1))
 276                (val (floor (* (1- num-points) (/ (- val min) (- max min))))))
 277           (call-next-method val)
 278           (send self :display-value)
 279           (send self :user-action)))
 280     (let ((min (elt interval 0))
 281           (max (elt interval 1)))
 282       (+ min (* (/ (call-next-method) (1- num-points)) (- max min))))))
 283
 284 (defmeth interval-scroll-item-proto :max (&optional (max nil set))
 285   (let ((value (send self :value)))
 286     (when set (setf (elt interval 1) max) (send self :value value))
 287     (elt interval 1)))
 288
 289 (defmeth interval-scroll-item-proto :min (&optional (min nil set))
 290   (let ((value (send self :value)))
 291     (when set (setf (elt interval 0) min) (send self :value value))
 292     (elt interval 0)))
 293
 294 (defmeth interval-scroll-item-proto :user-action ()
 295   (if (slot-value 'action)
 296       (funcall (slot-value 'action) (send self :value))))
 297
 298 (defmeth interval-scroll-item-proto :display-value ()
 299   (if (slot-value 'value-text-item)
 300       (send (slot-value 'value-text-item)
 301             :text (num-to-string (send self :value)))))
 302
 303 (defmeth interval-scroll-item-proto :scroll-action ()
 304   (send self :display-value)
 305   (send self :user-action))
 306
 307 (defmeth interval-scroll-item-proto :do-action ()
 308   (send self :display-value)
 309   (send self :user-action))
 310
 311 ;;;;
 312 ;;;;
 313 ;;;; Interval Slider Dialog Prototype
 314 ;;;;
 315 ;;;;
 316
 317 (defproto interval-slider-dialog-proto () () dialog-proto)
 318
 319 (defmeth interval-slider-dialog-proto :isnew
 320   (data &key (text "Value") (title "Slider") action (points 30) (nice t))
 321   (if nice
 322       (let ((range (get-nice-range (nth 0 data) (nth 1 data) points)))
 323         (setq data (list (nth 0 range) (nth 1 range)))
 324         (setq points (nth 2 range))))
 325   (let* ((value-item (send text-item-proto :new "              "
 326                            :location '(100 5)))
 327          (name-item (send text-item-proto :new text))
 328          (scroll-item (send interval-scroll-item-proto :new data
 329                             :text-item value-item
 330                             :action action :points points)))
 331     (call-next-method (list name-item value-item scroll-item) :title title)
 332     (send scroll-item :display-value)))
 333
 334 (defmeth interval-slider-dialog-proto :value (&rest args)
 335   (apply #'send (nth 2 (slot-value 'items)) :value args))
 336
 337 (defun interval-slider-dialog (&rest args)
 338 "Args: (data &key (text \"Value\") (title \"Slider\") action (points 30) (nice t))
 339 Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
 340 scrollbar. The scrollbar scrolls through the interval DATA, a list of the form
 341 (LOW HIGH), sequence and displays the value. When a scroll event occurs
 342 ACTION is called with the current value in the interval as argument. If NICE
 343 is not NIL DATA and POINTS are revised to produce a nice set of values."
 344   (apply #'send interval-slider-dialog-proto :new args))
 345