Keyboard input and cleanups for X11 backend

library/cocoa/ui.factor

@@ -53,24 +53,18 @@ H{ } clone views set-global
         { 124 "RIGHT" }
         { 125 "DOWN" }
         { 126 "UP" }
-    } hash ;
+    } ;
-
-: modifier ( mod -- seq )
-    modifiers
-    [ second swap bitand 0 > ] subset-with
-    [ first ] map ;
 
 : key-code ( event -- string )
-    dup [keyCode] key-codes
+    dup [keyCode] key-codes hash
     [ ] [ [charactersIgnoringModifiers] CF>string ] ?if ;
 
-: event>binding ( event -- binding )
+: event>gesture ( event -- gesture )
-    dup [modifierFlags] modifier swap key-code
+    dup [modifierFlags] modifiers modifier swap key-code
-    [ add >list ] [ drop f ] if* ;
+    add >list ;
 
 : send-key-event ( view event -- )
-    >r view world-focus r> dup event>binding
+    >r view world-focus r> dup event>gesture pick handle-gesture
-    [ pick handle-gesture ] [ t ] if*
     [ [characters] CF>string swap user-input ] [ 2drop ] if ;
 
 "NSOpenGLView" "FactorView" {
@@ -165,8 +159,8 @@ H{ } clone views set-global
 
 IN: gadgets
 
-: draw-handle ( handle -- )
+: redraw-world ( handle -- )
-    1 [setNeedsDisplay:] ;
+    world-handle 1 [setNeedsDisplay:] ;
 
 : in-window ( gadget status dim title -- )
     >r <world> r> <FactorWindow> drop ;

library/help/help.factor

@@ -17,3 +17,5 @@ DEFER: $heading
 : glossary ( name -- ) <term> help ;
 
 : handbook ( -- ) "handbook" help ;
+    
+: tutorial ( -- ) "tutorial" help ;

library/syntax/see.factor

@@ -117,9 +117,6 @@ M: word class. drop ;
         newline
     ] with-pprint ;
 
-: completions ( substring words -- seq )
-    [ word-name subseq? ] subset-with ;
-
 : apropos ( substring -- )
     all-words completions natural-sort
     [ [ synopsis ] keep simple-object terpri ] each ;

library/ui/backend.factor

@@ -1,7 +1,9 @@
 IN: gadgets
 USING: kernel opengl ;
 
-DEFER: draw-handle ( handle -- )
+DEFER: draw-world ! defined in world.factor
+
+: redraw-world ( world -- ) draw-world ;
 
 DEFER: in-window ( gadget status dim title -- )
 

library/ui/hand.factor

@@ -77,6 +77,10 @@ V{ } clone hand-buttons set-global
 : request-focus ( gadget -- )
     dup focusable-child swap find-world request-focus* ;
 
+: modifier ( mod modifiers -- seq )
+    [ second swap bitand 0 > ] subset-with
+    [ first ] map ;
+
 : drag-loc ( -- loc )
     hand-loc get-global hand-click-loc get-global v- ;
 
@@ -114,14 +118,18 @@ V{ } clone hand-buttons set-global
         drop
     ] [
         deque dup layout
-        find-world [ world-handle dup set ] when*
+        find-world [ dup world-handle set ] when*
         layout-queued
     ] if ;
 
+: init-ui ( -- )
+    H{ } clone \ timers set-global
+    <queue> \ invalid set-global ;
+    
 : ui-step ( -- )
     do-timers
     [ layout-queued ] make-hash
-    [ drop [ draw-handle ] when* ] hash-each
+    [ nip [ draw-world ] when* ] hash-each
     10 sleep ;
 
 : close-world ( world -- )

library/ui/launchpad.factor

@@ -1,6 +1,7 @@
 IN: gadgets-launchpad
 USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
-gadgets-listener io kernel memory namespaces sequences ;
+gadgets-listener help inspector io kernel memory namespaces
+sequences ;
 
 : <launchpad> ( menu -- )
     [ first2 >r <label> r> <bevel-button> ] map make-pile
@@ -9,6 +10,9 @@ gadgets-listener io kernel memory namespaces sequences ;
 : default-launchpad
     {
         { "Listener" [ listener-window ] }
+        { "Documentation" [ [ handbook ] in-browser ] }
+        { "Tutorial" [ [ tutorial ] in-browser ] }
+        { "Vocabularies" [ [ vocabs. ] in-browser ] }
         { "Save image" [ save ] }
         { "Exit" [ 0 exit ] }
     } <launchpad> ;

