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

Annotation of /lisp/tools/hirapoint.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;; ----------- ;;
2 :     ;; hirapoint.l ;;
3 :     ;; ----------- ;;
4 :    
5 :     (defun nearest-two-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 :     ; tanaka 1993/9/20
15 :     (when (memq (car l) '(hira-long outline stroke))
16 :     (let* ((p-no (cadr l))
17 :     (p-1 (car p-no))
18 :     (p-2 nil))
19 :     (do ((p (cdr p-no) (cdr p)))
20 :     ((null p))
21 :     (setq p-2 (car p))
22 :     (let* ((pp-1 (nth p-1 points))
23 :     (pp-2 (nth p-2 points))
24 :     (dist (distance-point-line (list x y)
25 :     (list pp-1 pp-2))))
26 :     (when (< dist maxdist)
27 :     (setq maxdist dist)
28 :     (setq ret (list p-1 p-2 pp-1 pp-2))))
29 :     (setq p-1 p-2))))))
30 :     (cond ((null ret)
31 :     nil)
32 :     ((< maxdist *near-range*)
33 :     ret)
34 :     (t
35 :     nil))))
36 :    
37 :     (defun draw-two-point-of-hira-win! (win point-of-hira)
38 :     (let* ((pp-1 (third point-of-hira))
39 :     (pp-2 (fourth point-of-hira))
40 :     (x0 (car pp-1))
41 :     (y0 (cadr pp-1))
42 :     (x1 (car pp-2))
43 :     (y1 (cadr pp-2)))
44 :     (draw-xorline-win! win x0 y0 x1 y1)))
45 :    
46 :     (comment defun draw-xor-part-of-hira-win! (win prim x y)
47 :     (let ((selected (nearest-two-point-of-hira prim x y)))
48 :     (if %end%
49 :     (unless (equal %end% selected)
50 :     (draw-two-point-of-hira-win! %end%)
51 :     (setq %end% selected)
52 :     (draw-two-point-of-hira-win! selected))
53 :     (draw-two-point-of-hira-win! selected)
54 :     (setq %end% selected))))
55 :    
56 :     (defun setup-add-hira-point ()
57 :     (setq %end% nil))
58 :    
59 :     (defun add-hira-point (win x y prim)
60 :     (let* ((selected (nearest-two-point-of-hira prim x y)))
61 :     (if (null selected)
62 :     (progn (beep win) prim)
63 :     (let* ((points (get-points prim))
64 :     (lines (get-lines prim))
65 :     (info (get-aux-info prim))
66 :     (newpnt (list x y))
67 :     (newnth (length points))
68 :     (begpnt (car selected))
69 :     (endpnt (cadr selected))
70 :     (hline nil)
71 :     (hlnnth nil)
72 :     (newlines nil)
73 :     (i 0)
74 :     (ret nil))
75 :     (mapcar lines
76 :     #'(lambda (l)
77 :     (let ((pnts (cadr l))
78 :     (info (cddr l)))
79 :     (when (and (memq (car l) '(hira-long outline stroke))
80 :     (memq begpnt pnts)
81 :     (memq endpnt pnts))
82 :     (let* ((top (takewhile `(lambda (x) (<> x ,begpnt))
83 :     pnts))
84 :     (btm
85 :     (do ((l pnts (cdr l))(ret))
86 :     ((atom l)ret)
87 :     (and (eq (car l) endpnt)(setq ret l))))
88 :     (wid (get-info l 'hirawidth))
89 :     (widtop nil) (widbtm nil)
90 :     (newl nil))
91 :     (setq newl (cons (car l)
92 :     (ncons (append top
93 :     (ncons begpnt)
94 :     (ncons newnth)
95 :     btm))))
96 :     (when wid
97 :     (put-info newl 'hirawidth
98 :     (let ((tt
99 :     (topoflist wid (1+ (length top))))
100 :     (bb
101 :     (nthcdr (1+ (length top)) wid)))
102 :     (append tt
103 :     (ncons (// (+ (car (last tt))
104 :     (car bb)) 2))
105 :     bb))))
106 :     (setq l newl)))
107 :     (setq newlines (append newlines (ncons l))))))
108 :     (setq ret (cons (append points (ncons newpnt))
109 :     (cons newlines info)))
110 :     (clear-win win)
111 :     (if grid (grid-win win))
112 :     (draw-skelton-win win ret)
113 :     (redraw-win win)
114 :     ret))))
115 :    
116 :     (defun topoflist (l n)
117 :     (if (= n 0)
118 :     nil
119 :     (cons (car l) (topoflist (cdr l) (1- n)))))
120 :    
121 :     (defun takewhile (pred? l)
122 :     (if (or (null l) (not (funcall pred? (car l))))
123 :     nil
124 :     (cons (car l) (takewhile pred? (cdr l)))))
125 :    
126 :     (defun dropwhile (pred? l)
127 :     (cond ((null l) nil)
128 :     ((funcall pred? (car l)) (dropwhile pred? (cdr l)))
129 :     (t l)))
130 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help