View of /lisp/tools/edhira.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; edhira.l
;; $Revision: 1.3 $
;;


;; -------------------------- ;;
;; some traditional functions ;;
;; -------------------------- ;;
(defun tofix (x)
  (if (floatp x)
      (fix x)
    x))

(defun toflo (x)
  (if (fixp x)
      (float x)
    x))

;;
;; xor circle
;;
(defun draw-xorcircle-win! (win x y r)
  (let ((diameter (+ r r)))
    (draw-arc win
	      (get-winprop win 'xorgc)
	      (- x r) (- y r) diameter diameter 0 360)))

(defun drag-circles-win! (win x0 y0 r)
  (if %pred-r%
      (when (neq %pred-r% r)
	(draw-xorcircle-win! win x0 y0 %pred-r%)
	(draw-xorcircle-win! win x0 y0 r))
    (draw-xorcircle-win! win x0 y0 r))
  (setq %pred-r% r))

(defun get-radius:drag-circles (win x0 y0 r0 (end-by-release nil))
  (let ((save-bp-handler (get-winprop win 'button-press-handler))
	(save-br-handler (get-winprop win 'button-release-handler))
	(save-mn-handler (get-winprop win 'motion-notify-handler))
	(save-event-mask (window-event-mask win))
	(center (list x0 y0))
	(%pred-r% nil)
	(%end% nil))
    
    (comment print 'enter-drag-circles-mode)
    
    (put-winprop win
		 (if (not end-by-release)
		     'button-release-handler
		   'button-press-handler)
		 nil)
    
    (put-winprop win
		 (if end-by-release
		     'button-release-handler
		   'button-press-handler)
		 `(lambda (win code x y) 
		    (setq %end% t)
		    (setq %pred-r%
			  (fix (sqrt (float (distance-points 
					     (list x y) ',center)))))))
    
    (put-winprop win
		 'motion-notify-handler
		 `(lambda (win x y) 
		    (drag-circles-win! win ,x0 ,y0
				       (fix (sqrt (float
						   (distance-points
						    (list x y)
						    ',center)))))))
    
    (setf (window-event-mask win) '(:exposure
				    :button-press
				    :button-release
				    :pointer-motion))
    
    (drag-circles-win! win x0 y0 r0)
    (loop-disable-other-win win #'(lambda () %end%))
    
    (setf (window-event-mask win) save-event-mask)
    (put-winprop win 
		 'button-press-handler 
		 save-bp-handler)
    (put-winprop win 
		 'button-release-handler 
		 save-br-handler)
    (put-winprop win
		 'motion-notify-handler 
		 save-mn-handler)
    
    (comment print 'exit-drag-circles-mode)
    
    %pred-r%))

;; 
;; width of hiragana
;;
(defun change-hira-width (win code x y prim)
  (lets ((ret nil)
	 (points   (get-points prim))
	 (lines    (get-lines  prim))
	 (aux-info (get-aux-info prim))
	 (now (list x y)))
    (if points
	(lets ((nth-nearest (nth-of-nearest-point now points))
	       (nearest (nth nth-nearest points)))
	  (cond ((< (distance-points nearest now) *near-range*)
		 (lets ((element 
			 (first (mem #'(lambda (x l) (memq x (second l))) 
				     nth-nearest
				     lines)))
			(p-nth (position nth-nearest (second element)))
			(hira-w (get-info element 'hirawidth)))
		   (cond ((memq (first element) *has-hirawidth*)
			  (unless hira-w
			    (put-info element 
				      'hirawidth 
				      (make-list (length (second element)) 
						 *default-hirawidth*))
			    (setq hira-w (get-info element 'hirawidth))
			    (if grid (grid-win win))
			    (draw-skeleton-win win prim)
			    (redraw-win win))
			  
			  (let ((r  (nth p-nth hira-w))
				(x0 (first  nearest))
				(y0 (second nearest)))
			    
			    (draw-xorcircle-win! win x0 y0 r)
			    
			    (setf (nth p-nth hira-w)
				  (get-radius:drag-circles 
				   win x0 y0 
				   (fix (sqrt (float
					       (distance-points
						(list x0 y0)
						(list x y)))))
				   *end-by-release*))))
			 (t (rem-info element 'hirawidth)
			    (beep win)))))
		(t (beep win))))
      (beep win))
    (setq ret (cons points (cons lines aux-info)))
    (clear-win win)
    (if grid (grid-win win))
    (draw-skeleton-win win ret)
    (redraw-win win)
    ret))

(defun draw-xorbox-win! (win x0 y0 x y)
  (lets ((width  (abs (- x x0)))
	 (height (abs (- y y0)))
	 (xx     (if (< x x0) x (- x0 width)))
	 (yy     (if (< y y0) y (- y0 height))))
    (draw-rectangle win
		    (get-winprop win 'xorgc)
		    xx yy (* 2 width) (* 2 height))))

(defun drag-boxes-win! (win x0 y0 x y)
  (let ((now (list x y)))
    (if %pred-position%
	(when (not (equal %pred-position% (list x y)))
	  (draw-xorbox-win! win 
			    x0 y0 
			    (first %pred-position%) (second %pred-position%))
	  (draw-xorbox-win! win x0 y0 x y))
      (draw-xorbox-win! win x0 y0 x y))
    (setq %pred-position% now)))
  
(defun get-position:drag-boxes (win x0 y0 x y (end-by-release nil))
  (let ((save-bp-handler (get-winprop win 'button-press-handler))
	(save-br-handler (get-winprop win 'button-release-handler))
	(save-mn-handler (get-winprop win 'motion-notify-handler))
	(save-event-mask (window-event-mask win))
	(%pred-position% nil)
	(%end% nil))
    
    (print 'enter-drag-boxes-mode)
    
    (put-winprop win
		 (if (not end-by-release)
		     'button-release-handler
		   'button-press-handler)
		 nil)
    
    (put-winprop win
		 (if end-by-release
		     'button-release-handler
		   'button-press-handler)
		 #'(lambda (win code x y) 
		     (setq %end% t)
		     (setq %pred-position% (list x y))))
    
    (put-winprop win
		 'motion-notify-handler
		 `(lambda (win x y) 
		    (drag-boxes-win! win ,x0 ,y0 x y)))
    
    (setf (window-event-mask win) '(:exposure
				    :button-press
				    :button-release
				    :pointer-motion))
    
    (drag-boxes-win! win x0 y0 x y)
    (loop-disable-other-win win #'(lambda () %end%))
    
    (setf (window-event-mask win) save-event-mask)
    (put-winprop win 
		 'button-press-handler 
		 save-bp-handler)
    (put-winprop win 
		 'button-release-handler 
		 save-br-handler)
    (put-winprop win
		 'motion-notify-handler 
		 save-mn-handler)
    
    (comment print 'exit-drag-circles-mode)
    
    %pred-position%))