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

Annotation of /lisp/tools/addhira.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; addhira.l
3 :     ;; $Revision$
4 :     ;;
5 :    
6 :     (defun make-hira-element-long (win code x y prim)
7 :     (lets ((ret nil)
8 :     (points (get-points prim))
9 :     (lines (get-lines prim))
10 :     (aux-info (get-aux-info prim))
11 :     (now (list x y))
12 :     (newposition nil))
13 :     (if lines
14 :     (lets ((nth-nearest-elem (nth-of-nearest-element now points lines))
15 :     (nearest-elem (nth nth-nearest-elem lines)))
16 :     (comment print (list 'nearest-elem nearest-elem))
17 :     (comment print (list 'distance (distance-point-element
18 :     now points nearest-elem)
19 :     *near-range*))
20 :     (cond ((and (< (distance-point-element now points nearest-elem)
21 :     *near-range*)
22 :     (eq (cadr (assq (first nearest-elem) *element-points*))
23 :     'arbitary))
24 :     (lets ((elempoints (second nearest-elem))
25 :     (head (nth (first elempoints) points))
26 :     (tail (nth (car (last elempoints)) points))
27 :     (to-head (distance-points now head))
28 :     (to-tail (distance-points now tail))
29 :     (new-pnum -1))
30 :    
31 :     (setq newposition
32 :     (get-position:drag-lines
33 :     win now
34 :     (ncons (if (< to-head to-tail) head tail))
35 :     *end-by-release*))
36 :     (setq points (append points (ncons newposition)))
37 :     (setq new-pnum (1- (length points)))
38 :     (setf (second nearest-elem)
39 :     (if (< to-head to-tail)
40 :     (cons new-pnum elempoints)
41 :     (append elempoints (ncons new-pnum))))
42 :     (let ((hira-w (get-info nearest-elem 'hirawidth)))
43 :     (cond ((null hira-w)
44 :     (put-info nearest-elem 'hirawidth
45 :     (make-list (length (second nearest-elem))
46 :     *default-hirawidth*)))
47 :     ((< to-head to-tail)
48 :     (put-info nearest-elem 'hirawidth
49 :     (cons *default-hirawidth* hira-w)))
50 :     (t
51 :     (put-info
52 :     nearest-elem 'hirawidth
53 :     (append hira-w
54 :     (ncons *default-hirawidth*))))))))
55 :     (t (beep win))))
56 :     (beep win))
57 :     (setq ret (shapeup-skelton (cons points (cons lines aux-info))))
58 :     (clear-win win)
59 :     (if grid (grid-win win))
60 :     (draw-skelton-win win ret)
61 :     (redraw-win win)
62 :     ret))
63 :    
64 :     (defun make-hira-element-short (win code x y prim)
65 :     (lets ((ret nil)
66 :     (points (get-points prim))
67 :     (lines (get-lines prim))
68 :     (aux-info (get-aux-info prim))
69 :     (now (list x y))
70 :     (newposition nil))
71 :     (if lines
72 :     (lets ((nth-nearest-elem (nth-of-nearest-element now points lines))
73 :     (nearest-elem (nth nth-nearest-elem lines)))
74 :     (cond ((and (< (distance-point-element now points nearest-elem)
75 :     *near-range*)
76 :     (eq (cadr (assq (first nearest-elem) *element-points*))
77 :     'arbitary))
78 :     (lets ((elempoints (second nearest-elem))
79 :     (head (nth (first elempoints) points))
80 :     (tail (nth (car (last elempoints)) points))
81 :     (to-head (distance-points now head))
82 :     (to-tail (distance-points now tail))
83 :     (new-pnum -1))
84 :    
85 :     (setf (second nearest-elem)
86 :     (if (< to-head to-tail)
87 :     (cdr elempoints)
88 :     (reverse (cdr (reverse elempoints)))))
89 :    
90 :     (let ((hira-w (get-info nearest-elem 'hirawidth)))
91 :     (cond ((null hira-w)
92 :     (put-info nearest-elem 'hirawidth
93 :     (make-list (length (second nearest-elem))
94 :     *default-hirawidth*)))
95 :     ((< to-head to-tail)
96 :     (put-info nearest-elem 'hirawidth (cdr hira-w)))
97 :     (t
98 :     (put-info
99 :     nearest-elem 'hirawidth
100 :     (reverse (cdr (reverse hira-w)))))))))
101 :     (t (beep win))))
102 :     (beep win))
103 :     (setq ret (shapeup-skelton (cons points (cons lines aux-info))))
104 :     (clear-win win)
105 :     (if grid (grid-win win))
106 :     (draw-skelton-win win ret)
107 :     (redraw-win win)
108 :     ret))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help