Annotation of /skeleton-edit/edhira.lAnnotation of /skeleton-edit/edhira.l
Parent Directory
| 
Revision Log
Revision: 1.1 - (view) (download)
| 1 : | ktanaka | 1.1 | ;; |
| 2 : | ;; edhira.l | ||
| 3 : | ;; $Revision: 1.2 $ | ||
| 4 : | ;; | ||
| 5 : | |||
| 6 : | |||
| 7 : | ;; -------------------------- ;; | ||
| 8 : | ;; some traditional functions ;; | ||
| 9 : | ;; -------------------------- ;; | ||
| 10 : | (defun tofix (x) | ||
| 11 : | (if (floatp x) | ||
| 12 : | (fix x) | ||
| 13 : | x)) | ||
| 14 : | |||
| 15 : | (defun toflo (x) | ||
| 16 : | (if (fixp x) | ||
| 17 : | (float x) | ||
| 18 : | x)) | ||
| 19 : | |||
| 20 : | ;; | ||
| 21 : | ;; xor circle | ||
| 22 : | ;; | ||
| 23 : | (defun draw-xorcircle-win! (win x y r) | ||
| 24 : | (let ((diameter (+ r r))) | ||
| 25 : | (draw-arc win | ||
| 26 : | (get-winprop win 'xorgc) | ||
| 27 : | (- x r) (- y r) diameter diameter 0 360))) | ||
| 28 : | |||
| 29 : | (defun drag-circles-win! (win x0 y0 r) | ||
| 30 : | (if %pred-r% | ||
| 31 : | (when (neq %pred-r% r) | ||
| 32 : | (draw-xorcircle-win! win x0 y0 %pred-r%) | ||
| 33 : | (draw-xorcircle-win! win x0 y0 r)) | ||
| 34 : | (draw-xorcircle-win! win x0 y0 r)) | ||
| 35 : | (setq %pred-r% r)) | ||
| 36 : | |||
| 37 : | (defun get-radius:drag-circles (win x0 y0 r0 (end-by-release nil)) | ||
| 38 : | (let ((save-bp-handler (get-winprop win 'button-press-handler)) | ||
| 39 : | (save-br-handler (get-winprop win 'button-release-handler)) | ||
| 40 : | (save-mn-handler (get-winprop win 'motion-notify-handler)) | ||
| 41 : | (save-event-mask (window-event-mask win)) | ||
| 42 : | (center (list x0 y0)) | ||
| 43 : | (%pred-r% nil) | ||
| 44 : | (%end% nil)) | ||
| 45 : | |||
| 46 : | (comment print 'enter-drag-circles-mode) | ||
| 47 : | |||
| 48 : | (put-winprop win | ||
| 49 : | (if (not end-by-release) | ||
| 50 : | 'button-release-handler | ||
| 51 : | 'button-press-handler) | ||
| 52 : | nil) | ||
| 53 : | |||
| 54 : | (put-winprop win | ||
| 55 : | (if end-by-release | ||
| 56 : | 'button-release-handler | ||
| 57 : | 'button-press-handler) | ||
| 58 : | `(lambda (win code x y) | ||
| 59 : | (setq %end% t) | ||
| 60 : | (setq %pred-r% | ||
| 61 : | (fix (sqrt (float (distance-points | ||
| 62 : | (list x y) ',center))))))) | ||
| 63 : | |||
| 64 : | (put-winprop win | ||
| 65 : | 'motion-notify-handler | ||
| 66 : | `(lambda (win x y) | ||
| 67 : | (drag-circles-win! win ,x0 ,y0 | ||
| 68 : | (fix (sqrt (float | ||
| 69 : | (distance-points | ||
| 70 : | (list x y) | ||
| 71 : | ',center))))))) | ||
| 72 : | |||
| 73 : | (setf (window-event-mask win) '(:exposure | ||
| 74 : | :button-press | ||
| 75 : | :button-release | ||
| 76 : | :pointer-motion)) | ||
| 77 : | |||
| 78 : | (drag-circles-win! win x0 y0 r0) | ||
| 79 : | (loop-disable-other-win win #'(lambda () %end%)) | ||
| 80 : | |||
| 81 : | (setf (window-event-mask win) save-event-mask) | ||
| 82 : | (put-winprop win | ||
| 83 : | 'button-press-handler | ||
| 84 : | save-bp-handler) | ||
| 85 : | (put-winprop win | ||
| 86 : | 'button-release-handler | ||
| 87 : | save-br-handler) | ||
| 88 : | (put-winprop win | ||
| 89 : | 'motion-notify-handler | ||
| 90 : | save-mn-handler) | ||
| 91 : | |||
| 92 : | (comment print 'exit-drag-circles-mode) | ||
| 93 : | |||
| 94 : | %pred-r%)) | ||
| 95 : | |||
| 96 : | ;; | ||
| 97 : | ;; width of hiragana | ||
| 98 : | ;; | ||
| 99 : | (defun change-hira-width (win code x y prim) | ||
| 100 : | (lets ((ret nil) | ||
| 101 : | (points (get-points prim)) | ||
| 102 : | (lines (get-lines prim)) | ||
| 103 : | (aux-info (get-aux-info prim)) | ||
| 104 : | (now (list x y))) | ||
| 105 : | (if points | ||
| 106 : | (lets ((nth-nearest (nth-of-nearest-point now points)) | ||
| 107 : | (nearest (nth nth-nearest points))) | ||
| 108 : | (cond ((< (distance-points nearest now) *near-range*) | ||
| 109 : | (lets ((element | ||
| 110 : | (first (mem #'(lambda (x l) (memq x (second l))) | ||
| 111 : | nth-nearest | ||
| 112 : | lines))) | ||
| 113 : | (p-nth (position nth-nearest (second element))) | ||
| 114 : | (hira-w (get-info element 'hirawidth))) | ||
| 115 : | (cond ((memq (first element) *has-hirawidth*) | ||
| 116 : | (unless hira-w | ||
| 117 : | (put-info element | ||
| 118 : | 'hirawidth | ||
| 119 : | (make-list (length (second element)) | ||
| 120 : | *default-hirawidth*)) | ||
| 121 : | (setq hira-w (get-info element 'hirawidth)) | ||
| 122 : | (if grid (grid-win win)) | ||
| 123 : | (draw-skeleton-win win prim) | ||
| 124 : | (redraw-win win)) | ||
| 125 : | |||
| 126 : | (let ((r (nth p-nth hira-w)) | ||
| 127 : | (x0 (first nearest)) | ||
| 128 : | (y0 (second nearest))) | ||
| 129 : | |||
| 130 : | (draw-xorcircle-win! win x0 y0 r) | ||
| 131 : | |||
| 132 : | (setf (nth p-nth hira-w) | ||
| 133 : | (get-radius:drag-circles | ||
| 134 : | win x0 y0 | ||
| 135 : | (fix (sqrt (float | ||
| 136 : | (distance-points | ||
| 137 : | (list x0 y0) | ||
| 138 : | (list x y))))) | ||
| 139 : | *end-by-release*)))) | ||
| 140 : | (t (rem-info element 'hirawidth) | ||
| 141 : | (beep win))))) | ||
| 142 : | (t (beep win)))) | ||
| 143 : | (beep win)) | ||
| 144 : | (setq ret (cons points (cons lines aux-info))) | ||
| 145 : | (clear-win win) | ||
| 146 : | (if grid (grid-win win)) | ||
| 147 : | (draw-skeleton-win win ret) | ||
| 148 : | (redraw-win win) | ||
| 149 : | ret)) | ||
| 150 : | |||
| 151 : | (defun draw-xorbox-win! (win x0 y0 x y) | ||
| 152 : | (lets ((width (abs (- x x0))) | ||
| 153 : | (height (abs (- y y0))) | ||
| 154 : | (xx (if (< x x0) x (- x0 width))) | ||
| 155 : | (yy (if (< y y0) y (- y0 height)))) | ||
| 156 : | (draw-rectangle win | ||
| 157 : | (get-winprop win 'xorgc) | ||
| 158 : | xx yy (* 2 width) (* 2 height)))) | ||
| 159 : | |||
| 160 : | (defun drag-boxes-win! (win x0 y0 x y) | ||
| 161 : | (let ((now (list x y))) | ||
| 162 : | (if %pred-position% | ||
| 163 : | (when (not (equal %pred-position% (list x y))) | ||
| 164 : | (draw-xorbox-win! win | ||
| 165 : | x0 y0 | ||
| 166 : | (first %pred-position%) (second %pred-position%)) | ||
| 167 : | (draw-xorbox-win! win x0 y0 x y)) | ||
| 168 : | (draw-xorbox-win! win x0 y0 x y)) | ||
| 169 : | (setq %pred-position% now))) | ||
| 170 : | |||
| 171 : | (defun get-position:drag-boxes (win x0 y0 x y (end-by-release nil)) | ||
| 172 : | (let ((save-bp-handler (get-winprop win 'button-press-handler)) | ||
| 173 : | (save-br-handler (get-winprop win 'button-release-handler)) | ||
| 174 : | (save-mn-handler (get-winprop win 'motion-notify-handler)) | ||
| 175 : | (save-event-mask (window-event-mask win)) | ||
| 176 : | (%pred-position% nil) | ||
| 177 : | (%end% nil)) | ||
| 178 : | |||
| 179 : | (print 'enter-drag-boxes-mode) | ||
| 180 : | |||
| 181 : | (put-winprop win | ||
| 182 : | (if (not end-by-release) | ||
| 183 : | 'button-release-handler | ||
| 184 : | 'button-press-handler) | ||
| 185 : | nil) | ||
| 186 : | |||
| 187 : | (put-winprop win | ||
| 188 : | (if end-by-release | ||
| 189 : | 'button-release-handler | ||
| 190 : | 'button-press-handler) | ||
| 191 : | #'(lambda (win code x y) | ||
| 192 : | (setq %end% t) | ||
| 193 : | (setq %pred-position% (list x y)))) | ||
| 194 : | |||
| 195 : | (put-winprop win | ||
| 196 : | 'motion-notify-handler | ||
| 197 : | `(lambda (win x y) | ||
| 198 : | (drag-boxes-win! win ,x0 ,y0 x y))) | ||
| 199 : | |||
| 200 : | (setf (window-event-mask win) '(:exposure | ||
| 201 : | :button-press | ||
| 202 : | :button-release | ||
| 203 : | :pointer-motion)) | ||
| 204 : | |||
| 205 : | (drag-boxes-win! win x0 y0 x y) | ||
| 206 : | (loop-disable-other-win win #'(lambda () %end%)) | ||
| 207 : | |||
| 208 : | (setf (window-event-mask win) save-event-mask) | ||
| 209 : | (put-winprop win | ||
| 210 : | 'button-press-handler | ||
| 211 : | save-bp-handler) | ||
| 212 : | (put-winprop win | ||
| 213 : | 'button-release-handler | ||
| 214 : | save-br-handler) | ||
| 215 : | (put-winprop win | ||
| 216 : | 'motion-notify-handler | ||
| 217 : | save-mn-handler) | ||
| 218 : | |||
| 219 : | (comment print 'exit-drag-circles-mode) | ||
| 220 : | |||
| 221 : | %pred-position%)) | ||
| 222 : | |||
| 223 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |