[wadalabfont-kit] / lisp / demo / kanjidemo.l  

Annotation of /lisp/demo/kanjidemo.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

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 :    

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help