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