basis/ui/backend/x11/x11.factor

   1 ! Copyright (C) 2005, 2009 Eduardo Cavazos and Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
   4 ui.gadgets.private ui.gestures ui.backend ui.clipboards
   5 ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
   6 namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
   7 x11.glx x11.clipboard x11.constants x11.windows x11.io
   8 io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
   9 command-line math.vectors classes.tuple opengl.gl threads
  10 math.rectangles environment ascii
  11 ui.pixel-formats ui.pixel-formats.private ;
  12 IN: ui.backend.x11
  13
  14 SINGLETON: x11-ui-backend
  15
  16 : XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
  17
  18 TUPLE: x11-handle-base glx ;
  19 TUPLE: x11-handle < x11-handle-base window xic ;
  20 TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
  21
  22 C: <x11-handle> x11-handle
  23 C: <x11-pixmap-handle> x11-pixmap-handle
  24
  25 M: world expose-event nip relayout ;
  26
  27 M: world configure-event
  28     over configured-loc >>window-loc
  29     swap configured-dim >>dim
  30     ! In case dimensions didn't change
  31     relayout-1 ;
  32
  33 PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
  34     { double-buffered { $ GLX_DOUBLEBUFFER } }
  35     { stereo { $ GLX_STEREO } }
  36     { color-bits { $ GLX_BUFFER_SIZE } }
  37     { red-bits { $ GLX_RED_SIZE } }
  38     { green-bits { $ GLX_GREEN_SIZE } }
  39     { blue-bits { $ GLX_BLUE_SIZE } }
  40     { alpha-bits { $ GLX_ALPHA_SIZE } }
  41     { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
  42     { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
  43     { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
  44     { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
  45     { depth-bits { $ GLX_DEPTH_SIZE } }
  46     { stencil-bits { $ GLX_STENCIL_SIZE } }
  47     { aux-buffers { $ GLX_AUX_BUFFERS } }
  48     { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
  49     { samples { $ GLX_SAMPLES } }
  50 }
  51
  52 M: x11-ui-backend (make-pixel-format)
  53     [ drop dpy get scr get ] dip
  54     >glx-visual-int-array glXChooseVisual ;
  55
  56 M: x11-ui-backend (free-pixel-format)
  57     handle>> XFree ;
  58
  59 M: x11-ui-backend (pixel-format-attribute)
  60     [ dpy get ] 2dip
  61     [ handle>> ] [ >glx-visual ] bi*
  62     [ drop f ] [
  63         first [ dpy get ] 2dip
  64         0 <int> [ glXGetConfig drop ] keep *int
  65     ] if-empty ;
  66
  67 CONSTANT: modifiers
  68     {
  69         { S+ HEX: 1 }
  70         { C+ HEX: 4 }
  71         { A+ HEX: 8 }
  72     }
  73
  74 CONSTANT: key-codes
  75     H{
  76         { HEX: FF08 "BACKSPACE" }
  77         { HEX: FF09 "TAB"       }
  78         { HEX: FF0D "RET"       }
  79         { HEX: FF8D "ENTER"     }
  80         { HEX: FF1B "ESC"       }
  81         { HEX: FFFF "DELETE"    }
  82         { HEX: FF50 "HOME"      }
  83         { HEX: FF51 "LEFT"      }
  84         { HEX: FF52 "UP"        }
  85         { HEX: FF53 "RIGHT"     }
  86         { HEX: FF54 "DOWN"      }
  87         { HEX: FF55 "PAGE_UP"   }
  88         { HEX: FF56 "PAGE_DOWN" }
  89         { HEX: FF57 "END"       }
  90         { HEX: FF58 "BEGIN"     }
  91         { HEX: FFBE "F1"        }
  92         { HEX: FFBF "F2"        }
  93         { HEX: FFC0 "F3"        }
  94         { HEX: FFC1 "F4"        }
  95         { HEX: FFC2 "F5"        }
  96         { HEX: FFC3 "F6"        }
  97         { HEX: FFC4 "F7"        }
  98         { HEX: FFC5 "F8"        }
  99         { HEX: FFC6 "F9"        }
 100     }
 101
 102 : key-code ( keysym -- keycode action? )
 103     dup key-codes at [ t ] [ 1string f ] ?if ;
 104
 105 : event-modifiers ( event -- seq )
 106     XKeyEvent-state modifiers modifier ;
 107
 108 : valid-input? ( string gesture -- ? )
 109     over empty? [ 2drop f ] [
 110         mods>> { f { S+ } } member? [
 111             [ [ 127 = not ] [ CHAR: \s >= ] bi and ] all?
 112         ] [
 113             [ [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] tri and and ] all?
 114         ] if
 115     ] if ;
 116
 117 : key-down-event>gesture ( event world -- string gesture )
 118     dupd
 119     handle>> xic>> lookup-string
 120     [ swap event-modifiers ] dip key-code <key-down> ;
 121
 122 M: world key-down-event
 123     [ key-down-event>gesture ] keep
 124     [ propagate-key-gesture drop ]
 125     [ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
 126     3bi ;
 127
 128 : key-up-event>gesture ( event -- gesture )
 129     [ event-modifiers ] [ 0 XLookupKeysym key-code ] bi <key-up> ;
 130
 131 M: world key-up-event
 132     [ key-up-event>gesture ] dip propagate-key-gesture ;
 133
 134 : mouse-event>gesture ( event -- modifiers button loc )
 135     [ event-modifiers ]
 136     [ XButtonEvent-button ]
 137     [ mouse-event-loc ]
 138     tri ;
 139
 140 M: world button-down-event
 141     [ mouse-event>gesture [ <button-down> ] dip ] dip
 142     send-button-down ;
 143
 144 M: world button-up-event
 145     [ mouse-event>gesture [ <button-up> ] dip ] dip
 146     send-button-up ;
 147
 148 : mouse-event>scroll-direction ( event -- pair )
 149     XButtonEvent-button {
 150         { 4 { 0 -1 } }
 151         { 5 { 0 1 } }
 152         { 6 { -1 0 } }
 153         { 7 { 1 0 } }
 154     } at ;
 155
 156 M: world wheel-event
 157     [ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
 158     send-wheel ;
 159
 160 M: world enter-event motion-event ;
 161
 162 M: world leave-event 2drop forget-rollover ;
 163
 164 M: world motion-event
 165     [ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
 166     move-hand fire-motion ;
 167
 168 M: world focus-in-event
 169     nip
 170     [ handle>> xic>> XSetICFocus ] [ focus-world ] bi ;
 171
 172 M: world focus-out-event
 173     nip
 174     [ handle>> xic>> XUnsetICFocus ] [ unfocus-world ] bi ;
 175
 176 M: world selection-notify-event
 177     [ handle>> window>> selection-from-event ] keep
 178     user-input ;
 179
 180 : supported-type? ( atom -- ? )
 181     { "UTF8_STRING" "STRING" "TEXT" }
 182     [ x-atom = ] with any? ;
 183
 184 : clipboard-for-atom ( atom -- clipboard )
 185     {
 186         { XA_PRIMARY [ selection get ] }
 187         { XA_CLIPBOARD [ clipboard get ] }
 188         [ drop <clipboard> ]
 189     } case ;
 190
 191 : encode-clipboard ( string type -- bytes )
 192     XSelectionRequestEvent-target
 193     XA_UTF8_STRING = utf8 ascii ? encode ;
 194
 195 : set-selection-prop ( evt -- )
 196     dpy get swap
 197     [ XSelectionRequestEvent-requestor ] keep
 198     [ XSelectionRequestEvent-property ] keep
 199     [ XSelectionRequestEvent-target ] keep
 200     [ 8 PropModeReplace ] dip
 201     [
 202         XSelectionRequestEvent-selection
 203         clipboard-for-atom contents>>
 204     ] keep encode-clipboard dup length XChangeProperty drop ;
 205
 206 M: world selection-request-event
 207     drop dup XSelectionRequestEvent-target {
 208         { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
 209         { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
 210         { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
 211         [ drop send-notify-failure ]
 212     } cond ;
 213
 214 M: x11-ui-backend (close-window) ( handle -- )
 215     [ xic>> XDestroyIC ]
 216     [ glx>> destroy-glx ]
 217     [ window>> [ unregister-window ] [ destroy-window ] bi ]
 218     tri ;
 219
 220 M: world client-event
 221     swap close-box? [ ungraft ] [ drop ] if ;
 222
 223 : gadget-window ( world -- )
 224     dup
 225     [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
 226     with-world-pixel-format swap
 227     dup "Factor" create-xic
 228     <x11-handle>
 229     [ window>> register-window ] [ >>handle drop ] 2bi ;
 230
 231 : wait-event ( -- event )
 232     QueuedAfterFlush events-queued 0 > [
 233         next-event dup
 234         None XFilterEvent 0 = [ drop wait-event ] unless
 235     ] [ wait-for-display wait-event ] if ;
 236
 237 M: x11-ui-backend do-events
 238     wait-event dup XAnyEvent-window window dup
 239     [ handle-event ] [ 2drop ] if ;
 240
 241 : x-clipboard@ ( gadget clipboard -- prop win )
 242     atom>> swap
 243     find-world handle>> window>> ;
 244
 245 M: x-clipboard copy-clipboard
 246     [ x-clipboard@ own-selection ] keep
 247     (>>contents) ;
 248
 249 M: x-clipboard paste-clipboard
 250     [ find-world handle>> window>> ] dip atom>> convert-selection ;
 251
 252 : init-clipboard ( -- )
 253     XA_PRIMARY <x-clipboard> selection set-global
 254     XA_CLIPBOARD <x-clipboard> clipboard set-global ;
 255
 256 : set-title-old ( dpy window string -- )
 257     dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
 258
 259 : set-title-new ( dpy window string -- )
 260     [ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
 261     utf8 encode dup length XChangeProperty drop ;
 262
 263 : set-class ( dpy window -- )
 264     XA_WM_CLASS XA_UTF8_STRING 8 PropModeReplace "Factor"
 265     utf8 encode dup length XChangeProperty drop ;
 266
 267 M: x11-ui-backend set-title ( string world -- )
 268     handle>> window>> swap
 269     [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
 270
 271 M: x11-ui-backend set-fullscreen* ( ? world -- )
 272     handle>> window>> "XClientMessageEvent" <c-object>
 273     [ set-XClientMessageEvent-window ] keep
 274     swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
 275     over set-XClientMessageEvent-data0
 276     ClientMessage over set-XClientMessageEvent-type
 277     dpy get over set-XClientMessageEvent-display
 278     "_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
 279     32 over set-XClientMessageEvent-format
 280     "_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
 281     [ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
 282
 283 M: x11-ui-backend (open-window) ( world -- )
 284     dup gadget-window
 285     handle>> window>>
 286     [ set-closable ] [ dpy get swap set-class ] [ map-window ] tri ;
 287
 288 M: x11-ui-backend raise-window* ( world -- )
 289     handle>> [
 290         dpy get swap window>>
 291         [ RevertToPointerRoot CurrentTime XSetInputFocus drop ]
 292         [ XRaiseWindow drop ]
 293         2bi
 294     ] when* ;
 295
 296 M: x11-handle select-gl-context ( handle -- )
 297     dpy get swap
 298     [ window>> ] [ glx>> ] bi glXMakeCurrent
 299     [ "Failed to set current GLX context" throw ] unless ;
 300
 301 M: x11-handle flush-gl-context ( handle -- )
 302     dpy get swap window>> glXSwapBuffers ;
 303
 304 M: x11-pixmap-handle select-gl-context ( handle -- )
 305     dpy get swap
 306     [ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
 307     [ "Failed to set current GLX context" throw ] unless ;
 308
 309 M: x11-pixmap-handle flush-gl-context ( handle -- )
 310     drop ;
 311
 312 M: x11-ui-backend (open-offscreen-buffer) ( world -- )
 313     dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
 314     with-world-pixel-format
 315     <x11-pixmap-handle> >>handle drop ;
 316 M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
 317     dpy get swap
 318     [ glx-pixmap>> glXDestroyGLXPixmap ]
 319     [ pixmap>> XFreePixmap drop ]
 320     [ glx>> glXDestroyContext ] 2tri ;
 321
 322 M: x11-ui-backend offscreen-pixels ( world -- alien w h )
 323     [ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
 324
 325 M: x11-ui-backend (with-ui) ( quot -- )
 326     [
 327         f [
 328             [
 329                 init-clipboard
 330                 start-ui
 331                 event-loop
 332             ] with-xim
 333         ] with-x
 334     ] ui-running ;
 335
 336 M: x11-ui-backend beep ( -- )
 337     dpy get 100 XBell drop ;
 338
 339 x11-ui-backend ui-backend set-global
 340
 341 [ "DISPLAY" os-env "ui.tools" "listener" ? ]
 342 main-vocab-hook set-global