[wadalabfont-kit] / lisp / skeledit.l  

Annotation of /lisp/skeledit.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 (cond ((definedp 'init_window))
2 :     (t (code-load "/home/misa/kanji/lib/window.o" "-lX11")))
3 :     ;(exfile (string-append system_lib_path "lisplib/readmacro.l"))
4 :     ;(cond ((definedp 'init_window))
5 :     ; (t (exfile "/home/misa/kanji/lib/new/window.l")))
6 :     ;(defun readsharp ()
7 :     ; (let ((r (read)))
8 :     ; (cond ((listp r)(vector (length r) r))
9 :     ; ((symbolp r)(character r))
10 :     ; (t r))))
11 :     ;(readmacro 35 'readsharp)
12 :    
13 :     (declare (marksize marksize1 linknumber linkpoints partlist nolinkpoints) special)
14 :     (declare (linkthresh) special)
15 :     (setq marksize 3 marksize1 3)
16 :     (defun sankaku (x y)
17 :     (drawline x (- y marksize1)(+ x marksize)(+ y marksize1))
18 :     (drawline x (- y marksize1)(- x marksize)(+ y marksize1))
19 :     (drawline (+ x marksize)(+ y marksize1)(- x marksize)(+ y marksize1)))
20 :     (defun shikaku (x y)
21 :     (drawline (- x marksize)(- y marksize)(+ x marksize)(- y marksize))
22 :     (drawline (+ x marksize)(- y marksize)(+ x marksize)(+ y marksize))
23 :     (drawline (+ x marksize)(+ y marksize)(- x marksize)(+ y marksize))
24 :     (drawline (- x marksize)(+ y marksize)(- x marksize)(- y marksize)))
25 :    
26 :     (defun hex2 (l)
27 :     (string-append (string (sref "0123456789abcdef" (logand 15 (logshift l -4))))
28 :     (string (sref "0123456789abcdef" (logand 15 l)))))
29 :     (defun setlinkpoint (x y)
30 :     (push (list 'link linknumber x y) linkpoints)
31 :     (setq linknumber (1+ linknumber)))
32 :    
33 :     (defun metric (x0 y0 x y)
34 :     (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y))))
35 :    
36 :     (defun bestlink (x y)
37 :     (do ((min 1000000)
38 :     (ret nil)
39 :     (met nil)
40 :     (l linkpoints (cdr l)))
41 :     ((atom l)(cond (ret)
42 :     (t (push (list 'link linknumber x y) linkpoints)
43 :     (car linkpoints))))
44 :     (setq met (metric x y (caddr (car l))(cadddr (car l))))
45 :     (cond ((< met min)
46 :     (setq ret (car l) min met)))))
47 :    
48 :     (defun bestpoint (x y)
49 :     (lets ((min 1000000)
50 :     (ret nil)
51 :     (met nil))
52 :     (do ((l linkpoints (cdr l))(met nil))
53 :     ((atom l))
54 :     (setq met (metric x y (caddr (car l))(cadddr (car l))))
55 :     (cond ((< met min)
56 :     (setq ret (car l) min met))))
57 :     (do ((l partlist (cdr l)))
58 :     ((atom l))
59 :     (do ((ll (cdar l)(cdr ll)))
60 :     ((atom ll))
61 :     (setq met (metric x y (point-x (car ll))(point-y (car ll))))
62 :     (cond ((< met min)
63 :     (setq ret (car ll) min met)))))
64 :     (cond ((eq 'link (car ret))(cddr ret))
65 :     (ret))))
66 :    
67 :    
68 :     (defun movepoint (fromx fromy tox toy)
69 :     (cond ;((and (null partlist)linkpoints))
70 :     (t
71 :     (let ((point (bestpoint fromx fromy)))
72 :     (rplaca point (+ (car point)(- tox fromx)))
73 :     (rplaca (cdr point)(+ (cadr point)(- toy fromy)))))))
74 :     (defun neighbor (point)
75 :     (do ((l partlist (cdr l))
76 :     (ret nil))
77 :     ((atom l)ret)
78 :     (do ((ll (cdar l)(cdr ll))
79 :     (last nil))
80 :     ((atom (cdr ll)))
81 :     (cond ((eq point (cddar ll))
82 :     (push (cddadr ll) ret))
83 :     ((eq point (cddadr ll))
84 :     (push (cddar ll) ret))))))
85 :     (defun yokosoroe ()
86 :     (let ((event nil)
87 :     (fromx nil)
88 :     (fromy nil)
89 :     (neighbor nil)
90 :     (point nil))
91 :     (loop
92 :     (setq event (checkevent))
93 :     (match event
94 :     (('ButtonPress 'button1 x y)
95 :     (setq fromx x fromy y)
96 :     (exit))))
97 :     (setq point (bestpoint fromx fromy))
98 :     (setq neighbor (neighbor point))
99 :     (do ((l neighbor (cdr l))
100 :     (miny 20)
101 :     (y fromy))
102 :     ((atom l)(rplaca (cdr point)y))
103 :     (cond ((> miny (abs (- fromy (cadr (car l)))))
104 :     (setq miny (abs (- fromy (cadr (car l)))))
105 :     (setq y (cadr (car l))))))))
106 :     (defun tatesoroe ()
107 :     (let ((event nil)
108 :     (fromx nil)
109 :     (fromy nil)
110 :     (neighbor nil)
111 :     (point nil))
112 :     (loop
113 :     (setq event (checkevent))
114 :     (match event
115 :     (('ButtonPress 'button1 x y)
116 :     (setq fromx x fromy y)
117 :     (exit))))
118 :     (setq point (bestpoint fromx fromy))
119 :     (setq neighbor (neighbor point))
120 :     (do ((l neighbor (cdr l))
121 :     (minx 20)
122 :     (x fromx))
123 :     ((atom l)(rplaca point x))
124 :     (cond ((> minx (abs (- fromx (car (car l)))))
125 :     (setq minx (abs (- fromx (car (car l)))))
126 :     (setq x (car (car l))))))))
127 :     (defun set-link ()
128 :     (let ((event nil)
129 :     (fromx nil)
130 :     (fromy nil)
131 :     (point nil))
132 :     (loop
133 :     (setq event (checkevent))
134 :     (match event
135 :     (('ButtonPress 'button1 x y)
136 :     (setq fromx x fromy y)
137 :     (exit))))
138 :     (setq point (bestpoint fromx fromy))
139 :     (cond ((memq point nolinkpoints)
140 :     (setq nolinkpoints (remq point nolinkpoints)))
141 :     (t (push point nolinkpoints)))))
142 :     (defun delete ()
143 :     (let ((x nil)(y nil)(point nil))
144 :     (do ((event (checkevent)(checkevent)))
145 :     ((eq (car event) 'ButtonPress)
146 :     (setq x (caddr event) y (cadddr event))))
147 :     (setq point (bestpoint x y))))
148 :    
149 :     (defun concat ()
150 :     (let ((fromx nil)(fromy nil)(tox nil)(toy nil)(p0 nil)(p1 nil))
151 :     (do ((event (checkevent)(checkevent)))
152 :     ()
153 :     (match event
154 :     (('ButtonPress 'button1 x y)
155 :     (setq fromx x fromy y)(exit))))
156 :     (do ((event (checkevent)(checkevent)))
157 :     ()
158 :     (match event
159 :     (('ButtonPress 'button1 x y)
160 :     (setq tox x toy y)(exit))))
161 :     (setq p0 (bestlink fromx fromy) p1 (bestlink tox toy))))
162 :    
163 :    
164 :    
165 :     (defun newpart (sym)
166 :     (push (ncons sym) partlist)
167 :     (do ((i 0)
168 :     (npoints (get sym 'npoint))
169 :     (points nil)
170 :     (event (checkevent)(checkevent)))
171 :     ((>= i npoints))
172 :     (match event
173 :     (('KeyPress #r)
174 :     (setq points nil)
175 :     (setq partlist (cons nil (cdr partlist)))
176 :     (setq i -1))
177 :     (('KeyPress #q)
178 :     (setq partlist (cdr partlist))
179 :     (exit))
180 :     (('ButtonPress 'button1 x y)
181 :     (push (bestlink x y)points)
182 :     (setq i (1+ i))))
183 :     (setq partlist (cons (cons sym (reverse points)) (cdr partlist)))
184 :     (disp)))
185 :    
186 :     (defun point-x (l)
187 :     (cond ((eq 'link (car l))
188 :     (caddr l))
189 :     (t (car l))))
190 :    
191 :     (defun point-y (l)
192 :     (cond ((eq 'link (car l))
193 :     (cadddr l))
194 :     (t (cadr l))))
195 :    
196 :     (setq nolinkpoints nil)
197 :     (defun disp ()
198 :     (copybg)
199 :     (do ((l linkpoints (cdr l)))
200 :     ((atom l))
201 :     (cond ((memq (cddr (car l)) nolinkpoints)
202 :     (sankaku (caddr (car l))(cadddr (car l))))
203 :     (t
204 :     (shikaku (caddr (car l))(cadddr (car l))))))
205 :     (do ((l partlist (cdr l)))
206 :     ((atom l))
207 :     (do ((ll (cdar l)(cdr ll))
208 :     (npoints (get (caar l) 'npoint))
209 :     (i 0 (1+ i)))
210 :     ((or (atom ll)(>= i npoints)))
211 :     (cond ((neq (caar ll) 'link)
212 :     (sankaku (caar ll)(cadar ll))))
213 :     (cond ((and (neq i (1- npoints))(cdr ll))
214 :     (drawline (point-x (car ll))(point-y (car ll))
215 :     (point-x (cadr ll))(point-y (cadr ll)))))))
216 :     (redraw))
217 :    
218 :     (defun skeledit (symbol (code)(fonttype 'mincho))
219 :     (princ ";")
220 :     (print (list symbol code))
221 :     (init_window 400 400)
222 :     ; (cond (code
223 :     ; (cond ((= 2 (string-length code))
224 :     ; (setq code (string-append (hex2 (logand 127 (sref code 0)))
225 :     ; (hex2 (logand 127 (sref code 1)))))))
226 :     ; (loadpbm (string-append "/home/misa/kanji/pbm/mincho/" code ".pbm"))))
227 :     (cond (code
228 :     (cond ((= 2 (string-length code))
229 :     (setq code (string-append (hex2 (logand 127 (sref code 0)))
230 :     (hex2 (logand 127 (sref code 1)))))))
231 :     (loadjis code)))
232 :     (setq partlist nil)
233 :     (setq linkpoints nil)
234 :     (setq nolinkpoints nil)
235 :     (setq linknumber 0)
236 :     (do ((event (checkevent)(checkevent))
237 :     (curx nil)(cury nil))
238 :     ()
239 :     ; (print event)
240 :     (match event
241 :     (('KeyPress code)
242 :     (selectq code
243 :     (#\t
244 :     (do ((event (checkevent)(checkevent)))
245 :     ()
246 :     (match event
247 :     (('KeyPress #\s)(newpart 'tasuki)(exit))
248 :     (('KeyPress #\l)(newpart 'tatehidari)(exit))
249 :     (('KeyPress #\h)(newpart 'tatehane)(exit)))))
250 :     (#\k
251 :     (do ((event (checkevent)(checkevent)))
252 :     ()
253 :     (match event
254 :     (('KeyPress #\z)(newpart 'kozato)(exit))
255 :     (('KeyPress #\k)(newpart 'kokoro)(exit))
256 :     (('KeyPress #\g)(newpart 'kagi)(exit)))))
257 :     (#\p (newpart 'ten))
258 :     (#\b (newpart 'tate))
259 :     (#\y (newpart 'yoko))
260 :     (#\u (newpart 'migiue))
261 :     (#\l (newpart 'hidari))
262 :     (#\r (newpart 'migi))
263 :     (#\h (newpart 'tsukurihane))
264 :     (#\s (newpart 'sanzui))
265 :     (#\m (newpart 'magaritate))
266 :     (#\n (newpart 'shin-nyuu))
267 :     (#\c (concat))
268 :     (#\q (close_window)
269 :     (prind `(setq ,symbol ',(convskelton1 (convskelton (add-link partlist)))))(exit))
270 :     ; (#\r (reset))
271 :     (#\i (setq partlist nil linkpoints nil)
272 :     (setq nolinkpoints nil linknumber 0))
273 :     (#\f (set-link))
274 :     (#\x (yokosoroe))
275 :     (#\z (tatesoroe))
276 :     (#\d (showfill fonttype))
277 :     (#\d (delete))))
278 :     (('ButtonPress 'button1 x y)
279 :     (setlinkpoint x y))
280 :     (('ButtonPress 'button2 x y)
281 :     (setq curx x cury y))
282 :     (('ButtonRelease 'button2 x y)
283 :     (movepoint curx cury x y)))
284 :     (disp)))
285 :     (defun showfill (fonttype)
286 :     (fill1 (convskelton1 (convskelton (add-link partlist))) fonttype))
287 :     (defun fill1 (l tag)
288 :     (let ((outline nil))
289 :     (setq outline (skelton2list (applykanji l) tag))
290 :     (mapcar outline '(lambda (x)(fillpolygon (setpart1 x))))
291 :     (redraw)
292 :     (checkevent)))
293 :    
294 :     ;(print (list (vref readtable 35)(vref macrotable 35)))
295 :    
296 :     (defprop ten 2 npoint)
297 :     (defprop tate 2 npoint)
298 :     (defprop yoko 2 npoint)
299 :     (defprop migiue 3 npoint)
300 :     (defprop hidari 3 npoint)
301 :     (defprop tatehidari 4 npoint)
302 :     (defprop migi 3 npoint)
303 :     (defprop kozato 3 npoint)
304 :     (defprop tatehane 3 npoint)
305 :     (defprop tsukurihane 4 npoint)
306 :     (defprop sanzui 2 npoint)
307 :     (defprop kokoro 4 npoint)
308 :     (defprop tasuki 4 npoint)
309 :     (defprop magaritate 3 npoint)
310 :     (defprop kagi 3 npoint)
311 :     (defprop shin-nyuu 3 npoint)
312 :    
313 :     (defun convskelton (prim)
314 :     (let ((linkpoints nil)
315 :     (points nil)
316 :     (linkcount 0)
317 :     (p nil)(as nil)(pp nil)
318 :     (lines nil))
319 :     (do ((l prim (cdr l)))
320 :     ((atom l)
321 :     `(,(nreverse points) ,(nreverse lines) nil nil))
322 :     (do ((ll (cdar l)(cdr ll))
323 :     (line nil)
324 :     (link nil)
325 :     (pointnmb 0)
326 :     (i 0 (1+ i))
327 :     (npoints (get (caar l) 'npoint)))
328 :     ((atom ll)
329 :     ; (print link)
330 :     (push (cons (caar l)(cons (nreverse line) (nreverse link))) lines))
331 :     (setq p (car ll))
332 :     (cond ((eq 'link (car p))
333 :     (setq as (assq (cadr p) linkpoints))
334 :     (cond ((null as)
335 :     (push (cons (cadr p) linkcount) linkpoints)
336 :     (setq pointnmb linkcount)
337 :     (cond ((null (cddr p))
338 :     (push nil points))
339 :     (t
340 :     (push (cons (caddr p)(cadddr p)) points)))
341 :     (setq linkcount (1+ linkcount)))
342 :     (t
343 :     (setq pointnmb (cdr as))
344 :     (setq pp (nthcdr (- linkcount pointnmb 1) points))
345 :     (cond ((and (cddr p)(null (car pp)))
346 :     (rplaca pp (cons (caddr p)(cadddr p))))))))
347 :     (t
348 :     (setq pointnmb linkcount)
349 :     (push (cons (car p)(cadr p))points)
350 :     (setq linkcount (1+ linkcount))))
351 :     (cond ((>= i npoints)
352 :     (push pointnmb link)
353 :     ; (print link)
354 :     )
355 :     (t
356 :     (push pointnmb line)))))))
357 :    
358 :     (defun convskelton1(prim)
359 :     (cond
360 :     ((atom prim)prim)
361 :     (t
362 :     (lets ((points (car prim))
363 :     (lines (cadr prim))
364 :     (alist (caddr prim))
365 :     (newpoints nil)
366 :     (newlines nil))
367 :     (do ((l points (cdr l)))
368 :     ((atom l))
369 :     (push (list (caar l)(cdar l)) newpoints))
370 :     (do ((l lines (cdr l))
371 :     (line nil))
372 :     ((atom l)`(,(nreverse newpoints) ,(nreverse newlines) .,alist))
373 :     (setq line (car l))
374 :     (cond ((cddr line)
375 :     (push `(,(car line),(cadr line)(link .,(cddr line))) newlines))
376 :     (t
377 :     (push line newlines))))))))
378 :     (setq linkthresh 10.0)
379 :     (defun add-link (body)
380 :     (lets ((newbody nil)
381 :     (linkpoints nil)
382 :     (pointhist (make-hist body))
383 :     (tmpdist nil)
384 :     (kouho (find-kouho body pointhist)))
385 :     (setq linkpoints nil)
386 :     (do ((l kouho (cdr l))
387 :     (curpoint nil)
388 :     (ret nil))
389 :     ((atom l)
390 :     (do ((ll body (cdr ll)))
391 :     ((atom ll)(setq body (reverse newbody)))
392 :     ; (print (car ll))
393 :     (do ((lll ret (cdr lll))
394 :     (newline nil))
395 :     ((atom lll)
396 :     (push (append (car ll)newline) newbody)
397 :     ; (print newbody)
398 :     )
399 :     (cond ((eq (cdar lll)(car ll))
400 :     (push (caar lll) newline))))))
401 :     (setq curpoint (car l))
402 :     (do ((ll body (cdr ll))
403 :     (curlink nil)
404 :     (minlink nil)
405 :     (mindist 1000.0))
406 :     ((atom ll)
407 :     (cond ((<$ mindist linkthresh)
408 :     (push (cons curpoint minlink) ret))))
409 :     (setq curlink (car ll))
410 :     ; (print curlink)
411 :     (cond ((member-point curpoint curlink))
412 :     (t
413 :     (do ((lll (cdr curlink) (cdr lll)))
414 :     ((atom (cdr lll)))
415 :     (setq tmpdist (calcdist-old curpoint (car lll)(cadr lll)))
416 :     ; (print tmpdist)
417 :     (cond ((<$ tmpdist mindist)
418 :     (setq mindist tmpdist)
419 :     (setq minlink curlink))))))))))
420 :    
421 :     (defun member-point (point link)
422 :     (cond ((atom link)nil)
423 :     ((eq point (car link))t)
424 :     ((member-point point (cdr link)))))
425 :    
426 :     (defun difffloat2-old (a b)
427 :     (list (-$ (float(point-x a))(float (point-x b)))
428 :     (-$ (float(point-y a))(float(point-y b)))))
429 :    
430 :     (defun calcdist-old (point p0 p1)
431 :     (lets ((v0 (difffloat2-old p1 p0))
432 :     (len0 (length2 v0))
433 :     (v1 (difffloat2-old point p0))
434 :     (len1 (length2 v1))
435 :     (naiseki (mul2 v0 v1))
436 :     (len2 (//$ naiseki len0))
437 :     (v3 (normlen2 len2 v0)))
438 :     ; (prind (list v0 len0 v1 len1 naiseki len2 v3))
439 :     (cond ((<=$ 0.0 len2 len0)(length2 (diff2 v3 v1)))
440 :     (t 1000.0))))
441 :    
442 :     (defun make-hist (x)
443 :     (do ((l x (cdr l))
444 :     (alist nil))
445 :     ((atom l)alist)
446 :     (do ((ll (cdar l) (cdr ll))
447 :     (pnumber nil)
448 :     (ptr nil))
449 :     ((atom ll))
450 :     (setq pnumber (cadar ll))
451 :     (setq ptr (assq pnumber alist))
452 :     (cond (ptr (rplacd ptr (1+ (cdr ptr))))
453 :     (t (push (cons pnumber 1) alist))))))
454 :    
455 :     (defun find-kouho (x hist)
456 :     (do ((l x (cdr l))
457 :     (npoint nil)
458 :     (ret nil))
459 :     ((atom l)ret)
460 :     (setq npoint (get (caar l) 'npoint))
461 :     (cond ((and (= 1 (cdr (assq (cadr (cadar l)) hist)))
462 :     (not (memq (cddr (cadar l)) nolinkpoints)))
463 :     ; (prind (cadar l))
464 :     (push (cadar l) ret)))
465 :     (cond ((and(= 1 (cdr (assq (cadar (last (car l))) hist)))
466 :     (not (memq (cddr (car (last (car l)))) nolinkpoints)))
467 :     ; (prind (car (last (car l))))
468 :     (push (car (last (car l))) ret)))))
469 :    
470 :     ;(exfile 'disp.l)
471 :     ;(exfile 'mincho.l)
472 :     ;(exfile 'lib.l)

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help