View of /lisp/window.l

Parent Directory

Revision Log

Initial revision

(print hostname)
;(setq ulx_lib_path "/home/misa/ken/work/ulx/")
;(cond (t (null (definedp 'connect-to-server))
;       (code-load (string-append ulx_lib_path "socket.o"))
;       (cd ulx_lib_path)
;       (setq *type-check?* nil)
;       (exfile 'loadulx.l)
;       (exfile 'text.l)
;       (exfile 'translate.l)))
;(cd "/home/misa/kanji/lib/new")
(exfile (string-append system_lib_path "ulx/loadulx.l"))
(setq *inhibit-appending* t)
(defun init_window (width height)
  (setq win_width width win_height 400)
  (setq display (open-display hostname))
  (setq screen (first (display-roots display)))
  (setq fg (screen-black-pixel screen) bg (screen-white-pixel screen))
  (setq root (screen-root screen))
  (setq window (create-window :parent root :x 0 :y 0 
			      :width width :height height
			      :background bg :class :input-output))
  (setf (wm-name window) "utilisp")
  (setf (window-event-mask window) 
	'(:button-press :exposure :button-release :key-press))
  (setq curgc (create-gcontext :drawable window :foreground fg))
  (setq white_gc (create-gcontext :drawable window :foreground bg))
  (setq save (create-pixmap :width width :height height 
			    :drawable root :depth 1))
  (draw-rectangle save white_gc 0 0 width height t)
  (copy-area save curgc 0 0 width height window 0 0)
  (map-window window)
  (buffer-force-output display))

(defun drawline (x0 y0 x1 y1)
  (draw-line save curgc x0 y0 x1 y1))

(defun redraw ()
  (copy-area save curgc 0 0 win_width win_height window 0 0)
  (buffer-force-output display))

(defun buttonnmb (n)
  (nth (1- n) '(button1 button2 button3)))
(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))
(defun checkevent ()
  (do ((ret nil)
       (key nil))
    (ret ret)
    (event-case (display)
		(:exposure 
		 (count)
		 (and (zerop count) (redraw))
		 t)
		(:button-press 
		 (event-window code x y)
		 (setq ret `(ButtonPress ,(buttonnmb code) ,x ,y))
		 t)
		(:button-release
		 (event-window code x y)
		 (setq ret `(ButtonRelease ,(buttonnmb code) ,x ,y))
		 t)
		(:key-press
		 (event-window code x y)
		 (setq key (memq code keytrans))
		 (cond (key (setq code (- 124 (length key)))))
		 (setq ret `(KeyPress ,code))
;		 (print (list code ret))
		 t)
		(otherwise () t))))

(defun close_window ()
  (close-display display))

(defun cons2flat (points)
  (do ((l points (cdr l))
       (ret nil))
    ((atom l)(nreverse ret))
    (push (caar l) ret)
    (push (cdar l) ret)))

(defun fillpolygon (points)
  (draw-lines save curgc (cons2flat points) :fill-p t :complex t))

(defun drawlines (points)
  (draw-lines save curgc (cons2flat points) :complex t))

(defun loadpbm (code))
(defun loadjis (code))
(defun copybg ()
  (draw-rectangle save white_gc 0 0 win_width win_height t)
)
(defun kanji2vec (str)
  (lets ((len (// (string-length str) 2))
	 (vec (vector len)))
    (do ((i 0 (1+ i)))
      ((>= i len)vec)
      (vset vec i (+ (* 256 (logand 127 (sref str (* 2 i))))
		     (logand 127 (sref str (1+ (* 2 i)))))))))