View of /skeleton-edit/hirapoint.l

Parent Directory

Revision Log

*** empty log message ***

;; ----------- ;;
;; hirapoint.l ;;
;; ----------- ;;

(defun nearest-two-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)
; tanaka 1993/9/20
	 (when (memq (car l) '(hira-long outline stroke))
	   (let* ((p-no (cadr l))
		  (p-1 (car p-no))
		  (p-2 nil))
	     (do ((p (cdr p-no) (cdr p)))
		 ((null p))
		 (setq p-2 (car p))
		 (let* ((pp-1 (nth p-1 points))
			(pp-2 (nth p-2 points))
			(dist (distance-point-line (list x y)
						   (list pp-1 pp-2))))
		   (when (< dist maxdist)
		     (setq maxdist dist)
		     (setq ret (list p-1 p-2 pp-1 pp-2))))
		 (setq p-1 p-2))))))
    (cond ((null ret)
	   nil)
	  ((< maxdist *near-range*)
	   ret)
	  (t
	   nil))))

(defun draw-two-point-of-hira-win! (win point-of-hira)
  (let* ((pp-1 (third point-of-hira))
	 (pp-2 (fourth point-of-hira))
	 (x0 (car pp-1))
	 (y0 (cadr pp-1))
	 (x1 (car pp-2))
	 (y1 (cadr pp-2)))
    (draw-xorline-win! win x0 y0 x1 y1)))

(comment defun draw-xor-part-of-hira-win! (win prim x y)
	 (let ((selected (nearest-two-point-of-hira prim x y)))
	   (if %end%
	       (unless (equal %end% selected)
		 (draw-two-point-of-hira-win! %end%)
		 (setq %end% selected)
		 (draw-two-point-of-hira-win! selected))
	     (draw-two-point-of-hira-win! selected)
	     (setq %end% selected))))

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

(defun add-hira-point (win x y prim)
  (let* ((selected (nearest-two-point-of-hira prim x y)))
    (if (null selected)
	(progn (beep win) prim)
      (let* ((points (get-points prim))
	     (lines  (get-lines prim))
	     (info   (get-aux-info prim))
	     (newpnt (list x y))
	     (newnth (length points))
	     (begpnt (car selected))
	     (endpnt (cadr selected))
	     (hline  nil)
	     (hlnnth nil)
	     (newlines nil)
	     (i 0)
	     (ret nil))
	(mapcar lines
		#'(lambda (l)
		    (let ((pnts (cadr l))
			  (info (cddr l)))
		      (when (and (memq (car l) '(hira-long outline stroke))
				 (memq begpnt pnts)
				 (memq endpnt pnts))
			(let* ((top (takewhile `(lambda (x) (<> x ,begpnt))
					       pnts))
			       (btm 
				(do ((l pnts (cdr l))(ret))
				  ((atom l)ret)
				  (and (eq (car l) endpnt)(setq ret l))))
			       (wid (get-info l 'hirawidth))
			       (widtop nil) (widbtm nil)
			       (newl nil))
			  (setq newl (cons (car l)
					   (ncons (append top
							  (ncons begpnt)
							  (ncons newnth)
							  btm))))
			  (when wid
			    (put-info newl 'hirawidth
				      (let ((tt
					     (topoflist wid (1+ (length top))))
					    (bb
					     (nthcdr (1+ (length top)) wid)))
					(append tt
						(ncons (// (+ (car (last tt))
							      (car bb)) 2))
						bb))))
			  (setq l newl)))
		      (setq newlines (append newlines (ncons l))))))
	(setq ret (cons (append points (ncons newpnt))
			(cons newlines info)))
	(clear-win win)
	(if grid (grid-win win))
	(draw-skeleton-win win ret)
	(redraw-win win)
	ret))))

(defun topoflist (l n)
  (if (= n 0)
      nil
    (cons (car l) (topoflist (cdr l) (1- n)))))

(defun takewhile (pred? l)
  (if (or (null l) (not (funcall pred? (car l))))
      nil
    (cons (car l) (takewhile pred? (cdr l)))))

(defun dropwhile (pred? l)
  (cond ((null l) nil)
	((funcall pred? (car l)) (dropwhile pred? (cdr l)))
	(t l)))