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 threads ;
   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 ;
  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     XButtonEvent-button {
  97         { 4 { 0 -1 } }
  98         { 5 { 0 1 } }
  99         { 6 { -1 0 } }
 100         { 7 { 1 0 } }
 101     } at ;
 102
 103 M: world wheel-event
 104     >r dup mouse-event>scroll-direction swap mouse-event-loc r>
 105     send-wheel ;
 106
 107 M: world enter-event motion-event ;
 108
 109 M: world leave-event 2drop forget-rollover ;
 110
 111 M: world motion-event
 112     >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
 113     move-hand fire-motion ;
 114
 115 M: world focus-in-event
 116     nip
 117     dup world-handle x11-handle-xic XSetICFocus focus-world ;
 118
 119 M: world focus-out-event
 120     nip
 121     dup world-handle x11-handle-xic XUnsetICFocus unfocus-world ;
 122
 123 M: world selection-notify-event
 124     [ world-handle x11-handle-window selection-from-event ] keep
 125     world-focus user-input ;
 126
 127 : supported-type? ( atom -- ? )
 128     { "UTF8_STRING" "STRING" "TEXT" }
 129     [ x-atom = ] with contains? ;
 130
 131 : clipboard-for-atom ( atom -- clipboard )
 132     {
 133         { [ dup XA_PRIMARY = ] [ drop selection get ] }
 134         { [ dup XA_CLIPBOARD = ] [ drop clipboard get ] }
 135         { [ t ] [ drop <clipboard> ] }
 136     } cond ;
 137
 138 : encode-clipboard ( string type -- bytes )
 139     XSelectionRequestEvent-target XA_UTF8_STRING =
 140     [ encode-utf8 ] [ string>char-alien ] if ;
 141
 142 : set-selection-prop ( evt -- )
 143     dpy get swap
 144     [ XSelectionRequestEvent-requestor ] keep
 145     [ XSelectionRequestEvent-property ] keep
 146     [ XSelectionRequestEvent-target ] keep
 147     >r 8 PropModeReplace r>
 148     [
 149         XSelectionRequestEvent-selection
 150         clipboard-for-atom x-clipboard-contents
 151     ] keep encode-clipboard dup length XChangeProperty drop ;
 152
 153 M: world selection-request-event
 154     drop dup XSelectionRequestEvent-target {
 155         { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
 156         { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
 157         { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
 158         { [ t ] [ drop send-notify-failure ] }
 159     } cond ;
 160
 161 M: x11-ui-backend (close-window) ( handle -- )
 162     dup x11-handle-xic XDestroyIC
 163     dup x11-handle-glx destroy-glx
 164     x11-handle-window dup unregister-window
 165     destroy-window ;
 166
 167 M: world client-event
 168     swap close-box? [ ungraft ] [ drop ] if ;
 169
 170 : gadget-window ( world -- )
 171     dup world-loc over rect-dim glx-window
 172     over "Factor" create-xic <x11-handle>
 173     2dup x11-handle-window register-window
 174     swap set-world-handle ;
 175
 176 : wait-event ( -- event )
 177     QueuedAfterFlush events-queued 0 > [
 178         next-event dup
 179         None XFilterEvent zero? [ drop wait-event ] unless
 180     ] [
 181         ui-step 10 sleep wait-event
 182     ] if ;
 183
 184 : do-events ( -- )
 185     wait-event dup XAnyEvent-window window dup
 186     [ [ 2dup handle-event ] assert-depth ] when 2drop ;
 187
 188 : event-loop ( -- )
 189     windows get empty? [
 190         [ do-events ] ui-try event-loop
 191     ] unless ;
 192
 193 : x-clipboard@ ( gadget clipboard -- prop win )
 194     x-clipboard-atom swap
 195     find-world world-handle x11-handle-window ;
 196
 197 M: x-clipboard copy-clipboard
 198     [ x-clipboard@ own-selection ] keep
 199     set-x-clipboard-contents ;
 200
 201 M: x-clipboard paste-clipboard
 202     >r find-world world-handle x11-handle-window
 203     r> x-clipboard-atom convert-selection ;
 204
 205 : init-clipboard ( -- )
 206     XA_PRIMARY <x-clipboard> selection set-global
 207     XA_CLIPBOARD <x-clipboard> clipboard set-global ;
 208
 209 : set-title-old ( dpy window string -- )
 210     dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
 211
 212 : set-title-new ( dpy window string -- )
 213     >r
 214     XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
 215     r> encode-utf8 dup length XChangeProperty drop ;
 216
 217 M: x11-ui-backend set-title ( string world -- )
 218     world-handle x11-handle-window swap dpy get -rot
 219     3dup set-title-old set-title-new ;
 220
 221 M: x11-ui-backend (open-window) ( world -- )
 222     dup gadget-window
 223     world-handle x11-handle-window dup set-closable map-window ;
 224
 225 M: x11-ui-backend raise-window ( world -- )
 226     world-handle [
 227         dpy get swap x11-handle-window XRaiseWindow drop
 228     ] when* ;
 229
 230 M: x11-ui-backend select-gl-context ( handle -- )
 231     dpy get swap
 232     dup x11-handle-window swap x11-handle-glx glXMakeCurrent
 233     [ "Failed to set current GLX context" throw ] unless ;
 234
 235 M: x11-ui-backend flush-gl-context ( handle -- )
 236     dpy get swap x11-handle-window glXSwapBuffers ;
 237
 238 M: x11-ui-backend ui ( -- )
 239     [
 240         f [
 241             [
 242                 init-clipboard
 243                 start-ui
 244                 event-loop
 245             ] with-xim
 246         ] with-x
 247     ] ui-running ;
 248
 249 T{ x11-ui-backend } ui-backend set-global
 250
 251 [ "DISPLAY" os-env "ui" "listener" ? ]
 252 main-vocab-hook set-global