View of /skeleton-edit/xyunit.l

Parent Directory

Revision Log

*** empty log message ***

;; -------- ;;
;; xyunit.l ;;
;; -------- ;;

(defun get-prim-info (prim key)
  (let* ((info (get-aux-info prim))
	 (loc  (assq key info)))
    loc))

(defun put-prim-info (prim key value)
  (let ((loc (get-prim-info prim key)))
    (if (null loc)
	(nconc (get-aux-info prim) (ncons (cons key value)))
      (setf (cdr loc) value))))

(defun center-of-primitive (prim)
  (lets ((edges (range-of-primitive-of-jp prim #(1.0 0.0 0.0 1.0 0.0 0.0)))
	 (minimum (car edges))
	 (maximum (cadr edges)))
    (list (quotient (plus (car minimum) (car maximum)) 2)
	  (quotient (plus (cadr minimum) (cadr maximum)) 2))))

(defun get-position:resize-boxes (win cx cy 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))
    (comment print 'enter-resize-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) 
		    (resize-boxes-win! win ,cx ,cy x y)))
    
    (setf (window-event-mask win) '(:exposure
				    :button-press
				    :button-release
				    :pointer-motion))
    
    (resize-boxes-win! win cx cy 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-resize-boxes-mode)
    %pred-position%))

(defun draw-xor-center-box-win! (win cx cy x y)
  (lets ((half-width  (abs (difference cx x)))
	 (half-height (abs (difference cy y)))
	 (xx (if (lessp cx x) (difference cx half-width) x))
	 (yy (if (lessp cy y) (difference cy half-height) y)))
    (draw-rectangle win
		    (get-winprop win 'xorgc)
		    xx yy (times 2 half-width) (times 2 half-height))))

(defun resize-boxes-win! (win cx cy x y)
  (let ((now (list x y)))
    (if %pred-position%
	(when (not (equal %pred-position% (list x y)))
	  (lets ((px (car %pred-position%))
		 (py (cadr %pred-position%)))
	    (draw-xor-center-box-win! win cx cy px py))))
    (draw-xor-center-box-win! win cx cy x y)
    (setq %pred-position% now)))

(defun edit-xyunit-of-primitive (win x y niti)
  (lets ((center (center-of-primitive niti))
	 (x0 (car center))
	 (y0 (cadr center))
	 (nxy (get-position:resize-boxes win x0 y0 x y *end-by-release*))
	 (nxunit 
	  (times 2 (abs (difference x0 (car nxy)))))
	 (nyunit
	  (times 2 (abs (difference y0 (cadr nxy))))))
    (put-prim-info niti 'xunit nxunit)
    (put-prim-info niti 'yunit nyunit)
    (clear-win editor)
    (if grid (grid-win editor))
    (draw-skeleton-win editor niti)
    (redisplay-win editor)

    (setf (window-cursor editor) please-wait-cursor)
    (display-force-output display)
    (show-temporary-nikuduked-skeletons temporary-window)
    (setf (window-cursor editor) hair-cross-cursor)

    niti))

(defun draw-temporary-nikuduked-skeleton-win! (win prim 
						  xwid ywid
						  xofs yofs
						  (mincho-gothic 'mincho))
  (setq prim (shapeup-skeleton prim))
  (when (not (null (car prim)))
    (let ((outline (skeleton2list (applykanji prim) mincho-gothic))
	  (save (get-winprop win 'button-press-handler))
	  (loopend nil))
      (mapcar outline 
	      #'(lambda (x)
		  (fill-polygon-win! 
		   win
		   (mapcar (setpart1 x)
			   #'(lambda (xy)
			       (let ((r (cons (plus xofs 
						    (quotient 
						     (times xwid (car xy))
						     400))
					      (plus yofs
						    (quotient 
						     (times ywid (cdr xy))
						     400)))))
				 r))))))
      (display-force-output (window-display win)))))

(defun draw-temporary-nikuduked-skeleton-win (win prim 
						 xwid ywid
						 xofs yofs
						 (mincho-gothic 'mincho))
  (setq prim (shapeup-skeleton prim))
  (when (not (null (car prim)))
    (let ((outline (skeleton2list (applykanji prim) mincho-gothic))
	  (save (get-winprop win 'button-press-handler))
	  (loopend nil))
      (mapcar outline 
	      #'(lambda (x)
		  (fill-polygon-win
		   win
		   (mapcar (setpart1 x)
			   #'(lambda (xy)
			       (let ((r (cons (plus xofs 
						    (quotient 
						     (times xwid (car xy))
						     400))
					      (plus yofs
						    (quotient 
						     (times ywid (cdr xy))
						     400)))))
				 r)))))))))


(defun fill-polygon-win (win points (mode 'black))
  (draw-lines (get-winprop win 'save)
	      (selectq mode 
		(white (get-winprop win 'savewhitegc))
		(black (get-winprop win 'saveblackgc))
		(t     (funcall err:argument-type mode)))
	      (cons2flat points)
	      :fill-p t))

(defun remove-assq (a-list key)
  (cond ((null a-list)
	 nil)
	((eq (caar a-list) key)
	 (remove-assq (cdr a-list) key))
	(t
	 (cons (car a-list)
	       (remove-assq (cdr a-list) key)))))

(defun remove-prim-info (prim key)
  (let ((points (get-points prim))
	(lines  (get-lines prim))
	(info   (get-aux-info prim)))
    (cons points
	  (cons lines
		(remove-assq info key)))))
    
(defun remove-prim-xyunit (prim)
  (remove-prim-info (remove-prim-info prim 'xunit) 'yunit))

(defun add-default-xyunit (prim)
  (add-unit (remove-prim-xyunit prim)))