[wadalabfont-kit] / lisp / demo / ulxtest.l  

Annotation of /lisp/demo/ulxtest.l

Parent Directory | Revision Log

Revision: 1.1.1.1 - (view) (download)

1 : ktanaka 1.1 ;;
2 :     ;; ulx のロード
3 :     (cond ((definedp 'get-display-host) nil)
4 :     (t (exfile (string-append system_lib_path "ulx/loadulx.l"))))
5 :    
6 :     ;; ディスプレイホストの設定
7 :     (setq display-host (get-display-host))
8 :     (or display-host (progn (format "Display unknown/n") (err:argument-type)))
9 :    
10 :     ;; スクリーンの定義
11 :     (setq display (open-display display-host))
12 :     (setq screen (first (display-roots display)))
13 :     (setq root (screen-root screen))
14 :    
15 :     ;; 白黒の定義
16 :     (setq black (screen-black-pixel screen)
17 :     white (screen-white-pixel screen))
18 :    
19 :     ;; フォントの定義
20 :     (setq ascii-font (open-font display "lucidasanstypewriter-bold-24"))
21 :    
22 :     (setq window (create-window :parent root :class :input-output
23 :     :x 0 :y 0
24 :     :width 640
25 :     :height 400
26 :     :foreground black
27 :     :background white))
28 :    
29 :     (defun screen-depth (scr)
30 :     (let ((alist (screen-depths scr)))
31 :     (do ((p alist (cdr p)))
32 :     ((or (null p)
33 :     (not (null (cdar p))))
34 :     (if (null p) nil (caar p)))
35 :     (comment print p))))
36 :    
37 :     (setq default-depth (screen-depth screen))
38 :    
39 :     (setq pixmap (create-pixmap :drawable root
40 :     :width 640
41 :     :height 400
42 :     :depth default-depth))
43 :    
44 :     (setq gcontext (create-gcontext :drawable root
45 :     :foreground black
46 :     :background white
47 :     :font ascii-font))
48 :    
49 :     (setq white-gcontext (create-gcontext :drawable root
50 :     :foreground white
51 :     :background black
52 :     :font ascii-font))
53 :    
54 :     (draw-rectangle pixmap white-gcontext 0 0
55 :     (drawable-width pixmap) (drawable-height pixmap) t)
56 :    
57 :     (setf (wm-name window) "This is ULX demo window")
58 :     (setf (window-event-mask window) '(:exposure :button-press))
59 :    
60 :     (map-window window)
61 :     (display-force-output display)
62 :    
63 :     (defun draws (pix)
64 :     (draw-line pix gcontext 10 10 20 50)
65 :     (draw-line pix gcontext 100 10 20 50)
66 :     (draw-line pix gcontext 10 100 200 50)
67 :    
68 :     (draw-rectangle pix gcontext 80 80 130 90)
69 :    
70 :     (draw-lines pix gcontext '(10 20 30 50 40 20 10 20)
71 :     :complex t)
72 :    
73 :     (draw-lines pix gcontext '(50 70 60 80 60 30 50 70)
74 :     :complex t
75 :     :fill-p t)
76 :    
77 :     (draw-arc pix gcontext 320 200 50 70 0 360)
78 :     (draw-arc pix gcontext 420 200 150 70 0 270)
79 :    
80 :     (draw-glyphs pix gcontext 320 100 "abcdef" ascii-font)
81 :    
82 :     (display-force-output display))
83 :    
84 :     (draws pixmap)
85 :    
86 :     (defun copy:pixmap->window (pix win)
87 :     (copy-plane pix
88 :     gcontext
89 :     1
90 :     0 0 (drawable-width pixmap) (drawable-height pixmap)
91 :     win 0 0))
92 :    
93 :     (print
94 :     (do ((end? nil))
95 :     (end? 'Done)
96 :     (event-case (display)
97 :     (:exposure
98 :     (event-window count)
99 :     (if (and (0= count)
100 :     (eq event-window window))
101 :     (copy:pixmap->window pixmap window))
102 :     t)
103 :     (:button-press
104 :     (event-window code x y)
105 :     (cond ((= code 3)
106 :     (setq end? t))
107 :     ((eq event-window window)
108 :     (draw-arc pixmap gcontext (- x 15) (- y 15) 30 30 0 360)
109 :     (copy:pixmap->window pixmap window)))
110 :     t)
111 :     (otherwise
112 :     t))))

ktanaka

Powered by ViewCVS 1.0-dev

ViewCVS and CVS Help