[wadalabfont-kit] / lisp / newedit.l  

Annotation of /lisp/newedit.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 (cond ((definedp 'init_window))
2 :     (t (code-load "/home/misa/kanji/lib/window.o" "-lX11")))
3 :     (defun readsharp ()
4 :     (let ((r (read)))
5 :     (cond ((listp r)(vector (length r) r))
6 :     ((symbolp r)(character r))
7 :     (t r))))
8 :     (readmacro 35 'readsharp)
9 :     (defun bez (x0 y0 x1 y1 x2 y2 x3 y3)
10 :     (let ((maxx (max x0 x1 x2 x3))
11 :     (maxy (max y0 y1 y2 y3))
12 :     (minx (min x0 x1 x2 x3))
13 :     (miny (min y0 y1 y2 y3))
14 :     (tempx 0)(tempy 0))
15 :     (cond ((or (< (- maxx minx) 2)(< (- maxy miny) 2))
16 :     `((,x3 . ,y3)))
17 :     (t
18 :     (setq tempx (// (+ x0 (* 3 x1)(* 3 x2) x3) 8))
19 :     (setq tempy (// (+ y0 (* 3 y1)(* 3 y2) y3) 8))
20 :     (append
21 :     (bez x0 y0 (// (+ x0 x1) 2)(// (+ y0 y1) 2)
22 :     (// (+ x0 x1 x1 x2) 4)(// (+ y0 y1 y1 y2) 4)
23 :     tempx tempy)
24 :     (bez tempx tempy (// (+ x3 x2 x2 x1) 4)(// (+ y3 y2 y2 y1) 4)
25 :     (// (+ x3 x2) 2)(// (+ y3 y2) 2) x3 y3))))))
26 :     (defun setpart (l)
27 :     (do ((ret nil ret)
28 :     (curl l (cdr curl)))
29 :     ((atom curl)ret)
30 :     (match (car curl)
31 :     (('move x0 y0)
32 :     (setq curx x0 cury y0)
33 :     (setq ret `((,(* mag x0) . ,(* mag y0)))))
34 :     (('line x0 y0)
35 :     (setq curx x0 cury y0)
36 :     (nconc ret `((,(* mag x0) . ,(* mag y0)))))
37 :     (('bezier x0 y0 x1 y1 x2 y2)
38 :     (nconc ret (bez (* mag curx) (* mag cury) (* mag x0) (* mag y0) (* mag x1) (* mag y1) (* mag x2)(* mag y2)))
39 :     (setq curx x2)(setq cury y2))
40 :     (any (print "not matched")(break)))))
41 :     (defun drawpoints0 (l)
42 :     (do ((first t nil)
43 :     (curl l (next-point curl)))
44 :     ((and (null first)(eq l curl)))
45 :     (cond ((null l)(exit)))
46 :     (match (car curl)
47 :     (('angle x0 y0)
48 :     (shikaku x0 y0))
49 :     (('smooth x0 y0)
50 :     (sankaku x0 y0))
51 :     (('bezier x0 y0)
52 :     (batsu x0 y0))
53 :     (any (print "not matched")(break)))))
54 :     (setq marksize 3 marksize1 3)
55 :     (defun batsu (x y)
56 :     (drawline (- x marksize)y(+ x marksize)y)
57 :     (drawline x(- y marksize)x(+ y marksize)))
58 :     (defun shikaku (x y)
59 :     (drawline (- x marksize)(- y marksize)(+ x marksize)(- y marksize))
60 :     (drawline (+ x marksize)(- y marksize)(+ x marksize)(+ y marksize))
61 :     (drawline (+ x marksize)(+ y marksize)(- x marksize)(+ y marksize))
62 :     (drawline (- x marksize)(+ y marksize)(- x marksize)(- y marksize)))
63 :     (defun sankaku (x y)
64 :     (drawline x (- y marksize1)(+ x marksize)(+ y marksize1))
65 :     (drawline x (- y marksize1)(- x marksize)(+ y marksize1))
66 :     (drawline (+ x marksize)(+ y marksize1)(- x marksize)(+ y marksize1)))
67 :    
68 :     (setq mag 1)
69 :     (setq width (* mag 110))
70 :     (setq height (* mag 300))
71 :    
72 :     (defun link-to-out (l)
73 :     (do ((ll l)
74 :     (first t nil)
75 :     (ret nil))
76 :     ((and (null first)(eq ll l))(nreverse ret))
77 :     ; (print ll)
78 :     (match ll
79 :     (((angle-or-smooth x y) pre next)
80 :     (cond ((eq first t)
81 :     (push `(move ,x ,y) ret)))
82 :     (cond
83 :     ((eq (caar next) 'bezier)
84 :     (push
85 :     `(bezier ,(cadar next)
86 :     ,(caddar next)
87 :     ,(cadar (next-point next))
88 :     ,(caddar (next-point next))
89 :     ,(cadar (next-point (next-point next)))
90 :     ,(caddar (next-point (next-point next))))
91 :     ret)
92 :     (setq ll (next-point (next-point next)))
93 :     )
94 :     (t (push `(line ,(cadar next) ,(caddar next)) ret)
95 :     (setq ll next)))))))
96 :    
97 :     (defun link-to-list (l)
98 :     (do ((ll l (next-point ll))
99 :     (first t nil)
100 :     (ret nil))
101 :     ((and (null first)(eq ll l))(nreverse ret))
102 :     (push (car ll) ret)))
103 :    
104 :     (defun list-to-link (l)
105 :     (do ((ll l (cdr ll))
106 :     (tmp nil)
107 :     (ret nil))
108 :     ((atom ll)ret)
109 :     (cond ((null ret)
110 :     (setq ret `(,(car ll) nil nil))
111 :     (setq tmp ret)
112 :     (rplaca (cdr ret) ret)
113 :     (rplaca (cddr ret) ret))
114 :     (t (insert-after tmp `(,(car ll) nil nil))
115 :     (setq tmp (next-point tmp))))))
116 :    
117 :     (defun disp (l ll)
118 :     (let ((outline (mapcar l '(lambda (x) (link-to-out (find-no-bezier x)))))
119 :     (currentline (link-to-out ll)))
120 :     (copybg)
121 :     ; (print outline)
122 :     (mapcar outline '(lambda (x) (drawlines (setpart x))))
123 :     (drawpoints0 ll)
124 :     (redraw)))
125 :    
126 :     (defun metric (x0 y0 x y)
127 :     (+(*(- x0 x)(- x0 x))(*(- y0 y)(- y0 y))))
128 :    
129 :     (defun find-point-in-group (group x y)
130 :     (do ((l group (next-point l))
131 :     (first t nil)
132 :     (min 1000000)
133 :     (near nil))
134 :     ((and (eq l group)(null first))near)
135 :     (setq x0 (cadar l) y0 (caddar l))
136 :     (cond ((> min (metric x y x0 y0))
137 :     (setq min (metric x y x0 y0))
138 :     (setq near l)))))
139 :    
140 :     (defun find-no-bezier (l)
141 :     (do ((ll l (next-point ll))
142 :     (first t nil))
143 :     ((or (neq (point-type ll) 'bezier)
144 :     (and (null first)(eq l ll)))
145 :     ll)))
146 :     (defun find-group (outline x y)
147 :     ; (print outline)
148 :     (do ((l outline (cdr l))
149 :     (near nil)
150 :     (min 1000000))
151 :     ((atom l)near)
152 :     (setq ll (find-no-bezier(find-point-in-group (car l) x y)))
153 :     (setq val (metric x y (cadar ll)(caddar ll)))
154 :     ; (print ll)(print val)
155 :     (cond ((> min val)
156 :     (setq min val)
157 :     (setq near ll)))))
158 :    
159 :     (defun movepoint (group curpoint x y)
160 :     (cond ((null outline))
161 :     (t
162 :     (lets ((point (find-point-in-group group (car curpoint) (cdr curpoint)))
163 :     (dx (- x (car curpoint)))
164 :     (dy (- y (cdr curpoint))))
165 :     (cond
166 :     ((null point))
167 :     (t
168 :     (setq xx (point-x point) yy (point-y point))
169 :     (set-x point (+ xx dx))
170 :     (set-y point (+ yy dy))
171 :     (cond
172 :     ((and (eq 'smooth (point-type point))
173 :     (eq 'bezier (point-type (next-point point)))
174 :     (eq 'bezier (point-type (previous-point point))))
175 :     (lets ((next (next-point point))
176 :     (previous (previous-point point))
177 :     (set-x next (+ (point-x next) dx))
178 :     (set-y next (+ (point-y next) dy))
179 :     (set-x previous (+ (point-x previous) dx))
180 :     (set-y previous (+ (point-y previous) dy)))))
181 :     ((or (and (eq 'bezier (point-type point))
182 :     (setq next (next-point point))
183 :     (eq 'smooth (point-type next))
184 :     (setq nextnext (next-point next))
185 :     (eq 'bezier (point-type nextnext)))
186 :     (and (eq 'bezier (point-type point))
187 :     (setq next (previous-point point))
188 :     (eq 'smooth (point-type next))
189 :     (setq nextnext (previous-point next))
190 :     (eq 'bezier (point-type nextnext))))
191 :     (lets ((x0 (point-x point))(y0 (point-y point))
192 :     (x1 (point-x next))(y1 (point-y next))
193 :     (x2 (point-x nextnext))(y2 (point-y nextnext))
194 :     (len0 (metric x0 y0 x1 y1))
195 :     (len1 (metric x1 y1 x2 y2))
196 :     (tt (sqrt (//$ (float len1)(float len0))))
197 :     (x3 (+ x1 (fix (*$ (float (- x1 x0)) tt))))
198 :     (y3 (+ y1 (fix (*$ (float (- y1 y0)) tt)))))
199 :     (set-x nextnext x3)(set-y nextnext y3)))
200 :     ((or (and (eq 'bezier (point-type point))
201 :     (setq next (next-point point))
202 :     (eq 'smooth (point-type next))
203 :     (setq nextnext (next-point next))
204 :     (neq 'bezier (point-type nextnext)))
205 :     (and (eq 'bezier (point-type point))
206 :     (setq next (previous-point point))
207 :     (eq 'smooth (point-type next))
208 :     (setq nextnext (previous-point next))
209 :     (neq 'bezier (point-type nextnext))))
210 :     (lets ((x0 (point-x point))(y0 (point-y point))
211 :     (x1 (point-x next))(y1 (point-y next))
212 :     (x2 (point-x nextnext))(y2 (point-y nextnext))
213 :     (len0 (metric x0 y0 x1 y1))
214 :     (len1 (metric x1 y1 x2 y2))
215 :     (tt (sqrt (//$ (float len0)(float len1))))
216 :     (x3 (+ x1 (fix (*$ (float (- x1 x2)) tt))))
217 :     (y3 (+ y1 (fix (*$ (float (- y1 y2)) tt)))))
218 :     (set-x point x3)(set-y point y3))))))))))
219 :    
220 :     (defun loadoutline (filename)
221 :     (catch 'ioerr
222 :     (lets ((err:open-close '(lambda (x (y))(throw 'ioerr nil)))
223 :     (s (inopen (stream filename)))
224 :     (l (read s)))
225 :     (close s)
226 :     ; (print l)
227 :     ; (print (mapcar l '(lambda (x)(list-to-link x))))
228 :     (throw 'ioerr (mapcar l '(lambda (x)(list-to-link x)))))))
229 :     (defun saveoutline (filename outline)
230 :     (let ((s (outopen (stream filename)))
231 :     (printlevel 0)
232 :     (printlength 0))
233 :     (print (mapcar outline '(lambda (x)(link-to-list x))) s)
234 :     (close s)))
235 :    
236 :     (defun loadbushu ()
237 :     (catch 'ioerr
238 :     (let ((err:open-close '(lambda (x (y))(throw 'ioerr nil)))
239 :     (err:end-of-file '(lambda (x (y))(throw 'ioerr ret)))
240 :     (s (inopen (stream "/home/misa/kanji/bushutable")))
241 :     (ret nil))
242 :     (loop (push (read s) ret)))))
243 :    
244 :     (defun hex2 (x)
245 :     (let ((str (make-string 2)))
246 :     (sset str 0 (hex-image-char (logand 7 (logshift (logand x 127) -1))))
247 :     (sset str 1 (hex-image-char (logand x 15)))
248 :     str))
249 :    
250 :     (defun kanji2jis (str)
251 :     (cond ((symbolp str)(setq str (pname str))))
252 :     (cond
253 :     ((<> (string-length str) 2))
254 :     (t (string-append (hex2 (sref str 0))(hex2 (sref str 1))))))
255 :    
256 :     (defun next-point (l)
257 :     (caddr l))
258 :     (defun set-next (l x)
259 :     (rplaca (cddr l) x))
260 :     (defun point-type (l)
261 :     (caar l))
262 :     (defun point-x (l)
263 :     (cadar l))
264 :     (defun point-y (l)
265 :     (caddar l))
266 :     (defun set-x (l val)
267 :     (rplaca (cdar l) val))
268 :     (defun set-y (l val)
269 :     (rplaca (cddar l) val))
270 :     (defun previous-point (l)
271 :     (cadr l))
272 :     (defun set-previous (l x)
273 :     (rplaca (cdr l) x))
274 :    
275 :     (defun insert-after (l ll)
276 :     (let ((next (caddr l)))
277 :     (rplaca (cddr l) ll)
278 :     (rplaca (cdr next) ll)
279 :     (rplaca (cdr ll) l)
280 :     (rplaca (cddr ll) next)))
281 :     (defun unlink (point)
282 :     (let ((next (next-point point))
283 :     (previous (previous-point point)))
284 :     (set-next previous next)
285 :     (set-previous next previous)))
286 :     (defun delete (point)
287 :     (print "Delete point")
288 :     (cond
289 :     ((eq 'bezier (caar point))
290 :     (cond
291 :     ((eq 'bezier (caar(next-point point)))
292 :     (unlink (next-point point)))
293 :     (t (unlink (previous-point point)))))
294 :     ((and (eq 'bezier (caar (previous-point point)))
295 :     (eq 'bezier (caar (next-point point))))
296 :     (unlink (previous-point point))
297 :     (unlink (next-point point))))
298 :     (unlink point))
299 :     (defun insert-bezier (point)
300 :     (cond ((and (not(eq 'bezier (point-type point)))
301 :     (not(eq 'bezier (point-type (next-point point)))))
302 :     (let ((x0 (point-x point))
303 :     (y0 (point-y point))
304 :     (x1 (point-x (next-point point)))
305 :     (y1 (point-y (next-point point))))
306 :     (insert-after point
307 :     `((bezier ,(// (+ x1 x1 x0) 3) ,(// (+ y1 y1 y0) 3)) nil nil))
308 :     (insert-after point
309 :     `((bezier ,(// (+ x1 x0 x0) 3) ,(// (+ y1 y0 y0) 3)) nil nil))))))
310 :     (defun smooth-point (point)
311 :     (cond ((eq 'angle (caar point))
312 :     (rplaca (car point) 'smooth))))
313 :     (defun copy-point (point)
314 :     (print "Copy point")
315 :     (setq x (cadar point) y (caddar point))
316 :     (cond
317 :     ((eq 'bezier (caar point)))
318 :     (t
319 :     ; (cond
320 :     ; ((eq (next-point point) point)
321 :     ; (insert-after point
322 :     ; `((bezier ,(+ x 5) ,(- y 5))nil nil))
323 :     ; (insert-after point
324 :     ; `((bezier ,(+ x 10) ,(- y 5))nil nil))))
325 :     (insert-after point
326 :     `((angle ,(+ x 15) ,y)nil nil))
327 :     ; (insert-after point
328 :     ; `((bezier ,(+ x 10) ,y)nil nil))
329 :     ; (insert-after point
330 :     ; `((bezier ,(+ x 5) ,y)nil nil))
331 :     )))
332 :    
333 :     (defun out-to-ps (psfile (code))
334 :     (cond ((null code))
335 :     (t
336 :     (setq outfile (string-append "/home/misa/kanji/outline/" code ".out"))
337 :     (setq outline (loadoutline outfile))))
338 :     (let ((standard-output (outopen (stream psfile)))
339 :     (l (mapcar outline 'link-to-out)))
340 :     (format "%!/n100 100 translate/n")
341 :     (do ((ll l (cdr ll)))
342 :     ((atom ll))
343 :     (do ((lll (car ll) (cdr lll)))
344 :     ((atom lll))
345 :     (match (car lll)
346 :     (('move x y)(format "/c /c moveto/n" x (- 400 y)))
347 :     (('line x y)(format "/c /c lineto/n" x (- 400 y)))
348 :     (('bezier x0 y0 x1 y1 x2 y2)
349 :     (format
350 :     "/c /c /c /c /c /c curveto/n"
351 :     x0 (- 400 y0) x1 (- 400 y1) x2 (- 400 y2))))))
352 :     (format "closepath fill showpage/n")))
353 :    
354 :    
355 :     )
356 :     (defun hex2 (l)
357 :     (string-append (string (sref "0123456789abcdef" (logand 15 (logshift l -4))))
358 :     (string (sref "0123456789abcdef" (logand 15 l)))))
359 :     (defun newedit (code (noload))
360 :     (init_window 400 400)
361 :     (cond ((= 2 (string-length code))
362 :     (setq code (string-append (hex2 (logand 127 (sref code 0)))
363 :     (hex2 (logand 127 (sref code 1)))))))
364 :     (cond ((null noload)
365 :     (loadpbm (string-append "/home/misa/kanji/pbm/mincho/" code ".pbm")))
366 :     (t
367 :     (loadpbm "/home/misa/kanji/pbm/nothing.pbm")))
368 :     (setq outfile (string-append "/home/misa/kanji/outline/" code ".out"))
369 :     (setq outline (loadoutline outfile))
370 :     (disp outline nil)
371 :     (do ((event (checkevent)(checkevent))
372 :     (currentgroup nil)
373 :     (x nil)
374 :     (y nil)
375 :     (currentpart nil))
376 :     ()
377 :     ; (gc)(princ (heapfree))
378 :     ; (print event)
379 :     ; (print outline)
380 :     (match event
381 :     (('KeyPress code)
382 :     (selectq code
383 :     (#g (print "Select group"))
384 :     (#c (print "Copy point"))
385 :     (#i (print "insert bezier point"))
386 :     (#d (print "Delete point"))
387 :     (#s (print "Smooth point"))
388 :     (#q
389 :     (close_window)(saveoutline outfile outline)(exit))
390 :     (#n (print "New point")))
391 :     (do ((event (checkevent)(checkevent)))
392 :     ((and (eq (car event) 'ButtonPress)
393 :     (eq (cadr event) 'button1))
394 :     (setq x (caddr event))
395 :     (setq y (cadddr event))))
396 :     (selectq code
397 :     (#g
398 :     (setq currentgroup (find-group outline x y)))
399 :     (#c (copy-point (find-point-in-group currentgroup x y)))
400 :     (#i (insert-bezier (find-point-in-group currentgroup x y)))
401 :     (#d (delete (find-point-in-group currentgroup x y)))
402 :     (#s
403 :     (smooth-point (find-point-in-group currentgroup x y)))
404 :     (#n
405 :     (setq currentgroup `((angle ,x ,y) nil nil))
406 :     (rplaca (cdr currentgroup)currentgroup)
407 :     (rplaca (cddr currentgroup)currentgroup)
408 :     (push currentgroup outline))))
409 :     (('ButtonPress 'button2 x y)
410 :     (setq curpoint (cons x y)))
411 :     (('ButtonRelease 'button2 x y)
412 :     (movepoint currentgroup curpoint x y)))
413 :     (disp outline currentgroup)))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help