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