View of /lisp/tools/drag-line.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; drag-line.l
;;

(defun draw-xorline-win! (win x0 y0 x1 y1)
  (draw-line win (get-winprop win 'xorgc) x0 y0 x1 y1))

(defun draw-convex-xorlines-win! (win org points)
  (let ((x0 (first org))
	(y0 (second org)))
    (mapcar points 
	    (function
	     (lambda (p)
	       (draw-xorline-win! win x0 y0 (first p) (second p)))))))

(setq %pred-position% nil)

(defun drag-lines-win! (win x y source-points)
  (cond ((null %pred-position%)
	 (setq %pred-position% (list x y))
	 (draw-convex-xorlines-win! win %pred-position% source-points)
	 (comment print 'first))
	(t 
	 (draw-convex-xorlines-win! win %pred-position% source-points)
	 (setq %pred-position% (list x y))
	 (draw-convex-xorlines-win! win %pred-position% source-points))))

(defun get-code-position:drag-lines (win now source-points 
					 (end-by-release nil))
  (let ((save-bp-handler (get-winprop win 'button-press-handler))
	(save-br-handler (get-winprop win 'button-release-handler))
	(save-mn-handler (get-winprop win 'motion-notify-handler))
	(save-event-mask (window-event-mask win))
	(%now-drag-lines-mode% t))
    (comment print 'enter-drag-lines-mode)
    (setq %pred-position% nil)

    (put-winprop win 
		 (if (not end-by-release)
		     'button-release-handler
		   'button-press-handler)
		 nil)

    (put-winprop win
		 (if end-by-release
		     'button-release-handler
		   'button-press-handler)
		 #'(lambda (win code x y) 
; tanaka 1993/9/19
		     (cond (grid
			    (setq x (* 5 (// (+ x 2) 5)))
			    (setq y (* 5 (// (+ y 2) 5)))))
		     (setq %now-drag-lines-mode% nil)
		     (when (and end-by-release (eq code *select-nearest*))
		       (selectq (length source-points)
			 (1 (lets ((p0 (first source-points))
				   (x0 (first p0))     (y0 (second p0))
				   (dx (abs (- x x0))) (dy (abs (- y y0))))
			      (cond ((< dx dy) (setq x x0))
				    (t         (setq y y0)))))
			 (2 (lets ((p0 (first  source-points))
				   (p1 (second source-points))
				   (x0 (first p0))     (y0 (second p0))
				   (x1 (first p1))     (y1 (second p1)))
			      (cond ((eq x0 x1) (setq x x0))
				    ((eq y0 y1) (setq y y0))
				    (t
				     (lets ((dx (- x1 x0))
					    (dy (- y1 y0))
					    (a dy)
					    (b (- dx))
					    (c (+ (* (- dy) x0) (* dx y0)))
					    (nowflag (+ (* a x)  (* b y)  c))
					    (kflag   (+ (* a x0) (* b y1) c)))
				       (if (0< (logxor nowflag kflag))
					   (setq x x0 y y1)
					 (setq x x1 y y0)))))))))
		     (setq %pred-position% (list code x y))))

    (put-winprop win
		 'motion-notify-handler
		 #'(lambda (win x y) 
		     (drag-lines-win! win 
				      (cond (grid (* 5 (// (+ x 2) 5)))(t x))
				      (cond (grid (* 5 (// (+ y 2) 5)))(t y))
				      source-points)))

    (setf (window-event-mask win) '(:exposure
				    :button-press :button-release
				    :pointer-motion))
    
    (drag-lines-win! win (first now) (second now) source-points)

    (loop-disable-other-win win 
			    #'(lambda () (null %now-drag-lines-mode%)))
    
    (setf (window-event-mask win) save-event-mask)
    (put-winprop win 
		 'button-press-handler 
		 save-bp-handler)
    (put-winprop win 
		 'button-release-handler 
		 save-br-handler)
    (put-winprop win
		 'motion-notify-handler 
		 save-mn-handler)
    
    (comment print 'exit-drag-lines-mode)
    %pred-position%))

(defun get-position:drag-lines (win now source (end-by-release nil))
  (cdr (get-code-position:drag-lines win now source end-by-release)))