;; ------------ ;; ;; 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))))