| 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 "スラ１" 10.0 90.0 'test-value 30.0) |
| 221 : |
|
|
(sl2 "スラ２" 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 : |
|
|
|
Annotation of /lisp/tools/slider.l
Parent Directory
| 
Revision Log