-
Notifications
You must be signed in to change notification settings - Fork 1
/
Copy pathclx-interface.lisp
129 lines (108 loc) · 4.09 KB
/
clx-interface.lisp
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
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
;;;
;;; clx-interface.lisp
;;;
;;; Interface to CLX for gaming stuff.
;;;
(cl:defpackage :nq-clim/clx-interface
(:use :cl
:nq-clim/event/event-queue
:nq-clim/frame/application-frame-functions
:nq-clim/frame/manageable-frame-functions
:nq-clim/layout/space-requirement
:nq-clim/sheet/mirror-functions
:nq-clim/sheet/sheet-geometry-protocol
:nq-clim/sheet/sheet-hierarchy-protocol
:nq-clim/geometry/identity-transformation
:nq-clim/port/port-discovery
:nq-clim/port/port-protocol
:nq-clim/backend/clx/port
:nq-clim/backend/clx/graft
:nq-clim/backend/clx/frame-sheet)
(:import-from :xlib)
(:export
"WITH-X11-DISPLAY"
;; For some reason, these don't appear to be defind in CLX.
"+XK-UP+"
"+XK-DOWN+"
"+XK-LEFT+"
"+XK-RIGHT+"
"+XK-ESC+"
"+XK-ENTER+"))
(cl:in-package :nq-clim/clx-interface)
;;; Important external variables.
(defvar *port* nil "The CLIM PORT.")
;; For some reason, CLX doesn't appear to have these keysyms defined.
(defconstant +xk-up+ #xff52)
(defconstant +xk-left+ #xff51)
(defconstant +xk-right+ #xff53)
(defconstant +xk-down+ #xff54)
(defconstant +xk-esc+ #xff1b)
(defconstant +xk-enter+ #xff0d)
;; Internal default values.
(defparameter *default-window-height* 240)
(defparameter *default-window-width* 256)
(defparameter *default-window-title* "CLX Interface Window")
(defun set-window-space-requirement (window space-requirement)
(multiple-value-bind
(width min-width max-width height max-height min-height)
(space-requirement-components space-requirement)
(setf (xlib:wm-normal-hints window)
(xlib:make-wm-size-hints
:width width :min-width min-width :max-width max-width
:height height :min-height min-height :max-height max-height))))
(defun init-display (&key display-name space-requirement frame)
(setf *port*
(find-port :server-path `(:clx ,@(when display-name
`(:display ,display-name)))))
;; KLUDGE: NOT the defined right way to obtain a graft, but it's
;; what we have available at the moment.
(let* ((graft (make-clx-graft *port*))
(event-queue (make-event-queue))
(sheet (make-instance 'clx-frame-sheet
:frame frame
:event-queue event-queue)))
(setf (sheet-transformation sheet) +identity-transformation+)
(let ((width (or (and space-requirement
(space-requirement-width space-requirement))
*default-window-width*))
(height (or (and space-requirement
(space-requirement-height space-requirement))
*default-window-height*)))
(resize-sheet sheet width height))
(sheet-adopt-child graft sheet)
(setf (frame-top-level-sheet frame) sheet)
(let ((pane (frame-panes frame)))
(when pane
(sheet-adopt-child sheet pane)))
(let ((window (sheet-mirror sheet)))
(setf (xlib:window-background window)
(xlib:screen-white-pixel
(xlib:display-default-screen
(clx-port-display *port*))))
(setf (xlib:window-event-mask window)
(xlib:make-event-mask :exposure))
(setf (xlib:wm-name window)
(or (and frame (frame-pretty-name frame)) *default-window-title*))
(when space-requirement
(set-window-space-requirement window space-requirement))
(xlib:map-window window))))
(defun close-display ()
(when *port*
(destroy-port *port*))
(setf *port* nil))
(defun call-with-x11-display (fun &key display-name space-requirement
frame)
(unwind-protect
(progn
(init-display :display-name display-name
:space-requirement space-requirement
:frame frame)
(funcall fun))
(close-display)))
(defmacro with-x11-display ((&key display-name space-requirement frame)
&body body)
`(call-with-x11-display (lambda () ,@body)
:display-name ,display-name
:space-requirement ,space-requirement
:frame ,frame))
;;; EOF