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

Annotation of /lisp/demo/demo.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

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

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help