Annotation of /lisp/window.lAnnotation 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 |