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

Annotation of /lisp/tools/slider.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;;----------;;
2 :     ;; slider.l ;;
3 :     ;;----------;;
4 :    
5 :     ;; スライド抵抗のようなウィンドウを作る ;;
6 :    
7 :     (defun create-slider-win (parent title x y right left var-name default
8 :     black white font
9 :     (len *default-slider-length*))
10 :     `(setq ,var-name nil)
11 :     (lets ((as (font-ascent font))
12 :     (de (font-descent font))
13 :     (leftstr (flonum->string16 left))
14 :     (rightstr (flonum->string16 right))
15 :     (titleofs *menu-margin*)
16 :     (numofs (+ titleofs
17 :     (text-width font title)
18 :     *menu-margin*))
19 :     (sliderofs (+ numofs
20 :     (max
21 :     (text-width font leftstr)
22 :     (text-width font rightstr))
23 :     (* 4 *menu-margin*)))
24 :    
25 :     (wid (+ sliderofs
26 :     len
27 :     (* 6 *menu-margin*)))
28 :    
29 :     (hei (+ as de (* 2 *menu-margin*)))
30 :     (mw (create-win parent x y wid hei black white font)))
31 :    
32 :     (setf (window-cursor mw) hair-cross-cursor)
33 :    
34 :     (setf (window-border mw) 0)
35 :     (setf (window-event-mask mw) '(:exposure
36 :     :button-press
37 :     :enter-window :leave-window))
38 :    
39 :     (put-winprop mw 'enter-notify-handler (function draw-frame-win))
40 :     (put-winprop mw 'leave-notify-handler (function erase-frame-win))
41 :     (put-winprop mw 'display-string title)
42 :     (put-winprop mw 'title-offset titleofs)
43 :     (put-winprop mw 'number-offset numofs)
44 :     (put-winprop mw 'slider-offset sliderofs)
45 :     (put-winprop mw 'slider-left left)
46 :     (put-winprop mw 'slider-right right)
47 :     (put-winprop mw 'slider-now-value nil)
48 :     (put-winprop mw 'string-offset-y (+ as *menu-margin*))
49 :     (put-winprop mw 'slider-offset-y (// hei 2))
50 :     (put-winprop mw 'slider-length len)
51 :    
52 :     (put-winprop mw 'button-press-handler
53 :     `(lambda (win code x y)
54 :     (setq ,var-name (slider-handler win code x y))))
55 :    
56 :     (set var-name (slider-handler
57 :     mw
58 :     0
59 :     (left-now-right left default right
60 :     sliderofs
61 :     (+ sliderofs len))
62 :     0))
63 :     mw))
64 :    
65 :     (defun left-now-right (left now right start stop)
66 :     (quotient (plus (times start (difference now left))
67 :     (times stop (difference right now)))
68 :     (difference right left)))
69 :    
70 :     (defun slider-handler (win code x y)
71 :     (let* ((left (get-winprop win 'slider-left))
72 :     (right (get-winprop win 'slider-right))
73 :     (x-left (get-winprop win 'slider-offset))
74 :     (x-right (+ x-left (get-winprop win 'slider-length)))
75 :     (newvalue nil)
76 :     (oldvalue (get-winprop win 'slider-now-value))
77 :     (oldvalue-x nil)
78 :     (center-y (get-winprop win 'slider-offset-y))
79 :     (radius 3))
80 :    
81 :     (comment print (list 'slider-handler x-left x-right))
82 :    
83 :     (if (lessp x x-left) (setq x x-left))
84 :     (if (greaterp x x-right) (setq x x-right))
85 :     (setq newvalue (left-now-right x-left x x-right left right))
86 :    
87 :     (draw-string16-win win (flonum->string16 newvalue)
88 :     (get-winprop win 'number-offset)
89 :     (get-winprop win 'string-offset-y))
90 :    
91 :     (comment print (list 'oldvalue oldvalue))
92 :    
93 :     (clear-win win)
94 :     (draw-string16-win win
95 :     (get-winprop win 'display-string)
96 :     (get-winprop win 'title-offset)
97 :     (get-winprop win 'string-offset-y))
98 :     (draw-string16-win win (flonum->string16 newvalue)
99 :     (get-winprop win 'number-offset)
100 :     (get-winprop win 'string-offset-y))
101 :     (draw-line-win win x-left center-y x-right center-y)
102 :     (draw-line-win win
103 :     x-left (- center-y 2)
104 :     x-left (+ center-y 2))
105 :     (draw-line-win win
106 :     x-right (- center-y 2)
107 :     x-right (+ center-y 2))
108 :    
109 :     (draw-circle-win win (fix x) center-y radius)
110 :     (redraw-win win)
111 :     (draw-frame-win win)
112 :    
113 :     (put-winprop win 'slider-now-value newvalue)
114 :    
115 :     (comment print (list 'newvalue newvalue))
116 :     newvalue))
117 :    
118 :    
119 :     ;; ---------------------- ;;
120 :     ;; make slider menu macro ;;
121 :     ;; ---------------------- ;;
122 :     (defmacro create-slider-menu (parent x y black white fnt . item-list)
123 :     (let ((mw (gensym))
124 :     (height (gensym))
125 :     (width (gensym)))
126 :     (append
127 :     `(let ((,mw (create-win ,parent ,x ,y 10 10
128 :     ,black ,white ,fnt))
129 :     (,height *menu-margin*)
130 :     (,width 0)))
131 :     (mapcar item-list
132 :     (function
133 :     (lambda (x)
134 :     `(progn
135 :     (setq ,(first x)
136 :     (create-slider-win
137 :     ,mw
138 :     ,(second x)
139 :     *menu-margin*
140 :     ,height
141 :     ,(third x)
142 :     ,(fourth x)
143 :     ,(fifth x)
144 :     ,(sixth x)
145 :     ,black
146 :     ,white
147 :     ,fnt))
148 :     (setq ,height
149 :     (+ ,height (height-win ,(first x))))
150 :     (setq ,width
151 :     (max ,width (width-win ,(first x))))
152 :     ))))
153 :    
154 :     `((resize-win ,mw
155 :     (+ ,width (* 4 *menu-margin*))
156 :     (+ ,height (* 2 *menu-margin*))))
157 :     (mapcar item-list
158 :     (function (lambda (x)
159 :     `(resize-win ,(first x) ,width))))
160 :     `(,mw))))
161 :    
162 :     (comment defun loop-test ()
163 :     (setq %end% nil)
164 :     (main-loop-test display '(lambda () %end%)))
165 :    
166 :     (comment defun main-loop-test (disp isend? (win nil))
167 :     (loop
168 :     (event-case (disp)
169 :     (:exposure
170 :     (event-window count)
171 :     (and (0= count) (handle-exposure event-window))
172 :     t)
173 :     (:button-press
174 :     (event-window code x y)
175 :     (handle-button-press event-window code x y)
176 :     t)
177 :     (:enter-notify
178 :     (event-window)
179 :     (handle-enter-notify event-window)
180 :     t)
181 :     (:leave-notify
182 :     (event-window)
183 :     (handle-leave-notify event-window)
184 :     t)
185 :     (:motion-notify
186 :     (event-window x y)
187 :     (and (eq event-window win)
188 :     (handle-motion-notify event-window x y))
189 :     t)
190 :     (:client-message
191 :     (event-window type format data)
192 :     (print (list 'client-message event-window type format data))
193 :     (pr data)
194 :     t)
195 :     (:property-notify
196 :     (event-window atom state time)
197 :     (print (list 'property-notify event-window atom state time))
198 :     t)
199 :     (otherwise
200 :     ()
201 :     (print (list 'other-events))
202 :     t))
203 :     (cond ((funcall isend?) (exit)))))
204 :    
205 :     (comment defun slider-win-test ()
206 :     (setq %end% nil)
207 :     (setup-display)
208 :     (initialize-skelton-edit-sub)
209 :     (setq main-win (create-win root 0 0 400 400 black white kanji-font))
210 :     (setf (wm-name main-win) "slider test")
211 :    
212 :     (put-winprop main-win
213 :     'button-press-handler
214 :     #'(lambda (win code x y) (setq %end% t)))
215 :    
216 :     (setf (window-event-mask main-win) '(:button-press :property-change))
217 :    
218 :     (setq sliders (create-slider-menu
219 :     main-win 0 0 black white kanji-font
220 :     (sl1 "スラ1" 10.0 90.0 'test-value 30.0)
221 :     (sl2 "スラ2" 0.0 1.0 'test-value-2 0.5)))
222 :    
223 :     (map-subwindows sliders)
224 :     (map-subwindows main-win)
225 :     (map-window main-win)
226 :    
227 :     (loop-test)
228 :    
229 :     (print test-value)
230 :     (print test-value-2)
231 :     nil)
232 :    
233 :     (defun flonum->string16 (flo (wid 7) (seido 2))
234 :     (setq wid (* 2 wid))
235 :     (let* ((sign nil)
236 :     (int-part nil)
237 :     (frac-part nil)
238 :     (len 2) ;; for point
239 :     (sign nil)
240 :     (start 0)
241 :     (str nil)
242 :     (int-s nil)
243 :     (frac-s nil))
244 :    
245 :     (when (setq sign (lessp flo 0))
246 :     (setq flo (minus flo))
247 :     (incr len 2))
248 :    
249 :     (setq int-part (fix flo))
250 :     (setq frac-part (difference flo int-part))
251 :     (do ((i 0 (1+ i)))
252 :     ((>= i seido))
253 :     (setq frac-part (times frac-part 10)))
254 :     (setq frac-part (fix frac-part))
255 :    
256 :     (when (eq int-part 0) (push 0 int-s) (incr len 2))
257 :     (do ((n int-part (// n 10)))
258 :     ((0= n))
259 :     (push (remainder n 10) int-s)
260 :     (incr len 2))
261 :    
262 :     (do ((i 0 (1+ i))
263 :     (n frac-part (// n 10)))
264 :     ((>= i seido))
265 :     (push (remainder n 10) frac-s)
266 :     (incr len 2))
267 :    
268 :     (setq str (make-string (max wid len)))
269 :     (cond ((> wid len)
270 :     (setq start (- wid len))
271 :     (setq len wid)
272 :     (do ((i 0 (+ i 2)))
273 :     ((>= i start))
274 :     (sset str i 161)
275 :     (sset str (1+ i) 161))))
276 :    
277 :     (when sign
278 :     (sset str start 161)
279 :     (sset str (1+ start) 221)
280 :     (incr start 2))
281 :    
282 :     (let ((i start))
283 :     (do ((digits int-s))
284 :     ((null digits))
285 :     (sset str i 163)
286 :     (sset str (1+ i) (+ (pop digits) 176))
287 :     (incr i 2))
288 :     (sset str i 161)
289 :     (sset str (1+ i) 165)
290 :     (incr i 2)
291 :     (do ((digits frac-s))
292 :     ((null digits))
293 :     (sset str i 163)
294 :     (sset str (1+ i) (+ (pop digits) 176))
295 :     (incr i 2))
296 :     str)))
297 :    
298 :     (comment defun fixnum->string16 (num (wid 4))
299 :     (setq wid (* wid 2))
300 :     (let* ((s nil)
301 :     (sign nil)
302 :     (len 0)
303 :     (start 0)
304 :     (str nil))
305 :    
306 :     (when (< num 0)
307 :     (setq sign t num (minus num))
308 :     (incr len 2))
309 :    
310 :     (do ((n num (// n 10)))
311 :     ((0= n))
312 :     (push (remainder n 10) s)
313 :     (incr len 2))
314 :     (setq str (make-string (max wid len)))
315 :     (cond ((> wid len)
316 :     (setq start (- wid len))
317 :     (setq len wid)
318 :     (do ((i 0 (+ i 2)))
319 :     ((>= i start))
320 :     (sset str i 161)
321 :     (sset str (1+ i) 161))))
322 :     (when sign
323 :     (sset str start 161)
324 :     (sset str (1+ start) 221)
325 :     (incr start 2))
326 :     (do ((i start (+ i 2)))
327 :     ((>= i len))
328 :     (sset str i 163)
329 :     (sset str (1+ i) (+ (pop s) 176)))
330 :     str))
331 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help