1 : |
ktanaka |
1.1 |
|
2 : |
|
|
;; 漢字文字列をベクタに変換 |
3 : |
|
|
(defun kanji2vec (str) |
4 : |
|
|
(lets ((len (// (string-length str) 2)) |
5 : |
|
|
(vec (vector len))) |
6 : |
|
|
(do ((i 0 (1+ i))) |
7 : |
|
|
((>= i len)vec) |
8 : |
|
|
(vset vec i (+ (* 256 (logand 127 (sref str (* 2 i)))) |
9 : |
|
|
(logand 127 (sref str (1+ (* 2 i))))))))) |
10 : |
|
|
|
11 : |
|
|
;; ulx のロード |
12 : |
|
|
(defun init_window () 'dummy) |
13 : |
|
|
(cond ((definedp 'get-display-host) nil) |
14 : |
|
|
(t (exfile (string-append system_lib_path "ulx/loadulx.l")) |
15 : |
|
|
(exfile "pack.l") |
16 : |
|
|
(exfile "all.l") |
17 : |
|
|
(exfile "disp.l") |
18 : |
|
|
(exfile "mincho.l") |
19 : |
|
|
(exfile "gothic.l") |
20 : |
|
|
(exfile "lib.l") |
21 : |
|
|
(exfile "joint.l"))) |
22 : |
|
|
|
23 : |
|
|
;; ディスプレイホストの設定 |
24 : |
|
|
(setq display-host (get-display-host)) |
25 : |
|
|
(or display-host (progn (format "Display unknown/n") (err:argument-type))) |
26 : |
|
|
|
27 : |
|
|
;; スクリーンの定義 |
28 : |
|
|
(setq display (open-display display-host)) |
29 : |
|
|
(setq screen (first (display-roots display))) |
30 : |
|
|
(setq root (screen-root screen)) |
31 : |
|
|
(setq window-of-menus root) |
32 : |
|
|
|
33 : |
|
|
;; 白黒の定義 |
34 : |
|
|
(setq black (screen-black-pixel screen) |
35 : |
|
|
white (screen-white-pixel screen)) |
36 : |
|
|
|
37 : |
|
|
;; リクエストの直後に描画する |
38 : |
|
|
;; (setf (display-after-function display) 'display-force-output) |
39 : |
|
|
|
40 : |
|
|
;; ウィンドウを作ってみる |
41 : |
|
|
(setq -all-smallwindows- nil) |
42 : |
|
|
|
43 : |
|
|
(defstruct (smallwindow) |
44 : |
|
|
window |
45 : |
|
|
save |
46 : |
|
|
gc |
47 : |
|
|
revgc |
48 : |
|
|
height |
49 : |
|
|
width) |
50 : |
|
|
|
51 : |
|
|
(defun create-smallwindow ((pare root) (title "unknown") (wid 400) (hei 400) (fontname "k14")) |
52 : |
|
|
(lets ((nowfont (open-font display fontname)) |
53 : |
|
|
(a (make-smallwindow |
54 : |
|
|
:window (create-window |
55 : |
|
|
:parent pare |
56 : |
|
|
:class :input-output |
57 : |
|
|
:x 0 |
58 : |
|
|
:y 0 |
59 : |
|
|
:width wid |
60 : |
|
|
:height hei |
61 : |
|
|
:foreground black |
62 : |
|
|
:background white) |
63 : |
|
|
:save (create-pixmap |
64 : |
|
|
:width wid |
65 : |
|
|
:height hei |
66 : |
|
|
:drawable root |
67 : |
|
|
:depth 1) |
68 : |
|
|
:gc (create-gcontext |
69 : |
|
|
:drawable root |
70 : |
|
|
:foreground black |
71 : |
|
|
:background white |
72 : |
|
|
:font nowfont) |
73 : |
|
|
:revgc (create-gcontext |
74 : |
|
|
:drawable root |
75 : |
|
|
:foreground white |
76 : |
|
|
:background black |
77 : |
|
|
:font nowfont) |
78 : |
|
|
:width wid |
79 : |
|
|
:height hei))) |
80 : |
|
|
(setf (wm-name (smallwindow-window a)) title) |
81 : |
|
|
(setf (window-event-mask (smallwindow-window a)) |
82 : |
|
|
'(:button-press :button-release :key-press :exposure)) |
83 : |
|
|
(map-window (smallwindow-window a)) |
84 : |
|
|
(draw-rectangle (smallwindow-save a) (smallwindow-revgc a) 0 0 wid hei t) |
85 : |
|
|
(push a -all-smallwindows-) |
86 : |
|
|
a)) |
87 : |
|
|
|
88 : |
|
|
;; ウィンドウを消す |
89 : |
|
|
(defun smallwindow-destroy (sw) |
90 : |
|
|
(destroy-window (smallwindow-window sw))) |
91 : |
|
|
|
92 : |
|
|
;; 真っ白にする |
93 : |
|
|
(defun smallwindow-clear (sw) |
94 : |
|
|
(draw-rectangle (smallwindow-save sw) (smallwindow-revgc sw) 0 0 |
95 : |
|
|
(smallwindow-width sw) (smallwindow-height sw) t)) |
96 : |
|
|
|
97 : |
|
|
;; 描画を(再)表示する |
98 : |
|
|
(defun smallwindow-redraw (sw) |
99 : |
|
|
(copy-area (smallwindow-save sw) (smallwindow-gc sw) 0 0 |
100 : |
|
|
(smallwindow-width sw) (smallwindow-height sw) |
101 : |
|
|
(smallwindow-window sw) |
102 : |
|
|
0 0)) |
103 : |
|
|
|
104 : |
|
|
;; 文字列を出力する |
105 : |
|
|
(defun smallwindow-putstr (sw x y str) |
106 : |
|
|
(draw-glyphs (smallwindow-save sw) (smallwindow-gc sw) x y (kanji2vec str) :size 16)) |
107 : |
|
|
|
108 : |
|
|
;; 線を描く |
109 : |
|
|
(defun smallwindow-drawline (sw x1 y1 x2 y2) |
110 : |
|
|
(draw-line (smallwindow-save sw) (smallwindow-gc sw) x1 y1 x2 y2)) |
111 : |
|
|
|
112 : |
|
|
(defun smallwindow-drawlines (sw points) |
113 : |
|
|
(draw-lines (smallwindow-save sw) (smallwindow-gc sw) |
114 : |
|
|
(cons2flat points) |
115 : |
|
|
:complex t)) |
116 : |
|
|
|
117 : |
|
|
(defun smallwindow-fillpolygon (sw points) |
118 : |
|
|
(draw-lines (smallwindow-save sw) (smallwindow-gc sw) |
119 : |
|
|
(cons2flat points) |
120 : |
|
|
:fill-p t |
121 : |
|
|
:complex t)) |
122 : |
|
|
|
123 : |
|
|
;; イベントのチェック |
124 : |
|
|
(defun buttonnmb (n) |
125 : |
|
|
(nth (1- n) '(button1 button2 button3))) |
126 : |
|
|
|
127 : |
|
|
(setq keytrans '(84 111 109 86 63 87 88 89 68 90 91 92 |
128 : |
|
|
113 112 69 70 61 64 85 65 67 110 62 108 66 107 83)) |
129 : |
|
|
|
130 : |
|
|
(defun search-smallwindow (event-window) |
131 : |
|
|
(do ((rest -all-smallwindows- (cdr rest)) |
132 : |
|
|
(ret nil)) |
133 : |
|
|
(ret ret) |
134 : |
|
|
(if (eq (smallwindow-window (car rest)) event-window) |
135 : |
|
|
(setq ret (car rest))) |
136 : |
|
|
(if (null (cdr rest)) |
137 : |
|
|
(print "???? display:error")))) |
138 : |
|
|
|
139 : |
|
|
(defun all-smallwindow-checkevent () |
140 : |
|
|
(do ((ret nil) |
141 : |
|
|
(key nil)) |
142 : |
|
|
(ret ret) |
143 : |
|
|
(event-case (display) |
144 : |
|
|
(:exposure |
145 : |
|
|
(event-window count) |
146 : |
|
|
(let ((kouho (search-smallwindow event-window))) |
147 : |
|
|
;;(princ "exposure ") |
148 : |
|
|
;;(prind kouho) |
149 : |
|
|
(if (0= count) (smallwindow-redraw kouho))) |
150 : |
|
|
t) |
151 : |
|
|
(:button-press |
152 : |
|
|
(event-window code x y) |
153 : |
|
|
(setq ret `(ButtonPress ,(buttonnmb code) ,x ,y |
154 : |
|
|
,(search-smallwindow event-window))) |
155 : |
|
|
t) |
156 : |
|
|
(:button-release |
157 : |
|
|
(event-window code x y) |
158 : |
|
|
(setq ret `(ButtonRelease ,(buttonnmb code) ,x ,y |
159 : |
|
|
,(search-smallwindow event-window))) |
160 : |
|
|
t) |
161 : |
|
|
(:key-press |
162 : |
|
|
(event-window code x y) |
163 : |
|
|
(setq key (memq code keytrans)) |
164 : |
|
|
(cond (key (setq code (- 124 (length key))))) |
165 : |
|
|
(setq ret `(KeyPress ,code ,(search-smallwindow event-window))) |
166 : |
|
|
t) |
167 : |
|
|
(otherwise |
168 : |
|
|
() |
169 : |
|
|
t)))) |
170 : |
|
|
|
171 : |
|
|
|
172 : |
|
|
(defun smallwindow-checkevent (sw) |
173 : |
|
|
(do ((ret nil)) |
174 : |
|
|
(ret ret) |
175 : |
|
|
(let ((events (all-smallwindow-checkevent))) |
176 : |
|
|
;;(prind events) |
177 : |
|
|
;;(prind (last events)) |
178 : |
|
|
;;(prind sw) |
179 : |
|
|
(if (eq (car (last events)) sw) |
180 : |
|
|
(setq ret (reverse (cdr (reverse events)))))))) |
181 : |
|
|
|
182 : |
|
|
;; 歴史的な理由による関数群 |
183 : |
|
|
(defun init_window (wid hei) |
184 : |
|
|
(setq -traditional-window- (create-smallwindow root "utilisp" wid 400))) |
185 : |
|
|
(defun drawline (x0 y0 x1 y1) |
186 : |
|
|
(smallwindow-drawline -traditional-window- x0 y0 x1 y1)) |
187 : |
|
|
(defun redraw () |
188 : |
|
|
(smallwindow-redraw -traditional-window-)) |
189 : |
|
|
(defun checkevent () |
190 : |
|
|
(smallwindow-checkevent -traditional-window-)) |
191 : |
|
|
(defun close_window () |
192 : |
|
|
(smallwindow-destroy -traditional-window-)) |
193 : |
|
|
(defun cons2flat (points) |
194 : |
|
|
(do ((l points (cdr l)) |
195 : |
|
|
(ret nil)) |
196 : |
|
|
((atom l)(nreverse ret)) |
197 : |
|
|
(push (caar l) ret) |
198 : |
|
|
(push (cdar l) ret))) |
199 : |
|
|
(defun fillpolygon (points) |
200 : |
|
|
(smallwindow-fillpolygon -traditional-window- points)) |
201 : |
|
|
(defun drawlines (points) |
202 : |
|
|
(smallwindow-drawlines -traditional-window- points)) |
203 : |
|
|
(defun loadpbm (code)) |
204 : |
|
|
(defun loadjis (code)) |
205 : |
|
|
(defun copybg () |
206 : |
|
|
(smallwindow-clear -traditional-window-)) |
207 : |
|
|
|
208 : |
|
|
;; 漢字を表から選ぶ |
209 : |
|
|
;; (select-kanji) で漢字の文字列がえられる |
210 : |
|
|
(setq kanji-itiran-high -1) |
211 : |
|
|
(setq min-kanji-high 48 |
212 : |
|
|
max-kanji-high 79) |
213 : |
|
|
|
214 : |
|
|
(defun display-kanji (start) |
215 : |
|
|
(let ((high start)) |
216 : |
|
|
(if (< high min-kanji-high) (setq high min-kanji-high)) |
217 : |
|
|
(if (> high max-kanji-high) (setq high max-kanji-high)) |
218 : |
|
|
(cond ((neq kanji-itiran-high high) |
219 : |
|
|
(setq kanji-itiran-high high) |
220 : |
|
|
(smallwindow-clear kanji-itiran) |
221 : |
|
|
(setq high (string (+ 128 high))) |
222 : |
|
|
(do ((low (+ 128 33)) |
223 : |
|
|
(disp-y 14 (+ 14 disp-y)) |
224 : |
|
|
(str "" "")) |
225 : |
|
|
((> low 254)) |
226 : |
|
|
(do ((count 0 (1+ count))) |
227 : |
|
|
((>= count 16)) |
228 : |
|
|
(cond ((<= low (+ 128 33)) |
229 : |
|
|
(setq count 1) |
230 : |
|
|
(if (<= kanji-itiran-high min-kanji-high) |
231 : |
|
|
(setq str "_") |
232 : |
|
|
(setq str "<")) |
233 : |
|
|
(setq str (string-append str high (string low)))) |
234 : |
|
|
((> low 254) |
235 : |
|
|
(setq count 16) |
236 : |
|
|
(if (>= kanji-itiran-high max-kanji-high) |
237 : |
|
|
(setq str (string-append str "_")) |
238 : |
|
|
(setq str (string-append str ">")))) |
239 : |
|
|
(t (setq str (string-append str high (string low))))) |
240 : |
|
|
(setq low (1+ low))) |
241 : |
|
|
(smallwindow-putstr kanji-itiran 0 disp-y str))))) |
242 : |
|
|
(smallwindow-redraw kanji-itiran)) |
243 : |
|
|
|
244 : |
|
|
(defun select-kanji () |
245 : |
|
|
(setq now-selected (-select-kanji-)) |
246 : |
|
|
(prind now-selected)) |
247 : |
|
|
|
248 : |
|
|
(defun -select-kanji- () |
249 : |
|
|
(display-kanji kanji-itiran-high) |
250 : |
|
|
(do ((check (smallwindow-checkevent kanji-itiran) |
251 : |
|
|
(smallwindow-checkevent kanji-itiran)) |
252 : |
|
|
(low-nth 0 0) |
253 : |
|
|
(ret nil)) |
254 : |
|
|
(ret ret) |
255 : |
|
|
(cond ((eq 'ButtonPress (first check)) |
256 : |
|
|
(setq low-nth (+ (// (third check) 14) |
257 : |
|
|
(* (// (fourth check) 14) 16))) |
258 : |
|
|
(princ " ") (princ low-nth) |
259 : |
|
|
(cond ((and (< low-nth 95) (> low-nth 0)) |
260 : |
|
|
(setq ret (string-append (string (+ kanji-itiran-high 128)) |
261 : |
|
|
(string (+ low-nth 128 33 -1))))) |
262 : |
|
|
(t |
263 : |
|
|
(cond ((and (eq low-nth 0) (> kanji-itiran-high min-kanji-high)) |
264 : |
|
|
(princ "pred-page ") |
265 : |
|
|
(display-kanji (1- kanji-itiran-high))) |
266 : |
|
|
((and (eq low-nth 95) (< kanji-itiran-high max-kanji-high)) |
267 : |
|
|
(princ "next-page ") |
268 : |
|
|
(display-kanji (1+ kanji-itiran-high)))))))))) |
269 : |
|
|
|
270 : |
|
|
;; メニューを作る |
271 : |
|
|
;; 呼び出し方法 (setq lang-menu (create-menu "Language" |
272 : |
|
|
;; '(("APL" APL) ("Lisp" Lisp)))) |
273 : |
|
|
;; (select-menu lang-menu) |
274 : |
|
|
;; 結果 => ("APL" APL) か ("Lisp" Lisp) |
275 : |
|
|
|
276 : |
|
|
(defstruct (menu) |
277 : |
|
|
window |
278 : |
|
|
items |
279 : |
|
|
) |
280 : |
|
|
|
281 : |
|
|
(defun create-menu (title item-list (width 200)) |
282 : |
|
|
(let ((sw (make-menu |
283 : |
|
|
:window (create-smallwindow window-of-menus |
284 : |
|
|
title |
285 : |
|
|
width |
286 : |
|
|
(+ (* 16 (length item-list)) 4)) |
287 : |
|
|
:items item-list))) |
288 : |
|
|
(do ((names item-list (cdr names)) |
289 : |
|
|
(disp-y 16 (+ 16 disp-y))) |
290 : |
|
|
((null names) nil) |
291 : |
|
|
;; (prind names) |
292 : |
|
|
;; (prind disp-y) |
293 : |
|
|
(smallwindow-putstr (menu-window sw) 0 disp-y (car (car names)))) |
294 : |
|
|
(smallwindow-redraw (menu-window sw)) |
295 : |
|
|
sw)) |
296 : |
|
|
|
297 : |
|
|
(defun select-menu (men) |
298 : |
|
|
(do ((event (smallwindow-checkevent (menu-window men)) |
299 : |
|
|
(smallwindow-checkevent (menu-window men))) |
300 : |
|
|
(ret nil) |
301 : |
|
|
(nth-menu nil)) |
302 : |
|
|
(ret ret) |
303 : |
|
|
;; (prind event) |
304 : |
|
|
(cond ((eq 'ButtonPress (first event)) |
305 : |
|
|
(setq nth-menu (// (fourth event) 16)) |
306 : |
|
|
(if (< nth-menu (length (menu-items men))) |
307 : |
|
|
(setq ret (nth nth-menu (menu-items men)))))))) |
308 : |
|
|
|
309 : |
|
|
(comment (setq lang-menu |
310 : |
|
|
(create-menu "Language" |
311 : |
|
|
'(("えーぴーえる" APL) |
312 : |
|
|
("りすぷ" Lisp) |
313 : |
|
|
("ふぉーとらん" Fortran) |
314 : |
|
|
("ぱすかる" Pascal)))) |
315 : |
|
|
(loop (print (select-menu lang-menu)))) |
316 : |
|
|
|
317 : |
|
|
(setq now-jitai 'mincho) |
318 : |
|
|
(setq now-width 20.0 |
319 : |
|
|
max-width 40.0 |
320 : |
|
|
min-width 5.0) |
321 : |
|
|
(setq now-selected nil) |
322 : |
|
|
|
323 : |
|
|
(setq -number-str-juu- "_1234567890") |
324 : |
|
|
(setq -number-str-iti- "01234567890") |
325 : |
|
|
(defun width2str () |
326 : |
|
|
(let ((wid (fix now-width))) |
327 : |
|
|
(cond ((or (< wid (fix min-width)) (> wid (fix max-width))) "??") |
328 : |
|
|
(t (let ((juu (remainder (quotient wid 10) 10)) |
329 : |
|
|
(iti (remainder wid 10))) |
330 : |
|
|
(string-append (substring -number-str-juu- |
331 : |
|
|
(* juu 2) (+ 2 (* juu 2))) |
332 : |
|
|
(substring -number-str-iti- |
333 : |
|
|
(* iti 2) (+ 2 (* iti 2))))))))) |
334 : |
|
|
|
335 : |
|
|
(defun redraw-status () |
336 : |
|
|
(smallwindow-clear status-window) |
337 : |
|
|
(smallwindow-putstr status-window 0 16 |
338 : |
|
|
(string-append "字体_____" |
339 : |
|
|
(cond ((eq now-jitai 'mincho) |
340 : |
|
|
"明朝") |
341 : |
|
|
((eq now-jitai 'gothic) |
342 : |
|
|
"ゴシック") |
343 : |
|
|
(t "不明")))) |
344 : |
|
|
(smallwindow-putstr status-window 0 32 |
345 : |
|
|
(string-append "幅の係数___" (width2str))) |
346 : |
|
|
(smallwindow-putstr status-window 0 48 |
347 : |
|
|
(string-append "漢字_____「" |
348 : |
|
|
(if now-selected now-selected "?") |
349 : |
|
|
"」")) |
350 : |
|
|
(smallwindow-redraw status-window)) |
351 : |
|
|
|
352 : |
|
|
;; 漢字フォントを表示してみる |
353 : |
|
|
|
354 : |
|
|
(defun smallwindow-display-kanji-font (sw l tag) |
355 : |
|
|
(let ((outline (skelton2list (applykanji l) tag))) |
356 : |
|
|
(smallwindow-clear sw) |
357 : |
|
|
(mapcar outline '(lambda (x) (smallwindow-fillpolygon sw (setpart1 x)))) |
358 : |
|
|
(smallwindow-redraw sw))) |
359 : |
|
|
|
360 : |
|
|
(defun display-kanji-font (l tag) |
361 : |
|
|
(princ "表示の計算中 ") |
362 : |
|
|
(smallwindow-display-kanji-font hyouji l tag) |
363 : |
|
|
(smallwindow-redraw hyouji) |
364 : |
|
|
(prind "終了")) |
365 : |
|
|
|
366 : |
|
|
;; メインの作業 |
367 : |
|
|
|
368 : |
|
|
(defun make-windows () |
369 : |
|
|
(setq kanji-itiran (create-smallwindow window-of-menus "kanzi itiran" (* 14 16) (+ (* 14 6) 3))) |
370 : |
|
|
(setq jitai-etc-menu |
371 : |
|
|
(create-menu "zitai" |
372 : |
|
|
'(("明朝" mincho) |
373 : |
|
|
("ゴシック" gothic) |
374 : |
|
|
("幅を増やす" incr-width) |
375 : |
|
|
("幅を減らす" decr-width) |
376 : |
|
|
("再表示" re-display) |
377 : |
|
|
("次の字" next-select)) |
378 : |
|
|
80)) |
379 : |
|
|
(setq status-window |
380 : |
|
|
(create-smallwindow window-of-menus "zyoutai" 180 54)) |
381 : |
|
|
(setq hyouji (create-smallwindow root "hyouzi"))) |
382 : |
|
|
|
383 : |
|
|
(defun main () |
384 : |
|
|
(make-windows) |
385 : |
|
|
(redraw-status) |
386 : |
|
|
(do () |
387 : |
|
|
(nil nil) |
388 : |
|
|
(select-kanji) |
389 : |
|
|
(redraw-status) |
390 : |
|
|
(display-kanji-font (intern now-selected) now-jitai) |
391 : |
|
|
|
392 : |
|
|
(do ((key (second (select-menu jitai-etc-menu)) |
393 : |
|
|
(second (select-menu jitai-etc-menu)))) |
394 : |
|
|
((eq key 'next-select) |
395 : |
|
|
(progn (princ "next-select") |
396 : |
|
|
(setq now-selected nil) |
397 : |
|
|
(redraw-status))) |
398 : |
|
|
(princ key) (princ " ") |
399 : |
|
|
(cond ((eq key 'mincho) (setq now-jitai 'mincho)) |
400 : |
|
|
((eq key 'gothic) (setq now-jitai 'gothic)) |
401 : |
|
|
((eq key 'incr-width) (setq now-width (+$ now-width 1.0))) |
402 : |
|
|
((eq key 'decr-width) (setq now-width (-$ now-width 1.0)))) |
403 : |
|
|
(if (<$ now-width min-width) (setq now-width min-width)) |
404 : |
|
|
(if (>$ now-width max-width) (setq now-width max-width)) |
405 : |
|
|
(setq minchowidth now-width |
406 : |
|
|
gothicwidth now-width) |
407 : |
|
|
|
408 : |
|
|
(if (eq key 're-display) |
409 : |
|
|
(display-kanji-font (intern now-selected) now-jitai) |
410 : |
|
|
(redraw-status))))) |
411 : |
|
|
|