;;;;
;;;; graphics.lsp XLISP-STAT custom dialog objects and functions
;;;; XLISP-STAT 2.1 Copyright (c) 1990, by Luke Tierney
;;;; Additions to Xlisp 2.1, Copyright (c) 1989 by David Michael Betz
;;;; You may give out copies of this software; for conditions see the file
;;;; COPYING included with this distribution.
;;;;
(in-package "XLISP")
(provide "dialogs")
(export '(num-to-string ok-or-cancel-dialog-proto ok-or-cancel-dialog
message-dialog-proto message-dialog
get-string-dialog-proto get-string-dialog get-value-dialog
choose-item-dialog-proto choose-item-dialog
choose-subset-dialog-proto choose-subset-dialog
sequence-scroll-item-proto sequence-slider-dialog-proto
sequence-slider-dialog
interval-scroll-item-proto interval-slider-dialog-proto
interval-slider-dialog))
(defun num-to-string (n) (prin1-to-string n))
;;;;
;;;;
;;;; OK-or-Cancel Dialog Prototype
;;;;
;;;;
(defproto ok-or-cancel-dialog-proto
'(ok-button cancel-button) () modal-dialog-proto)
(defmeth ok-or-cancel-dialog-proto :isnew (items &rest args
&key (ok-default t)
(ok-action #'(lambda () t))
(cancel-action
#'(lambda () nil)))
(let ((items (if (consp items) items (list items)))
(ok-button (send modal-button-proto :new "OK"
:action ok-action))
(cancel-button (send modal-button-proto :new "Cancel"
:action cancel-action)))
(setf items (mapcar #'(lambda (x)
(if (stringp x)
(send text-item-proto :new x)
x))
items))
(setf (slot-value 'ok-button) ok-button)
(setf (slot-value 'cancel-button) cancel-button)
(apply #'call-next-method
(append items (list (list ok-button cancel-button)))
args)
(send self :default-button (if ok-default ok-button cancel-button))))
(defun ok-or-cancel-dialog (s &optional (ok-default t) &rest args)
"Args: (s &optional (ok-default t) &rest args)
Open modal dialog with string S and OK, Cancel buttons. Returns T for
OK, NIL for Cancel. S can contain format directives, which are filled
from the remaining arguments."
(let ((d (send ok-or-cancel-dialog-proto :new
(apply #'format nil s args) :ok-default ok-default)))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Message Dialog Prototype
;;;;
;;;;
(defproto message-dialog-proto '() () modal-dialog-proto)
(defmeth message-dialog-proto :isnew (s)
(let ((text (if (consp s) s (list s)))
(ok-button (send modal-button-proto :new "OK")))
(call-next-method (append text (list ok-button)))
(send self :default-button ok-button)))
(defun message-dialog (&rest args)
"Args: (s &rest args)
Open modal dialog with string S and OK buttons. Returns NIL. S can contain
format directives, which are filled from the remaining arguments."
(let ((d (send message-dialog-proto :new (apply #'format nil args))))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Get String/Value Dialog Prototype
;;;;
;;;;
(defproto get-string-dialog-proto () () ok-or-cancel-dialog-proto)
(defmeth get-string-dialog-proto :isnew (s &rest args &key (initial nil has-init))
(let* ((prompt-item (send text-item-proto :new s))
(edit-item (send edit-text-item-proto :new
(if has-init (format nil "~a" initial) "")
:text-length 20)))
(apply #'call-next-method
(list prompt-item edit-item)
:ok-action #'(lambda () (send edit-item :text))
args)))
(defun get-string-dialog (&rest args)
"Args: (s &key initial)
Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
INITIAL is converted to a string with ~A format directive. Returns string
of text field content on OK, NIL on cancel."
(let ((d (apply #'send get-string-dialog-proto :new args)))
(send d :modal-dialog)))
(defun get-value-dialog (prompt &rest args &key (initial "" supplied))
"Args: (s &key initial)
Opens a modal dialog with prompt S, a text field and OK, Cancel buttons.
INITIAL is converted to a string with ~S format directive. On Cancel returns
NIL. ON OK Returns list of result of reading and eval'ing the text field's
content."
(let* ((initial (if supplied
(format nil "~s" initial)
initial))
(s (apply #'get-string-dialog prompt :initial initial args)))
(if s (list (eval (read (make-string-input-stream s) nil))))))
;;;;
;;;;
;;;; Choose string/value dialog prototype
;;;;
;;;;
(defproto choose-item-dialog-proto () () ok-or-cancel-dialog-proto)
(defmeth choose-item-dialog-proto :isnew (s strings &rest args
&key (initial 0))
(let* ((prompt-item (send text-item-proto :new s))
(string-item (send choice-item-proto :new strings :value initial)))
(apply #'call-next-method (list prompt-item string-item)
:ok-action #'(lambda () (send string-item :value))
args)))
(defun choose-item-dialog (&rest args)
"Args: (s strings &key initial)
Opens modal dialog with prompt S, a choice item for list of strings STRINGS
and OK, Cancel buttons. Returns chosen string on OK, NIL on cancel."
(let ((d (apply #'send choose-item-dialog-proto :new args)))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Choose string/value dialog prototype
;;;;
;;;;
(defproto choose-subset-dialog-proto () () ok-or-cancel-dialog-proto)
(defmeth choose-subset-dialog-proto :isnew (s strings &rest args
&key (initial nil))
(let ((prompt-item (send text-item-proto :new s))
(subset-items (mapcar #'(lambda (x y)
(send toggle-item-proto
:new x :value (member y initial)))
strings (iseq 0 (- (length strings) 1)))))
(apply #'call-next-method (cons prompt-item subset-items)
:ok-action #'(lambda ()
(list (which (mapcar #'(lambda (x) (send x :value))
subset-items))))
args)))
(defun choose-subset-dialog (&rest args)
"Args: (s strings &key initial)
Opens modal dialog with prompt S, a set of toggle items for list of
strings STRINGS, and OK, Cancel buttons. Returns list of list of indices
of chosen items on OK, NIL on cancel."
(let ((d (apply #'send choose-subset-dialog-proto :new args)))
(send d :modal-dialog)))
;;;;
;;;;
;;;; Sequence Scroll Bar Item Prototype
;;;;
;;;;
(defproto sequence-scroll-item-proto
'(sequence display-sequence value-text-item) () scroll-item-proto)
(defmeth sequence-scroll-item-proto :isnew
(x &key text-item (size '(180 16)) location action display)
(let* ((sequence (coerce x 'vector))
(display (if display (coerce display 'vector) sequence)))
(setf (slot-value 'sequence) sequence)
(setf (slot-value 'display-sequence) display)
(setf (slot-value 'value-text-item) text-item)
(call-next-method :size size
:location location
:min-value 0 :max-value (1- (length sequence))
:page-increment 5
:action action)))
(defmeth sequence-scroll-item-proto :scroll-action ()
(send self :display-value)
(send self :user-action))
(defmeth sequence-scroll-item-proto :do-action ()
(send self :display-value)
(send self :user-action))
(defmeth sequence-scroll-item-proto :value (&optional (val nil set))
(when set (call-next-method val) (send self :display-value))
(call-next-method))
(defmeth sequence-scroll-item-proto :display-value ()
(if (slot-value 'value-text-item)
(send (slot-value 'value-text-item) :text
(format nil "~s"
(elt (slot-value 'display-sequence)
(send self :value))))))
(defmeth sequence-scroll-item-proto :user-action ()
(if (slot-value 'action)
(funcall (slot-value 'action)
(elt (slot-value 'sequence) (send self :value)))))
;;;;
;;;;
;;;; Sequence Slider Dialog Prototype
;;;;
;;;;
(defproto sequence-slider-dialog-proto () () dialog-proto)
(defmeth sequence-slider-dialog-proto :isnew
(data &key (text "Value") (title "Slider") action display)
(let* ((name-item (send text-item-proto :new text))
(value-item (send text-item-proto :new " "
:location '(100 5)))
(scroll-item (send sequence-scroll-item-proto :new data
:text-item value-item
:action action :display display)))
(call-next-method (list name-item value-item scroll-item) :title title)
(send scroll-item :display-value)))
(defmeth sequence-slider-dialog-proto :value (&rest args)
(apply #'send (nth 2 (slot-value 'items)) :value args))
(defun sequence-slider-dialog (&rest args)
"Args: (data &key (text \"Value\") (title \"Slider\") action display)
Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
scrollbar. The scrollbar scrolls through the DATA sequence and displays the
corresponding element of the DISPLAY sequence. When a scroll event occurs
ACTION is called with the current value of DATA as argument."
(apply #'send sequence-slider-dialog-proto :new args))
;;;;
;;;;
;;;; Interval Scroll Bar Item Prototype
;;;;
;;;;
(defproto interval-scroll-item-proto
'(interval num-points value-text-item) () scroll-item-proto)
(defmeth interval-scroll-item-proto :isnew
(x &key text-item (size '(180 16)) location action
(points (nth 2 (get-nice-range (nth 0 x) (nth 1 x) 50))))
(setf (slot-value 'interval) x)
(setf (slot-value 'num-points) points)
(setf (slot-value 'value-text-item) text-item)
(call-next-method :size size :location location :min-value 0
:max-value (1- points)
:action action))
(defmeth interval-scroll-item-proto :value (&optional (val nil set))
(let ((interval (slot-value 'interval))
(num-points (slot-value 'num-points)))
(if set
(let* ((min (elt interval 0))
(max (elt interval 1))
(val (floor (* (1- num-points) (/ (- val min) (- max min))))))
(call-next-method val)
(send self :display-value)
(send self :user-action)))
(let ((min (elt interval 0))
(max (elt interval 1)))
(+ min (* (/ (call-next-method) (1- num-points)) (- max min))))))
(defmeth interval-scroll-item-proto :max (&optional (max nil set))
(let ((value (send self :value)))
(when set (setf (elt interval 1) max) (send self :value value))
(elt interval 1)))
(defmeth interval-scroll-item-proto :min (&optional (min nil set))
(let ((value (send self :value)))
(when set (setf (elt interval 0) min) (send self :value value))
(elt interval 0)))
(defmeth interval-scroll-item-proto :user-action ()
(if (slot-value 'action)
(funcall (slot-value 'action) (send self :value))))
(defmeth interval-scroll-item-proto :display-value ()
(if (slot-value 'value-text-item)
(send (slot-value 'value-text-item)
:text (num-to-string (send self :value)))))
(defmeth interval-scroll-item-proto :scroll-action ()
(send self :display-value)
(send self :user-action))
(defmeth interval-scroll-item-proto :do-action ()
(send self :display-value)
(send self :user-action))
;;;;
;;;;
;;;; Interval Slider Dialog Prototype
;;;;
;;;;
(defproto interval-slider-dialog-proto () () dialog-proto)
(defmeth interval-slider-dialog-proto :isnew
(data &key (text "Value") (title "Slider") action (points 30) (nice t))
(if nice
(let ((range (get-nice-range (nth 0 data) (nth 1 data) points)))
(setq data (list (nth 0 range) (nth 1 range)))
(setq points (nth 2 range))))
(let* ((value-item (send text-item-proto :new " "
:location '(100 5)))
(name-item (send text-item-proto :new text))
(scroll-item (send interval-scroll-item-proto :new data
:text-item value-item
:action action :points points)))
(call-next-method (list name-item value-item scroll-item) :title title)
(send scroll-item :display-value)))
(defmeth interval-slider-dialog-proto :value (&rest args)
(apply #'send (nth 2 (slot-value 'items)) :value args))
(defun interval-slider-dialog (&rest args)
"Args: (data &key (text \"Value\") (title \"Slider\") action (points 30) (nice t))
Opens modeless dialog with title TITLE, prompt TEXT, a text display and a
scrollbar. The scrollbar scrolls through the interval DATA, a list of the form
(LOW HIGH), sequence and displays the value. When a scroll event occurs
ACTION is called with the current value in the interval as argument. If NICE
is not NIL DATA and POINTS are revised to produce a nice set of values."
(apply #'send interval-slider-dialog-proto :new args))
syntax highlighted by Code2HTML, v. 0.9.1