1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
|
(ns glimmer-gfx.x11
"The port layer: Xlib through jolt.ffi, with no toolkit under it. Opens a
surface, blits an int-array, reports the mouse; it draws nothing itself.
`run-window` is the loop glimmer-gfx.core drives; nothing else in this
project talks to X."
(:require [glimmer-gfx.raster :as r] [jolt.ffi :as ffi]))
(ffi/defcfn x-open "XOpenDisplay" [:pointer] :pointer)
(ffi/defcfn x-screen "XDefaultScreen" [:pointer] :int)
(ffi/defcfn x-root "XRootWindow" [:pointer :int] :ulong)
(ffi/defcfn x-visual "XDefaultVisual" [:pointer :int] :pointer)
(ffi/defcfn x-gc "XDefaultGC" [:pointer :int] :pointer)
(ffi/defcfn x-depth "XDefaultDepth" [:pointer :int] :int)
(ffi/defcfn x-black "XBlackPixel" [:pointer :int] :ulong)
(ffi/defcfn x-create "XCreateSimpleWindow"
[:pointer :ulong :int :int :uint :uint :uint :ulong :ulong] :ulong)
(ffi/defcfn x-select "XSelectInput" [:pointer :ulong :long] :int)
(ffi/defcfn x-map "XMapWindow" [:pointer :ulong] :int)
(ffi/defcfn x-store-name "XStoreName" [:pointer :ulong :pointer] :int)
(ffi/defcfn x-atom "XInternAtom" [:pointer :string :int] :ulong)
(ffi/defcfn x-protocols "XSetWMProtocols" [:pointer :ulong :pointer :int] :int)
(ffi/defcfn x-image "XCreateImage"
[:pointer :pointer :uint :int :int :pointer :uint :uint :int :int] :pointer)
(ffi/defcfn x-put "XPutImage"
[:pointer :ulong :pointer :pointer :int :int :int :int :uint :uint] :int)
(ffi/defcfn x-flush "XFlush" [:pointer] :int)
(ffi/defcfn x-pending "XPending" [:pointer] :int)
(ffi/defcfn x-next "XNextEvent" [:pointer :pointer] :int)
(ffi/defcfn x-close "XCloseDisplay" [:pointer] :int)
(ffi/defcfn x-keysym "XLookupKeysym" [:pointer :int] :ulong)
;; Without this a held key repeats as release/press pairs, and a frame can catch
;; the key up. Detectable repeat suppresses the synthetic releases.
(ffi/defcfn x-detectable-repeat "XkbSetDetectableAutoRepeat"
[:pointer :int :pointer] :int)
(def ^:private ZPixmap 2)
(def ^:private event-mask (bit-or 32768 4 8 64 131072 1 2)) ; expose|btn|motion|structure|key
;; XEvent is a 192-byte union. Offsets verified against X11/Xlib.h with
;; offsetof on x86-64 -- do not infer one struct's layout from another's:
;; XButtonEvent x=64 y=68
;; XClientMessageEvent message_type=40 format=48 data=56
;; XClientMessageEvent has no root/subwindow/time, so its data sits 16 bytes
;; earlier than a pointer event's coordinates would suggest. Reading it at 72
;; is why the window close button did nothing: the atom never compared equal.
(def ^:private EV-SIZE 192)
(def ^:private EV-X 64) (def ^:private EV-Y 68) (def ^:private EV-DATA 56)
(def ^:private PRESS 4) (def ^:private RELEASE 5)
(def ^:private MOTION 6) (def ^:private CLIENT 33)
(def ^:private KEY-DOWN 2) (def ^:private KEY-UP 3)
(defn- drain!
"Fold every queued X event into the input map. :quit? on window close."
[dpy ev input wm-delete]
(loop [in input]
(if (zero? (x-pending dpy))
in
(do (x-next dpy ev)
(let [t (ffi/read ev :int 0)
p [(ffi/read ev :int EV-X) (ffi/read ev :int EV-Y)]]
(recur (condp = t
PRESS (assoc in :down? true :mouse p)
RELEASE (assoc in :down? false :released? true :mouse p)
MOTION (assoc in :mouse p)
;; the keysym, not the raw keycode: it is what the user's
;; own layout says the key means.
KEY-DOWN (update in :keys conj (x-keysym ev 0))
KEY-UP (update in :keys disj (x-keysym ev 0))
CLIENT (cond-> in
(= wm-delete (ffi/read ev :ulong EV-DATA))
(assoc :quit? true))
in)))))))
(defn run-window
"Open a window and run `frame-fn` once per frame until it closes.
frame-fn is (fn [buf input] ...) -- it paints into `buf`; the loop blits.
:auto-quit-ms closes the window on a timer, for tests."
[{:keys [width height title auto-quit-ms] :or {width 480 height 320 title "gfx"}}
frame-fn]
(let [dpy (x-open ffi/null)]
(when (ffi/null? dpy)
(throw (ex-info "no X display -- is DISPLAY set?" {})))
(let [scr (x-screen dpy)
win (x-create dpy (x-root dpy scr) 0 0 width height 0
(x-black dpy scr) (x-black dpy scr))
gc (x-gc dpy scr)
data (ffi/alloc (* width height 4))
img (x-image dpy (x-visual dpy scr) (x-depth dpy scr) ZPixmap 0
data width height 32 0)
ev (ffi/alloc EV-SIZE)
prot (ffi/alloc 8)
wm-delete (x-atom dpy "WM_DELETE_WINDOW" 0)
buf (r/buf width height)
deadline (when auto-quit-ms (+ (System/currentTimeMillis) auto-quit-ms))]
(ffi/write prot :ulong wm-delete 0)
(x-protocols dpy win prot 1)
(ffi/with-c-string [t title] (x-store-name dpy win t))
(x-select dpy win event-mask)
(x-map dpy win)
(try
(x-detectable-repeat dpy 1 ffi/null)
(loop [input {:mouse [0 0] :down? false :released? false :keys #{}}]
(let [input (drain! dpy ev input wm-delete)]
(frame-fn buf input)
(ffi/write-array data :int (:px buf))
(x-put dpy win gc img 0 0 0 0 width height)
(x-flush dpy)
(Thread/sleep 16)
(when-not (or (:quit? input)
(and deadline (> (System/currentTimeMillis) deadline)))
(recur (assoc input :released? false)))))
(finally (ffi/free data) (ffi/free ev) (ffi/free prot) (x-close dpy))))))
|