CLIM mail archive
[Prev][Next][Index][Thread]

Is there a CLIM version of tv:momentary-multiple-menu?

    Date: Tue, 23 Jul 1991 14:02 EDT
    From: jd05@gte.com

    I need to display a list of items, and let the user select as many as needed, 
    press DO IT and return a list of the items selected.

    If I were in DW, I would do this with 

    tv:momentary-multiple-menu

    But I want to use CLIM.  Is there an easy way to do it with CLIM?  

Since a number of people have asked for this, I guess it's time to
just forward the hack I wrote to do it.  Here it is.  To paraphrase:
the code expressed below is mine, not necessarily that of my employer.
No warranties offered or implied.

----------------
;;; -*- Base: 10; Package: CLIM; Mode: LISP; Syntax: Common-Lisp; Lowercase: Yes -*-

(export 'clim::(menu-multiple-choose)
	'clim)

(define-presentation-type menu-multiple-choose-selection ())

(defun menu-multiple-choose (item-list
			     &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))
  (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 (mapcar #'(lambda (x) (list x nil)) item-list))
		(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)))))
	    ;; 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 ('accept-values-exit-box :override t)
				    (exit)
		     (with-input-context ('menu-multiple-choose-selection)
					 (selection)
			  (read-gesture :stream stream)
			(menu-multiple-choose-selection
			  (setf (second selection) (not (second selection)))
			  (let ((piece (second (assoc selection selection-pieces))))
			    (when piece
			      (redisplay piece stream)
			      (unless (eql piece first-piece)
				(replay first-piece stream))))))
		   (accept-values-exit-box
		     (ecase exit
		       (: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)))  |#

0,,
References:
Main Index | Thread Index