[wadalabfont-kit] / lisp / tools / delhirapnt.l  

Annotation of /lisp/tools/delhirapnt.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;; ------------ ;;
2 :     ;; delhirapnt.l ;;
3 :     ;; ------------ ;;
4 :    
5 :     (defun nearest-point-of-hira (prim x y)
6 :     (let ((points (get-points prim))
7 :     (lines (get-lines prim))
8 :     (info (get-aux-info prim))
9 :     (maxdist *near-range*)
10 :     (ret nil))
11 :     (mapcar
12 :     lines
13 :     #'(lambda (l)
14 :     (when (memq (car l) '(outline stroke hira-long))
15 :     (let* ((p-no (cadr l)))
16 :     (do ((p p-no (cdr p)))
17 :     ((endp p))
18 :     (let* ((p-1 (car p))
19 :     (pp-1 (nth p-1 points))
20 :     (dist (distance-points (list x y)
21 :     pp-1)))
22 :     (when (< dist maxdist)
23 :     (setq maxdist dist)
24 :     (setq ret (list p-1 pp-1)))))))))
25 :     (cond ((null ret)
26 :     nil)
27 :     ((< maxdist *near-range*)
28 :     ret)
29 :     (t
30 :     nil))))
31 :    
32 :     (defun setup-del-hira-point ()
33 :     (setq %end% nil))
34 :    
35 :     (defun remove-member (mem lst)
36 :     (cond ((null lst) nil)
37 :     ((eq (car lst) mem)
38 :     (remove-member mem (cdr lst)))
39 :     (t
40 :     (cons (car lst)
41 :     (remove-member mem (cdr lst))))))
42 :    
43 :     (defun remove-member-2 (mem lst lst2)
44 :     (cond ((or (null lst) (null lst2))
45 :     (cons nil nil))
46 :     ((eq (car lst) mem)
47 :     (remove-member-2 mem (cdr lst) (cdr lst2)))
48 :     (t
49 :     (let ((sub (remove-member-2 mem (cdr lst) (cdr lst2))))
50 :     (cons (cons (car lst) (car sub))
51 :     (cons (car lst2) (cdr sub)))))))
52 :    
53 :    
54 :     (defun del-hira-point (win x y prim)
55 :     (let* ((selected (nearest-point-of-hira prim x y)))
56 :     (if (null selected)
57 :     (progn (beep win) prim)
58 :     (setq selected (car selected))
59 :     (let* ((points (get-points prim))
60 :     (lines (get-lines prim))
61 :     (info (get-aux-info prim))
62 :     (newlines nil)
63 :     (ret nil))
64 :     (mapcar lines
65 :     #'(lambda (l)
66 :     (let ((pnts (cadr l))
67 :     (info (cddr l))
68 :     (wid (get-info l 'hirawidth)))
69 :     (when (and (memq (car l) '(outline stroke hira-long)) (memq selected pnts))
70 :     (if (null wid)
71 :     (setq wid (make-list (length pnts)
72 :     *default-hirawidth*)))
73 :     (let* ((newpntdef (remove-member-2 selected pnts wid))
74 :     (newpnts (car newpntdef))
75 :     (newwid (cdr newpntdef))
76 :     (newl (cons (car l) (ncons newpnts))))
77 :     (and (eq (car l) 'hira-long)
78 :     (put-info newl 'hirawidth newwid))
79 :     (setq l newl)))
80 :     (setq newlines (append newlines (ncons l))))))
81 :     (setq ret (shapeup-skelton (cons points (cons newlines info))))
82 :    
83 :     (clear-win win)
84 :     (if grid (grid-win win))
85 :     (draw-skelton-win win ret)
86 :     (redraw-win win)
87 :     ret))))
88 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help