From 195acdd600587db326277b3e2e26a0959c9ad2f0 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 10 Dec 2008 13:54:22 -0600 Subject: [PATCH 1/6] flatland: add 'within?' --- extra/flatland/flatland.factor | 14 ++++++++++++++ 1 file changed, 14 insertions(+) diff --git a/extra/flatland/flatland.factor b/extra/flatland/flatland.factor index c98c5a6c57..72d9e50a9d 100644 --- a/extra/flatland/flatland.factor +++ b/extra/flatland/flatland.factor @@ -2,6 +2,7 @@ USING: accessors arrays fry kernel math math.vectors sequences math.intervals multi-methods + combinators.short-circuit combinators.cleave.enhanced multi-method-syntax ; @@ -218,3 +219,16 @@ USING: locals combinators ; cond 2array ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +GENERIC: within? ( a b -- ? ) + +METHOD: within? ( -- ? ) + { + [ left to-the-right-of? ] + [ right to-the-left-of? ] + [ bottom above? ] + [ top below? ] + } + 2&& ; From 22fb54185685dd4786361f26353f688c085cde76 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Wed, 10 Dec 2008 13:54:41 -0600 Subject: [PATCH 2/6] pong: Un-closurify --- extra/pong/pong.factor | 133 ++++++++++++++++++++--------------------- 1 file changed, 66 insertions(+), 67 deletions(-) diff --git a/extra/pong/pong.factor b/extra/pong/pong.factor index befb64a7a7..3f7626074a 100644 --- a/extra/pong/pong.factor +++ b/extra/pong/pong.factor @@ -15,6 +15,13 @@ USING: kernel accessors locals math math.intervals math.order IN: pong +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Inspired by this Ruby/Shoes version by why: http://gist.github.com/26431 +! +! Which was based on this Nodebox version: http://billmill.org/pong.html +! by Bill Mill. +! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : clamp-to-interval ( x interval -- x ) @@ -95,28 +102,37 @@ METHOD: draw ( -- ) [ pos>> ] [ diameter>> 2 / ] bi circle ; USE: syntax ! Switch back to core 'TUPLE:' instead of the one provided ! by multi-methods -TUPLE: < gadget draw closed ; +TUPLE: < gadget paused field ball player computer ; -M: pref-dim* ( -- dim ) drop { 400 400 } ; -M: draw-gadget* ( -- ) draw>> call ; -M: ungraft* ( -- ) t >>closed drop ; +: pong ( -- gadget ) + new-gadget + T{ { pos { 0 0 } } { dim { 400 400 } } } clone >>field + T{ { pos { 50 50 } } { vel { 3 4 } } } clone >>ball + T{ { pos { 200 396 } } { dim { 75 4 } } } clone >>player + T{ { pos { 200 0 } } { dim { 75 4 } } } clone >>computer ; + +M: pref-dim* ( -- dim ) drop { 400 400 } ; +M: ungraft* ( -- ) t >>paused drop ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +M:: draw-gadget* ( PONG -- ) + + PONG computer>> draw + PONG player>> draw + PONG ball>> draw ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: make-draw-closure ( -- closure ) +:: iterate-system ( GADGET -- ) - ! Establish some bindings - - [let | PLAY-FIELD [ T{ { pos { 0 0 } } { dim { 400 400 } } } ] - BALL [ T{ { pos { 50 50 } } { vel { 3 4 } } } ] - - PLAYER [ T{ { pos { 200 396 } } { dim { 75 4 } } } ] - COMPUTER [ T{ { pos { 200 0 } } { dim { 75 4 } } } ] | - - ! Define some internal words in terms of those bindings ... + [let | FIELD [ GADGET field>> ] + BALL [ GADGET ball>> ] + PLAYER [ GADGET player>> ] + COMPUTER [ GADGET computer>> ] | [wlet | align-player-with-mouse [ ( -- ) - PLAYER PLAY-FIELD align-paddle-with-mouse ] + PLAYER FIELD align-paddle-with-mouse ] move-ball [ ( -- ) BALL 1 move-for ] @@ -127,69 +143,52 @@ M: ungraft* ( -- ) t >>closed drop ; BALL COMPUTER { [ below? ] [ in-between-horizontally? ] } && ] bounce-off-wall? [ ( -- ? ) - BALL PLAY-FIELD in-between-horizontally? not ] | + BALL FIELD in-between-horizontally? not ] - ! Note, we're returning a quotation. - ! The quotation closes over the bindings established by the 'let'. - ! Thus the name of the word 'make-draw-closure'. - ! This closure is intended to be placed in the 'draw' slot of a - ! gadget. - + stop-game [ ( -- ) t GADGET (>>paused) ] | + + BALL FIELD in-bounds? [ - BALL PLAY-FIELD in-bounds? - [ - align-player-with-mouse - - move-ball - - ! computer reaction - - BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when - BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when + align-player-with-mouse - ! check if ball bounced off something - - player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when - computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when - bounce-off-wall? [ BALL reverse-horizontal-velocity ] when + move-ball - ! draw the objects - - COMPUTER draw - PLAYER draw - BALL draw - - ] - when + ! computer reaction - ] ] ] ( -- closure ) ; ! The trailing stack effect here is a workaround. - ! The stack effects in the wlet expression throw - ! off the effect for the whole word, so we reset - ! it to the correct one here. + BALL COMPUTER to-the-left-of? [ COMPUTER computer-move-left ] when + BALL COMPUTER to-the-right-of? [ COMPUTER computer-move-right ] when + + ! check if ball bounced off something + + player-blocked-ball? [ BALL PLAYER bounce-off-paddle ] when + computer-blocked-ball? [ BALL COMPUTER bounce-off-paddle ] when + bounce-off-wall? [ BALL reverse-horizontal-velocity ] when + ] + [ stop-game ] + if + + ] ] ( gadget -- ) ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -:: pong-loop-step ( PONG -- ? ) - PONG closed>> - [ f ] - [ PONG relayout-1 25 milliseconds sleep t ] - if ; - -:: start-pong-thread ( PONG -- ) [ [ PONG pong-loop-step ] loop ] in-thread ; +:: start-pong-thread ( GADGET -- ) + f GADGET (>>paused) + [ + [ + GADGET paused>> + [ f ] + [ GADGET iterate-system GADGET relayout-1 25 milliseconds sleep t ] + if + ] + loop + ] + in-thread ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: play-pong ( -- ) +: pong-window ( -- ) pong [ "PONG" open-window ] [ start-pong-thread ] bi ; - new-gadget - make-draw-closure >>draw - dup "PONG" open-window - - start-pong-thread ; +: pong-main ( -- ) [ pong-window ] with-ui ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -: play-pong-main ( -- ) [ play-pong ] with-ui ; - -MAIN: play-pong-main \ No newline at end of file +MAIN: pong-window \ No newline at end of file From 164f8ccb678b8db3971c201b844b71f352ee919c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Dec 2008 14:28:22 -0600 Subject: [PATCH 3/6] parse the fsid_t for the rest of the platforms --- basis/io/unix/files/freebsd/freebsd.factor | 5 +++-- basis/io/unix/files/linux/linux.factor | 5 +++-- basis/io/unix/files/netbsd/netbsd.factor | 4 ++-- basis/io/unix/files/openbsd/openbsd.factor | 5 +++-- 4 files changed, 11 insertions(+), 8 deletions(-) diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor index 3786a82b55..7fa03a97cd 100644 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -3,7 +3,8 @@ USING: accessors alien.c-types alien.syntax combinators io.backend io.files io.unix.files kernel math system unix unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd -sequences grouping alien.strings io.encodings.utf8 ; +sequences grouping alien.strings io.encodings.utf8 +specialized-arrays.direct.uint ; IN: io.unix.files.freebsd TUPLE: freebsd-file-system-info < unix-file-system-info @@ -32,7 +33,7 @@ M: freebsd statfs>file-system-info ( file-system-info statvfs -- file-system-inf [ statfs-f_asyncreads >>asyncreads ] [ statfs-f_namemax >>name-max ] [ statfs-f_owner >>owner ] - [ statfs-f_fsid >>id ] + [ statfs-f_fsid 2 >array >>id ] [ statfs-f_fstypename utf8 alien>string >>type ] [ statfs-f_mntfromname utf8 alien>string >>device-name ] [ statfs-f_mntonname utf8 alien>string >>mount-point ] diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor index 3e4e1c043a..cbdfbce1ce 100644 --- a/basis/io/unix/files/linux/linux.factor +++ b/basis/io/unix/files/linux/linux.factor @@ -3,7 +3,8 @@ USING: accessors alien.c-types alien.syntax combinators csv io.backend io.encodings.utf8 io.files io.streams.string io.unix.files kernel math.order namespaces sequences sorting -system unix unix.statfs.linux unix.statvfs.linux ; +system unix unix.statfs.linux unix.statvfs.linux +specialized-arrays.direct.uint ; IN: io.unix.files.linux TUPLE: linux-file-system-info < unix-file-system-info @@ -23,7 +24,7 @@ M: linux statfs>file-system-info ( struct -- statfs ) [ statfs64-f_bavail >>blocks-available ] [ statfs64-f_files >>files ] [ statfs64-f_ffree >>files-free ] - [ statfs64-f_fsid >>id ] + [ statfs64-f_fsid 2 >array >>id ] [ statfs64-f_namelen >>namelen ] [ statfs64-f_frsize >>preferred-block-size ] ! [ statfs64-f_spare >>spare ] diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor index 23717b41a4..702d8443e4 100644 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -4,7 +4,7 @@ USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types io.encodings.utf8 alien.strings unix.types io.unix.files io.files unix.statvfs.netbsd unix.getfsstat.netbsd -grouping sequences io.encodings.utf8 ; +grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ; IN: io.unix.files.netbsd TUPLE: netbsd-file-system-info < unix-file-system-info @@ -35,7 +35,7 @@ M: netbsd statvfs>file-system-info ( file-system-info statvfs -- file-system-inf [ statvfs-f_syncwrites >>sync-writes ] [ statvfs-f_asyncreads >>async-reads ] [ statvfs-f_asyncwrites >>async-writes ] - [ statvfs-f_fsidx >>idx ] + [ statvfs-f_fsidx 2 >array >>idx ] [ statvfs-f_fsid >>id ] [ statvfs-f_namemax >>name-max ] [ statvfs-f_owner >>owner ] diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor index 8c8f7c154b..51c5c4fe10 100644 --- a/basis/io/unix/files/openbsd/openbsd.factor +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -3,7 +3,8 @@ USING: accessors alien.c-types alien.strings alien.syntax combinators io.backend io.files io.unix.files kernel math sequences system unix unix.getfsstat.openbsd grouping -unix.statfs.openbsd unix.statvfs.openbsd unix.types ; +unix.statfs.openbsd unix.statvfs.openbsd unix.types +specialized-arrays.direct.uint ; IN: io.unix.files.openbsd TUPLE: freebsd-file-system-info < unix-file-system-info @@ -30,7 +31,7 @@ M: openbsd statfs>file-system-info ( file-system-info statfs -- file-system-info [ statfs-f_syncreads >>sync-reads ] [ statfs-f_asyncwrites >>async-writes ] [ statfs-f_asyncreads >>async-reads ] - [ statfs-f_fsid >>id ] + [ statfs-f_fsid 2 >array >>id ] [ statfs-f_namemax >>name-max ] [ statfs-f_owner >>owner ] ! [ statfs-f_spare >>spare ] From 2af947b08ec4f7de177ceea60021ce64eee659c0 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Dec 2008 14:43:56 -0600 Subject: [PATCH 4/6] fix using for recent change --- basis/io/unix/files/freebsd/freebsd.factor | 2 +- basis/io/unix/files/linux/linux.factor | 2 +- basis/io/unix/files/netbsd/netbsd.factor | 2 +- basis/io/unix/files/openbsd/openbsd.factor | 2 +- 4 files changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/io/unix/files/freebsd/freebsd.factor b/basis/io/unix/files/freebsd/freebsd.factor index 7fa03a97cd..eaf217af62 100644 --- a/basis/io/unix/files/freebsd/freebsd.factor +++ b/basis/io/unix/files/freebsd/freebsd.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.syntax combinators io.backend io.files io.unix.files kernel math system unix unix.statfs.freebsd unix.statvfs.freebsd unix.getfsstat.freebsd sequences grouping alien.strings io.encodings.utf8 -specialized-arrays.direct.uint ; +specialized-arrays.direct.uint arrays ; IN: io.unix.files.freebsd TUPLE: freebsd-file-system-info < unix-file-system-info diff --git a/basis/io/unix/files/linux/linux.factor b/basis/io/unix/files/linux/linux.factor index cbdfbce1ce..c30855c3ee 100644 --- a/basis/io/unix/files/linux/linux.factor +++ b/basis/io/unix/files/linux/linux.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.syntax combinators csv io.backend io.encodings.utf8 io.files io.streams.string io.unix.files kernel math.order namespaces sequences sorting system unix unix.statfs.linux unix.statvfs.linux -specialized-arrays.direct.uint ; +specialized-arrays.direct.uint arrays ; IN: io.unix.files.linux TUPLE: linux-file-system-info < unix-file-system-info diff --git a/basis/io/unix/files/netbsd/netbsd.factor b/basis/io/unix/files/netbsd/netbsd.factor index 702d8443e4..82ac3dc70d 100644 --- a/basis/io/unix/files/netbsd/netbsd.factor +++ b/basis/io/unix/files/netbsd/netbsd.factor @@ -3,7 +3,7 @@ USING: alien.syntax kernel unix.stat math unix combinators system io.backend accessors alien.c-types io.encodings.utf8 alien.strings unix.types io.unix.files -io.files unix.statvfs.netbsd unix.getfsstat.netbsd +io.files unix.statvfs.netbsd unix.getfsstat.netbsd arrays grouping sequences io.encodings.utf8 specialized-arrays.direct.uint ; IN: io.unix.files.netbsd diff --git a/basis/io/unix/files/openbsd/openbsd.factor b/basis/io/unix/files/openbsd/openbsd.factor index 51c5c4fe10..e5e18b29ea 100644 --- a/basis/io/unix/files/openbsd/openbsd.factor +++ b/basis/io/unix/files/openbsd/openbsd.factor @@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings alien.syntax combinators io.backend io.files io.unix.files kernel math sequences system unix unix.getfsstat.openbsd grouping unix.statfs.openbsd unix.statvfs.openbsd unix.types -specialized-arrays.direct.uint ; +specialized-arrays.direct.uint arrays ; IN: io.unix.files.openbsd TUPLE: freebsd-file-system-info < unix-file-system-info From 24a8cb0a958eb24fbc32770c693f9ca18460b4d4 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 16:25:57 -0600 Subject: [PATCH 5/6] Remove >r/r> usage from ui.cocoa --- basis/ui/cocoa/views/views.factor | 15 ++++----------- 1 file changed, 4 insertions(+), 11 deletions(-) diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index 128fdceeb4..f1e2f725b0 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -266,14 +266,9 @@ CLASS: { { "writeSelectionToPasteboard:types:" "char" { "id" "SEL" "id" "id" } [ CF>string-array NSStringPboardType swap member? [ - >r drop window-focus gadget-selection dup [ - r> set-pasteboard-string 1 - ] [ - r> 2drop 0 - ] if - ] [ - 3drop 0 - ] if + [ drop window-focus gadget-selection ] dip over + [ set-pasteboard-string 1 ] [ 2drop 0 ] if + ] [ 3drop 0 ] if ] } @@ -281,9 +276,7 @@ CLASS: { [ pasteboard-string dup [ [ drop window-focus ] dip swap user-input 1 - ] [ - 3drop 0 - ] if + ] [ 3drop 0 ] if ] } From 6346999f6659e08ce87e6ff6a061dbc8397a33cd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Wed, 10 Dec 2008 16:40:05 -0600 Subject: [PATCH 6/6] Fix race condition with gesture handling and grafting --- basis/ui/cocoa/views/views.factor | 6 +++--- basis/ui/gestures/gestures.factor | 21 +++++++++++++++------ basis/ui/ui.factor | 2 +- basis/ui/windows/windows.factor | 4 ++-- basis/ui/x11/x11.factor | 7 +++---- 5 files changed, 24 insertions(+), 16 deletions(-) diff --git a/basis/ui/cocoa/views/views.factor b/basis/ui/cocoa/views/views.factor index f1e2f725b0..7bb9679132 100644 --- a/basis/ui/cocoa/views/views.factor +++ b/basis/ui/cocoa/views/views.factor @@ -60,7 +60,7 @@ IN: ui.cocoa.views dup event-modifiers swap key-code ; : send-key-event ( view gesture -- ) - swap window-focus propagate-gesture ; + swap window propagate-key-gesture ; : interpret-key-event ( view event -- ) NSArray swap -> arrayWithObject: -> interpretKeyEvents: ; @@ -275,14 +275,14 @@ CLASS: { { "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" } [ pasteboard-string dup [ - [ drop window-focus ] dip swap user-input 1 + [ drop window ] dip swap user-input 1 ] [ 3drop 0 ] if ] } ! Text input { "insertText:" "void" { "id" "SEL" "id" } - [ nip CF>string swap window-focus user-input ] + [ nip CF>string swap window user-input ] } { "hasMarkedText" "char" { "id" "SEL" } diff --git a/basis/ui/gestures/gestures.factor b/basis/ui/gestures/gestures.factor index 5faaa93292..123a7620d1 100644 --- a/basis/ui/gestures/gestures.factor +++ b/basis/ui/gestures/gestures.factor @@ -41,13 +41,25 @@ M: propagate-gesture send-queued-gesture : propagate-gesture ( gesture gadget -- ) \ propagate-gesture queue-gesture ; -TUPLE: user-input string gadget ; +TUPLE: propagate-key-gesture gesture world ; + +: world-focus ( world -- gadget ) + dup focus>> [ world-focus ] [ ] ?if ; + +M: propagate-key-gesture send-queued-gesture + [ gesture>> ] [ world>> world-focus ] bi + [ handle-gesture ] with each-parent drop ; + +: propagate-key-gesture ( gesture world -- ) + \ propagate-key-gesture queue-gesture ; + +TUPLE: user-input string world ; M: user-input send-queued-gesture - [ string>> ] [ gadget>> ] bi + [ string>> ] [ world>> world-focus ] bi [ user-input* ] with each-parent drop ; -: user-input ( string gadget -- ) +: user-input ( string world -- ) '[ _ \ user-input queue-gesture ] unless-empty ; ! Gesture objects @@ -261,9 +273,6 @@ SYMBOL: drag-timer scroll-direction set-global T{ mouse-scroll } hand-gadget get-global propagate-gesture ; -: world-focus ( world -- gadget ) - dup focus>> [ world-focus ] [ ] ?if ; - : send-action ( world gesture -- ) swap world-focus propagate-gesture ; diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 88f0a353b9..d9ff287014 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -140,7 +140,7 @@ SYMBOL: ui-hook graft-queue [ notify ] slurp-deque ; : send-queued-gestures ( -- ) - gesture-queue [ send-queued-gesture ] slurp-deque ; + gesture-queue [ send-queued-gesture notify-queued ] slurp-deque ; : update-ui ( -- ) [ diff --git a/basis/ui/windows/windows.factor b/basis/ui/windows/windows.factor index 0510e21f17..10539df8e7 100755 --- a/basis/ui/windows/windows.factor +++ b/basis/ui/windows/windows.factor @@ -181,7 +181,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; : send-key-gesture ( sym action? quot hWnd -- ) [ [ key-modifiers ] 3dip call ] dip - window-focus propagate-gesture ; inline + window propagate-key-gesture ; inline : send-key-down ( sym action? hWnd -- ) [ [ ] ] dip send-key-gesture ; @@ -213,7 +213,7 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; ctrl? alt? xor [ wParam 1string [ f hWnd send-key-down ] - [ hWnd window-focus user-input ] bi + [ hWnd window user-input ] bi ] unless ] unless ; diff --git a/basis/ui/x11/x11.factor b/basis/ui/x11/x11.factor index a532a13b69..b4a0427ccd 100755 --- a/basis/ui/x11/x11.factor +++ b/basis/ui/x11/x11.factor @@ -83,8 +83,7 @@ M: world configure-event M: world key-down-event [ key-down-event>gesture ] keep - world-focus - [ propagate-gesture drop ] + [ propagate-key-gesture drop ] [ 2over valid-input? [ nip user-input ] [ 3drop ] if ] 3bi ; @@ -92,7 +91,7 @@ M: world key-down-event dup event-modifiers swap 0 XLookupKeysym key-code ; M: world key-up-event - [ key-up-event>gesture ] dip world-focus propagate-gesture ; + [ key-up-event>gesture ] dip propagate-key-gesture ; : mouse-event>gesture ( event -- modifiers button loc ) [ event-modifiers ] @@ -138,7 +137,7 @@ M: world focus-out-event M: world selection-notify-event [ handle>> window>> selection-from-event ] keep - world-focus user-input ; + world user-input ; : supported-type? ( atom -- ? ) { "UTF8_STRING" "STRING" "TEXT" }