basis/ui/x11/x11.factor

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