extra/ui/x11/x11.factor

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