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

Annotation of /lisp/tools/delprim.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; delprim.l
3 :     ;; $Revistion$
4 :     ;;
5 :    
6 :     (defun distance-point-element (org points elem)
7 :     (lets ((linepoints (second elem))
8 :     (kouho-distance *range-too-large*))
9 :     (if (= (length linepoints) 1)
10 :     (min kouho-distance
11 :     (distance-points org (nth (first linepoints) points)))
12 :     (do ((rest linepoints (cdr rest))
13 :     (next (cdr linepoints) (cdr next)))
14 :     ((null next) kouho-distance)
15 :     (lets ((p1 (first rest))
16 :     (p2 (first next))
17 :     (ko-line (list
18 :     (nth p1 points)
19 :     (nth p2 points)))
20 :     (now-distance (distance-point-line
21 :     org
22 :     ko-line)))
23 :     (if (< now-distance kouho-distance)
24 :     (setq kouho-distance now-distance)))))))
25 :    
26 :     (defun nth-of-nearest-element (org points lines)
27 :     (let ((kouho-distance (distance-point-element org points (car lines)))
28 :     (kouho-line 0))
29 :     (do ((rest (cdr lines) (cdr rest))
30 :     (i 1 (1+ i)))
31 :     ((null rest) kouho-line)
32 :     (lets ((now (car rest))
33 :     (now-distance (distance-point-element org points now)))
34 :     (cond ((< now-distance kouho-distance)
35 :     (setq kouho-distance now-distance
36 :     kouho-line i)))))))
37 :    
38 :     (defun delete-skelton-element (win code x y prim)
39 :     (lets ((ret nil)
40 :     (points (get-points prim))
41 :     (lines (get-lines prim))
42 :     (aux-info (get-aux-info prim))
43 :     (now (list x y)))
44 :     (if lines
45 :     (lets ((nth-nearest (nth-of-nearest-element now points lines))
46 :     (nearest (nth nth-nearest lines)))
47 :     (cond ((< (distance-point-element now points nearest) *near-range*)
48 :     (setq lines (rem-nth nth-nearest lines)))
49 :     (t (beep win))))
50 :     (beep win))
51 :     (setq ret (shapeup-skelton (cons points (cons lines aux-info))))
52 :     (clear-win win)
53 :     (if grid (grid-win win))
54 :     (draw-skelton-win win ret)
55 :     (redraw-win win)
56 :     ret))
57 :    
58 :     (defun draw-dash-nth-element-win! (win prim n)
59 :     (lets ((points (get-points prim))
60 :     (lines (get-lines prim))
61 :     (pointlist (second (nth n lines)))
62 :     (linenum (1- (length pointlist))))
63 :     (do ((i 0 (1+ i)))
64 :     ((>= i linenum))
65 :     (lets ((p0 (nth (nth i pointlist) points))
66 :     (p1 (nth (nth (1+ i) pointlist) points))
67 :     (x0 (first p0))
68 :     (y0 (second p0))
69 :     (x1 (first p1))
70 :     (y1 (second p1)))
71 :     (draw-line win
72 :     (get-winprop win 'dashlinegc)
73 :     x0 y0 x1 y1)))))
74 :    
75 :     (defun draw-nth-element-win! (win prim n)
76 :     (lets ((points (get-points prim))
77 :     (lines (get-lines prim))
78 :     (pointlist (second (nth n lines)))
79 :     (linenum (1- (length pointlist))))
80 :     (do ((i 0 (1+ i)))
81 :     ((>= i linenum))
82 :     (lets ((p0 (nth (nth i pointlist) points))
83 :     (p1 (nth (nth (1+ i) pointlist) points))
84 :     (x0 (first p0))
85 :     (y0 (second p0))
86 :     (x1 (first p1))
87 :     (y1 (second p1)))
88 :     (draw-line win (get-winprop win 'blackgc)
89 :     x0 y0 x1 y1)))))
90 :    
91 :    
92 :     (setq %pred-nearest-element% nil)
93 :     (defun nearest-line-dotted (win x y prim)
94 :     (lets ((points (get-points prim))
95 :     (lines (get-lines prim))
96 :     (now (list x y)))
97 :     (when lines
98 :     (lets ((nth-nearest (nth-of-nearest-element now points lines))
99 :     (nearest (nth nth-nearest lines))
100 :     (distance (distance-point-element now points nearest))
101 :     (leng-lines (length lines)))
102 :     (comment
103 :     (print (list %pred-nearest-element% nth-nearest
104 :     distance *near-range*)))
105 :     (cond ((and (neq %pred-nearest-element% nth-nearest)
106 :     (< distance *near-range*))
107 :     (if (and %pred-nearest-element%
108 :     (< %pred-nearest-element% leng-lines))
109 :     (draw-nth-element-win! win prim %pred-nearest-element%))
110 :     (draw-dash-nth-element-win! win prim nth-nearest)
111 :     (display-force-output (window-display win))
112 :     (setq %pred-nearest-element% nth-nearest))
113 :     ((and (eq %pred-nearest-element% nth-nearest)
114 :     (< distance *near-range*))
115 :     'do-nothing)
116 :     ((and %pred-nearest-element%
117 :     (< %pred-nearest-element% leng-lines))
118 :     (draw-nth-element-win! win prim %pred-nearest-element%)
119 :     (setq %pred-nearest-element% nil)))))))
120 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help