factor/library/ui/x11/ui.factor

! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
IN: x11
USING: arrays errors freetype gadgets gadgets-listener
gadgets-workspace hashtables kernel kernel-internals math
namespaces opengl sequences strings ;

! In the X11 backend, world-handle is a pair { window context }.
! The window is an X11 window ID, and the context is a
! GLX context pointer.

M: world expose-event nip relayout ;

: configured-loc ( event -- dim )
    dup XConfigureEvent-x swap XConfigureEvent-y 2array ;

: configured-dim ( event -- dim )
    dup XConfigureEvent-width swap XConfigureEvent-height 2array ;

M: world configure-event
    over configured-loc over set-world-loc
    swap configured-dim swap set-gadget-dim ;

: modifiers
    {
        { S+ HEX: 1 }
        { C+ HEX: 4 }
        { A+ HEX: 8 }
    } ;
    
: key-codes
    H{
        { HEX: FF08 "BACKSPACE" }
        { HEX: FF09 "TAB"       }
        { HEX: FF0D "RETURN"    }
        { HEX: FF8D "ENTER"     }
        { HEX: FF1B "ESCAPE"    }
        { HEX: FFFF "DELETE"    }
        { HEX: FF50 "HOME"      }
        { HEX: FF51 "LEFT"      }
        { HEX: FF52 "UP"        }
        { HEX: FF53 "RIGHT"     }
        { HEX: FF54 "DOWN"      }
        { HEX: FF55 "PAGE_UP"   }
        { HEX: FF56 "PAGE_DOWN" }
        { HEX: FF57 "END"       }
        { HEX: FF58 "BEGIN"     }
        { HEX: FFBE "F1"        }
        { HEX: FFBF "F2"        }
        { HEX: FFC0 "F3"        }
        { HEX: FFC1 "F4"        }
        { HEX: FFC2 "F5"        }
        { HEX: FFC3 "F6"        }
        { HEX: FFC4 "F7"        }
        { HEX: FFC5 "F8"        }
        { HEX: FFC6 "F9"        }
    } ;

: ignored-key? ( keycode -- ? )
    {
        HEX: FFE1 HEX: FFE2 HEX: FFE3 HEX: FFE4 HEX: FFE5
        HEX: FFE6 HEX: FFE7 HEX: FFE8 HEX: FFE9 HEX: FFEA
        HEX: FFEB HEX: FFEC HEX: FFED HEX: FFEE
    } member? ;

: key-code ( event -- keycode )
    lookup-string drop dup ignored-key? [
        drop f
    ] [
        dup key-codes hash [ ] [ ch>string ] ?if
    ] if ;

: event-modifiers XKeyEvent-state modifiers modifier ;

: key-event>gesture ( event -- modifiers gesture )
    dup event-modifiers swap key-code ;

: key-down-event>gesture ( event -- gesture )
    key-event>gesture [ <key-down> ] [ drop f ] if* ;

M: world key-down-event
    world-focus over key-down-event>gesture [
        over handle-gesture
        [ swap lookup-string nip swap user-input ] [ 2drop ] if
    ] [
        2drop
    ] if* ;

M: world key-up-event
    world-focus swap key-event>gesture dup [
        <key-up> dup [ swap handle-gesture drop ] [ 2drop ] if
    ] [
        3drop
    ] if ;

: mouse-event-loc ( event -- loc )
    dup XButtonEvent-x swap XButtonEvent-y 2array ;

: mouse-event>gesture ( event -- modifiers button loc )
    dup event-modifiers over XButtonEvent-button
    rot mouse-event-loc ;

M: world button-down-event
    >r mouse-event>gesture >r <button-down> r> r>
    send-button-down ;

M: world button-up-event
    >r mouse-event>gesture >r <button-up> r> r>
    send-button-up ;

: mouse-event>scroll-direction ( event -- pair )
    XButtonEvent-button 4 = 1 -1 ? 0 swap 2array ;

M: world wheel-event
    >r dup mouse-event>scroll-direction swap mouse-event-loc r>
    send-wheel ;

M: world enter-event motion-event ;

M: world leave-event 2drop forget-rollover ;

M: world motion-event
    >r dup XMotionEvent-x swap XMotionEvent-y 2array r>
    move-hand fire-motion ;

M: world focus-in-event nip focus-world ;

M: world focus-out-event nip unfocus-world ;

M: world selection-notify-event
    [ world-handle first selection-from-event ] keep
    world-focus user-input ;

: supported-type? ( atom -- ? )
    { "STRING" "UTF8_STRING" "TEXT" }
    [ x-atom = ] contains-with? ;

M: world selection-request-event
    drop dup XSelectionRequestEvent-target {
        { [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
        { [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
        { [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
        { [ t ] [ drop send-notify-failure ] }
    } cond ;

: close-box? ( event -- ? )
    dup XClientMessageEvent-message_type "WM_PROTOCOLS" x-atom =
    swap XClientMessageEvent-data0 "WM_DELETE_WINDOW" x-atom =
    and ;

M: world client-event
    swap close-box? [
        dup world-handle
        >r close-world
        r> first2 destroy-window*
    ] [
        drop
    ] if ;

: gadget-window ( world -- )
    [
        dup world-loc over rect-dim glx-window >r
        [ register-window ] keep r> 2array
    ] keep set-world-handle ;

: event-loop ( -- )
    windows get empty? [
        [ do-events ] ui-try event-loop
    ] unless ;

IN: gadgets

: set-title ( string world -- )
    world-handle first dpy get -rot swap XStoreName drop ;

: open-window* ( world -- )
    dup gadget-window
    dup start-world
    world-handle first dup set-closable map-window ;

: raise-window ( world -- )
    dpy get swap world-handle first XRaiseWindow drop ;

: select-gl-context ( handle -- )
    dpy get swap first2 glXMakeCurrent
    [ "Failed to set current GLX context" throw ] unless ;

: flush-gl-context ( handle -- )
    dpy get swap first glXSwapBuffers ;

IN: shells

: ui ( -- )
    [
        f [
            init-timers
            init-clipboard
            restore-windows? [
                restore-windows
            ] [
                init-ui
                workspace-window
                drop
            ] if
            event-loop
        ] with-x
    ] with-freetype ;

IN: command-line

: default-shell "DISPLAY" os-env empty? "tty" "ui" ? ;