library/ui/layouts.factor

@@ -12,8 +12,6 @@ IN: gadgets-layouts
 
 : invalid ( -- queue ) \ invalid get-global ;
 
-<queue> \ invalid set-global
-
 : add-invalid ( gadget -- ) invalid enque ;
 
 : relayout ( gadget -- )

library/ui/line-editor.factor

@@ -1,8 +1,7 @@
 ! Copyright (C) 2005 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: line-editor
-USING: kernel math namespaces prettyprint sequences strings
+USING: kernel math namespaces sequences strings vectors words ;
-vectors ;
 
 SYMBOL: history
 SYMBOL: history-index
@@ -146,6 +145,7 @@ M: document-elt prev-elt* 3drop 0 ;
         2drop f
     ] [
         line-text get subseq possibilities get completions
+        [ word-name ] map
     ] if ;
 
 : complete ( completion -- )

library/ui/listener.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2006 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 IN: gadgets-listener
 USING: arrays compiler gadgets gadgets-editors gadgets-labels
@@ -8,7 +8,7 @@ inference inspector io jedit kernel listener lists math
 namespaces parser prettyprint sequences shells threads words
 help ;
 
-SYMBOL: stack-bar
+TUPLE: listener-gadget pane stack status ;
 
 : in-browser ( quot -- )
     make-pane <scroller> "Browser" simple-window ; inline
@@ -19,9 +19,8 @@ SYMBOL: stack-bar
 : usable-words ( -- words )
     use get hash-concat hash-values ;
 
-: word-completion ( -- )
+: word-completion ( pane -- )
-    usable-words [ word-name ] map
+    usable-words swap pane-input set-possibilities ;
-    pane get pane-input set-possibilities ;
 
 : show-stack ( seq pack -- )
     dup clear-gadget [
@@ -33,22 +32,23 @@ SYMBOL: stack-bar
         ] if
     ] with-stream* ;
 
-: ui-listener-hook ( -- )
+: ui-listener-hook ( listener -- )
-    datastack-hook get call stack-bar get show-stack
+    [
-    word-completion ;
+        >r datastack-hook get call r>
+        listener-gadget-stack show-stack
+    ] keep
+    listener-gadget-pane word-completion ;
 
