Annotation of /skeleton-edit/slider.lAnnotation of /skeleton-edit/slider.l
Parent Directory
| 
Revision Log
Revision: 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-skeleton-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 : |
|
ktanaka Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |