[wadalabfont-kit] / lisp / tools / edhira.l  

Annotation of /lisp/tools/edhira.l

Parent Directory | Revision Log

Revision: 1.3 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; edhira.l
3 : ktanaka 1.3 ;; $Revision: 1.2 $
4 : ktanaka 1.1 ;;
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 : ktanaka 1.2 (draw-skeleton-win win prim)
124 : ktanaka 1.1 (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 : ktanaka 1.2 (draw-skeleton-win win ret)
148 : ktanaka 1.1 (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