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

Re: fancy highlighting of presentations

Thank you all for the help in highlighting presentations with a cursor
that moves along the presentation.  With a day of fiddling I managed to
make it work.  Following is the code I ended up with -- not elegant but
it works.  If there are better ways of doing things in here, feel free
to comment.
-Bill Long

;;;; ----- code follows -----

;; data structure to hold values
(defstruct (measure (:print-function
		      (lambda (measure str lev)
			(declare (ignore lev))
			(format str "<m ~A>" (measure-name measure)))))
  name
  value
  type)

;; the presentation type that's displayed as a horizontal scale
(define-presentation-type measnum ())

(defvar *arrow* (clim:make-pattern #2a((0 0 0 0 1 1 1 1 1 0 0 0 0)
				       (0 0 0 0 1 1 1 1 1 0 0 0 0)
				       (0 0 0 0 1 1 1 1 1 0 0 0 0)
				       (0 0 0 0 1 1 1 1 1 0 0 0 0)
				       (0 0 0 0 1 1 1 1 1 0 0 0 0)
				       (1 1 1 1 1 1 1 1 1 1 1 1 1)
				       (0 1 1 1 1 1 1 1 1 1 1 1 0)
				       (0 0 1 1 1 1 1 1 1 1 1 0 0)
				       (0 0 0 1 1 1 1 1 1 1 0 0 0)
				       (0 0 0 0 1 1 1 1 1 0 0 0 0)
				       (0 0 0 0 0 1 1 1 0 0 0 0 0)
				       (0 0 0 0 0 0 1 0 0 0 0 0 0)
				       )
				   (list clim:+background+ clim:+foreground+)))

(defvar *in-highlight* ()) ; the only way I can find to keep tracking-pointer from
			   ; recursively calling highlight-presentation

(define-presentation-method highlight-presentation ((type measnum) record stream state)
  (declare (ignore record))
  (when (and (eq state :highlight) ; does this do anything?
	     (not *in-highlight*))
    (setq *in-highlight* t)(highlight-scale stream)(setq *in-highlight* ())))

(defun highlight-scale (stream)
  (let (ox oy)
    (with-output-recording-options (stream :record-p nil)
      (tracking-pointer (stream :context-type 'measnum
				:transformp t ; doesn't seem to do anything
				:highlight ()) ; doesn't work, hence the *in-highlight*
        (:presentation (presentation x)
	 (with-bounding-rectangle* (left top) presentation
	   (declare (ignore left))
	   (multiple-value-bind (xr yr)
	       (convert-from-relative-to-absolute-coordinates ; copied from menu-multiple-choose
		 stream (output-record-parent presentation)) ; any reason for parent?
	     (declare (ignore xr))
	     (when ox (draw-i-beam stream ox oy))
	     (draw-i-beam stream (setq ox x)(setq oy (+ yr top 6))))))
	(:pointer-motion ()
	 (when ox (draw-i-beam stream ox oy)
	       (setq ox nil))
	 (return-from highlight-scale))
	(:presentation-button-press (event) ; if I don't include this I-beam remains and
					    ; gesture gets eaten anyway
	 (when ox (draw-i-beam stream ox oy)
	       (setq ox nil))
	 (unread-gesture event)
	 (return-from highlight-scale))))))

(define-hfcl-command (com-select-measnum) ; as command causes redisplay to show arrow
   ((meas 'measure)(val 'integer))
  (setf (measure-value meas) val))

(define-presentation-to-command-translator set-measnum
    (measnum com-select-measnum hfcl)
    (object presentation x)
  (let* ((stream (get-frame-pane *application-frame* 'input-window))
	 (xr (convert-from-relative-to-absolute-coordinates stream presentation)))
          ; with-output-as-presentation is inside with-room-for-graphics so conversion needed
      (list object (/ (- x xr) 300.0))))

;; the method that handles displaying the input pane
(defmethod display-measures ((frame hfcl) stream)
  (loop with val for meas in *measures* do
    (fresh-line stream)
    (updating-output (stream :unique-id meas :cach-value (measure-value meas))
      (with-output-as-presentation (:object meas :type 'measnam :stream stream)
	(with-text-face ((if (measure-value meas) :italic :roman) stream)
	  (format stream "~A: " (measure-name meas))))
      (cond ((eq (measure-type meas) 'scale)
	     (with-room-for-graphics (stream)
	       (with-output-as-presentation (:object meas :type 'measnum :stream stream
					     :single-box t) ; else sensitive area is just line
		 (draw-scale stream))
	       (draw-text* stream "0.0" 0 -2 :align-x :center :align-y :top)
	       (draw-text* stream "1.0" 300 -2 :align-x :center :align-y :top)
	       (if (setq val (measure-value meas))
		   (draw-icon* stream *arrow* (- (round (* 300 val)) 6) 0))))
	    ( ;; handle other types
	     )))))

(defun draw-scale (stream)
  (draw-line* stream 0 0 300 0)
  (draw-line* stream 0 0 0 12)
  (draw-line* stream 300 0 300 12))

(defun draw-i-beam (stream x y &aux (y1 (- y 8))(y2 (+ y 8))(x1 (- x 2))(x2 (+ x 2)))
  (draw-line* stream x y1 x y2 :ink +flipping-ink+)
  (draw-line* stream x1 y1 x2 y1 :ink +flipping-ink+)
  (draw-line* stream x1 y2 x2 y2 :ink +flipping-ink+))


0,,
Main Index | Thread Index