[wadalabfont-kit] / lisp / tools / drag-line.l  

Annotation 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