View of /skeleton-edit/edjoint.l

Parent Directory

Revision Log

*** empty log message ***

;;-----------;;
;; edjoint.l ;;
;;-----------;;

(defun triads-of-jointed-primitive (prim)
  (comment prind prim)
  (let* ((vecs (cadr (second prim)))
	 (subs (cadr (third prim)))
	 (ret nil))
    (loop
     (let* ((v (car vecs))
	    (s (car subs))
	    (as (applykanji s)))
       
       (push (list s v as) ret)
       
       (setq vecs (cdr vecs)
	     subs (cdr subs))
       (if (or (endp vecs) (endp subs)) (exit))))
    ret))

(defun frame-points-of-primitive (prim)
  (let* ((pr (applykanji prim))
	 (points (car pr))
	 (1st (car points)))
    (do ((points (cdr points) (cdr points))
	 (maxx (car 1st))
	 (minx (car 1st))
	 (maxy (cadr 1st))
	 (miny (cadr 1st)))
	((endp points) (list (list minx miny) (list maxx maxy)))
	(let* ((p (car points))
	       (x (car p))
	       (y (cadr p)))
	  (cond ((lessp x minx) (setq minx x))
		((greaterp x maxx) (setq maxx x)))
	  (cond ((lessp y miny) (setq miny y))
		((greaterp y maxy) (setq maxy y)))))))

(defun range-of-primitive-of-jp (prim vec)
  (let* ((frame (frame-points-of-primitive prim))
	 (ps (affine-translate-points frame vec))
	 (x0 (caar ps))
	 (y0 (cadar ps))
	 (x1 (caadr ps))
	 (y1 (cadadr ps))
	 (xx0 (times (plus (times 9.0 x0) x1) 0.1))
	 (xx1 (times (plus x0 (times 9.0 x1)) 0.1))
	 (yy0 (times (plus (times 9.0 y0) y1) 0.1))
	 (yy1 (times (plus y0 (times 9.0 y1)) 0.1)))
    (list (list (tofix xx0) (tofix yy0))
	  (list (tofix xx1) (tofix yy1)))))

(defun draw-frame-of-primitive-win (win prim vec)
  (let* ((range (range-of-primitive-of-jp prim vec))
	 (xx0 (caar range))
	 (yy0 (cadar range))
	 (xx1 (caadr range))
	 (yy1 (cadadr range)))
    (draw-rectangle-win win xx0 yy0 xx1 yy1)))

(defun draw-joint-vecs-primname-win (win prim)
  (let* ((vecs (cadr (second prim)))
	 (subs (cadr (third prim)))
	 (a-list (cdddr prim)))
    (loop
     (let ((v (car vecs))
	   (s (applykanji (car subs))))
       (if grid (grid-win win))
       (draw-skeleton-win win (affine-translate-pure-primitive s v))
       (draw-frame-of-primitive-win win s v)
       (setq vecs (cdr vecs)
	     subs (cdr subs))
       (if (or (endp vecs) (endp subs)) (exit))))))

(defun draw-jointed-primitive-win (win pr)
  (if (and (listp pr) (eq (car pr) 'joint))
      (draw-joint-vecs-primname-win win pr)
    (draw-joint-vecs-primname-win win (expandkanji pr))))

(defun draw-nikuduked-jointed-primitive-win! (win pr-def)
  (let* ((prim pr-def)
	 (vecs (cadr (second prim)))
	 (subs (cadr (third prim)))
	 (a-list (cdddr prim)))
    (clear-win! win)
    (loop
     (let ((v (car vecs))
	   (s (car subs)))
       
       (draw-nikuduked-skeleton-win!
	win 
	(affine-translate-pure-primitive (applykanji s) v)
	'mincho)
       
       (setq vecs (cdr vecs)
	     subs (cdr subs))
       (if (or (endp vecs) (endp subs)) (exit))))))

(defun redisplay-win (win)
  (redraw-win win)
  (display-force-output (window-display win)))

(defun inrange (nowpoint range)
  (let ((nowx (car nowpoint))
	(nowy (cadr nowpoint))
	(x0 (caar range))
	(y0 (cadar range))
	(x1 (caadr range))
	(y1 (cadadr range)))
    (and (lessp x0 nowx) (lessp nowx x1)
	 (lessp y0 nowy) (lessp nowy y1))))

(defun move-primitive-of-jointed-primitive (win code x0 y0)
  (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)
	 (whichprim-nth nil)
	 (whichprim nil)
	 (nth-prim nil)
	 (range nil)
	 (triads (triads-of-jointed-primitive joint-prim-def)))
    
    (setq whichprim-nth
	  (do ((len (length triads))
	       (nowp triads (cdr nowp))
	       (i 0 (1+ i))
	       (found nil))
	      ((or found (endp nowp)) (cons (- len i) found))
	      (let* ((pr (car nowp))
		     (vec (second pr))
		     (prdef (third pr)))
		(setq range (range-of-primitive-of-jp prdef vec))
		(if (inrange (list x0 y0) range)
		    (setq found pr)))))
    
    (setq whichprim (cdr whichprim-nth)
	  nth-prim (car whichprim-nth))
    (if (null whichprim) 
	(progn (beep win) joint-prim-def)
      (catch 'exit-move-pjp
	(let ((prim-n (car whichprim))
	      (prim-vec  (cadr whichprim))
	      (prim-def  (caddr whichprim)))
	  
	  (let* ((minx (caar range))
		 (miny (cadar range))
		 (maxx (caadr range))
		 (maxy (cadadr range))
		 (xwid (// (- maxx minx) 2))
		 (ywid (// (- maxy miny) 2)))
	    
	    (draw-corner-xorbox-win! win minx miny maxx maxy)
	    (draw-corner-dashbox-win! win minx miny maxx maxy)
	    
	    (setq %pred-position% nil)
	    (setq %end% nil)
	    
	    (put-winprop win
			 'button-press-handler
			 #'(lambda (win code x y) 
			     (setq %end% (if (eq code *end-mode*)
					     'exit-move-some
					   t))
			     (setq %pred-position% (list x y))))
	    
	    (put-winprop win
			 'motion-notify-handler
			 `(lambda (win x y) 
			    (move-boxes-win! win x y ,xwid ,ywid)))
	    
	    (setf (window-event-mask win) '(:exposure
					    :button-press
					    :button-release
					    :pointer-motion))
	    
	    (move-boxes-win! win x0 y0 xwid ywid)
	    
	    (loop-disable-other-win win #'(lambda () %end%))
	    
	    (if (eq %end% 'exit-move-some) (throw 'exit-move-pjp nil))
	    
	    (let* ((src joint-prim-def)
		   (vecs (cadadr src))
		   (v    (nth nth-prim vecs))
		   (dx (difference (first %pred-position%) 
				   (times (plus minx maxx) 0.5)))
		   (dy (difference (second %pred-position%) 
				   (times (plus miny maxy) 0.5)))
		   (e (vref v 4))
		   (f (vref v 5))
		   
		   (vec (vector (vector-length v) v)))
	      (setf (nth nth-prim vecs) vec)

	      (vset vec 4 (plus e dx))
	      (vset vec 5 (plus f dy))
	      
	      (clear-win win)
	      (draw-joint-vecs-primname-win win src)
	      (redraw-win win)
	      
	      (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)
	      src
	      )))))))

(defun draw-rectangle-win (win x y x1 y1 (mode 'black))
  (setq x (fix x) y (fix y) x1 (fix x1) y1 (fix y1))
  (draw-rectangle (get-winprop win 'save)
                  (selectq mode
                    (white (get-winprop win 'savewhitegc))
                    (black (get-winprop win 'saveblackgc))
                    (t (funcall err:argument-type mode)))
		  x y (- x1 x) (- y1 y)))

(defun resize-primitive-of-jointed-primitive (win code x0 y0)
  (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)
	 (whichprim-nth nil)
	 (whichprim nil)
	 (nth-prim nil)
	 (range nil)
	 (triads (triads-of-jointed-primitive joint-prim-def)))
    
    (setq whichprim-nth
	  (do ((len (length triads))
	       (nowp triads (cdr nowp))
	       (i 0 (1+ i))
	       (found nil))
	      ((or found (endp nowp)) (cons (- len i) found))
	      (let* ((pr (car nowp))
		     (vec (second pr))
		     (prdef (third pr)))
		(setq range (range-of-primitive-of-jp prdef vec))
		(if (inrange (list x0 y0) range)
		    (setq found pr)))))
    
    (setq whichprim (cdr whichprim-nth)
	  nth-prim (car whichprim-nth))
    (if (null whichprim) 
	(progn (beep win) joint-prim-def)
      (catch 'exit-move-pjp
	(let ((prim-n (car whichprim))
	      (prim-vec  (cadr whichprim))
	      (prim-def  (caddr whichprim)))
	  
	  (let* ((minx (caar range))
		 (miny (cadar range))
		 (maxx (caadr range))
		 (maxy (cadadr range))
		 (xfar nil)
		 (yfar nil)
		 (xnear nil)
		 (ynear nil))
	    
	    (if (greaterp (difference x0 minx) (difference maxx x0))
		(setq xfar minx xnear maxx)
	      (setq xfar maxx xnear minx))
	    (if (greaterp (difference y0 miny) (difference maxy y0))
		(setq yfar miny ynear maxy)
	      (setq yfar maxy ynear miny))
	    
	    (draw-corner-xorbox-win! win minx miny maxx maxy)
	    (draw-corner-dashbox-win! win minx miny maxx maxy)
	    
	    (setq %pred-position% nil)
	    (setq %end% nil)
	    
	    (put-winprop win
			 'button-press-handler
			 #'(lambda (win code x y) 
			     (setq %end% (if (eq code *end-mode*)
					     'exit-move-some
					   t))
			     (setq %pred-position% (list x y))))
	    
	    (put-winprop win
			 'motion-notify-handler
			 `(lambda (win x y) 
			    (drag-corner-boxes-win! win ,xfar ,yfar x y)))
	    
	    (setf (window-event-mask win) '(:exposure
					    :button-press
					    :button-release
					    :pointer-motion))
	    
	    
	    (loop-disable-other-win win #'(lambda () %end%))
	    
	    (if (eq %end% 'exit-move-some) (throw 'exit-move-pjp nil))
	    
	    (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)
	    
	    (let* ((src joint-prim-def)
		   (vecs (cadadr src))
		   (v (nth nth-prim vecs))
		   (vec (vector (vector-length v) v))
		   (from (list (list xfar yfar) (list xnear ynear)))
		   (to   (list (list xfar yfar) %pred-position%))
		   (newvec (affine-affine (resolve-affine from to)
					  vec)))

	      (setf (nth nth-prim vecs) vec)
	      
	      (do ((i 0 (1+ i)))
		  ((>= i 6))
		  (vset vec i (vref newvec i)))
	      
	      (clear-win win)
	      (draw-joint-vecs-primname-win win src)
	      (redraw-win win)
	      
	      src)))))))