| 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))) |
Annotation of /lisp/tools/xyunit.l
Parent Directory
| 
Revision Log