Annotation of /skeleton-edit/xyunit.lAnnotation of /skeleton-edit/xyunit.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 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 : | (draw-skeleton-win editor niti) | ||
| 106 : | (redisplay-win editor) | ||
| 107 : | |||
| 108 : | (setf (window-cursor editor) please-wait-cursor) | ||
| 109 : | (display-force-output display) | ||
| 110 : | (show-temporary-nikuduked-skeletons temporary-window) | ||
| 111 : | (setf (window-cursor editor) hair-cross-cursor) | ||
| 112 : | |||
| 113 : | niti)) | ||
| 114 : | |||
| 115 : | (defun draw-temporary-nikuduked-skeleton-win! (win prim | ||
| 116 : | xwid ywid | ||
| 117 : | xofs yofs | ||
| 118 : | (mincho-gothic 'mincho)) | ||
| 119 : | (setq prim (shapeup-skeleton prim)) | ||
| 120 : | (when (not (null (car prim))) | ||
| 121 : | (let ((outline (skeleton2list (applykanji prim) mincho-gothic)) | ||
| 122 : | (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 : | (defun draw-temporary-nikuduked-skeleton-win (win prim | ||
| 142 : | xwid ywid | ||
| 143 : | xofs yofs | ||
| 144 : | (mincho-gothic 'mincho)) | ||
| 145 : | (setq prim (shapeup-skeleton prim)) | ||
| 146 : | (when (not (null (car prim))) | ||
| 147 : | (let ((outline (skeleton2list (applykanji prim) mincho-gothic)) | ||
| 148 : | (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))) |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |