View of /skeleton-edit/edprim.l

Parent Directory

Revision Log

*** empty log message ***

;;
;; edprim.l
;; $Revision: 1.1 $
;; 

(defun get-points (prim)
  (first prim))

(defun get-lines (prim)
  (second prim))

(defun get-aux-info (prim)
  (nthcdr 2 prim))

(defun cl:first (l)
  (if (< (length l) 1)
      nil
    (car l)))

(defun draw-skeleton-win (win prim (mode 'black))
  (if (eq (car prim) 'joint)
      (draw-jointed-primitive-win win prim)
    (draw-simple-skeleton-win win prim mode)))

(defun draw-simple-skeleton-win (win prim (mode 'black))
  (let ((points (get-points prim))
	(lines  (get-lines prim)))
    (mapcar points 
	    #'(lambda (x) 
		(if (cl:first (get-info x 'link-ok))
		    (draw-sikaku-win  win (first x) (second x))
		  (draw-sankaku-win win (first x) (second x)))))

    (mapcar lines 
	    #'(lambda (x)
		(lets ((pointlist (second x))
		       (linenum (- (length pointlist) 1)))
		  (do ((i 0 (1+ i)))
		      ((>= i linenum))
		      (comment print (list i linenum))
		      (lets ((p0 (nth (nth i      pointlist) points))
			     (p1 (nth (nth (1+ i) pointlist) points))
			     (x0 (first p0))
			     (y0 (second p0))
			     (x1 (first p1))
			     (y1 (second p1)))
			(draw-line-win win x0 y0 x1 y1 mode))))))

    (mapcar lines
	    #'(lambda (l)
		(let ((elmname (first l)))
		  (let ((draw-func (get elmname 'skeleton-edit-draw-optional)))
		    (if draw-func
			(funcall draw-func win l points))))))
    
    (mapcar lines
	    #'(lambda (x)
		(lets ((hirawidth (get-info x 'hirawidth))
		       (pointlist (second x)))
		  (when (and hirawidth pointlist)
		    (do ((nowpnt pointlist (cdr nowpnt))
			 (nowwid hirawidth (cdr nowwid)))
			((or (null nowpnt) (null nowwid)))
			(lets ((now (nth (first nowpnt) points))
			       (r (first nowwid))
			       (x (first now))
			       (y (second now)))
			  (draw-circle-win win x y r)))))))

    (let ((xu (get-prim-info prim 'xunit))
	  (yu (get-prim-info prim 'yunit)))
      (if (and xu yu)
	  (lets ((center (center-of-primitive prim))
		 (cx (car center))
		 (cy (cadr center))
		 (xunit (fix (cdr xu)))
		 (yunit (fix (cdr yu)))
		 (x0 (difference cx (quotient xunit 2)))
		 (y0 (difference cy (quotient yunit 2))))
	    (draw-dash-rectangle-win win x0 y0 xunit yunit)
	    (comment print (list xunit yunit)))))
    ))

(defun draw-dash-rectangle-win (win x y xwid ywid)
  (draw-rectangle (get-winprop win 'save)
		  (get-winprop win 'dashlinegc)
		  x y xwid ywid))
      
(defun rem-nth (n l)
  (do ((ret nil)
       (i 0 (1+ i))
       (rest l (cdr rest)))
      ((or (> i n) (null rest)) ret)
      (cond ((< i n) (setq ret (append ret (list (first rest)))))
	    (t       (setq ret (append ret (cdr rest)))))))

(defun uniq (l)
  (let ((ret nil))
    (mapcar l (function (lambda (x) 
			  (if (not (memq x ret)) (push x ret)))))
    ret))

(defun cl:second (l)
  (if (< (length l) 2) 
      nil
    (second l)))

(defun neighbor (item l)
  (lets ((left  (memq item l))
	 (right (memq item (reverse l)))
	 (ltop  (cl:second left))
	 (rtop  (cl:second right)))
    (append (if ltop (ncons ltop) nil)
	    (if rtop (ncons rtop) nil))))

(defun connected-points (n prim)
  (let ((points   (get-points prim))
	(lines    (get-lines  prim))
	(retpoints nil))
    (mapcar lines 
	    (function 
	     (lambda (x)
	       (setq retpoints (append (neighbor n (second x)) retpoints)))))
    
    
    (setq retpoints (uniq retpoints))
    (mapcar retpoints 
	    (function (lambda (x) (nth x points))))))

(defun cl:third (l)
  (if (< (length l) 3)
      nil
    (third l)))

(defun move-skeleton-point (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*)
		 (let ((source (connected-points nth-nearest prim)))
		   (mapcar source 
			   #'(lambda (x) (draw-line-win win
							(first nearest)
							(second nearest)
							(first x)
							(second x)
							'white)))
		   (draw-sikaku-win win 
				    (first nearest) (second nearest) 'white)
		   (redraw-win win)
		   (setq nearest 
			 (get-position:drag-lines win now source 
						  *end-by-release*))
		   
		   (lets ((link-info (cl:third (nth nth-nearest points)))
			  (new-nth   (if link-info
					 (append nearest (ncons link-info))
				       nearest)))
		     (setf (nth nth-nearest points) new-nth))))
		(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))