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

Annotation of /lisp/tools/addprim.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; addprim.l
3 :     ;; $Revision$
4 :     ;;
5 :    
6 :     (defun get-code-position (win)
7 :     (let ((code-position nil)
8 :     (save-bp-handler (get-winprop win 'button-press-handler)))
9 :     (put-winprop win 'button-press-handler
10 :     #'(lambda (win code x y)
11 :     (setq code-position
12 :     (list code
13 :     ; tanaka 1993/9/19
14 :     (cond (grid (* 5 (// (+ x 2) 5)))(t x))
15 :     (cond (grid (* 5 (// (+ y 2) 5)))(t y))))))
16 :     (loop-disable-other-win win
17 :     (function (lambda () code-position)))
18 :     (put-winprop win 'button-press-handler save-bp-handler)
19 :     code-position))
20 :    
21 :     (defun add-skelton-element (win code x y prim element)
22 :     (lets ((points (get-points prim))
23 :     (now-nth (1- (length points)))
24 :     (lines (get-lines prim))
25 :     (aux-info (get-aux-info prim))
26 :     ; tanaka 1993/9/19
27 :     (x (cond (grid (* 5 (// (+ x 2) 5)))(t x)))
28 :     (y (cond (grid (* 5 (// (+ y 2) 5)))(t y)))
29 :     (now (list x y))
30 :     (number (cl:second (assq element *element-points*)))
31 :     (newelem nil)
32 :     (code-position nil)
33 :     (src nil)
34 :     (ret nil)
35 :     (i 0))
36 :    
37 :     (print number)
38 :    
39 :     ;; identify positions
40 :     (loop
41 :     (cond ((eq code *select-nearest*)
42 :     (lets ((nth-nearest (nth-of-nearest-point now points))
43 :     (nearest (nth nth-nearest points)))
44 :     (cond ((< (distance-points nearest now) *near-range*)
45 :     (setq newelem (append newelem (ncons nth-nearest)))
46 :     (unless (0= i)
47 :     (draw-line-win win
48 :     (first nearest) (second nearest)
49 :     (first src) (second src))
50 :     (redraw-win win))
51 :     (setq src nearest)
52 :     (incr i 1))
53 :     (t (beep win)))))
54 :     ((and (eq code *end-mode*) (eq number 'arbitary))
55 :     ;;(setq points (append points (ncons now)));; eg) hira3
56 :     ;;(incr now-nth 1)
57 :     ;;(setq newelem (append newelem (ncons now-nth)))
58 :     ;;(unless (0= i)
59 :     ;; (draw-line-win win
60 :     ;;(first now) (second now)
61 :     ;;(first src) (second src))
62 :     ;;(redraw-win win))
63 :     ;;(setq src now)
64 :     (exit))
65 :     (t ;; *new-point-position*
66 :     (setq points (append points (ncons now)))
67 :     (incr now-nth 1)
68 :     (setq newelem (append newelem (ncons now-nth)))
69 :     (unless (0= i)
70 :     (draw-line-win win
71 :     (first now) (second now)
72 :     (first src) (second src))
73 :     (redraw-win win))
74 :     (setq src now)
75 :     (incr i 1)))
76 :    
77 :     (if (and (fixp number) (>= i number)) (exit))
78 :     (setq code-position
79 :     (if (0= i)
80 :     (get-code-position win)
81 :     (get-code-position:drag-lines win now (list src))))
82 :     (setq code (first code-position)
83 :     now (nthcdr 1 code-position)))
84 :    
85 :     (setq newelem (cons element (list newelem)))
86 :    
87 :     (setq ret (cons points (cons (append lines (list newelem)) aux-info)))
88 :     (clear-win win)
89 :     (if grid (grid-win win))
90 :     (draw-skelton-win win ret)
91 :     (redraw-win win)
92 :     ret))
93 :    
94 :    
95 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help