[wadalabfont-kit] / lisp / tools / message.l  

Annotation of /lisp/tools/message.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;; --------- ;;
2 :     ;; message.l ;;
3 :     ;; --------- ;;
4 :    
5 :     ;; 文字を出力するとスクロールするウィンドウ
6 :     (defun is-kanji (code)
7 :     (= (logand 128 code) 128))
8 :    
9 :     (defun scroll-up-win (win up)
10 :     (comment print (list 'scroll up))
11 :     (let ((wid (get-winprop win 'width))
12 :     (hei (get-winprop win 'height))
13 :     (gc (get-winprop win 'saveblackgc))
14 :     (wgc (get-winprop win 'savewhitegc))
15 :     (pix (get-winprop win 'save)))
16 :     (copy-plane pix gc 1
17 :     0 up wid (- hei up)
18 :     pix 0 0)
19 :     (draw-rectangle pix wgc
20 :     0 (- hei up)
21 :     wid up t)))
22 :    
23 :     (defun scroll-down-win (win down)
24 :     (let ((wid (get-winprop win 'width))
25 :     (hei (get-winprop win 'height))
26 :     (gc (get-winprop win 'saveblackgc))
27 :     (wgc (get-winprop win 'savewhitegc))
28 :     (pix (get-winprop win 'save)))
29 :     (copy-plane pix gc 1
30 :     0 0 wid (- hei down)
31 :     pix 0 down)
32 :     (draw-rectangle pix wgc
33 :     0 0
34 :     wid down t)))
35 :    
36 :     (defun scroll-win (win up-down)
37 :     (if (minusp up-down)
38 :     (scroll-down-win win (minus up-down))
39 :     (scroll-up-win win up-down)))
40 :    
41 :     (defun print-message-win (win string)
42 :     (princ-message-win win string t))
43 :    
44 :     (defun princ-message-win (win string (lf nil))
45 :     (let* ((length (string-length string))
46 :     (high nil) (low nil) (str "") (nstr "")
47 :     (font (gcontext-font (get-winprop win 'blackgc)))
48 :     (ascent (+ (font-ascent font) 2))
49 :     (descent (font-descent font))
50 :     (now-x (get-winprop win 'now-x))
51 :     (last-x (- (get-winprop win 'width) 2))
52 :     (now-y (get-winprop win 'now-y))
53 :     (last-y (- (get-winprop win 'height) ascent descent))
54 :     (kanji nil)
55 :     (left t)
56 :     (next-x nil) (next-y nil)
57 :     (dx nil))
58 :     (unless now-x (setq now-x 0))
59 :     (unless now-y (setq now-y 0))
60 :     (setq next-x now-x next-y now-y)
61 :    
62 :     (do ((i 0))
63 :     ((or (>= i length) (not left)))
64 :     (setq str "")
65 :     (comment print (list now-x now-y))
66 :     (loop
67 :     (if (>= i length) (exit))
68 :     (setq kanji (is-kanji (sref string i)))
69 :     (setq nstr (if kanji (substring string i (+ i 2)) ""))
70 :     (setq dx (text-width font
71 :     (string-append str nstr)))
72 :     (when (>= (setq next-x (+ now-x dx)) last-x)
73 :     (setq next-x 0)
74 :     (setq next-y (+ now-y ascent descent))
75 :     (exit))
76 :    
77 :     (setq str (string-append str nstr))
78 :     (setq i (+ i (if kanji 2 1))))
79 :    
80 :     (comment print (list now-x now-y last-y))
81 :     (draw-string16-win win str (+ now-x 2) (+ now-y ascent))
82 :     (when (>= next-y last-y)
83 :     (scroll-up-win win (+ ascent descent))
84 :     (setq next-y now-y))
85 :    
86 :     (setq now-x next-x)
87 :     (setq now-y next-y)
88 :    
89 :     (comment print (list now-x now-y last-y)))
90 :    
91 :     (when lf
92 :     (setq now-x 0)
93 :     (setq next-y (+ now-y ascent descent))
94 :     (when (>= next-y last-y)
95 :     (scroll-up-win win (+ ascent descent))
96 :     (setq next-y now-y))
97 :     (setq now-y next-y))
98 :    
99 :     (redraw-win win)
100 :     (display-force-output (window-display win))
101 :    
102 :    
103 :     (put-winprop win 'now-x now-x)
104 :     (put-winprop win 'now-y now-y)))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help