-: help-button
+: listener-thread ( listener -- )
-    "Please read the " write { "handbook" } $link "." print ;
+    dup listener-gadget-pane [
-
+        [ ui-listener-hook ] curry listener-hook set
-: listener-thread
+        print-banner listener
-    pane get [
-        [ ui-listener-hook ] listener-hook set
-        help-button
-        listener
     ] with-stream* ;
 
 : <status-bar> ( -- gadget ) "" <label> dup status-theme ;
 
+: <stack-bar> ( -- gadget ) <shelf> dup status-theme ;
+
 : <bottom-bar> ( -- gadget status )
     <status-bar> [
         <shelf> dup stack-bar set-global
@@ -58,13 +58,17 @@ SYMBOL: stack-bar
 : <scroller> ( -- gadget )
     <input-pane> dup pane set-global <scroller> ;
 
-: <listener> ( -- gadget status )
+C: listener-gadget ( -- gadget )
-    <frame>
+    <frame> over set-delegate
-    <input-pane> dup pane set-global <scroller>
+    <input-pane> dup pick set-listener-gadget-pane
-    over @center frame-add
+    <scroller> over @center frame-add
-    <bottom-bar> >r over @bottom frame-add r> ;
+    <status-bar> dup pick set-listener-gadget-status
+    over @bottom frame-add
+    <stack-bar> dup pick set-listener-gadget-stack
+    over @top frame-add ;
 
 : listener-window ( -- )
-    <listener> { 600 700 0 } "Listener" in-window
+    <listener-gadget> dup dup listener-gadget-status
-    [ clear listener-thread ] in-thread
+    { 600 700 0 } "Listener" in-window
-    pane get request-focus ;
+    [ >r clear r> listener-thread ] in-thread
+    listener-gadget-pane request-focus ;

library/ui/theme.factor

@@ -83,6 +83,4 @@ USING: arrays gadgets kernel sequences styles ;
     { "monospace" bold 12 } swap set-label-font ;
 
 : status-theme ( label -- )
-    dup reverse-video-theme
+    T{ solid f { 0.9 0.95 1.0 1.0 } } swap set-gadget-interior ;
-    { 1.0 1.0 1.0 1.0 } over set-label-color
-    { "monospace" plain 12 } swap set-label-font ;

library/ui/timers.factor

@@ -16,8 +16,6 @@ GENERIC: tick ( ms object -- )
 
 : timers \ timers get-global ;
 
-H{ } clone \ timers set-global
-
 : add-timer ( object delay -- )
     over >r <timer> r> timers set-hash ;
 

library/words.factor

@@ -97,3 +97,6 @@ M: word literalize <wrapper> ;
 : gensym ( -- word )
     [ "G:" % \ gensym counter # ] "" make
     f <word> dup init-word ;
+
+: completions ( substring words -- seq )
+    [ word-name subseq? ] subset-with ;

library/x11/events.factor

@@ -2,9 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: x11
 USING: alien arrays errors gadgets hashtables io kernel math
-namespaces prettyprint sequences threads ;
+namespaces prettyprint sequences strings threads ;
-
-GENERIC: expose-event ( event window -- )
 
 GENERIC: resize-event ( event window -- )
 
@@ -14,7 +12,9 @@ GENERIC: button-up-event ( event window -- )
 
 GENERIC: motion-event ( event window -- )
 
-GENERIC: key-event ( event window -- )
+GENERIC: key-down-event ( event window -- )
+
+GENERIC: key-up-event ( event window -- )
 
 GENERIC: client-event ( event window -- )
 
@@ -35,12 +35,12 @@ GENERIC: client-event ( event window -- )
 
 : handle-event ( event window -- )
     over XAnyEvent-type {
-        { [ dup Expose = ] [ drop expose-event ] }
         { [ dup ConfigureNotify = ] [ drop resize-event ] }
         { [ dup ButtonPress = ] [ drop button-down-event ] }
         { [ dup ButtonRelease = ] [ drop button-up-event ] }
         { [ dup MotionNotify = ] [ drop motion-event ] }
-        { [ dup KeyPress = ] [ drop key-event ] }
+        { [ dup KeyPress = ] [ drop key-down-event ] }
+        { [ dup KeyRelease = ] [ drop key-up-event ] }
         { [ dup ClientMessage = ] [ drop client-event ] }
         { [ t ] [ 3drop ] }
     } cond ;
@@ -48,3 +48,15 @@ GENERIC: client-event ( event window -- )
 : event-loop ( -- )
     wait-event dup XAnyEvent-window windows get hash dup
     [ handle-event ] [ 2drop ] if event-loop ;
+
+: char-array>string ( n <char-array> -- string )
+    swap >string [ swap char-nth ] map-with ;
+
+: buf-size 100 ;
+
+: lookup-string ( event -- keysym string )
+    buf-size "char" <c-array> [
+        buf-size 0 <KeySym>
+        [ f XLookupString ] keep
+        *KeySym swap
+    ] keep char-array>string ;

library/x11/ui.factor

@@ -3,14 +3,13 @@
 IN: x11
 USING: arrays errors freetype gadgets gadgets-launchpad
 gadgets-layouts gadgets-listener hashtables kernel
-kernel-internals math namespaces opengl sequences x11 ;
+kernel-internals lists math namespaces opengl sequences
+strings x11 ;
 
 ! 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 ( event world -- ) nip draw-world ;
-
 M: world resize-event ( event world -- )
     >r
     dup XConfigureEvent-width swap XConfigureEvent-height 0
@@ -27,7 +26,58 @@ M: world motion-event ( event world -- )
     >r dup XMotionEvent-x swap XMotionEvent-y 0 3array r>
     move-hand ;
 
-M: world key-event ( event world -- ) 2drop ;
+: modifiers
+    {
+        { "SHIFT" HEX: 1 }
+        { "CTRL" HEX: 4 }
+        { "ALT" HEX: 8 }
+    } ;
+    
+: key-codes
+    H{
+        { HEX: FF08 "BACKSPACE" }
+        { HEX: FF09 "TAB"       }
+        { HEX: FF0D "RETURN"    }
+        { 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"     }
+    } ;
+
+: 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>gesture ( event -- gesture )
+    dup XKeyEvent-state modifiers modifier
+    swap key-code [ add >list ] [ drop f ] if* ;
+
+M: world key-down-event ( event world -- )
+    world-focus over event>gesture [
+        over handle-gesture
+        [ over lookup-string nip swap user-input ] [ 2drop ] if
+    ] [
+        drop
+    ] if* ;
+
+M: world key-up-event ( event world -- ) 2drop ;
 
 : close-box? ( event -- )
     dup XClientMessageEvent-type "WM_PROTOCOLS" x-atom =
@@ -42,16 +92,13 @@ M: world client-event ( event world -- )
     ] if ;
 
 : gadget-window ( world -- window )
-    dup rect-dim first2 choose-visual [
+    [ dup rect-dim glx-window* dupd 2array ] keep
-        create-window 2dup map-window*
+    set-world-handle ;
-    ] keep create-context 2array swap set-world-handle ;
 
 IN: gadgets
 
-: draw-handle ( handle -- ) first windows get hash draw-world ;
-
 : in-window ( gadget status dim title -- )
-    >r <world> r> drop gadget-window ;
+    >r <world> gadget-window r> swap set-title ;
 
 : select-gl-context ( handle -- )
     dpy get swap first2 glXMakeCurrent
@@ -65,6 +112,7 @@ IN: shells
 : ui ( -- )
     [
         f [
+            init-ui
             launchpad-window
             listener-window
             event-loop

library/x11/windows.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: x11
-USING: alien hashtables kernel math namespaces ;
+USING: alien hashtables kernel math namespaces sequences ;
 
 : create-window-mask ( -- n )
     CWBackPixel CWBorderPixel bitor
@@ -12,7 +12,7 @@ USING: alien hashtables kernel math namespaces ;
     XCreateColormap ;
 
 : event-mask ( -- n )
-    StructureNotifyMask ExposureMask bitor 
+    StructureNotifyMask
     KeyPressMask bitor
     KeyReleaseMask bitor
     ButtonPressMask	bitor
@@ -31,6 +31,9 @@ USING: alien hashtables kernel math namespaces ;
     [ XVisualInfo-depth InputOutput ] keep
     [ XVisualInfo-visual create-window-mask ] keep
     window-attributes XCreateWindow ;
+    
+: glx-window ( dim -- window context )
+    first2 choose-visual [ create-window ] keep create-context ;
 
 : destroy-window ( win -- )
     dpy get swap XDestroyWindow drop ;
@@ -38,17 +41,14 @@ USING: alien hashtables kernel math namespaces ;
 : destroy-window* ( win -- )
     dup windows get remove-hash destroy-window ;
 
-: map-window ( win -- )
+: map-window ( win -- ) dpy get swap XMapWindow drop ;
-    dpy get swap XMapWindow drop ;
 
 : map-window* ( world win -- )
     [ windows get set-hash ] keep map-window ;
 
-: map-subwindows ( win -- )
+: glx-window* ( world dim -- win context )
-    dpy get swap XMapSubwindows drop ;
+    glx-window >r [ map-window* ] keep r> ;
 
-: unmap-window ( win -- )
+: unmap-window ( win -- ) dpy get swap XUnmapWindow drop ;
-    dpy get swap XUnmapWindow drop ;
 
-: unmap-subwindows ( win -- )
+: set-title ( string win -- ) dpy get -rot swap XStoreName drop ;
-    dpy get swap XUnmapSubwindows drop ;

library/x11/xlib.factor

@@ -46,9 +46,17 @@ TYPEDEF: ulong Time
 
 TYPEDEF: void* Window**
 
-: False 0 ;
+: <ulong> <uint> ;
-: True 1 ;
+: <XID> <ulong> ;
+: <Window> <XID> ;
+: <Drawable> <XID> ;
+: <KeySym> <XID> ;
 
+: *ulong *uint ;
+: *XID *ulong ;
+: *Window *XID ;
+: *Drawable *XID ;
+: *KeySym *XID ;
 !
 ! 2 - Display Functions
 !
@@ -1306,3 +1314,6 @@ FUNCTION: Status XSetStandardProperties (
 : PropModeReplace         0 ; inline
 : PropModePrepend         1 ; inline
 : PropModeAppend          2 ; inline
+    
+! The rest of the stuff is not from the book.
+FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;