[wadalabfont-kit] / lisp / window.l  

Annotation of /lisp/window.l

Parent Directory | Revision Log

Revision: 1.1 - (view) (download)

1 : ktanaka 1.1 (print hostname)
2 :     ;(setq ulx_lib_path "/home/misa/ken/work/ulx/")
3 :     ;(cond (t (null (definedp 'connect-to-server))
4 :     ; (code-load (string-append ulx_lib_path "socket.o"))
5 :     ; (cd ulx_lib_path)
6 :     ; (setq *type-check?* nil)
7 :     ; (exfile 'loadulx.l)
8 :     ; (exfile 'text.l)
9 :     ; (exfile 'translate.l)))
10 :     ;(cd "/home/misa/kanji/lib/new")
11 :     (exfile (string-append system_lib_path "ulx/loadulx.l"))
12 :     (setq *inhibit-appending* t)
13 :     (defun init_window (width height)
14 :     (setq win_width width win_height 400)
15 :     (setq display (open-display hostname))
16 :     (setq screen (first (display-roots display)))
17 :     (setq fg (screen-black-pixel screen) bg (screen-white-pixel screen))
18 :     (setq root (screen-root screen))
19 :     (setq window (create-window :parent root :x 0 :y 0
20 :     :width width :height height
21 :     :background bg :class :input-output))
22 :     (setf (wm-name window) "utilisp")
23 :     (setf (window-event-mask window)
24 :     '(:button-press :exposure :button-release :key-press))
25 :     (setq curgc (create-gcontext :drawable window :foreground fg))
26 :     (setq white_gc (create-gcontext :drawable window :foreground bg))
27 :     (setq save (create-pixmap :width width :height height
28 :     :drawable root :depth 1))
29 :     (draw-rectangle save white_gc 0 0 width height t)
30 :     (copy-area save curgc 0 0 width height window 0 0)
31 :     (map-window window)
32 :     (buffer-force-output display))
33 :    
34 :     (defun drawline (x0 y0 x1 y1)
35 :     (draw-line save curgc x0 y0 x1 y1))
36 :    
37 :     (defun redraw ()
38 :     (copy-area save curgc 0 0 win_width win_height window 0 0)
39 :     (buffer-force-output display))
40 :    
41 :     (defun buttonnmb (n)
42 :     (nth (1- n) '(button1 button2 button3)))
43 :     (setq keytrans '(84 111 109 86 63 87 88 89 68 90 91 92 113 112 69 70 61 64 85 65 67 110 62 108 66 107 83))
44 :     (defun checkevent ()
45 :     (do ((ret nil)
46 :     (key nil))
47 :     (ret ret)
48 :     (event-case (display)
49 :     (:exposure
50 :     (count)
51 :     (and (zerop count) (redraw))
52 :     t)
53 :     (:button-press
54 :     (event-window code x y)
55 :     (setq ret `(ButtonPress ,(buttonnmb code) ,x ,y))
56 :     t)
57 :     (:button-release
58 :     (event-window code x y)
59 :     (setq ret `(ButtonRelease ,(buttonnmb code) ,x ,y))
60 :     t)
61 :     (:key-press
62 :     (event-window code x y)
63 :     (setq key (memq code keytrans))
64 :     (cond (key (setq code (- 124 (length key)))))
65 :     (setq ret `(KeyPress ,code))
66 :     ; (print (list code ret))
67 :     t)
68 :     (otherwise () t))))
69 :    
70 :     (defun close_window ()
71 :     (close-display display))
72 :    
73 :     (defun cons2flat (points)
74 :     (do ((l points (cdr l))
75 :     (ret nil))
76 :     ((atom l)(nreverse ret))
77 :     (push (caar l) ret)
78 :     (push (cdar l) ret)))
79 :    
80 :     (defun fillpolygon (points)
81 :     (draw-lines save curgc (cons2flat points) :fill-p t :complex t))
82 :    
83 :     (defun drawlines (points)
84 :     (draw-lines save curgc (cons2flat points) :complex t))
85 :    
86 :     (defun loadpbm (code))
87 :     (defun loadjis (code))
88 :     (defun copybg ()
89 :     (draw-rectangle save white_gc 0 0 win_width win_height t)
90 :     )
91 :     (defun kanji2vec (str)
92 :     (lets ((len (// (string-length str) 2))
93 :     (vec (vector len)))
94 :     (do ((i 0 (1+ i)))
95 :     ((>= i len)vec)
96 :     (vset vec i (+ (* 256 (logand 127 (sref str (* 2 i))))
97 :     (logand 127 (sref str (1+ (* 2 i)))))))))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help