1 : |
ktanaka |
1.1 |
;; -------- ;; |
2 : |
|
|
;; xyunit.l ;; |
3 : |
|
|
;; -------- ;; |
4 : |
|
|
|
5 : |
|
|
(defun get-prim-info (prim key) |
6 : |
|
|
(let* ((info (get-aux-info prim)) |
7 : |
|
|
(loc (assq key info))) |
8 : |
|
|
loc)) |
9 : |
|
|
|
10 : |
|
|
(defun put-prim-info (prim key value) |
11 : |
|
|
(let ((loc (get-prim-info prim key))) |
12 : |
|
|
(if (null loc) |
13 : |
|
|
(nconc (get-aux-info prim) (ncons (cons key value))) |
14 : |
|
|
(setf (cdr loc) value)))) |
15 : |
|
|
|
16 : |
|
|
(defun center-of-primitive (prim) |
17 : |
|
|
(lets ((edges (range-of-primitive-of-jp prim #(1.0 0.0 0.0 1.0 0.0 0.0))) |
18 : |
|
|
(minimum (car edges)) |
19 : |
|
|
(maximum (cadr edges))) |
20 : |
|
|
(list (quotient (plus (car minimum) (car maximum)) 2) |
21 : |
|
|
(quotient (plus (cadr minimum) (cadr maximum)) 2)))) |
22 : |
|
|
|
23 : |
|
|
(defun get-position:resize-boxes (win cx cy x y (end-by-release nil)) |
24 : |
|
|
(let ((save-bp-handler (get-winprop win 'button-press-handler)) |
25 : |
|
|
(save-br-handler (get-winprop win 'button-release-handler)) |
26 : |
|
|
(save-mn-handler (get-winprop win 'motion-notify-handler)) |
27 : |
|
|
(save-event-mask (window-event-mask win)) |
28 : |
|
|
(%pred-position% nil) |
29 : |
|
|
(%end% nil)) |
30 : |
|
|
(comment print 'enter-resize-boxes-mode) |
31 : |
|
|
|
32 : |
|
|
(put-winprop win |
33 : |
|
|
(if (not end-by-release) |
34 : |
|
|
'button-release-handler |
35 : |
|
|
'button-press-handler) |
36 : |
|
|
nil) |
37 : |
|
|
|
38 : |
|
|
(put-winprop win |
39 : |
|
|
(if end-by-release |
40 : |
|
|
'button-release-handler |
41 : |
|
|
'button-press-handler) |
42 : |
|
|
#'(lambda (win code x y) |
43 : |
|
|
(setq %end% t) |
44 : |
|
|
(setq %pred-position% (list x y)))) |
45 : |
|
|
|
46 : |
|
|
(put-winprop win |
47 : |
|
|
'motion-notify-handler |
48 : |
|
|
`(lambda (win x y) |
49 : |
|
|
(resize-boxes-win! win ,cx ,cy x y))) |
50 : |
|
|
|
51 : |
|
|
(setf (window-event-mask win) '(:exposure |
52 : |
|
|
:button-press |
53 : |
|
|
:button-release |
54 : |
|
|
:pointer-motion)) |
55 : |
|
|
|
56 : |
|
|
(resize-boxes-win! win cx cy x y) |
57 : |
|
|
(loop-disable-other-win win #'(lambda () %end%)) |
58 : |
|
|
|
59 : |
|
|
(setf (window-event-mask win) save-event-mask) |
60 : |
|
|
(put-winprop win |
61 : |
|
|
'button-press-handler |
62 : |
|
|
save-bp-handler) |
63 : |
|
|
(put-winprop win |
64 : |
|
|
'button-release-handler |
65 : |
|
|
save-br-handler) |
66 : |
|
|
(put-winprop win |
67 : |
|
|
'motion-notify-handler |
68 : |
|
|
save-mn-handler) |
69 : |
|
|
|
70 : |
|
|
(comment print 'exit-resize-boxes-mode) |
71 : |
|
|
%pred-position%)) |
72 : |
|
|
|
73 : |
|
|
(defun draw-xor-center-box-win! (win cx cy x y) |
74 : |
|
|
(lets ((half-width (abs (difference cx x))) |
75 : |
|
|
(half-height (abs (difference cy y))) |
76 : |
|
|
(xx (if (lessp cx x) (difference cx half-width) x)) |
77 : |
|
|
(yy (if (lessp cy y) (difference cy half-height) y))) |
78 : |
|
|
(draw-rectangle win |
79 : |
|
|
(get-winprop win 'xorgc) |
80 : |
|
|
xx yy (times 2 half-width) (times 2 half-height)))) |
81 : |
|
|
|
82 : |
|
|
(defun resize-boxes-win! (win cx cy x y) |
83 : |
|
|
(let ((now (list x y))) |
84 : |
|
|
(if %pred-position% |
85 : |
|
|
(when (not (equal %pred-position% (list x y))) |
86 : |
|
|
(lets ((px (car %pred-position%)) |
87 : |
|
|
(py (cadr %pred-position%))) |
88 : |
|
|
(draw-xor-center-box-win! win cx cy px py)))) |
89 : |
|
|
(draw-xor-center-box-win! win cx cy x y) |
90 : |
|
|
(setq %pred-position% now))) |
91 : |
|
|
|
92 : |
|
|
(defun edit-xyunit-of-primitive (win x y niti) |
93 : |
|
|
(lets ((center (center-of-primitive niti)) |
94 : |
|
|
(x0 (car center)) |
95 : |
|
|
(y0 (cadr center)) |
96 : |
|
|
(nxy (get-position:resize-boxes win x0 y0 x y *end-by-release*)) |
97 : |
|
|
(nxunit |
98 : |
|
|
(times 2 (abs (difference x0 (car nxy))))) |
99 : |
|
|
(nyunit |
100 : |
|
|
(times 2 (abs (difference y0 (cadr nxy)))))) |
101 : |
|
|
(put-prim-info niti 'xunit nxunit) |
102 : |
|
|
(put-prim-info niti 'yunit nyunit) |
103 : |
|
|
(clear-win editor) |
104 : |
|
|
(if grid (grid-win editor)) |
105 : |
ktanaka |
1.2 |
(draw-skeleton-win editor niti) |
106 : |
ktanaka |
1.1 |
(redisplay-win editor) |
107 : |
|
|
|
108 : |
|
|
(setf (window-cursor editor) please-wait-cursor) |
109 : |
|
|
(display-force-output display) |
110 : |
ktanaka |
1.2 |
(show-temporary-nikuduked-skeletons temporary-window) |
111 : |
ktanaka |
1.1 |
(setf (window-cursor editor) hair-cross-cursor) |
112 : |
|
|
|
113 : |
|
|
niti)) |
114 : |
|
|
|
115 : |
ktanaka |
1.2 |
(defun draw-temporary-nikuduked-skeleton-win! (win prim |
116 : |
ktanaka |
1.1 |
xwid ywid |
117 : |
|
|
xofs yofs |
118 : |
|
|
(mincho-gothic 'mincho)) |
119 : |
ktanaka |
1.2 |
(setq prim (shapeup-skeleton prim)) |
120 : |
ktanaka |
1.1 |
(when (not (null (car prim))) |
121 : |
ktanaka |
1.2 |
(let ((outline (skeleton2list (applykanji prim) mincho-gothic)) |
122 : |
ktanaka |
1.1 |
(save (get-winprop win 'button-press-handler)) |
123 : |
|
|
(loopend nil)) |
124 : |
|
|
(mapcar outline |
125 : |
|
|
#'(lambda (x) |
126 : |
|
|
(fill-polygon-win! |
127 : |
|
|
win |
128 : |
|
|
(mapcar (setpart1 x) |
129 : |
|
|
#'(lambda (xy) |
130 : |
|
|
(let ((r (cons (plus xofs |
131 : |
|
|
(quotient |
132 : |
|
|
(times xwid (car xy)) |
133 : |
|
|
400)) |
134 : |
|
|
(plus yofs |
135 : |
|
|
(quotient |
136 : |
|
|
(times ywid (cdr xy)) |
137 : |
|
|
400))))) |
138 : |
|
|
r)))))) |
139 : |
|
|
(display-force-output (window-display win))))) |
140 : |
|
|
|
141 : |
ktanaka |
1.2 |
(defun draw-temporary-nikuduked-skeleton-win (win prim |
142 : |
ktanaka |
1.1 |
xwid ywid |
143 : |
|
|
xofs yofs |
144 : |
|
|
(mincho-gothic 'mincho)) |
145 : |
ktanaka |
1.2 |
(setq prim (shapeup-skeleton prim)) |
146 : |
ktanaka |
1.1 |
(when (not (null (car prim))) |
147 : |
ktanaka |
1.2 |
(let ((outline (skeleton2list (applykanji prim) mincho-gothic)) |
148 : |
ktanaka |
1.1 |
(save (get-winprop win 'button-press-handler)) |
149 : |
|
|
(loopend nil)) |
150 : |
|
|
(mapcar outline |
151 : |
|
|
#'(lambda (x) |
152 : |
|
|
(fill-polygon-win |
153 : |
|
|
win |
154 : |
|
|
(mapcar (setpart1 x) |
155 : |
|
|
#'(lambda (xy) |
156 : |
|
|
(let ((r (cons (plus xofs |
157 : |
|
|
(quotient |
158 : |
|
|
(times xwid (car xy)) |
159 : |
|
|
400)) |
160 : |
|
|
(plus yofs |
161 : |
|
|
(quotient |
162 : |
|
|
(times ywid (cdr xy)) |
163 : |
|
|
400))))) |
164 : |
|
|
r))))))))) |
165 : |
|
|
|
166 : |
|
|
|
167 : |
|
|
(defun fill-polygon-win (win points (mode 'black)) |
168 : |
|
|
(draw-lines (get-winprop win 'save) |
169 : |
|
|
(selectq mode |
170 : |
|
|
(white (get-winprop win 'savewhitegc)) |
171 : |
|
|
(black (get-winprop win 'saveblackgc)) |
172 : |
|
|
(t (funcall err:argument-type mode))) |
173 : |
|
|
(cons2flat points) |
174 : |
|
|
:fill-p t)) |
175 : |
|
|
|
176 : |
|
|
(defun remove-assq (a-list key) |
177 : |
|
|
(cond ((null a-list) |
178 : |
|
|
nil) |
179 : |
|
|
((eq (caar a-list) key) |
180 : |
|
|
(remove-assq (cdr a-list) key)) |
181 : |
|
|
(t |
182 : |
|
|
(cons (car a-list) |
183 : |
|
|
(remove-assq (cdr a-list) key))))) |
184 : |
|
|
|
185 : |
|
|
(defun remove-prim-info (prim key) |
186 : |
|
|
(let ((points (get-points prim)) |
187 : |
|
|
(lines (get-lines prim)) |
188 : |
|
|
(info (get-aux-info prim))) |
189 : |
|
|
(cons points |
190 : |
|
|
(cons lines |
191 : |
|
|
(remove-assq info key))))) |
192 : |
|
|
|
193 : |
|
|
(defun remove-prim-xyunit (prim) |
194 : |
|
|
(remove-prim-info (remove-prim-info prim 'xunit) 'yunit)) |
195 : |
|
|
|
196 : |
|
|
(defun add-default-xyunit (prim) |
197 : |
|
|
(add-unit (remove-prim-xyunit prim))) |