Key down events now sent

library/cocoa/ui.factor

@@ -69,13 +69,22 @@ H{ } clone views set-global
     dup [keyCode] key-codes hash
     [ ] [ [charactersIgnoringModifiers] CF>string ] ?if ;
 
-: event>gesture ( event -- gesture )
-    dup [modifierFlags] modifiers modifier swap key-code
-    <key-down> ;
+: event>gesture ( event -- modifiers keycode )
+    dup [modifierFlags] modifiers modifier swap key-code ;
 
-: send-key-event ( view event -- )
-    >r view world-focus r> dup event>gesture pick handle-gesture
-    [ [characters] CF>string swap user-input ] [ 2drop ] if ;
+: send-key-event ( view event quot -- )
+    >r event>gesture r> call swap view world-focus
+    handle-gesture ; inline
+
+: send-user-input ( view event -- )
+    [characters] CF>string swap view world-focus user-input ;
+
+: send-key-down-event ( view event -- )
+    2dup [ <key-down> ] send-key-event
+    [ send-user-input ] [ 2drop ] if ;
+
+: send-key-up-event ( view event -- )
+    [ <key-up> ] send-key-event ;
 
 : send-button-down$ ( view event -- )
     over >r button&loc r> view send-button-down ;
@@ -136,7 +145,11 @@ H{ } clone views set-global
     }
     
     { "keyDown:" "void" { "id" "SEL" "id" }
-        [ nip send-key-event ]
+        [ nip send-key-down-event ]
+    }
+    
+    { "keyUp:" "void" { "id" "SEL" "id" }
+        [ nip send-key-up-event ]
     }
 
     { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }

library/ui/paint.factor

@@ -8,7 +8,6 @@ IN: gadgets
 SYMBOL: clip
 
 : init-gl ( dim -- )
-    { 1.0 0.0 0.0 1.0 } gl-color
     GL_PROJECTION glMatrixMode
     glLoadIdentity
     GL_MODELVIEW glMatrixMode
@@ -21,7 +20,6 @@ SYMBOL: clip
     GL_BLEND glEnable
     GL_SRC_ALPHA GL_ONE_MINUS_SRC_ALPHA glBlendFunc
     GL_SCISSOR_TEST glEnable
-    GL_MODELVIEW glMatrixMode
     1.0 1.0 1.0 1.0 glClearColor
     GL_COLOR_BUFFER_BIT glClear ;
 

library/ui/world.factor

@@ -30,13 +30,7 @@ C: world ( gadget status -- world )
     H{ } clone over set-world-fonts
     dup world-gadget request-focus ;
 
-GENERIC: find-world ( gadget -- world )
-
-M: f find-world ;
-
-M: gadget find-world gadget-parent find-world ;
-
-M: world find-world ;
+: find-world [ world? ] find-parent ;
 
 M: world pref-dim* ( world -- dim )
     delegate pref-dim* { 1024 768 0 } vmin ;