View of /lisp/demo/ulxtest.l

Parent Directory

Revision Log

change to CVS wadalab font project

;;
;; ulx のロード
(cond ((definedp 'get-display-host) nil)
      (t (exfile (string-append system_lib_path "ulx/loadulx.l"))))

;; ディスプレイホストの設定
(setq display-host (get-display-host))
(or display-host (progn (format "Display unknown/n") (err:argument-type)))

;; スクリーンの定義
(setq display (open-display display-host))
(setq screen (first (display-roots display)))
(setq root (screen-root screen))

;; 白黒の定義
(setq black (screen-black-pixel screen)
      white (screen-white-pixel screen))

;; フォントの定義
(setq ascii-font (open-font display "lucidasanstypewriter-bold-24"))

(setq window (create-window :parent root :class :input-output
			    :x 0 :y 0
			    :width 640
			    :height 400
			    :foreground black
			    :background white))

(defun screen-depth (scr)
  (let ((alist (screen-depths scr)))
    (do ((p alist (cdr p)))
	((or (null p)
	     (not (null (cdar p))))
	 (if (null p) nil (caar p)))
	(comment print p))))

(setq default-depth (screen-depth screen))

(setq pixmap (create-pixmap :drawable root
			    :width 640
			    :height 400
			    :depth default-depth))

(setq gcontext (create-gcontext :drawable root
				:foreground black
				:background white
				:font ascii-font))

(setq white-gcontext (create-gcontext :drawable root
				      :foreground white
				      :background black
				      :font ascii-font))

(draw-rectangle pixmap white-gcontext 0 0 
		(drawable-width pixmap) (drawable-height pixmap) t)

(setf (wm-name window) "This is ULX demo window")
(setf (window-event-mask window) '(:exposure :button-press))

(map-window window)
(display-force-output display)

(defun draws (pix)
  (draw-line pix gcontext 10 10 20 50)
  (draw-line pix gcontext 100 10 20 50)
  (draw-line pix gcontext 10 100 200 50)
  
  (draw-rectangle pix gcontext 80 80 130 90)
  
  (draw-lines pix gcontext '(10 20 30 50 40 20 10 20)
	      :complex t)
  
  (draw-lines pix gcontext '(50 70 60 80 60 30 50 70)
	      :complex t
	      :fill-p t)

  (draw-arc pix gcontext 320 200 50 70 0 360)
  (draw-arc pix gcontext 420 200 150 70 0 270)

  (draw-glyphs pix gcontext 320 100 "abcdef" ascii-font)
  
  (display-force-output display))

(draws pixmap)

(defun copy:pixmap->window (pix win)
  (copy-plane pix
	      gcontext
	      1 
	      0 0 (drawable-width pixmap) (drawable-height pixmap)
	      win 0 0))

(print
 (do ((end? nil))
     (end? 'Done)
     (event-case (display)
       (:exposure 
	(event-window count)
	(if (and (0= count)
		 (eq event-window window))
	    (copy:pixmap->window pixmap window))
	t)
       (:button-press
	(event-window code x y)
	(cond ((= code 3)
	       (setq end? t))
	      ((eq event-window window)
	       (draw-arc pixmap gcontext (- x 15) (- y 15) 30 30 0 360)
	       (copy:pixmap->window pixmap window)))
	t)
       (otherwise
	t))))