| 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) ("Ｌｉｓｐ" Lisp)))) |
| 173 : |
|
|
;; (select-menu lang-menu) |
| 174 : |
|
|
;; 結果 => ("ＡＰＬ" APL) か ("Ｌｉｓｐ" 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- "＿１２３４５６７８９０") |
| 205 : |
|
|
(setq -number-str-iti- "０１２３４５６７８９０") |
| 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 : |
ktanaka |
1.2 |
(let ((outline (skeleton2list (cache-applykanji l) tag))) |
| 245 : |
ktanaka |
1.1 |
(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 : |
|
|
|
Annotation of /lisp/demo/demo.l
Parent Directory
| 
Revision Log