1 : |
ktanaka |
1.1 |
;;-----------;; |
2 : |
|
|
;; movebox.l ;; |
3 : |
|
|
;;-----------;; |
4 : |
|
|
|
5 : |
|
|
(defun move-boxes-win! (win x y xwid ywid) |
6 : |
|
|
(let ((now (list x y))) |
7 : |
|
|
(if %pred-position% |
8 : |
|
|
(when (not (equal %pred-position% (list x y))) |
9 : |
|
|
(draw-xorbox-win! win |
10 : |
|
|
(first %pred-position%) (second %pred-position%) |
11 : |
|
|
(+ (first %pred-position%) xwid) |
12 : |
|
|
(+ (second %pred-position%) ywid)) |
13 : |
|
|
(draw-xorbox-win! win x y (+ x xwid) (+ y ywid))) |
14 : |
|
|
(draw-xorbox-win! win x y (+ x xwid) (+ y ywid))) |
15 : |
|
|
(setq %pred-position% now))) |
16 : |
|
|
|
17 : |
|
|
(defun get-position:move-boxes (win x y xwid ywid (end-by-release nil)) |
18 : |
|
|
(let ((save-bp-handler (get-winprop win 'button-press-handler)) |
19 : |
|
|
(save-br-handler (get-winprop win 'button-release-handler)) |
20 : |
|
|
(save-mn-handler (get-winprop win 'motion-notify-handler)) |
21 : |
|
|
(save-event-mask (window-event-mask win)) |
22 : |
|
|
(%pred-position% nil) |
23 : |
|
|
(%end% nil)) |
24 : |
|
|
|
25 : |
|
|
(print 'enter-move-boxes-mode) |
26 : |
|
|
|
27 : |
|
|
(put-winprop win |
28 : |
|
|
(if (not end-by-release) |
29 : |
|
|
'button-release-handler |
30 : |
|
|
'button-press-handler) |
31 : |
|
|
nil) |
32 : |
|
|
|
33 : |
|
|
(put-winprop win |
34 : |
|
|
(if end-by-release |
35 : |
|
|
'button-release-handler |
36 : |
|
|
'button-press-handler) |
37 : |
|
|
#'(lambda (win code x y) |
38 : |
|
|
(setq %end% t) |
39 : |
|
|
(setq %pred-position% (list x y)))) |
40 : |
|
|
|
41 : |
|
|
(put-winprop win |
42 : |
|
|
'motion-notify-handler |
43 : |
|
|
`(lambda (win x y) |
44 : |
|
|
(move-boxes-win! win x y ,xwid ,ywid))) |
45 : |
|
|
|
46 : |
|
|
(setf (window-event-mask win) '(:exposure |
47 : |
|
|
:button-press |
48 : |
|
|
:button-release |
49 : |
|
|
:pointer-motion)) |
50 : |
|
|
|
51 : |
|
|
(move-boxes-win! win x y xwid ywid) |
52 : |
|
|
(loop-disable-other-win win #'(lambda () %end%)) |
53 : |
|
|
|
54 : |
|
|
(setf (window-event-mask win) save-event-mask) |
55 : |
|
|
(put-winprop win |
56 : |
|
|
'button-press-handler |
57 : |
|
|
save-bp-handler) |
58 : |
|
|
(put-winprop win |
59 : |
|
|
'button-release-handler |
60 : |
|
|
save-br-handler) |
61 : |
|
|
(put-winprop win |
62 : |
|
|
'motion-notify-handler |
63 : |
|
|
save-mn-handler) |
64 : |
|
|
|
65 : |
|
|
(print 'exit-move-boxes-mode) |
66 : |
|
|
|
67 : |
|
|
%pred-position%)) |
68 : |
|
|
|
69 : |
|
|
(defun draw-corner-xorbox-win! (win x0 y0 x y) |
70 : |
|
|
(let* ((minx (min x0 x)) |
71 : |
|
|
(miny (min y0 y)) |
72 : |
|
|
(widx (- (max x0 x) minx)) |
73 : |
|
|
(widy (- (max y0 y) miny))) |
74 : |
|
|
(draw-rectangle win |
75 : |
|
|
(get-winprop win 'xorgc) |
76 : |
|
|
minx miny widx widy))) |
77 : |
|
|
|
78 : |
|
|
(defun drag-corner-boxes-win! (win x0 y0 x y) |
79 : |
|
|
(let ((now (list x y))) |
80 : |
|
|
(if %pred-position% |
81 : |
|
|
(when (not (equal %pred-position% (list x y))) |
82 : |
|
|
(draw-corner-xorbox-win! win |
83 : |
|
|
x0 y0 |
84 : |
|
|
(first %pred-position%) |
85 : |
|
|
(second %pred-position%)) |
86 : |
|
|
(draw-corner-xorbox-win! win x0 y0 x y)) |
87 : |
|
|
(draw-corner-xorbox-win! win x0 y0 x y)) |
88 : |
|
|
(setq %pred-position% now))) |
89 : |
|
|
|
90 : |
|
|
(defun move-some-points (win code x0 y0 prim (end-by-release nil)) |
91 : |
|
|
(let ((save-bp-handler (get-winprop win 'button-press-handler)) |
92 : |
|
|
(save-br-handler (get-winprop win 'button-release-handler)) |
93 : |
|
|
(save-mn-handler (get-winprop win 'motion-notify-handler)) |
94 : |
|
|
(save-event-mask (window-event-mask win)) |
95 : |
|
|
(%pred-position% nil) |
96 : |
|
|
(%end% nil) |
97 : |
|
|
(xwid nil) (ywid nil) |
98 : |
|
|
(minx nil) (miny nil) (maxx nil) (maxy nil)) |
99 : |
|
|
|
100 : |
|
|
(catch 'exit-move-some |
101 : |
|
|
(put-winprop win |
102 : |
|
|
(if (not end-by-release) |
103 : |
|
|
'button-release-handler |
104 : |
|
|
'button-press-handler) |
105 : |
|
|
nil) |
106 : |
|
|
|
107 : |
|
|
(put-winprop win |
108 : |
|
|
(if end-by-release |
109 : |
|
|
'button-release-handler |
110 : |
|
|
'button-press-handler) |
111 : |
|
|
#'(lambda (win code x y) |
112 : |
|
|
(setq %end% (if (eq code *end-mode*) |
113 : |
|
|
'exit-move-some |
114 : |
|
|
t)) |
115 : |
|
|
(setq %pred-position% (list x y)))) |
116 : |
|
|
|
117 : |
|
|
(put-winprop win |
118 : |
|
|
'motion-notify-handler |
119 : |
|
|
`(lambda (win x y) |
120 : |
|
|
(drag-corner-boxes-win! win ,x0 ,y0 x y))) |
121 : |
|
|
|
122 : |
|
|
(setf (window-event-mask win) '(:exposure |
123 : |
|
|
:button-press |
124 : |
|
|
:button-release |
125 : |
|
|
:pointer-motion)) |
126 : |
|
|
|
127 : |
|
|
(loop-disable-other-win win #'(lambda () %end%)) |
128 : |
|
|
|
129 : |
|
|
(if (eq %end% 'exit-move-some) (throw 'exit-move-some nil)) |
130 : |
|
|
|
131 : |
|
|
;; |
132 : |
|
|
;; I've got coodinates of the square's points already... |
133 : |
|
|
;; |
134 : |
|
|
(setq xwid (abs (- x0 (first %pred-position%))) |
135 : |
|
|
ywid (abs (- y0 (second %pred-position%)))) |
136 : |
|
|
|
137 : |
|
|
(setq minx (min x0 (first %pred-position%)) |
138 : |
|
|
miny (min y0 (second %pred-position%))) |
139 : |
|
|
|
140 : |
|
|
(setq maxx (+ minx xwid) maxy (+ miny ywid)) |
141 : |
|
|
|
142 : |
|
|
(setq xwid (// xwid 2) ywid (// ywid 2) |
143 : |
|
|
x0 (// (+ minx maxx) 2) |
144 : |
|
|
y0 (// (+ miny maxy) 2)) |
145 : |
|
|
|
146 : |
|
|
(comment draw-xorline-win! win minx miny maxx maxy) |
147 : |
|
|
|
148 : |
|
|
(draw-corner-xorbox-win! win minx miny maxx maxy) |
149 : |
|
|
(draw-corner-dashbox-win! win minx miny maxx maxy) |
150 : |
|
|
|
151 : |
|
|
(setq %pred-position% nil) |
152 : |
|
|
(setq %end% nil) |
153 : |
|
|
|
154 : |
|
|
(put-winprop win |
155 : |
|
|
'button-press-handler |
156 : |
|
|
#'(lambda (win code x y) |
157 : |
|
|
(setq %end% (if (eq code *end-mode*) |
158 : |
|
|
'exit-move-some |
159 : |
|
|
t)) |
160 : |
|
|
(setq %pred-position% (list x y)))) |
161 : |
|
|
|
162 : |
|
|
(put-winprop win |
163 : |
|
|
'motion-notify-handler |
164 : |
|
|
`(lambda (win x y) |
165 : |
|
|
(move-boxes-win! win x y ,xwid ,ywid))) |
166 : |
|
|
|
167 : |
|
|
(setf (window-event-mask win) '(:exposure |
168 : |
|
|
:button-press |
169 : |
|
|
:button-release |
170 : |
|
|
:pointer-motion)) |
171 : |
|
|
|
172 : |
|
|
(move-boxes-win! win x0 y0 xwid ywid) |
173 : |
|
|
|
174 : |
|
|
(loop-disable-other-win win #'(lambda () %end%)) |
175 : |
|
|
|
176 : |
|
|
(if (eq %end% 'exit-move-some) (throw 'exit-move-some nil)) |
177 : |
|
|
|
178 : |
|
|
(setq prim |
179 : |
|
|
(move-some-points-of-primitive minx maxx miny maxy |
180 : |
|
|
(- (first %pred-position%) x0) |
181 : |
|
|
(- (second %pred-position%) y0) |
182 : |
|
|
prim))) |
183 : |
|
|
|
184 : |
|
|
(clear-win win) |
185 : |
|
|
(if grid (grid-win win)) |
186 : |
|
|
(draw-skelton-win win prim) |
187 : |
|
|
(redraw-win win) |
188 : |
|
|
|
189 : |
|
|
(setf (window-event-mask win) save-event-mask) |
190 : |
|
|
(put-winprop win |
191 : |
|
|
'button-press-handler |
192 : |
|
|
save-bp-handler) |
193 : |
|
|
(put-winprop win |
194 : |
|
|
'button-release-handler |
195 : |
|
|
save-br-handler) |
196 : |
|
|
(put-winprop win |
197 : |
|
|
'motion-notify-handler |
198 : |
|
|
save-mn-handler) |
199 : |
|
|
prim)) |
200 : |
|
|
|
201 : |
|
|
(defun move-some-points-of-primitive (xmin xmax ymin ymax offx offy prim) |
202 : |
|
|
(let ((ret nil) |
203 : |
|
|
(points (get-points prim)) |
204 : |
|
|
(lines (get-lines prim)) |
205 : |
|
|
(aux-info (get-aux-info prim)) |
206 : |
|
|
(now nil)) |
207 : |
|
|
|
208 : |
|
|
(setq points |
209 : |
|
|
(mapcar points |
210 : |
|
|
`(lambda (e) |
211 : |
|
|
(let* ((x (first e)) |
212 : |
|
|
(y (second e)) |
213 : |
|
|
(info (cddr e))) |
214 : |
|
|
(if (and (< xmin x) (< x xmax) (< ymin y) (< y ymax)) |
215 : |
|
|
(cons (+ x offx) (cons (+ y offy) info)) |
216 : |
|
|
e))))) |
217 : |
|
|
|
218 : |
|
|
(setq ret (cons points (cons lines aux-info))) |
219 : |
|
|
ret)) |