View of /skeleton-edit/nolink.l

Parent Directory

Revision Log

*** empty log message ***

;;
;;  nolink.l
;;  $Revision: 1.1 $
;;

(defun toggle-skeleton-link (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))
	       (ret nil))
	  (cond ((< (distance-points now nearest) *near-range*)
		 (lets ((l-info (cl:first (get-info nearest 'link-ok))))
		   (put-info nearest 'link-ok (ncons (not l-info)))))
		(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 recursive-copy (s)
  (cond ((listp s) (cons (recursive-copy (car s))
			 (recursive-copy (cdr s))))
	((vectorp s) (let* ((len (vector-length s))
			    (ret (vector len)))
		       (do ((i 0 (1+ i)))
			   ((>= i len))
			   (vset ret i (recursive-copy (vref s i))))
		       (comment print (list 'vector s ret))
		       ret))
	 
	((stringp s) (string-append "" s))
	((atom s) s)
	(t 
	 (print (list 'hatena s))
	 s)))

(defun shapeup-skeleton (prim (leave nil))
  (cond ((null prim) '(nil nil))
	((and (listp prim) (eq (car prim) 'joint))
	 (recursive-copy prim))
	((and (listp prim) (symbolp (car prim)))
	 (recursive-copy prim))
	(t
	 (lets ((prrrrr    (recursive-copy prim))
		(points    (get-points prrrrr))
		(lines     (get-lines  prrrrr))
		(aux-info  (get-aux-info prrrrr))
		(reference nil))
	   
	   ;; referenced ?
	   (setq reference (vector (length points) 0))
	   (mapcar lines
		   (function
		    (lambda (l) 
		      (mapc (second l)
			    (function (lambda (x) 
					(vset reference x 1)))))))
	   (do ((i 0 (1+ i))
		(next 0))
	       ((>= i (vector-length reference)))
	       (if (0= (vref reference i))
		   (vset reference i -1)
		 (vset reference i next)
		 (incr next 1)))
	   
	   ;; delete no referenced points
	   (setq points 
		 (do ((i 0 (1+ i))
		      (ret nil)
		      (rest points (cdr rest)))
		     ((null rest) ret)
		     (if (>= (vref reference i) 0)
			 (setq ret (append ret (ncons (first rest)))))))
	   
	   ;; change point-reference in elements
	   (setq lines 
		 (mapcar lines
			 (function
			  (lambda (l)
			    (let ((top (first l))
				  (pos (second l))
				  (line-info (nthcdr 2 l)))
			      (cons top 
				    (cons (mapcar pos
						  (function
						   (lambda (x) 
						     (vref reference x))))
					  line-info)))))))
	   
	   ;; delete (link-ok nil)
	   ;; and float -> fix
	   (setq points (mapcar points
				#'(lambda (p)
				    (setf (car p) (fix (car p)))
				    (setf (cadr p) (fix (cadr p)))
				    (unless (cl:first (get-info p 'link-ok))
				      (rem-info p 'link-ok))
				    p)))
	   
	   ;; make skeleton link
	   (setq 
	    lines
	    (mapcar lines 
		    #'(lambda (l)
; changed by tanaka 1993/9/18
			(cond ((memq (car l) '(outline stroke))
			       (lets ((epoints (cadr l))
				      (apoints 
				       (do ((i 0 (1+ i))
					    (ll epoints (cdr ll))(ret))
					 ((atom ll)(nreverse ret))
					 (and (assq 'link-ok (cddr (nth (car ll) points)))
					     (push i ret)))))
;				 (prind apoints)
				 (if apoints (put-info l 'curve apoints) nil)
;				 (prind l)
				 l))
			      (t
			       (let ((old-links (if leave
						    (get-info l 'link)
						  nil))
				     (links
				      (do ((ret nil)
					   (i 0 (1+ i))
					   (rest points (cdr rest)))
					((null rest) ret)
					(let ((now (car rest)))
					  (when (and 
						 (cl:first (get-info now 'link-ok))
						 (not (memq i (second l)))
						 (< (distance-point-element 
						     now points l) 
						    *link-near-range*))
						(push i ret))))))
				 (setq links (append old-links links))
				 (if links
				     (put-info l 'link links)
				   (rem-info l 'link))
				 (mapcar links
				   #'(lambda (n)
				       (put-info (nth n points)
						 'link-ok (ncons t)))))
			       l)))))
	   
	   ;; result
	   (cons points (cons lines aux-info))))))

(defun make-link-ok-from-old-version (prim)
  (lets ((points    (get-points prim))
	 (lines     (get-lines  prim))
	 (aux-info  (get-aux-info prim))
	 (link-ok-points nil))
     (mapcar lines
	     #'(lambda (now)
; changed by tanaka 1993/9/18		 
		 (let ((ps (or (get-info now 'link)
			       (and (memq (car now) '(outline stroke))
				    (mapcar (get-info now 'curve)
				      #'(lambda (x) (nth x (cadr now))))))))
		   (if ps 
		       (setq link-ok-points
			     (append ps link-ok-points))))))

     (let ((i 0))
       (mapcar points
	       #'(lambda (np)
		   (if (memq i link-ok-points)
		       (put-info np 'link-ok '(t)))
		   (setq i (1+ i)))))
     (cons points (cons lines aux-info))))