View of /lisp/tools/delprim.l

Parent Directory

Revision Log

change to CVS wadalab font project

;;
;; delprim.l
;; $Revistion$
;;

(defun distance-point-element (org points elem)
  (lets ((linepoints (second elem))
	 (kouho-distance *range-too-large*))
    (if (= (length linepoints) 1)
	(min kouho-distance 
	     (distance-points org (nth (first linepoints) points)))
      (do ((rest linepoints (cdr rest))
	   (next (cdr linepoints) (cdr next)))
	  ((null next) kouho-distance)
	  (lets ((p1 (first rest))
		 (p2 (first next))
		 (ko-line (list
			   (nth p1 points)
			   (nth p2 points)))
		 (now-distance (distance-point-line 
				org 
				ko-line)))
	    (if (< now-distance kouho-distance)
		(setq kouho-distance now-distance)))))))

(defun nth-of-nearest-element (org points lines)
  (let ((kouho-distance (distance-point-element org points (car lines)))
        (kouho-line    0))
    (do ((rest (cdr lines) (cdr rest))
	 (i 1 (1+ i)))
	((null rest) kouho-line)
	(lets ((now (car rest))
	       (now-distance (distance-point-element org points now)))
	  (cond ((< now-distance kouho-distance)
		 (setq kouho-distance now-distance
		       kouho-line i)))))))

(defun delete-skelton-element (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 lines
	(lets ((nth-nearest (nth-of-nearest-element now points lines))
	       (nearest (nth nth-nearest lines)))
	  (cond ((< (distance-point-element now points nearest) *near-range*)
		 (setq lines (rem-nth nth-nearest lines)))
		(t (beep win))))
      (beep win))
    (setq ret (shapeup-skelton (cons points (cons lines aux-info))))
    (clear-win win)
    (if grid (grid-win win))
    (draw-skelton-win win ret)
    (redraw-win win)
    ret))

(defun draw-dash-nth-element-win! (win prim n)
  (lets ((points (get-points prim))
	 (lines  (get-lines  prim))
	 (pointlist (second (nth n lines)))
	 (linenum (1- (length pointlist))))
    (do ((i 0 (1+ i)))
	((>= 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 
		     (get-winprop win 'dashlinegc)
		     x0 y0 x1 y1)))))

(defun draw-nth-element-win! (win prim n)
  (lets ((points (get-points prim))
	 (lines  (get-lines  prim))
	 (pointlist (second (nth n lines)))
	 (linenum (1- (length pointlist))))
    (do ((i 0 (1+ i)))
	((>= 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 (get-winprop win 'blackgc)
		     x0 y0 x1 y1)))))


(setq %pred-nearest-element% nil)
(defun nearest-line-dotted (win x y prim)
  (lets ((points (get-points prim))
	 (lines (get-lines prim))
	 (now (list x y)))
    (when lines
      (lets ((nth-nearest (nth-of-nearest-element now points lines))
	     (nearest (nth nth-nearest lines))
	     (distance (distance-point-element now points nearest))
	     (leng-lines (length lines)))
	(comment
	 (print (list %pred-nearest-element% nth-nearest
		      distance *near-range*)))
	(cond ((and (neq %pred-nearest-element% nth-nearest)
		    (< distance *near-range*))
	       (if (and %pred-nearest-element%
			(< %pred-nearest-element% leng-lines))
		   (draw-nth-element-win! win prim %pred-nearest-element%))
	       (draw-dash-nth-element-win! win prim nth-nearest)
	       (display-force-output (window-display win))
	       (setq %pred-nearest-element% nth-nearest))
	      ((and (eq %pred-nearest-element% nth-nearest)
		    (< distance *near-range*))
	       'do-nothing)
	      ((and %pred-nearest-element%
		    (< %pred-nearest-element% leng-lines))
	       (draw-nth-element-win! win prim %pred-nearest-element%)
	       (setq %pred-nearest-element% nil)))))))