rubber-band lines ?

• To: Ralph.Hensel@gmd.de
• Subject: rubber-band lines ?
• From: John Kern <kern%kuwait@lucid.com>
• Date: Fri, 14 Aug 92 09:16:29 PDT
• Cc: clim@BBN.COM
• Reply-To: kern@lucid.com

Howdy Mr. Hensel,

The following short program does this with a straight line.  While
it isn't quite what you asked for, I hope it helps.

Sincerely,

John S. Kern
Lucid, Inc
===============
(in-package :clim-user)

(define-application-frame test
			  ()
  ()
  (:panes
    ((main  :application
	    :incremental-redisplay nil
	    :default-size :rest
	    :display-function 'display-main)
     (test-menu  :command-menu)))
   (:command-table
    (test-menu
     :inherit-from (user-command-table)
     :menu
     (("EXIT"      :command cmd-exit)
      ("rubber" :command cmd-rubberband)
      ))))


(defmethod display-main ((frame test) stream)
  (cmd-rubberband)
  )
  

(defun ctest (root)
  (let (frame)
    (setq *frame* (make-application-frame 'test
					:parent root
					:left 0

					
					:top 0
					:right 500
					:bottom 500))
    (run-frame-top-level *frame*)
    ))


(defun cmd-exit ()
  (frame-exit *application-frame*)
  )


(defun cmd-rubberband ()
  (let ((x1 0)  ;; x1, y1 represents the fix point 
	(y1 0)
	(x2 0)  ;; x2,y2 represents the point that is changing
	(y2 0)
	(mouse-button-press nil)  ;;  set to T when mouse button has
				 ;;  press to select pivot
	(stream (get-frame-pane *application-frame* 'main)))
    (tracking-pointer (stream)
		      (:pointer-button-press (event x y )
					     (setf x1 x
						   y1 y
						   x2 x
						   y2 y)
					     (draw-line* stream
						   x1 y1 x2 y2
						   :ink +flipping-ink+)
					     (setf mouse-button-press t))
		      (:pointer-motion (window x y)
				       (when Mouse-button-press
					 ;;erase
					 (draw-line* stream x1 y1
						     x2 y2 :ink +flipping-ink+)
					 ;; draw
					 (draw-line* stream x1 y1 x y
						     :ink +flipping-ink+)
					 (setf x2 x y2 y)))
		      (:pointer-button-release (event x y )
					       (cond ((eq
							mouse-button-press t)
						      (return (list x1
								    y1
								    x2 y2))))))
    )
  )

• Prev: draw-arrow and answer
• Next: Re: draw-arrow and answer
• Index: CLIM Mailing list (1-Jan-92 to 31-Aug-92)
• Thread: CLIM Mailing list Index (1-Jan-92 to 31-Aug-92)