View of /skeleton-edit/delhirapnt.l

Parent Directory

Revision Log

*** empty log message ***

;; ------------ ;;
;; delhirapnt.l ;;
;; ------------ ;;

(defun nearest-point-of-hira (prim x y)
  (let ((points (get-points prim))
	(lines  (get-lines prim))
	(info   (get-aux-info prim))
	(maxdist *near-range*)
	(ret nil))
    (mapcar 
     lines
     #'(lambda (l)
	 (when (memq (car l) '(outline stroke hira-long))
	   (let* ((p-no (cadr l)))
	     (do ((p p-no (cdr p)))
		 ((endp p))
		 (let* ((p-1 (car p))
			(pp-1 (nth p-1 points))
			(dist (distance-points (list x y)
					       pp-1)))
		   (when (< dist maxdist)
		     (setq maxdist dist)
		     (setq ret (list p-1 pp-1)))))))))
    (cond ((null ret)
	   nil)
	  ((< maxdist *near-range*)
	   ret)
	  (t
	   nil))))

(defun setup-del-hira-point ()
  (setq %end% nil))

(defun remove-member (mem lst)
  (cond ((null lst) nil)
	((eq (car lst) mem)
	 (remove-member mem (cdr lst)))
	(t 
	 (cons (car lst)
	       (remove-member mem (cdr lst))))))

(defun remove-member-2 (mem lst lst2)
  (cond ((or (null lst) (null lst2))
	 (cons nil nil))
	((eq (car lst) mem)
	 (remove-member-2 mem (cdr lst) (cdr lst2)))
	(t 
	 (let ((sub (remove-member-2 mem (cdr lst) (cdr lst2))))
	   (cons (cons (car lst)  (car sub))
		 (cons (car lst2) (cdr sub)))))))


(defun del-hira-point (win x y prim)
  (let* ((selected (nearest-point-of-hira prim x y)))
    (if (null selected)
	(progn (beep win) prim)
      (setq selected (car selected))
      (let* ((points (get-points prim))
	     (lines  (get-lines prim))
	     (info   (get-aux-info prim))
	     (newlines nil)
	     (ret nil))
	(mapcar lines
		#'(lambda (l)
		    (let ((pnts (cadr l))
			  (info (cddr l))
			  (wid (get-info l 'hirawidth)))
		      (when (and (memq (car l) '(outline stroke hira-long)) (memq selected pnts))
			(if (null wid) 
			    (setq wid (make-list (length pnts)
						 *default-hirawidth*)))
			(let* ((newpntdef (remove-member-2 selected pnts wid))
			       (newpnts (car newpntdef))
			       (newwid  (cdr newpntdef))
			       (newl (cons (car l) (ncons newpnts))))
			  (and (eq (car l) 'hira-long)
			       (put-info newl 'hirawidth newwid))
			  (setq l newl)))
		      (setq newlines (append newlines (ncons l))))))
	(setq ret (shapeup-skeleton (cons points (cons newlines info))))
	
	(clear-win win)
	(if grid (grid-win win))
	(draw-skeleton-win win ret)
	(redraw-win win)
	ret))))