core/ui/x11/ui.factor

   1 ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: x11
   4 USING: arrays errors freetype gadgets gadgets-listener
   5 gadgets-workspace hashtables kernel kernel-internals math
   6 namespaces opengl sequences strings timers ;
   7
   8 ! In the X11 backend, world-handle is a pair { window context }.
   9 ! The window is an X11 window ID, and the context is a
  10 ! GLX context pointer.
  11
  12 M: world expose-event nip relayout ;
  13
  14 : configured-loc ( event -- dim )
  15     dup XConfigureEvent-x swap XConfigureEvent-y 2array ;
  16
  17 : configured-dim ( event -- dim )
  18     dup XConfigureEvent-width swap XConfigureEvent-height 2array ;
  19
  20 M: world configure-event
  21     over configured-loc over set-world-loc
  22     swap configured-dim swap set-gadget-dim ;
  23
  24 : modifiers
  25     {
  26         { S+ HEX: 1 }
  27         { C+ HEX: 4 }
  28         { A+ HEX: 8 }
  29     } ;
  30
  31 : key-codes
  32     H{
  33         { HEX: FF08 "BACKSPACE" }
  34         { HEX: FF09 "TAB"       }
  35         { HEX: FF0D "RETURN"    }
  36         { HEX: FF8D "ENTER"     }
  37         { HEX: FF1B "ESCAPE"    }
  38         { HEX: FFFF "DELETE"    }
  39         { HEX: FF50 "HOME"      }
  40         { HEX: FF51 "LEFT"      }
  41         { HEX: FF52 "UP"        }
  42         { HEX: FF53 "RIGHT"     }
  43         { HEX: FF54 "DOWN"      }
  44         { HEX: FF55 "PAGE_UP"   }
  45         { HEX: FF56 "PAGE_DOWN" }
  46         { HEX: FF57 "END"       }
  47         { HEX: FF58 "BEGIN"     }
  48         { HEX: FFBE "F1"        }
  49         { HEX: FFBF "F2"        }
  50         { HEX: FFC0 "F3"        }
  51         { HEX: FFC1 "F4"        }
  52         { HEX: FFC2 "F5"        }
  53         { HEX: FFC3 "F6"        }
  54         { HEX: FFC4 "F7"        }
  55         { HEX: FFC5 "F8"        }
  56         { HEX: FFC6 "F9"        }
  57     } ;
  58
  59 : ignored-key? ( keycode -- ? )
  60     {
  61         HEX: FFE1 HEX: FFE2 HEX: FFE3 HEX: FFE4 HEX: FFE5
  62         HEX: FFE6 HEX: FFE7 HEX: FFE8 HEX: FFE9 HEX: FFEA
  63         HEX: FFEB HEX: FFEC HEX: FFED HEX: FFEE
  64     } member? ;
  65
  66 : key-code ( event -- keycode )
  67     lookup-string drop dup ignored-key? [
  68         drop f
  69     ] [
  70         dup key-codes hash [ ] [ ch>string ] ?if
  71     ] if ;
  72
  73 : event-modifiers XKeyEvent-state modifiers modifier ;
  74
  75 : key-event>gesture ( event -- modifiers gesture )
  76     dup event-modifiers swap key-code ;
  77
  78 : key-down-event>gesture ( event -- gesture )
  79     key-event>gesture [ <key-down> ] [ drop f ] if* ;
  80
  81 M: world key-down-event
  82     world-focus over key-down-event>gesture [
  83         over send-gesture
  84         [ swap lookup-string nip swap user-input ] [ 2drop ] if
  85     ] [
  86         2drop
  87     ] if* ;
  88
  89 M: world key-up-event
  90     world-focus swap key-event>gesture dup [
  91         <key-up> dup [ swap send-gesture drop ] [ 2drop ] if
  92     ] [
  93         3drop
  94     ] if ;
  95
  96 : mouse-event-loc ( event -- loc )
  97     dup XButtonEvent-x swap XButtonEvent-y 2array ;
  98
  99 : mouse-event>gesture ( event -- modifiers button loc )
 100     dup event-modifiers over XButtonEvent-button
 101     rot mouse-event-loc ;
 102
 103 M: world button-down-event
 104     >r mouse-event>gesture >r <button-down> r> r>
 105     send-button-down ;
 106
 107 M: world button-up-event
 108     >r mouse-event>gesture >r <button-up> r> r>
 109     send-button-up ;
 110
 111 : mouse-event>scroll-direction ( event -- pair )
 112     #! Reminder for myself: 4 is up, 5 is down
 113     XButtonEvent-button 5 = 1 -1 ? 0 swap 2array ;
 114
 115 M: world wheel-event
 116     >r dup mouse-event>scroll-direction swap mouse-event-loc r>
 117     send-wheel ;
 118
 119 M: world enter-event motion-event ;
 120
 121 M: world leave-event 2drop forget-rollover ;
 122
 123 M: world motion-event
 124     >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
 125     move-hand fire-motion ;
 126
 127 M: world focus-in-event nip focus-world ;
 128
 129 M: world focus-out-event nip unfocus-world ;
 130
 131 M: world selection-notify-event
 132     [ world-handle first selection-from-event ] keep
 133     world-focus user-input ;
 134
 135 : supported-type? ( atom -- ? )
 136     { "STRING" "UTF8_STRING" "TEXT" }
 137     [ x-atom = ] contains-with? ;
 138
 139 M: world selection-request-event
 140     drop dup XSelectionRequestEvent-target {
 141         { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
 142         { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
 143         { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
 144         { [ t ] [ drop send-notify-failure ] }
 145     } cond ;
 146
 147 : close-box? ( event -- ? )
 148     dup XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom =
 149     swap XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom =
 150     and ;
 151
 152 M: world client-event
 153     swap close-box? [
 154         dup world-handle
 155         >r close-world
 156         r> first2 destroy-window*
 157     ] [
 158         drop
 159     ] if ;
 160
 161 : gadget-window ( world -- )
 162     [
 163         dup world-loc over rect-dim glx-window >r
 164         [ register-window ] keep r> 2array
 165     ] keep set-world-handle ;
 166
 167 : event-loop ( -- )
 168     windows get empty? [
 169         [ do-events ] ui-try event-loop
 170     ] unless ;
 171
 172 IN: gadgets
 173
 174 : set-title ( string world -- )
 175     world-handle first dpy get -rot swap XStoreName drop ;
 176
 177 : open-window* ( world -- )
 178     dup gadget-window
 179     dup start-world
 180     world-handle first dup set-closable map-window ;
 181
 182 : raise-window ( world -- )
 183     dpy get swap world-handle first XRaiseWindow drop ;
 184
 185 : select-gl-context ( handle -- )
 186     dpy get swap first2 glXMakeCurrent
 187     [ "Failed to set current GLX context" throw ] unless ;
 188
 189 : flush-gl-context ( handle -- )
 190     dpy get swap first glXSwapBuffers ;
 191
 192 IN: shells
 193
 194 : ui ( -- )
 195     [
 196         f [
 197             init-timers
 198             init-clipboard
 199             restore-windows? [
 200                 restore-windows
 201             ] [
 202                 init-ui
 203                 workspace-window
 204                 drop
 205             ] if
 206             event-loop
 207         ] with-x
 208     ] with-freetype ;
 209
 210 IN: command-line
 211
 212 : default-shell "DISPLAY" os-env empty? "tty" "ui" ? ;