basis/ui/backend/x11/x11.factor

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