View of /lisp/tools/slider.l

Parent Directory

Revision Log

change to CVS wadalab font project

;;----------;;
;; slider.l ;;
;;----------;;

;; スライド抵抗のようなウィンドウを作る ;;

(defun create-slider-win (parent title x y right left var-name default
				 black white font
				 (len *default-slider-length*))
  `(setq ,var-name nil)
  (lets	((as (font-ascent font))
	 (de (font-descent font))
	 (leftstr  (flonum->string16 left))
	 (rightstr (flonum->string16 right))
	 (titleofs *menu-margin*)
	 (numofs   (+ titleofs
		      (text-width font title)
		      *menu-margin*))
	 (sliderofs (+ numofs
		       (max 
			(text-width font leftstr)
			(text-width font rightstr))
		       (* 4 *menu-margin*)))
	 
	 (wid  (+ sliderofs
		  len
		  (* 6 *menu-margin*)))
	 
	 (hei (+ as de (* 2 *menu-margin*)))
	 (mw (create-win parent x y wid hei black white font)))

    (setf (window-cursor mw) hair-cross-cursor)
    
    (setf (window-border mw) 0)
    (setf (window-event-mask mw) '(:exposure 
				   :button-press
				   :enter-window   :leave-window))
    
    (put-winprop mw 'enter-notify-handler (function draw-frame-win))
    (put-winprop mw 'leave-notify-handler (function erase-frame-win))
    (put-winprop mw 'display-string title)
    (put-winprop mw 'title-offset titleofs)
    (put-winprop mw 'number-offset numofs)
    (put-winprop mw 'slider-offset sliderofs)
    (put-winprop mw 'slider-left   left)
    (put-winprop mw 'slider-right  right)
    (put-winprop mw 'slider-now-value nil)
    (put-winprop mw 'string-offset-y (+ as *menu-margin*))
    (put-winprop mw 'slider-offset-y (// hei 2))
    (put-winprop mw 'slider-length len)
    
    (put-winprop mw 'button-press-handler 
		 `(lambda (win code x y)
		    (setq ,var-name (slider-handler win code x y))))
    
    (set var-name (slider-handler 
		   mw 
		   0 
		   (left-now-right left default right
				   sliderofs
				   (+ sliderofs len))
		   0))
    mw))

(defun left-now-right (left now right start stop)
  (quotient (plus (times start (difference now left))
		  (times stop  (difference right now)))
	    (difference right left)))

