CLIM mail archive
[Prev][Next][Index][Thread]
MULTIPLE-MENU-CHOOSE
Date: Mon, 7 Sep 1992 19:39 EDT
From: "John C. Mallery" <jcma@reagan.ai.mit.edu>
How come CLIM does not provide a facility analogous to tv:MULTIPLE-MENU-CHOOSE
on the Lisp Machine? This addresses a common choice situation and everyone
will just have to write their own anyway.
Try these for CLIM 1.1. I'll probably install some form of this stuff
in CLIM 2.0.
Could somebody at BBN please install this in the "CLIM library" as
multiple-menus.lisp? Thanks.
-------- cut here --------
;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: CLIM; Base: 10; Lowercase: Yes -*-
"Copyright (c) 1991, 1992 Symbolics, Inc. All rights reserved."
(in-package "CLIM")
(export '(clim::menu-multiple-choose)
'clim)
(define-presentation-type menu-multiple-choose-selection ())
(define-presentation-type menu-multiple-choose-button ())
;; Menu interface for choosing a (possibly empty) subset of items.
;; ITEMS is as for MENU-CHOOSE.
(defun menu-multiple-choose (items
&key (associated-window
(frame-top-level-window *application-frame*))
default-style label (printer #'print-menu-item)
max-width max-height n-rows n-columns
inter-column-spacing inter-row-spacing
(cell-align-x ':left) (cell-align-y ':top)
all-button none-button)
(with-menu (stream associated-window)
(setf (window-label stream) label)
(with-end-of-page-action (:allow stream)
(with-end-of-line-action (:allow stream)
(with-text-style (default-style stream)
(let ((selections (map 'list #'(lambda (x) (list x nil)) items))
(selection-pieces ())
;;--- Need this first-piece kludge to work around a redisplay
;;--- bug that causes the first item to be erased whenever
;;--- any other item is redisplayed.
(first-piece nil))
;; Display all the selections, collecting redisplay pieces as we go
(formatting-item-list (stream :max-width max-width :max-height max-height
:n-rows n-rows :n-columns n-columns
:inter-column-spacing inter-column-spacing
:inter-row-spacing inter-row-spacing)
(dolist (selection selections)
(formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
(let ((piece (let ((selection selection))
(updating-output (stream)
(updating-output (stream :unique-id selection
:cache-value (second selection))
(with-output-as-presentation
(:stream stream
:object selection
:type 'menu-multiple-choose-selection)
(if (second selection)
(with-text-face (:bold stream)
(funcall printer (first selection) stream))
(funcall printer (first selection) stream))))))))
(when (null first-piece)
(setq first-piece piece))
(push (list selection piece) selection-pieces))))
(when all-button
(when (eql all-button 't)
(setq all-button "All"))
(formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
(with-output-as-presentation (:stream stream
:object ':all
:type 'menu-multiple-choose-button)
(with-text-face (:italic stream)
(write-string all-button stream)))))
(when none-button
(when (eql none-button 't)
(setq none-button "None"))
(formatting-cell (stream :align-x cell-align-x :align-y cell-align-y)
(with-output-as-presentation (:stream stream
:object ':none
:type 'menu-multiple-choose-button)
(with-text-face (:italic stream)
(write-string none-button stream))))))
;; Display the exit boxes
(let ((exit "<End> uses these values")
(abort "<Abort> aborts"))
(terpri stream)
(updating-output (stream :unique-id stream
:cache-value 'exit-boxes)
(with-output-as-presentation (:stream stream
:type 'accept-values-exit-box
:object ':abort)
(write-string abort stream))
(write-string ", " stream)
(with-output-as-presentation (:stream stream
:type 'accept-values-exit-box
:object ':exit)
(write-string exit stream)))
(terpri stream))
;; Size and expose the multiple-choice menu
(size-menu-appropriately stream)
(multiple-value-bind (x y)
(stream-pointer-position-in-window-coordinates (window-parent stream))
(position-window-near-carefully stream x y))
(window-expose stream)
;; Now read from the menu
(with-input-focus (stream)
(loop
(with-input-context ('(or menu-multiple-choose-selection
menu-multiple-choose-button
accept-values-exit-box)
:override t)
(object)
(read-gesture :stream stream)
(menu-multiple-choose-selection
(setf (second object) (not (second object)))
(let ((piece (second (assoc object selection-pieces))))
(when piece
(redisplay piece stream)
(unless (eql piece first-piece)
(replay first-piece stream)))))
(menu-multiple-choose-button
(ecase object
(:all
(dolist (selection-piece selection-pieces)
(let ((selection (first selection-piece))
(piece (second selection-piece)))
(unless (second selection)
(setf (second selection) t)
(redisplay piece stream)
(unless (eql piece first-piece)
(replay first-piece stream))))))
(:none
(dolist (selection-piece selection-pieces)
(let ((selection (first selection-piece))
(piece (second selection-piece)))
(when (second selection)
(setf (second selection) nil)
(redisplay piece stream)
(unless (eql piece first-piece)
(replay first-piece stream))))))))
(accept-values-exit-box
(ecase object
(:abort
(return-from menu-multiple-choose nil))
(:exit
(return-from menu-multiple-choose
(mapcan #'(lambda (selection)
(and (second selection)
(list (menu-item-value (first selection)))))
selections))))))))))))))
#||
()
(menu-multiple-choose (loop for i below 40 collect (cons (format nil "~R" i) i)))
||#
(export '(clim::multiple-choice-menu-choose)
'clim)
(defclass multiple-choice-check-box ()
((value :accessor check-box-value :initarg :value)
(item :reader check-box-item :initarg :item)c
(choice :reader check-box-choice :initarg :choice)
(presentation :accessor check-box-presentation)
(prompt :accessor check-box-prompt)))
;;--- This should be in CLIM itself, no?
(define-presentation-method presentation-typep (object (type accept-values-exit-box))
(or (eq object :exit)
(eq object :abort)))
(define-presentation-method highlight-presentation ((type multiple-choice-check-box)
record stream state)
(declare (ignore state))
(let* ((check-box (presentation-object record))
(prompt (check-box-prompt check-box)))
(with-bounding-rectangle* (left top right bottom) prompt
(declare (ignore top))
(multiple-value-bind (xoff yoff)
(convert-from-relative-to-absolute-coordinates stream (output-record-parent prompt))
(draw-line-internal stream xoff yoff
left bottom right bottom
+flipping-ink+ +highlighting-line-style+)))))
(defun menu-item-choices (menu-item)
(menu-item-getf menu-item :choices))
;; Menu interface for selecting among a number of possibilities for some items.
;; ITEMS is as for MENU-CHOOSE, with a new :CHOICES option that specifies a list
;; of choices for one item. Each choice is a list of a choice name (a symbol)
;; and its initial value (true or false). If the choice is a symbol instead of
;; a list, the initial value is false.
;; CHOICES is a list of the possible choices, (SYMBOL NAME . IMPLICATIONS).
;; SYMBOL names the choice (used in the item's choices), NAME is a string of its
;; name, and IMPLICATIONS is a list of on-positive, on-negative, off-positive, and
;; off-negative implications for when the choice is selected, each one either a
;; list of (other) keywords or T for all other keywords. IMPLICATIONS defaults
;; to (NIL T NIL NIL).
;; The returned value is a list of (ITEM-VALUE . CHOICE-VALUES), where ITEM-VALUE
;; is a value from ITEMS and CHOICE-VALUES are all of the choices selected for
;; that item.
(defun multiple-choice-menu-choose
(items choices
&key (associated-window
(frame-top-level-window *application-frame*))
default-style label)
(let ((hash-table (make-hash-table :test #'equal)))
(with-menu (stream associated-window)
(labels ((draw-check-box (check-box x y)
(let ((radius 5))
(draw-rectangle* stream x y (+ x 10) (+ y 10) :filled nil)
(draw-circle* stream (+ x radius) (+ y radius) (- radius 3)
:ink (if (check-box-value check-box)
+foreground+
+background+)
:filled t)))
(redraw-check-box (check-box presentation new-value)
(multiple-value-bind (x y)
(bounding-rectangle-position* presentation)
(multiple-value-bind (xoff yoff)
(convert-from-relative-to-absolute-coordinates
stream (output-record-parent presentation))
(translate-positions xoff yoff x y))
(setf (check-box-value check-box) new-value)
(draw-check-box check-box x y))))
(declare (dynamic-extent #'draw-check-box #'redraw-check-box))
(macrolet ((choice-name (choice)
`(if (consp ,choice) (second ,choice) ,choice))
(choice-value (choice)
`(if (consp ,choice) (first ,choice) ,choice))
(choice-implications (choice)
`(if (consp ,choice)
(or (rest (rest ,choice)) '(nil t nil nil))
'(nil t nil nil)))
(check-box (item choice)
`(gethash (cons (menu-item-value ,item) (choice-value ,choice))
hash-table)))
(setf (window-label stream) label)
(with-end-of-page-action (:allow stream)
(with-end-of-line-action (:allow stream)
(with-text-style (default-style stream)
;; Initialize hash table
(dolist (item items)
(dolist (choice choices)
(block no-choice
(let ((value (dolist (ch (menu-item-choices item)
(return-from no-choice))
(if (consp ch)
(and (eq (choice-value choice) (first ch))
(return (second ch)))
(and (eq (choice-value choice) ch)
(return nil))))))
(setf (check-box item choice)
;; Make new instance, and transfer the (maybe)
;; preset value in this location into the button
(make-instance 'multiple-choice-check-box
:value value :item item :choice choice))))))
(formatting-table (stream :equalize-column-widths t)
;; Generate heading
(formatting-row (stream)
(dolist (choice (cons " " choices))
(formatting-cell (stream :align-x :center)
(let ((choice-name (choice-name choice)))
(present choice-name (presentation-type-of choice-name)
:stream stream)))))
(fresh-line)
;; Generate the check boxes for each item
(dolist (item items)
(formatting-row (stream)
(let ((prompt (formatting-cell (stream :align-y :center)
(print-menu-item item stream))))
(dolist (choice choices)
(formatting-cell (stream :align-x :center :align-y :center)
(let ((check-box (check-box item choice)))
(cond (check-box
(setf (check-box-presentation check-box)
(with-output-as-presentation
(:stream stream
:object check-box
:type 'multiple-choice-check-box
:single-box t)
(draw-check-box check-box 0 0)))
(setf (check-box-prompt check-box) prompt))
(t
(write-string " " stream))))))))))
(terpri stream)
;; Generate exit boxes
(let ((exit "<End> uses these values")
(abort "<Abort> aborts"))
(terpri stream)
(with-output-as-presentation (:stream stream
:type 'accept-values-exit-box
:object ':abort)
(write-string abort stream))
(write-string ", " stream)
(with-output-as-presentation (:stream stream
:type 'accept-values-exit-box
:object ':exit)
(write-string exit stream))
(terpri stream)))
;; Size and expose the multiple-choice menu
(size-menu-appropriately stream)
(multiple-value-bind (x y)
(stream-pointer-position-in-window-coordinates (window-parent stream))
(position-window-near-carefully stream x y))
(window-expose stream)
;; Now handle user input
(let ((button-pressed-p nil)
(last-check-box nil)
(highlighted-presentation nil)
(highlighted-type nil))
(flet ((handle-presentation (presentation)
;; Called for side effect (toggle button) and returned
;; value return value is a symbol when exit box clicked,
;; otherwise NIL
(let ((object (presentation-object presentation))
(type (presentation-type presentation)))
(case (presentation-type-name type)
(accept-values-exit-box
(setq last-check-box nil)
object)
(multiple-choice-check-box
;; Don't toggle this button unless we have been
;; somewhere else in the interim
(unless (eql object last-check-box)
(let ((new-value (not (check-box-value object)))
(implications
(choice-implications (check-box-choice object))))
(redraw-check-box object presentation new-value)
;; Process the implications
(let ((on (if new-value
(nth 0 implications)
(nth 2 implications)))
(off (if new-value
(nth 1 implications)
(nth 3 implications))))
(dolist (choice choices)
(unless (eql choice (check-box-choice object))
(let ((other-box
(check-box (check-box-item object) choice)))
(when other-box
(when (or (eql on 't) (member choice on))
(redraw-check-box
other-box
(check-box-presentation other-box)
t))
(when (or (eql off 't) (member choice off))
(redraw-check-box
other-box
(check-box-presentation other-box)
nil)))))))))
(setq last-check-box object)
nil))))
(handle-exit ()
(let ((results nil))
(dolist (item items)
(let ((result nil))
(dolist (choice choices)
(let* ((check-box (check-box item choice))
(value (and check-box
(check-box-value check-box))))
(when (and check-box value)
(push (choice-value choice) result))))
(push (cons (menu-item-value item) (nreverse result))
results)))
(return-from multiple-choice-menu-choose
(nreverse results)))))
(declare (dynamic-extent #'handle-presentation #'handle-exit))
(macrolet ((highlight (presentation)
`(progn
(setq highlighted-presentation ,presentation
highlighted-type (presentation-type ,presentation))
(highlight-presentation
highlighted-presentation highlighted-type
stream :highlight)))
(unhighlight ()
`(when highlighted-presentation
(highlight-presentation
highlighted-presentation highlighted-type
stream :unhighlight)
(setq highlighted-presentation nil))))
(with-output-recording-options (stream :record-p nil)
(tracking-pointer (stream :context-type '(or multiple-choice-check-box
accept-values-exit-box)
:multiple-window nil
:highlight nil)
(:pointer-motion ()
(unhighlight)
(setq last-check-box nil))
(:presentation-button-press (presentation)
(setq button-pressed-p t)
(let ((exit (handle-presentation presentation)))
(case exit
(:exit
(handle-exit))
(:abort
(return-from multiple-choice-menu-choose
nil)))))
(:pointer-button-release ()
(setq button-pressed-p nil)
(setq last-check-box nil))
(:presentation (presentation)
(unless (eql presentation highlighted-presentation)
(unhighlight)
(highlight presentation))
(when button-pressed-p
;; Don't handle the exit boxes unless the user
;; clicks on one of them explicitly
(handle-presentation presentation)))
(:keyboard (character)
(when (member character '(#+Genera #\End))
(handle-exit)))))))))))))))
#||
()
(multiple-choice-menu-choose
'(("Buffer1" :value buffer1 :choices ((:save t) :kill :not-modified :hardcopy))
("Buffer2" :value buffer2 :choices ((:save t) :kill :not-modified :hardcopy))
("Buffer3" :value buffer3 :choices ((:save t) :kill :not-modified :hardcopy))
("Buffer4" :value buffer4 :choices (:save :kill :not-modified :hardcopy))
("Buffer5" :value buffer5 :choices ((:save t) :kill :not-modified :hardcopy)))
'((:save "Save" nil (:not-modified) nil nil)
(:kill "Kill" nil (:not-modified) nil nil)
(:not-modified "UnMod" nil (:save) nil nil)
(:hardcopy "Hardcopy" nil nil nil nil)))
||#
0,,
References:
Main Index |
Thread Index