Got Cocoa input events working

TODO.FACTOR.txt

@@ -21,6 +21,7 @@
 - autoload frameworks in cocoa class words
 - auto-define classes in obj-c class words
 - super message sends
+  super [foo]...
 
 + ui/help:
 
@@ -42,6 +43,7 @@
 
 + compiler/ffi:
 
+- alien>utf16-string, utf16-string>alien words
 - float intrinsics
 - complex float type
 - complex float intrinsics

library/cocoa/core-foundation.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 IN: cocoa
-USING: alien arrays errors hashtables kernel namespaces
+USING: alien arrays errors hashtables kernel math namespaces
 sequences ;
 
 TYPEDEF: int CFIndex
@@ -9,6 +9,7 @@ TYPEDEF: int CFIndex
 ! Core Foundation utilities -- will be moved elsewhere
 : kCFURLPOSIXPathStyle 0 ;
 
+: kCFStringEncodingMacRoman HEX: 0 ;
 : kCFStringEncodingUnicode HEX: 100 ;
 
 FUNCTION: void* CFURLCreateWithFileSystemPath ( void* allocator, void* filePath, int pathStyle, bool isDirectory ) ;
@@ -17,11 +18,13 @@ FUNCTION: void* CFURLCreateWithString ( void* allocator, void* string, void* bas
 
 FUNCTION: void* CFURLCopyFileSystemPath ( void* url, int pathStyle ) ;
 
-FUNCTION: void* CFStringCreateWithCString ( void* allocator, ushort* cStr, int encoding ) ;
+FUNCTION: void* CFStringCreateWithCString ( void* allocator, char* cStr, int encoding ) ;
 
 FUNCTION: CFIndex CFStringGetLength ( void* theString ) ;
 
-FUNCTION: ushort* CFStringGetCStringPtr ( void* theString, int encoding ) ;
+FUNCTION: bool CFStringGetCString ( void* theString, void* buffer, CFIndex bufferSize, int encoding ) ;
+
+FUNCTION: CFIndex CFStringGetLength ( void* string ) ;
 
 FUNCTION: void* CFBundleCreate ( void* allocator, void* bundleURL ) ;
 
@@ -36,10 +39,12 @@ FUNCTION: bool CFBundleLoadExecutable ( void* bundle ) ;
 FUNCTION: void CFRelease ( void* cf ) ;
 
 : <CFString> ( string -- cf )
-    f swap kCFStringEncodingUnicode CFStringCreateWithCString ;
+    f swap kCFStringEncodingMacRoman CFStringCreateWithCString ;
 
 : CF>string ( string -- string )
-    kCFStringEncodingUnicode CFStringGetCStringPtr ;
+    dup CFStringGetLength 1+ dup <byte-array> [
+        swap kCFStringEncodingMacRoman CFStringGetCString drop
+    ] keep alien>string ;
 
 : <CFFileSystemURL> ( string dir? -- cf )
     >r <CFString> f over kCFURLPOSIXPathStyle

library/cocoa/ui.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factor.sf.net/license.txt for BSD license.
 USING: alien arrays cocoa freetype gadgets gadgets-layouts
-gadgets-listener io kernel math namespaces objc
+gadgets-listener hashtables io kernel lists math namespaces objc
 objc-NSApplication objc-NSEvent objc-NSMenu objc-NSObject
 objc-NSOpenGLContext objc-NSOpenGLView objc-NSView objc-NSWindow
 opengl prettyprint sequences threads walker ;
@@ -37,13 +37,17 @@ IN: gadgets-cocoa
     [ [makeCurrentContext] call glFlush ] keep
     [flushBuffer] ; inline
 
+: button ( event -- n )
+    #! Cocoa -> Factor UI button mapping
+    [buttonNumber] H{ { 0 1 } { 2 2 } { 1 3 } } hash ;
+
 : send-button-down ( event -- )
     update-clicked
-    [buttonNumber] dup hand get hand-buttons push
+    button dup hand get hand-buttons push
     [ button-down ] button-gesture ;
 
 : send-button-up ( event -- )
-    [buttonNumber] dup hand get hand-buttons delete
+    button dup hand get hand-buttons delete
     [ button-up ] button-gesture ;
 
 : mouse-location ( window -- loc )
@@ -61,17 +65,49 @@ IN: gadgets-cocoa
     [ wheel-up ] [ wheel-down ] ?
     hand get hand-clicked handle-gesture drop ;
 
-! M: key-down-event handle-event ( event -- )
-!     dup keyboard-event>binding
-!     hand get hand-focus handle-gesture [
-!         keyboard-event-unicode dup control? [
-!             drop
-!         ] [
-!             hand get hand-focus user-input drop
-!         ] if
-!     ] [
-!         drop
-!     ] if ;
+: modifiers
+    {
+        { "SHIFT" HEX: 10000 }
+        { "CTRL" HEX: 40000 }
+        { "ALT" HEX: 80000 }
+        { "META" HEX: 100000 }
+    } ;
+
+: key-codes
+    H{
+        { 36 "RETURN" }
+        { 48 "TAB" }
+        { 51 "BACKSPACE" }
+        { 115 "HOME" }
+        { 117 "DELETE" }
+        { 119 "END" }
+        { 123 "LEFT" }
+        { 124 "RIGHT" }
+        { 125 "DOWN" }
+        { 126 "UP" }
+    } hash ;
+
+: modifier ( mod -- seq )
+    modifiers
+    [ second swap bitand 0 > ] subset-with
+    [ first ] map ;
+
+: event>binding ( event -- binding )
+    dup [modifierFlags] modifier swap [keyCode] key-codes
+    [ add >list ] [ drop f ] if* ;
+
+: send-user-input ( event -- )
+    [characters] CF>string dup empty?
+    [ hand get hand-focus user-input ] unless drop ;
+
+: send-key-event ( event -- )
+    dup event>binding
+    [ hand get hand-focus handle-gesture ] [ t ] if*
+    [ send-user-input ] [ drop ] if ;
+
+: resize-world ( world -- )
+    dup world-handle [frame] dup NSRect-w swap NSRect-h 0 3array
+    swap set-gadget-dim ;
 
 : init-FactorView-class
     "NSOpenGLView" "FactorView" {
@@ -129,14 +165,11 @@ IN: gadgets-cocoa
         }
         
         { "keyDown:" "void" { "id" "SEL" "id" }
-            [
-                2nip [characters] CF>string dup . flush
-                hand get hand-focus user-input drop
-            ]
+            [ 2nip send-key-event ]
         }
 
         { "reshape" "void" { "id" "SEL" }
-            [ drop 1 [setNeedsDisplay:] ]
+            [ ( 2drop world get resize-world ) ]
         }
         
         { "acceptsFirstResponder" "bool" { "id" "SEL" }

library/collections/namespaces.factor

@@ -47,8 +47,6 @@ SYMBOL: building
 
 : , ( obj -- ) building get push ;
 
-: ?, ( obj ? -- ) [ , ] [ drop ] if ;
-
 : % ( seq -- ) building get swap nappend ;
 
 : # ( n -- ) number>string % ;

library/collections/namespaces.facts

@@ -96,10 +96,6 @@ HELP: , "( elt -- )"
 { $values { "elt" "an object" } }
 { $description "Adds an element to the end of the sequence being constructed by " { $link make } "." } ;
 
-HELP: ?, "( elt ? -- )"
-{ $values { "elt" "an object" } { ">" "a boolean indicating of the element should be added or not" } }
-{ $description "Conditionally adds an element to the end of the sequence being constructed by " { $link make } "." } ;
-
 HELP: % "( seq -- )"
 { $values { "seq" "a sequence" } }
 { $description "Appends a sequence to the end of the sequence being constructed by " { $link make } "." } ;

library/compiler/basic-blocks.factor

@@ -106,6 +106,8 @@ GENERIC: trim-dead* ( tail vop -- )
 
 M: tuple trim-dead* ( tail vop -- ) dup forget-vregs , drop ;
 
+: ?, [ , ] [ drop ] if ;
+
 : simplify-inc ( vop -- ) dup 0 vop-in zero? not ?, ;
 
 M: %inc-d trim-dead* ( tail vop -- ) simplify-inc drop ;

library/ui/world.factor

@@ -20,6 +20,7 @@ TUPLE: world glass status invalid timers handle ;
 
 C: world ( -- world )
     <stack> over set-delegate
+    dup solid-interior
     t over set-gadget-root?
     H{ } clone over set-world-timers ;
 
@@ -100,7 +101,6 @@ global [ first-time on ] bind
     global [
         first-time get [
             <world> world set
-            world get solid-interior
             { 600 700 0 } world get set-gadget-dim
             <hand> hand set
             first-time off