(defun slider-handler (win code x y)
  (let* ((left (get-winprop win 'slider-left))
	 (right (get-winprop win 'slider-right))
	 (x-left (get-winprop win 'slider-offset))
	 (x-right (+ x-left (get-winprop win 'slider-length)))
	 (newvalue nil)
	 (oldvalue (get-winprop win 'slider-now-value))
	 (oldvalue-x nil)
	 (center-y (get-winprop win 'slider-offset-y))
	 (radius 3))

    (comment print (list 'slider-handler x-left x-right))

    (if (lessp x x-left) (setq x x-left))
    (if (greaterp x x-right) (setq x x-right))
    (setq newvalue (left-now-right x-left x x-right left right))
    
    (draw-string16-win win (flonum->string16 newvalue)
		       (get-winprop win 'number-offset)
		       (get-winprop win 'string-offset-y))
    
    (comment print (list 'oldvalue oldvalue))
    
    (clear-win win)
    (draw-string16-win win
		       (get-winprop win 'display-string)
		       (get-winprop win 'title-offset)
		       (get-winprop win 'string-offset-y))
    (draw-string16-win win (flonum->string16 newvalue)
		       (get-winprop win 'number-offset)
		       (get-winprop win 'string-offset-y))
    (draw-line-win win x-left center-y x-right center-y)
    (draw-line-win win 
		   x-left (- center-y 2)
		   x-left (+ center-y 2))
    (draw-line-win win 
		   x-right (- center-y 2)
		   x-right (+ center-y 2))
    
    (draw-circle-win win (fix x) center-y radius)
    (redraw-win win)
    (draw-frame-win win)
    
    (put-winprop win 'slider-now-value newvalue)
    
    (comment print (list 'newvalue newvalue))
    newvalue))


;; ---------------------- ;;
;; make slider menu macro ;;
;; ---------------------- ;;
(defmacro create-slider-menu (parent x y black white fnt . item-list)
  (let ((mw (gensym))
	(height (gensym))
	(width (gensym)))
    (append 
     `(let ((,mw (create-win ,parent ,x ,y 10 10
			     ,black ,white ,fnt))
	    (,height *menu-margin*)
	    (,width  0)))
     (mapcar item-list
	     (function 
	      (lambda (x) 
		`(progn
		   (setq ,(first x)
			 (create-slider-win
			  ,mw
			  ,(second x)
			  *menu-margin*
			  ,height
			  ,(third x)
			  ,(fourth x)
			  ,(fifth x)
			  ,(sixth x)
			  ,black
			  ,white
			  ,fnt))
		   (setq ,height
			 (+ ,height (height-win ,(first x))))
		   (setq ,width
			 (max ,width (width-win ,(first x))))
		   ))))
     
     `((resize-win ,mw 
		   (+ ,width (* 4 *menu-margin*))
		   (+ ,height (* 2 *menu-margin*))))
     (mapcar item-list
	     (function (lambda (x)
			 `(resize-win ,(first x) ,width))))
     `(,mw))))

(comment defun loop-test ()
  (setq %end% nil)
  (main-loop-test display '(lambda () %end%)))

(comment defun main-loop-test (disp isend? (win nil))
  (loop 
   (event-case (disp)
	       (:exposure 
		(event-window count)
		(and (0= count) (handle-exposure event-window))
		t)
	       (:button-press
		(event-window code x y)
		(handle-button-press event-window code x y)
		t)
	       (:enter-notify
		(event-window)
		(handle-enter-notify event-window)
		t)
	       (:leave-notify
		(event-window)
		(handle-leave-notify event-window)
		t)
	       (:motion-notify
		(event-window x y)
		(and (eq event-window win) 
		     (handle-motion-notify event-window x y))
		t)
	       (:client-message
		(event-window type format data)
		(print (list 'client-message event-window type format data))
		(pr data)
		t)
	       (:property-notify
		(event-window atom state time)
		(print (list 'property-notify event-window atom state time))
		t)
	       (otherwise
		()
		(print (list 'other-events))
		t))
   (cond ((funcall isend?) (exit)))))

(comment defun slider-win-test ()
	 (setq %end% nil)
	 (setup-display)
	 (initialize-skelton-edit-sub)
	 (setq main-win (create-win root 0 0 400 400 black white kanji-font))
	 (setf (wm-name main-win) "slider test")
	 
	 (put-winprop main-win 
		      'button-press-handler
		      #'(lambda (win code x y) (setq %end% t)))
	 
	 (setf (window-event-mask main-win) '(:button-press :property-change))
  
	 (setq sliders (create-slider-menu
			main-win 0 0 black white kanji-font
			(sl1 "スラ１" 10.0 90.0 'test-value 30.0)
			(sl2 "スラ２" 0.0 1.0 'test-value-2 0.5)))
	 
	 (map-subwindows sliders)
	 (map-subwindows main-win)
	 (map-window main-win)
	 
	 (loop-test)
	 
	 (print test-value)
	 (print test-value-2)
	 nil)

(defun flonum->string16 (flo (wid 7) (seido 2))
  (setq wid (* 2 wid))
  (let* ((sign nil)
	 (int-part nil)
	 (frac-part nil)
	 (len 2) ;; for point
	 (sign nil)
	 (start 0)
	 (str nil)
	 (int-s nil) 
	 (frac-s nil))

    (when (setq sign (lessp flo 0))
      (setq flo (minus flo))
      (incr len 2))

    (setq int-part (fix flo))
    (setq frac-part (difference flo int-part))
    (do ((i 0 (1+ i)))
	((>= i seido))
	(setq frac-part (times frac-part 10)))
    (setq frac-part (fix frac-part))
    
    (when (eq int-part 0) (push 0 int-s) (incr len 2))
    (do ((n int-part (// n 10)))
	((0= n))
	(push (remainder n 10) int-s)
	(incr len 2))

    (do ((i 0 (1+ i))
	 (n frac-part (// n 10)))
	((>= i seido))
	(push (remainder n 10) frac-s)
	(incr len 2))

    (setq str (make-string (max wid len)))
    (cond ((> wid len)
	   (setq start (- wid len))
	   (setq len wid)
	   (do ((i 0 (+ i 2)))
	       ((>= i start))
	       (sset str i 161)
	       (sset str (1+ i) 161))))

    (when sign
      (sset str start 161)
      (sset str (1+ start) 221)
      (incr start 2))

    (let ((i start))
      (do ((digits int-s))
	  ((null digits))
	  (sset str i 163)
	  (sset str (1+ i) (+ (pop digits) 176))
	  (incr i 2))
      (sset str i 161)
      (sset str (1+ i) 165)
      (incr i 2)
      (do ((digits frac-s))
	  ((null digits))
	  (sset str i 163)
	  (sset str (1+ i) (+ (pop digits) 176))
	  (incr i 2))
      str)))

(comment defun fixnum->string16 (num (wid 4))
  (setq wid (* wid 2))
  (let* ((s nil)
	 (sign nil)
	 (len 0)
	 (start 0)
	 (str nil))

    (when (< num 0) 
      (setq sign t num (minus num))
      (incr len 2))
    
    (do ((n num (// n 10)))
	((0= n))
	(push (remainder n 10) s)
	(incr len 2))
    (setq str (make-string (max wid len)))
    (cond ((> wid len)
	   (setq start (- wid len))
	   (setq len wid)
	   (do ((i 0 (+ i 2)))
	       ((>= i start))
	       (sset str i 161)
	       (sset str (1+ i) 161))))
    (when sign
      (sset str start 161)
      (sset str (1+ start) 221)
      (incr start 2))
    (do ((i start (+ i 2)))
	((>= i len))
	(sset str i 163)
	(sset str (1+ i) (+ (pop s) 176)))
    str))