1 : |
ktanaka |
1.1 |
;; -*- Mode: lisp -*- |
2 : |
|
|
;; 新しい左ハライの検討の実験 lisp コード |
3 : |
|
|
;; 1991 年 長橋 |
4 : |
|
|
|
5 : |
|
|
;; テスト用の漢字リスト |
6 : |
|
|
;; |
7 : |
|
|
(setq jis-list |
8 : |
|
|
'(娃 哀 有 葵 旭 圧 扱 宛 姐 安 杏 井 伊 衣 亥)) |
9 : |
|
|
|
10 : |
|
|
;; X-window に描くためのルーチン群(要 ulx) |
11 : |
|
|
(defun draw-bezier (window gc x0 y0 x1 y1 x2 y2 x3 y3) |
12 : |
|
|
(let ((bez (bez x0 y0 x1 y1 x2 y2 x3 y3))) |
13 : |
|
|
(draw-lines window gc (points-to-flat bez)))) |
14 : |
|
|
|
15 : |
|
|
(defun points-to-flat (points) |
16 : |
|
|
(mapcan points |
17 : |
|
|
(function (lambda (x) (list (car x) (cdr x)))))) |
18 : |
|
|
|
19 : |
|
|
(defun draw-harai (window gc x0 y0 x1 y1 x2 y2) |
20 : |
|
|
(lets ((spec (funcall (get 'migi 'mincho) |
21 : |
|
|
`((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)) nil)) |
22 : |
|
|
(line1 (first spec)) |
23 : |
|
|
(line2 (second spec)) |
24 : |
|
|
(trans (function (lambda (x) |
25 : |
|
|
(list (fix (second x))(fix (third x))))))) |
26 : |
|
|
(draw-line window gc x0 y0 x1 y1) |
27 : |
|
|
(draw-line window gc x1 y1 x2 y2) |
28 : |
|
|
(apply 'draw-bezier (cons window (cons gc (mapcan line1 trans)))) |
29 : |
|
|
(apply 'draw-bezier (cons window (cons gc (mapcan line2 trans)))) |
30 : |
|
|
)) |
31 : |
|
|
|
32 : |
|
|
;; PostScript コードを生成するための関数 |
33 : |
|
|
;; |
34 : |
|
|
;; postscript-bez: bez (list of 3 control points) -> bezier line. |
35 : |
|
|
;; |
36 : |
|
|
(defun postscript-bez (bez p) |
37 : |
|
|
;;(format "/s /s moveto " (first bez) (second bez)) |
38 : |
|
|
(format "/s /s /s " (first bez) (second bez) p) |
39 : |
|
|
(mapcar (cddr bez) '(lambda (x) (princ x) (princ " "))) |
40 : |
|
|
(format "curveto/n")) |
41 : |
|
|
|
42 : |
|
|
;; postscript-bez-control: bez -> control point |
43 : |
|
|
;; |
44 : |
|
|
(defun postscript-bez-control (bez (dot)) |
45 : |
|
|
(and dot |
46 : |
|
|
(do ((x (cddr bez) (cddr x)) |
47 : |
|
|
(R 4)) |
48 : |
|
|
((atom (cddr x))) |
49 : |
|
|
(format "/c /c moveto /c 0 rmoveto /c /c /c 0 360 arc fill/n" |
50 : |
|
|
(first x) (second x) R |
51 : |
|
|
(first x) (second x) R))) |
52 : |
|
|
(format "gsave .3 setlinewidth/n") |
53 : |
|
|
(do ((x bez (cddr x)) |
54 : |
|
|
(m 'moveto 'lineto)) |
55 : |
|
|
((atom x)) |
56 : |
|
|
(format "/c /c /c " (first x) (second x) m)) |
57 : |
|
|
(format "[3 5] 0 setdash stroke grestore/n") |
58 : |
|
|
) |
59 : |
|
|
|
60 : |
|
|
;; パラメータを変化させつつハライを描く |
61 : |
|
|
;; |
62 : |
|
|
(defun postscript-harai (x0 y0 x1 y1 x2 y2) |
63 : |
|
|
(lets ((spec (funcall (get 'migi 'mincho) |
64 : |
|
|
`((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)) nil)) |
65 : |
|
|
(line1 (first spec)) |
66 : |
|
|
(line2 (reverse (second spec))) |
67 : |
|
|
(trans (function (lambda (x) |
68 : |
|
|
(list (fix (second x))(fix (third x)))))) |
69 : |
|
|
(bez1 (mapcan line1 trans)) |
70 : |
|
|
(bez2 (mapcan line2 trans))) |
71 : |
|
|
|
72 : |
|
|
(format "gsave/n") |
73 : |
|
|
(postscript-bez bez1 'moveto) |
74 : |
|
|
(postscript-bez bez2 'lineto) |
75 : |
|
|
(format "closepath 0.6 setgray fill grestore/n") |
76 : |
|
|
|
77 : |
|
|
(postscript-bez-control bez1) |
78 : |
|
|
(postscript-bez-control bez2) |
79 : |
|
|
|
80 : |
|
|
(format "/s /s moveto /s /s lineto /s /s lineto 0.3 setlinewidth stroke/n" |
81 : |
|
|
x0 y0 x1 y1 x2 y2))) |
82 : |
|
|
|
83 : |
|
|
;; postscript 出力用マクロ |
84 : |
|
|
;; |
85 : |
|
|
(defmacro with-postscript-output (filename . body) |
86 : |
|
|
`(let ((standard-output (outopen (stream ,filename)))) |
87 : |
|
|
(format "%!/n") |
88 : |
|
|
(format "0.5 0.5 scale 20 50 translate/n") |
89 : |
|
|
(progn . ,body) |
90 : |
|
|
(format "showpage/n") |
91 : |
|
|
(close standard-output) |
92 : |
|
|
nil)) |
93 : |
|
|
|
94 : |
|
|
;; dx, dy = delta vector to p3.(forth point) |
95 : |
|
|
(defun postscript-bez-harai-list (dx dy) |
96 : |
|
|
(with-postscript-output "d" |
97 : |
|
|
(format "40 1500 translate 1 -1 scale/n") |
98 : |
|
|
(lets ((px0 dx) (py0 0) |
99 : |
|
|
(px1 dx) (py1 100) |
100 : |
|
|
(px2 0) (py2 (+ py1 dy)) |
101 : |
|
|
(xy (//$ (float dy) (float dx))) |
102 : |
|
|
(dxx (//$ (float dx) 10.0))) |
103 : |
|
|
(do ((y 0 (+ y 10))) |
104 : |
|
|
((>= y 100)) |
105 : |
|
|
(format "save/n") |
106 : |
|
|
(do ((x dxx (+$ x dxx))) |
107 : |
|
|
((>$ x (float dx))) |
108 : |
|
|
|
109 : |
|
|
(let ((bez (list px0 py0 px0 y |
110 : |
|
|
(fix x) (- py2 (fix (*$ x xy))) |
111 : |
|
|
px2 py2))) |
112 : |
|
|
(postscript-bez bez 'moveto) |
113 : |
|
|
(format "3 setlinewidth stroke/n") |
114 : |
|
|
(postscript-bez-control bez t)) |
115 : |
|
|
(format "/c 0 translate/n" (+ dx 20))) |
116 : |
|
|
(format "restore 0 /c translate/n" (+ 100 dy 10))) |
117 : |
|
|
))) |
118 : |
|
|
|
119 : |
|
|
|
120 : |
|
|
(defun postscript-harai-list () |
121 : |
|
|
(with-postscript-output "d" |
122 : |
|
|
(format "1200 0 translate -1 1 scale/n") |
123 : |
|
|
(lets ((x1 100) (y1 100)) |
124 : |
|
|
(do ((gy 0 (+ gy 250)) |
125 : |
|
|
(y2 (+ y1 40) (+ y2 20))) |
126 : |
|
|
((>= gy 1500)) |
127 : |
|
|
(do ((gx 0 (+ gx 100)) |
128 : |
|
|
(x2 x1 (+ x2 20))) |
129 : |
|
|
((>= gx 1000)) |
130 : |
|
|
(format "save /s /s translate/n" gx gy) |
131 : |
|
|
(postscript-harai x1 0 x1 y1 x2 y2) |
132 : |
|
|
(format "restore/n") |
133 : |
|
|
))))) |
134 : |
|
|
|
135 : |
|
|
(defun postscript-hidari (x0 y0 x1 y1 x2 y2) |
136 : |
|
|
(lets ((spec (funcall (get 'hidari 'mincho) |
137 : |
|
|
`((,x0 ,y0) (,x1 ,y1) (,x2 ,y2)) nil)) |
138 : |
|
|
(line1 (first spec)) |
139 : |
|
|
(line2 (reverse (second spec))) |
140 : |
|
|
(trans (function (lambda (x) |
141 : |
|
|
(list (fix (second x))(fix (third x)))))) |
142 : |
|
|
(bez1 (mapcan line1 trans)) |
143 : |
|
|
(bez2 (mapcan line2 trans))) |
144 : |
|
|
|
145 : |
|
|
(format "gsave/n") |
146 : |
|
|
(postscript-bez bez1 'moveto) |
147 : |
|
|
(postscript-bez bez2 'lineto) |
148 : |
|
|
(format "closepath 0.6 setgray fill grestore/n") |
149 : |
|
|
|
150 : |
|
|
(postscript-bez-control bez1 t) |
151 : |
|
|
(postscript-bez-control bez2 t) |
152 : |
|
|
|
153 : |
|
|
(format "/s /s moveto /s /s lineto /s /s lineto 0.3 setlinewidth stroke/n" |
154 : |
|
|
x0 y0 x1 y1 x2 y2))) |
155 : |
|
|
|
156 : |
|
|
(defun postscript-hidari-list () |
157 : |
|
|
(with-postscript-output "d" |
158 : |
|
|
(format "1200 0 translate -1 1 scale/n") |
159 : |
|
|
(lets ((x1 200) (y1 100)) |
160 : |
|
|
(do ((gy 0 (+ gy 250)) |
161 : |
|
|
(y2 (+ y1 40) (+ y2 20))) |
162 : |
|
|
((>= gy 1500)) |
163 : |
|
|
(do ((gx 0 (+ gx 100)) |
164 : |
|
|
(x2 x1 (- x2 20))) |
165 : |
|
|
((>= gx 1000)) |
166 : |
|
|
(format "save /s /s translate/n" gx gy) |
167 : |
|
|
(postscript-hidari x1 0 x1 y1 x2 y2) |
168 : |
|
|
(format "restore/n") |
169 : |
|
|
))))) |
170 : |
|
|
|
171 : |
|
|
(defun radian (deg) |
172 : |
|
|
(*$ (//$ (float deg) 180.0) 3.141593)) |
173 : |
|
|
|
174 : |
|
|
(defun postscript-hidari-list2 () |
175 : |
|
|
(with-postscript-output "d" |
176 : |
|
|
(format "50 1500 translate 1 -1 scale/n") |
177 : |
|
|
(lets ((x0 150) (y0 0) |
178 : |
|
|
(x1 (- x0 50)) (y1 300)) |
179 : |
|
|
(do ((gy 0 (+ gy 500)) |
180 : |
|
|
(r 100 (+ r 20))) |
181 : |
|
|
((>= gy 1500)) |
182 : |
|
|
(do ((gx 0 (+ gx 100)) |
183 : |
|
|
(s 0 (+ s 10))) |
184 : |
|
|
((>= gx 1000)) |
185 : |
|
|
(format "save /s /s translate/n" gx gy) |
186 : |
|
|
(let ((x2 (- x1 (fix (*$ (float r) (sin (radian s)))))) |
187 : |
|
|
(y2 (+ y1 (fix (*$ (float r) (cos (radian s))))))) |
188 : |
|
|
(postscript-hidari x0 y0 x1 y1 x2 y2) |
189 : |
|
|
(format "restore/n") |
190 : |
|
|
)))))) |
191 : |
|
|
|
192 : |
|
|
;; prim-p: checks prim is a primitive or not. |
193 : |
|
|
;; |
194 : |
|
|
(defun prim-p (prim) |
195 : |
|
|
(and (symbolp prim) (setq (eval prim))) |
196 : |
|
|
(or (and (consp prim) (stringp (car prim))) |
197 : |
|
|
(stringp prim) |
198 : |
|
|
(and (consp prim) (consp (car prim))))) |
199 : |
|
|
|
200 : |
|
|
(defun postscript-outline (prim (tag 'mincho)) |
201 : |
|
|
(let ((outline (skelton2list (applykanji prim) tag))) |
202 : |
|
|
(and (consp outline) |
203 : |
|
|
(do ((ll outline (cdr ll))) |
204 : |
|
|
((atom ll)) |
205 : |
|
|
(setq last (caar ll)) |
206 : |
|
|
(format "/c /c moveto/n" (fix (cadr last)) (fix (caddr last))) |
207 : |
|
|
(do ((lll (cdar ll) (cdr lll))) |
208 : |
|
|
((atom lll)) |
209 : |
|
|
(match (car lll) |
210 : |
|
|
(('angle x y) |
211 : |
|
|
(format "/c /c lineto/n" (fix x) (fix y))) |
212 : |
|
|
(('bezier x0 y0) |
213 : |
|
|
(setq next (cadr lll)) |
214 : |
|
|
(setq nextnext |
215 : |
|
|
(cond ((cddr lll)(setq lll (cddr lll))(car lll)) |
216 : |
|
|
(t (setq lll (cdr lll))last))) |
217 : |
|
|
(setq x1 (cadr next) y1 (caddr next)) |
218 : |
|
|
(setq x2 (cadr nextnext) y2 (caddr nextnext)) |
219 : |
|
|
(format "/c /c /c /c /c /c curveto/n" |
220 : |
|
|
(fix x0) (fix y0) |
221 : |
|
|
(fix x1) (fix y1) |
222 : |
|
|
(fix x2) (fix y2))))) |
223 : |
|
|
(format "closepath fill/n"))))) |
224 : |
|
|
|
225 : |
|
|
;; skelton を出力 |
226 : |
|
|
(defun postscript-skelton (prim) |
227 : |
|
|
(and (symbolp prim) (setq prim (eval prim))) |
228 : |
|
|
(and (consp prim) (stringp (car prim)) (setq prim (car prim))) |
229 : |
|
|
(and (stringp prim) (setq prim (unpackprim prim))) |
230 : |
|
|
|
231 : |
|
|
(let ((points (first prim)) |
232 : |
|
|
(links (second prim)) |
233 : |
|
|
(gx 50) (gy 50) |
234 : |
|
|
(R 10)) |
235 : |
|
|
;;(format "/c /c translate/n" gx gy) |
236 : |
|
|
|
237 : |
|
|
(format "gsave 0.8 setgray/n") |
238 : |
|
|
(postscript-outline prim) |
239 : |
|
|
(format "grestore/n") |
240 : |
|
|
|
241 : |
|
|
(princ "gsave ") |
242 : |
|
|
(format "0 0 moveto 0 400 rlineto 400 0 rlineto 0 -400 rlineto/n") |
243 : |
|
|
(format "closepath 0 setlinewidth stroke grestore/n") |
244 : |
|
|
|
245 : |
|
|
(format "gsave .5 setlinewidth/n") |
246 : |
|
|
(mapcar points '(lambda (x) (format "/c /c " (first x) (second x)))) |
247 : |
|
|
(format "/c { 2 copy moveto /c 0 rmoveto /c 0 360 arc stroke } repeat/n" |
248 : |
|
|
(length points) R R) |
249 : |
|
|
(format "grestore/n") |
250 : |
|
|
|
251 : |
|
|
(format "gsave 2 setlinewidth/n") |
252 : |
|
|
(do ((l links (cdr l))) |
253 : |
|
|
((atom l )) |
254 : |
|
|
(do ((p (second (car l)) (cdr p)) |
255 : |
|
|
(m 'moveto 'lineto)) |
256 : |
|
|
((atom p)) |
257 : |
|
|
(let ((f (nth (car p) points))) |
258 : |
|
|
(format "/c /c /c " (first f) (second f) m))) |
259 : |
|
|
(format "stroke/n")) |
260 : |
|
|
(format "grestore/n"))) |
261 : |
|
|
|
262 : |
|
|
;; 一枚の紙に複数の図を描くためのマクロ |
263 : |
|
|
;; |
264 : |
|
|
(defmacro multi-postscript-output ((filename xsize ysize) . body) |
265 : |
|
|
`(let ((standard-output (outopen (stream ,filename))) |
266 : |
|
|
(xsize ,xsize) (ysize ,ysize) |
267 : |
|
|
(gx 20) (gy 810)) |
268 : |
|
|
(format "%!/n") |
269 : |
|
|
(loop |
270 : |
|
|
(format "save /c /c translate 1 -1 scale/n" gx gy) |
271 : |
|
|
(let ((whatnext (progn . ,body))) |
272 : |
|
|
(format "restore/n/n") |
273 : |
|
|
(cond (whatnext (format "showpage/n") (exit))) |
274 : |
|
|
(setq gx (+ gx xsize)) |
275 : |
|
|
(and (>= gx (- 600 xsize)) (setq gx 20 gy (- gy ysize))) |
276 : |
|
|
(or (>= gy ysize) (progn (setq gy 800) (format "showpage/n/n"))))) |
277 : |
|
|
(close standard-output))) |
278 : |
|
|
|
279 : |
|
|
;; postscript-skelton-all: primitive list -> skelton. |
280 : |
|
|
(defun postscript-skelton-all (prims) |
281 : |
|
|
(and (atom prims) (setq prims (ncons prims))) |
282 : |
|
|
(multi-postscript-output ("skel.ps" 205 205) |
283 : |
|
|
(cond ((atom prims) t) |
284 : |
|
|
(t (format "0.5 0.5 scale/n") |
285 : |
|
|
(postscript-skelton (pop prims)) |
286 : |
|
|
nil)))) |
287 : |
|
|
|
288 : |
|
|
(macro gsave (body) |
289 : |
|
|
`(progn |
290 : |
|
|
(format "gsave/n") |
291 : |
|
|
(progn . ,body) |
292 : |
|
|
(format "grestore/n"))) |
293 : |
|
|
|
294 : |
|
|
(defun postscript-harai-all (prims) |
295 : |
|
|
(and (atom prims) (setq prims (ncons prims))) |
296 : |
|
|
(multi-postscript-output ("harai.ps" 205 205) |
297 : |
|
|
(or (atom prims) |
298 : |
|
|
(let ((harai (get (pop prims) 'harai))) |
299 : |
|
|
(format "0.5 0.5 scale gsave/n") |
300 : |
|
|
(format "0 0 moveto 0 400 rlineto 400 0 rlineto 0 -400 rlineto/n") |
301 : |
|
|
(format "closepath 0 setlinewidth stroke grestore/n") |
302 : |
|
|
(do ((h harai (cdr h))) |
303 : |
|
|
((atom h)) |
304 : |
|
|
(let ((bez (mapcan (car h) '(lambda (x) (copy (cdr x)))))) |
305 : |
|
|
(gsave |
306 : |
|
|
(postscript-bez bez 'moveto) |
307 : |
|
|
(format "2 setlinewidth stroke/n")) |
308 : |
|
|
(postscript-bez-control bez t))) |
309 : |
|
|
nil)))) |
310 : |
|
|
|
311 : |
|
|
(defmacro X (p) `(first ,p)) |
312 : |
|
|
(defmacro Y (p) `(second ,p)) |
313 : |
|
|
|
314 : |
|
|
(defun postscript-bezier-point (prim) |
315 : |
|
|
(do ((p prim (cdr p))) |
316 : |
|
|
((atom p)) |
317 : |
|
|
(do ((h (get (car p) 'harai) (cdr h))) |
318 : |
|
|
((atom h)) |
319 : |
|
|
|
320 : |
|
|
(lets ((points (mapcar (car h) 'cdr)) |
321 : |
|
|
(p0 (first points)) |
322 : |
|
|
(p1 (third points)) |
323 : |
|
|
(p2 (fourth points)) |
324 : |
|
|
(cp (second points)) |
325 : |
|
|
(d1 (diff2 p0 p1)) |
326 : |
|
|
(d2 (diff2 p2 p1)) |
327 : |
|
|
(ss (minus (//$ (float (X d2))(float (Y d2))))) |
328 : |
|
|
(ys (//$ (float (- (Y p1) (Y cp))) |
329 : |
|
|
(float (- (Y p1) (Y p0))))) |
330 : |
|
|
(armlen1 (sqrt (+$ (*$ (float (X d1)) (float (X d1))) |
331 : |
|
|
(*$ (float (Y d1)) (float (Y d1)))))) |
332 : |
|
|
(armlen2 (sqrt (+$ (*$ (float (X d2)) (float (X d2))) |
333 : |
|
|
(*$ (float (Y d2)) (float (Y d2)))))) |
334 : |
|
|
(yd (float (- (Y p1) (Y cp)))) |
335 : |
|
|
(lenratio (//$ armlen2 armlen1)) |
336 : |
|
|
) |
337 : |
|
|
;;(format "/c /c/n" ss ys) ;; harai.data3 |
338 : |
|
|
;;(format "/c /c/n" armlen2 yd) ;; harai.data4 |
339 : |
|
|
;;(format "/c /c/n" lenratio ys) ;; harai.data5 |
340 : |
|
|
(format "/c /c/n" lenratio (sqrt ys)) ;; harai.data6 |
341 : |
|
|
)))) |
342 : |
|
|
|
343 : |
|
|
;; |
344 : |
|
|
;; redefine hidari-harai. |
345 : |
|
|
(defelement mincho hidari |
346 : |
|
|
(let ((p0 (first points)) |
347 : |
|
|
(p1 (second points)) |
348 : |
|
|
(p2 (third points)) |
349 : |
|
|
(w (times minchowidth 0.9))) ; chotto herasita houga dekiga yoi. |
350 : |
|
|
(lets ((v10 (diff2 p0 p1)) |
351 : |
|
|
(v12 (diff2 p2 p1)) |
352 : |
|
|
(d10 (norm2 (list (Y v10) (minus (X v10))))) |
353 : |
|
|
(d12 (norm2 (list (minus (Y v12)) (X v12)))) |
354 : |
|
|
(vc (plus2 d10 d12)) |
355 : |
|
|
|
356 : |
|
|
(a (length2 v10))(b (length2 v12)) |
357 : |
|
|
;;(c1disp (//$ b 2.0)) |
358 : |
|
|
(lenratio (//$ b a)) |
359 : |
|
|
(c1disp (*$ lenratio lenratio a)) |
360 : |
|
|
|
361 : |
|
|
(wl (*$ (//$ b (+$ a b)) w)) |
362 : |
|
|
(cc (minus (Y (norm2 v10)))) ;cosine |
363 : |
|
|
(w2 (+$ (*$ w cc) (*$ wl (-$ 1.0 cc)))) |
364 : |
|
|
|
365 : |
|
|
(dc (times2 (//$ w2 (mul2 vc d10)) vc)) |
366 : |
|
|
(cl (plus2 p1 dc)) |
367 : |
|
|
(cr (diff2 p1 dc))) |
368 : |
|
|
`(((angle . ,(plus2 p0 (times2 w d10))) |
369 : |
|
|
(bezier . ,(plus2 cl (normlen2 c1disp v10))) |
370 : |
|
|
(bezier . ,cl) |
371 : |
|
|
(angle . ,p2)) |
372 : |
|
|
((angle . ,(plus2 p0 (normlen2 (minus w) d10))) |
373 : |
|
|
(bezier . ,(plus2 cr (normlen2 c1disp v10))) |
374 : |
|
|
(bezier . ,cr) |
375 : |
|
|
(angle . ,p2)))))) |