Annotation of /lisp/tools/drag-line.lAnnotation of /lisp/tools/drag-line.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; |
| 2 : | ;; drag-line.l | ||
| 3 : | ;; | ||
| 4 : | |||
| 5 : | (defun draw-xorline-win! (win x0 y0 x1 y1) | ||
| 6 : | (draw-line win (get-winprop win 'xorgc) x0 y0 x1 y1)) | ||
| 7 : | |||
| 8 : | (defun draw-convex-xorlines-win! (win org points) | ||
| 9 : | (let ((x0 (first org)) | ||
| 10 : | (y0 (second org))) | ||
| 11 : | (mapcar points | ||
| 12 : | (function | ||
| 13 : | (lambda (p) | ||
| 14 : | (draw-xorline-win! win x0 y0 (first p) (second p))))))) | ||
| 15 : | |||
| 16 : | (setq %pred-position% nil) | ||
| 17 : | |||
| 18 : | (defun drag-lines-win! (win x y source-points) | ||
| 19 : | (cond ((null %pred-position%) | ||
| 20 : | (setq %pred-position% (list x y)) | ||
| 21 : | (draw-convex-xorlines-win! win %pred-position% source-points) | ||
| 22 : | (comment print 'first)) | ||
| 23 : | (t | ||
| 24 : | (draw-convex-xorlines-win! win %pred-position% source-points) | ||
| 25 : | (setq %pred-position% (list x y)) | ||
| 26 : | (draw-convex-xorlines-win! win %pred-position% source-points)))) | ||
| 27 : | |||
| 28 : | (defun get-code-position:drag-lines (win now source-points | ||
| 29 : | (end-by-release nil)) | ||
| 30 : | (let ((save-bp-handler (get-winprop win 'button-press-handler)) | ||
| 31 : | (save-br-handler (get-winprop win 'button-release-handler)) | ||
| 32 : | (save-mn-handler (get-winprop win 'motion-notify-handler)) | ||
| 33 : | (save-event-mask (window-event-mask win)) | ||
| 34 : | (%now-drag-lines-mode% t)) | ||
| 35 : | (comment print 'enter-drag-lines-mode) | ||
| 36 : | (setq %pred-position% nil) | ||
| 37 : | |||
| 38 : | (put-winprop win | ||
| 39 : | (if (not end-by-release) | ||
| 40 : | 'button-release-handler | ||
| 41 : | 'button-press-handler) | ||
| 42 : | nil) | ||
| 43 : | |||
| 44 : | (put-winprop win | ||
| 45 : | (if end-by-release | ||
| 46 : | 'button-release-handler | ||
| 47 : | 'button-press-handler) | ||
| 48 : | #'(lambda (win code x y) | ||
| 49 : | ; tanaka 1993/9/19 | ||
| 50 : | (cond (grid | ||
| 51 : | (setq x (* 5 (// (+ x 2) 5))) | ||
| 52 : | (setq y (* 5 (// (+ y 2) 5))))) | ||
| 53 : | (setq %now-drag-lines-mode% nil) | ||
| 54 : | (when (and end-by-release (eq code *select-nearest*)) | ||
| 55 : | (selectq (length source-points) | ||
| 56 : | (1 (lets ((p0 (first source-points)) | ||
| 57 : | (x0 (first p0)) (y0 (second p0)) | ||
| 58 : | (dx (abs (- x x0))) (dy (abs (- y y0)))) | ||
| 59 : | (cond ((< dx dy) (setq x x0)) | ||
| 60 : | (t (setq y y0))))) | ||
| 61 : | (2 (lets ((p0 (first source-points)) | ||
| 62 : | (p1 (second source-points)) | ||
| 63 : | (x0 (first p0)) (y0 (second p0)) | ||
| 64 : | (x1 (first p1)) (y1 (second p1))) | ||
| 65 : | (cond ((eq x0 x1) (setq x x0)) | ||
| 66 : | ((eq y0 y1) (setq y y0)) | ||
| 67 : | (t | ||
| 68 : | (lets ((dx (- x1 x0)) | ||
| 69 : | (dy (- y1 y0)) | ||
| 70 : | (a dy) | ||
| 71 : | (b (- dx)) | ||
| 72 : | (c (+ (* (- dy) x0) (* dx y0))) | ||
| 73 : | (nowflag (+ (* a x) (* b y) c)) | ||
| 74 : | (kflag (+ (* a x0) (* b y1) c))) | ||
| 75 : | (if (0< (logxor nowflag kflag)) | ||
| 76 : | (setq x x0 y y1) | ||
| 77 : | (setq x x1 y y0))))))))) | ||
| 78 : | (setq %pred-position% (list code x y)))) | ||
| 79 : | |||
| 80 : | (put-winprop win | ||
| 81 : | 'motion-notify-handler | ||
| 82 : | #'(lambda (win x y) | ||
| 83 : | (drag-lines-win! win | ||
| 84 : | (cond (grid (* 5 (// (+ x 2) 5)))(t x)) | ||
| 85 : | (cond (grid (* 5 (// (+ y 2) 5)))(t y)) | ||
| 86 : | source-points))) | ||
| 87 : | |||
| 88 : | (setf (window-event-mask win) '(:exposure | ||
| 89 : | :button-press :button-release | ||
| 90 : | :pointer-motion)) | ||
| 91 : | |||
| 92 : | (drag-lines-win! win (first now) (second now) source-points) | ||
| 93 : | |||
| 94 : | (loop-disable-other-win win | ||
| 95 : | #'(lambda () (null %now-drag-lines-mode%))) | ||
| 96 : | |||
| 97 : | (setf (window-event-mask win) save-event-mask) | ||
| 98 : | (put-winprop win | ||
| 99 : | 'button-press-handler | ||
| 100 : | save-bp-handler) | ||
| 101 : | (put-winprop win | ||
| 102 : | 'button-release-handler | ||
| 103 : | save-br-handler) | ||
| 104 : | (put-winprop win | ||
| 105 : | 'motion-notify-handler | ||
| 106 : | save-mn-handler) | ||
| 107 : | |||
| 108 : | (comment print 'exit-drag-lines-mode) | ||
| 109 : | %pred-position%)) | ||
| 110 : | |||
| 111 : | (defun get-position:drag-lines (win now source (end-by-release nil)) | ||
| 112 : | (cdr (get-code-position:drag-lines win now source end-by-release))) | ||
| 113 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |