Merge branch 'master' of git://factorcode.org/git/factor into mongo-factor-driver

basis/formatting/formatting.factor

@@ -4,7 +4,7 @@
 USING: accessors arrays ascii assocs calendar combinators fry kernel 
 generalizations io io.encodings.ascii io.files io.streams.string
 macros math math.functions math.parser peg.ebnf quotations
-sequences splitting strings unicode.case vectors ;
+sequences splitting strings unicode.case vectors combinators.smart ;
 
 IN: formatting
 
@@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
 : sprintf ( format-string -- result )
     [ printf ] with-string-writer ; inline
 
-
 <PRIVATE
 
 : pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
@@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
     [ pad-00 ] map "/" join ; inline
 
 : >datetime ( timestamp -- string )
-    { [ day-of-week day-abbreviation3 ]
+    [
+       {
+          [ day-of-week day-abbreviation3 ]
           [ month>> month-abbreviation ]
           [ day>> pad-00 ]
           [ >time ]
           [ year>> number>string ]
-    } cleave 5 narray " " join ; inline
+       } cleave
+    ] output>array " " join ; inline
 
 : (week-of-year) ( timestamp day -- n )
     [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@@ -187,5 +189,3 @@ PRIVATE>
 MACRO: strftime ( format-string -- )
     parse-strftime [ length ] keep [ ] join
     '[ _ <vector> @ reverse concat nip ] ;
-
-

basis/literals/literals-tests.factor

@@ -19,3 +19,9 @@ IN: literals.tests
 [ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
 
 [ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
+
+<<
+CONSTANT: constant-a 3
+>>
+
+[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test

basis/literals/literals.factor

@@ -1,6 +1,8 @@
 ! (c) Joe Groff, see license for details
-USING: accessors continuations kernel parser words quotations vectors ;
+USING: accessors continuations kernel parser words quotations
+combinators.smart vectors sequences ;
 IN: literals
 
 SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
 SYNTAX: $[ parse-quotation with-datastack >vector ;
+SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;

basis/prettyprint/backend/backend.factor

@@ -135,8 +135,8 @@ M: pathname pprint*
     [ text ] [ f <inset pprint* block> ] bi*
     \ } pprint-word block> ;
 
-M: tuple pprint*
+: pprint-tuple ( tuple -- )
-    boa-tuples? get [ call-next-method ] [
+    boa-tuples? get [ pprint-object ] [
         [
             <flow
             \ T{ pprint-word
@@ -149,6 +149,9 @@ M: tuple pprint*
         ] check-recursion
     ] if ;
 
+M: tuple pprint*
+    pprint-tuple ;
+
 : do-length-limit ( seq -- trimmed n/f )
     length-limit get dup [
         over length over [-]

basis/ui/backend/cocoa/views/views.factor

@@ -9,7 +9,7 @@ threads combinators math.rectangles ;
 IN: ui.backend.cocoa.views
 
 : send-mouse-moved ( view event -- )
-    [ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
+    [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
 
 : button ( event -- n )
     #! Cocoa -> Factor UI button mapping

basis/ui/gadgets/gadgets.factor

@@ -3,7 +3,8 @@
 USING: accessors arrays hashtables kernel models math namespaces
 make sequences quotations math.vectors combinators sorting
 binary-search vectors dlists deques models threads
-concurrency.flags math.order math.rectangles fry locals ;
+concurrency.flags math.order math.rectangles fry locals
+prettyprint.backend prettyprint.custom ;
 IN: ui.gadgets
 
 ! Values for orientation slot
@@ -27,6 +28,9 @@ interior
 boundary
 model ;
 
+! Don't print gadgets with RECT: syntax
+M: gadget pprint* pprint-tuple ;
+
 M: gadget equal? 2drop f ;
 
 M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;

basis/ui/gadgets/status-bar/status-bar-docs.factor

@@ -18,7 +18,7 @@ HELP: <status-bar>
 { $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
 
 HELP: open-status-window
-{ $values { "gadget" gadget } { "title" string } }
+{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
 { $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." }
 { $see-also show-status hide-status } ;
 

basis/ui/gadgets/status-bar/status-bar.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors models models.delay models.arrow
 sequences ui.gadgets.labels ui.gadgets.tracks
-ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
+ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
 IN: ui.gadgets.status-bar
 
 : <status-bar> ( model -- gadget )
@@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar
     reverse-video-theme
     t >>root? ;
 
-: open-status-window ( gadget title -- )
+: open-status-window ( gadget title/attributes -- )
-    f <model> [ <world> ] keep
+    ?attributes f <model> >>status <world>
-    <status-bar> f track-add
+    dup status>> <status-bar> f track-add
     open-world-window ;
 
 : show-summary ( object gadget -- )

basis/ui/gadgets/worlds/worlds-docs.factor

@@ -48,8 +48,8 @@ HELP: world
 } ;
 
 HELP: <world>
-{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
+{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } }
-{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
+{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ;
 
 HELP: find-world
 { $values { "gadget" gadget } { "world/f" { $maybe world } } }
@@ -65,6 +65,30 @@ HELP: find-gl-context
 { $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." }
 { $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ;
 
+HELP: begin-world
+{ $values { "world" world } }
+{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ;
+
+HELP: end-world
+{ $values { "world" world } }
+{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ;
+
+HELP: resize-world
+{ $values { "world" world } }
+{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ;
+
+HELP: draw-world*
+{ $values { "world" world } }
+{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ;
+
+ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds"
+"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:"
+{ $subsection begin-world }
+{ $subsection end-world }
+{ $subsection resize-world }
+{ $subsection draw-world* }
+"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ;
+
 ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
 "The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
 { $subsection draw-gadget* }
@@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
 $nl
 "Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:"
 { $subsection find-gl-context }
-"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
+"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "."
 { $subsection "ui-paint-coord" }
+{ $subsection "ui.gadgets.worlds-subclassing" }
 { $subsection "gl-utilities" }
 { $subsection "text-rendering" } ;

basis/ui/gadgets/worlds/worlds.factor

@@ -4,15 +4,28 @@ USING: accessors arrays assocs continuations kernel math models
 namespaces opengl opengl.textures sequences io combinators
 combinators.short-circuit fry math.vectors math.rectangles cache
 ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors ;
+ui.commands ui.pixel-formats destructors literals ;
 IN: ui.gadgets.worlds
 
+CONSTANT: default-world-pixel-format-attributes
+    { windowed double-buffered T{ depth-bits { value 16 } } }
+
 TUPLE: world < track
-active? focused?
+    active? focused?
-layers
+    layers
-title status status-owner
+    title status status-owner
-text-handle handle images
+    text-handle handle images
-window-loc ;
+    window-loc
+    pixel-format-attributes ;
+
+TUPLE: world-attributes
+    { world-class initial: world }
+    title
+    status
+    gadgets
+    { pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
+
+C: <world-attributes> world-attributes
 
 : find-world ( gadget -- world/f ) [ world? ] find-parent ;
 
@@ -45,18 +58,23 @@ M: world request-focus-on ( child gadget -- )
     2dup eq?
     [ 2drop ] [ dup focused?>> (request-focus) ] if ;
 
-: new-world ( gadget title status class -- world )
+: new-world ( class -- world )
     vertical swap new-track
         t >>root?
         t >>active?
-        { 0 0 } >>window-loc
+        { 0 0 } >>window-loc ;
-        swap >>status
-        swap >>title
-        swap 1 track-add
-    dup request-focus ;
 
-: <world> ( gadget title status -- world )
+: apply-world-attributes ( world attributes -- world )
-    world new-world ;
+    {
+        [ title>> >>title ]
+        [ status>> >>status ]
+        [ pixel-format-attributes>> >>pixel-format-attributes ]
+        [ gadgets>> [ 1 track-add ] each ]
+    } cleave ;
+
+: <world> ( world-attributes -- world )
+    [ world-class>> new-world ] keep apply-world-attributes
+    dup request-focus ;
 
 : as-big-as-possible ( world gadget -- )
     dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
@@ -77,17 +95,36 @@ SYMBOL: flush-layout-cache-hook
 
 flush-layout-cache-hook [ [ ] ] initialize
 
-: (draw-world) ( world -- )
+GENERIC: begin-world ( world -- )
-    dup handle>> [
+GENERIC: end-world ( world -- )
+
+GENERIC: resize-world ( world -- )
+
+M: world begin-world
+    drop ;
+M: world end-world
+    drop ;
+M: world resize-world
+    drop ;
+
+M: world (>>dim)
+    [ call-next-method ]
+    [
+        dup handle>>
+        [ select-gl-context resize-world ]
+        [ drop ] if*
+    ] bi ;
+
+GENERIC: draw-world* ( world -- )
+
+M: world draw-world*
     check-extensions
     {
         [ init-gl ]
         [ draw-gadget ]
         [ text-handle>> [ purge-cache ] when* ]
         [ images>> [ purge-cache ] when* ]
-        } cleave
+    } cleave ;
-    ] with-gl-context
-    flush-layout-cache-hook get call( -- ) ;
 
 : draw-world? ( world -- ? )
     #! We don't draw deactivated worlds, or those with 0 size.
@@ -108,7 +145,10 @@ ui-error-hook [ [ rethrow ] ] initialize
 : draw-world ( world -- )
     dup draw-world? [
         dup world [
-            [ (draw-world) ] [
+            [
+                dup handle>> [ draw-world* ] with-gl-context
+                flush-layout-cache-hook get call( -- )
+            ] [
                 over <world-error> ui-error
                 f >>active? drop
             ] recover
@@ -151,8 +191,7 @@ M: world handle-gesture ( gesture gadget -- ? )
     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
 
 M: world world-pixel-format-attributes
-    drop
+    pixel-format-attributes>> ;
-    { windowed double-buffered T{ depth-bits { value 16 } } } ;
 
 M: world check-world-pixel-format
     2drop ;
@@ -160,3 +199,4 @@ M: world check-world-pixel-format
 : with-world-pixel-format ( world quot -- )
     [ dup dup world-pixel-format-attributes <pixel-format> ]
     dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
+

basis/ui/pixel-formats/pixel-formats-docs.factor

@@ -91,29 +91,29 @@ HELP: backing-store
 { double-buffered backing-store } related-words
 
 HELP: multisampled
-{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of multisampling." }
+{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." }
 { $notes "On some window systems this is not distinct from " { $link supersampled } "." } ;
 
 HELP: supersampled
-{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be specified to specify the level of supersampling." }
+{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." }
 { $notes "On some window systems this is not distinct from " { $link multisampled } "." } ;
 
 HELP: sample-alpha
 { $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ;
 
 HELP: color-float
-{ $class-description "Requests a pixel format where the pixels are stored in floating-point format." } ;
+{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ;
 
 HELP: color-bits
-{ $class-description "Requests a pixel format of at least " { $snippet "value" } " bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ;
 HELP: red-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " red bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
 HELP: green-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " green bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ;
 HELP: blue-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " blue bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
 HELP: alpha-bits
-{ $class-description "Requests a pixel format with at least " { $snippet "value" } " alpha bits per pixel." } ;
+{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
 
 { color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words
 

basis/ui/ui-docs.factor

@@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger
 namespaces ui.backend ui.gadgets ui.gadgets.worlds
 ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
 ui.gadgets.private math.rectangles colors ui.text fonts
-kernel ui.private ;
+kernel ui.private classes sequences ;
 IN: ui
 
 HELP: windows
 { $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
 
-{ windows open-window find-window } related-words
+{ windows open-window find-window world-attributes } related-words
 
 HELP: open-window
-{ $values { "gadget" gadget } { "title" string } }
+{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
-{ $description "Opens a native window with the specified title." } ;
+{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
+
+HELP: world-attributes
+{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
+{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
+{ $list
+    { { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." }
+    { { $snippet "title" } " is the window title." }
+    { { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
+    { { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
+    { { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
+} ;
 
 HELP: set-fullscreen?
 { $values { "?" "a boolean" } { "gadget" gadget } }

basis/ui/ui.factor

@@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists
 deques sequences threads sequences words continuations init
 combinators combinators.short-circuit hashtables concurrency.flags
 sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
-ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
+ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
+strings ;
 IN: ui
 
 <PRIVATE
@@ -49,8 +50,20 @@ SYMBOL: windows
     f >>focused?
     focus-path f swap focus-gestures ;
 
-M: world graft*
+: try-to-open-window ( world -- )
+    {
         [ (open-window) ]
+        [ handle>> select-gl-context ]
+        [
+            [ begin-world ]
+            [ [ handle>> (close-window) ] [ ui-error ] bi* ]
+            recover
+        ]
+        [ resize-world ]
+    } cleave ;
+
+M: world graft*
+    [ try-to-open-window ]
     [ [ title>> ] keep set-title ]
     [ request-focus ] tri ;
 
@@ -66,6 +79,7 @@ M: world graft*
         [ images>> [ dispose ] when* ]
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
+        [ end-world ]
     } cleave ;
 
 M: world ungraft*
@@ -166,13 +180,17 @@ PRIVATE>
 : restore-windows? ( -- ? )
     windows get empty? not ;
 
+: ?attributes ( gadget title/attributes -- attributes )
+    dup string? [ world-attributes new swap >>title ] when
+    swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
+
 PRIVATE>
 
 : open-world-window ( world -- )
     dup pref-dim >>dim dup relayout graft ;
 
-: open-window ( gadget title -- )
+: open-window ( gadget title/attributes -- )
-    f <world> open-world-window ;
+    ?attributes <world> open-world-window ;
 
 : set-fullscreen? ( ? gadget -- )
     find-world set-fullscreen* ;

basis/windows/errors/errors.factor

@@ -1,7 +1,7 @@
 USING: alien.c-types kernel locals math math.bitwise
 windows.kernel32 sequences byte-arrays unicode.categories
 io.encodings.string io.encodings.utf16n alien.strings
-arrays ;
+arrays literals ;
 IN: windows.errors
 
 CONSTANT: ERROR_SUCCESS                               0
@@ -732,11 +732,13 @@ ERROR: error-message-failed id ;
         win32-error-string throw
     ] when ;
 
-: expected-io-errors ( -- seq )
+CONSTANT: expected-io-errors
+    ${
         ERROR_SUCCESS
         ERROR_IO_INCOMPLETE
         ERROR_IO_PENDING
-    WAIT_TIMEOUT 4array ; foldable
+        WAIT_TIMEOUT
+    }
 
 : expected-io-error? ( error-code -- ? )
     expected-io-errors member? ;

extra/bunny/bunny.factor

@@ -1,58 +1,67 @@
 USING: accessors arrays bunny.cel-shaded bunny.fixed-pipeline
 bunny.model bunny.outlined destructors kernel math opengl.demo-support
 opengl.gl sequences ui ui.gadgets ui.gadgets.worlds ui.gestures
-ui.render words ;
+ui.render words ui.pixel-formats ;
 IN: bunny
 
-TUPLE: bunny-gadget < demo-gadget model-triangles geom draw-seq draw-n ;
+TUPLE: bunny-world < demo-world model-triangles geom draw-seq draw-n ;
 
-: <bunny-gadget> ( -- bunny-gadget )
+: get-draw ( gadget -- draw )
-    0.0 0.0 0.375 bunny-gadget new-demo-gadget
-    maybe-download read-model >>model-triangles ;
-
-: bunny-gadget-draw ( gadget -- draw )
     [ draw-n>> ] [ draw-seq>> ] bi nth ;
 
-: bunny-gadget-next-draw ( gadget -- )
+: next-draw ( gadget -- )
     dup [ draw-seq>> ] [ draw-n>> ] bi
     1+ swap length mod
     >>draw-n relayout-1 ;
 
-M: bunny-gadget graft* ( gadget -- )
+: make-draws ( gadget -- draw-seq )
-    dup find-gl-context
-    GL_DEPTH_TEST glEnable
-    dup model-triangles>> <bunny-geom> >>geom
-    dup
     [ <bunny-fixed-pipeline> ]
     [ <bunny-cel-shaded> ]
     [ <bunny-outlined> ] tri 3array
-    sift >>draw-seq
+    sift ;
+
+M: bunny-world begin-world
+    GL_DEPTH_TEST glEnable
+    0.0 0.0 0.375 set-demo-orientation
+    maybe-download read-model
+    [ >>model-triangles ] [ <bunny-geom> >>geom ] bi
+    dup make-draws >>draw-seq
     0 >>draw-n
     drop ;
 
-M: bunny-gadget ungraft* ( gadget -- )
+M: bunny-world end-world
     dup find-gl-context
     [ geom>> [ dispose ] when* ]
     [ draw-seq>> [ [ dispose ] when* ] each ] bi ;
 
-M: bunny-gadget draw-gadget* ( gadget -- )
+M: bunny-world draw-world*
     dup draw-seq>> empty? [ drop ] [
         0.15 0.15 0.15 1.0 glClearColor
         GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
-        dup demo-gadget-set-matrices
+        dup demo-world-set-matrix
         GL_MODELVIEW glMatrixMode
         0.02 -0.105 0.0 glTranslatef
-        [ geom>> ] [ bunny-gadget-draw ] bi draw-bunny
+        [ geom>> ] [ get-draw ] bi draw-bunny
     ] if ;
 
-M: bunny-gadget pref-dim* ( gadget -- dim )
+M: bunny-world pref-dim* ( gadget -- dim )
     drop { 640 480 } ;
     
-bunny-gadget H{
+bunny-world H{
-    { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
+    { T{ key-down f f "TAB" } [ next-draw ] }
 } set-gestures
 
 : bunny-window ( -- )
-    [ <bunny-gadget> "Bunny" open-window ] with-ui ;
+    [
+        f T{ world-attributes
+            { world-class bunny-world }
+            { title "Bunny" }
+            { pixel-format-attributes {
+                windowed
+                double-buffered
+                T{ depth-bits { value 16 } }
+            } }
+        } open-window
+    ] with-ui ;
 
 MAIN: bunny-window

extra/bunny/outlined/outlined.factor

@@ -216,7 +216,11 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
     ] with-framebuffer ;
 
 : (pass2) ( draw -- )
-    init-matrices {
+    GL_PROJECTION glMatrixMode
+    glPushMatrix glLoadIdentity
+    GL_MODELVIEW glMatrixMode
+    glLoadIdentity
+    {
         [ color-texture>>  GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit ]
         [ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
         [ depth-texture>>  GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
@@ -230,7 +234,9 @@ MACRO: (framebuffer-texture>>draw) ( iformat xformat setter -- )
                 } cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
             ] with-gl-program
         ]
-    } cleave ;
+    } cleave
+    GL_PROJECTION glMatrixMode
+    glPopMatrix ;
 
 M: bunny-outlined draw-bunny
     [ remake-framebuffer-if-needed ]

extra/file-trees/file-trees.factor

@@ -1,10 +1,10 @@
-USING: accessors delegate delegate.protocols io.pathnames
+USING: accessors arrays delegate delegate.protocols
-kernel locals namespaces sequences vectors
+io.pathnames kernel locals namespaces prettyprint sequences
-tools.annotations prettyprint ;
+ui.frp vectors ;
 IN: file-trees
 
 TUPLE: tree node children ;
-CONSULT: sequence-protocol tree children>> [ node>> ] map ;
+CONSULT: sequence-protocol tree children>> ;
 
 : <tree> ( start -- tree ) V{ } clone
    [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
@@ -21,3 +21,8 @@ DEFER: (tree-insert)
    ] if* ;
 : create-tree ( file-list -- tree ) [ path-components ] map
    t <tree> [ [ tree-insert ] curry each ] keep ;
+
+: <dir-table> ( tree-model -- table )
+   <frp-list*> [ node>> 1array ] >>quot
+   [ selected-value>> <switch> ]
+   [ swap >>model ] bi ;

extra/opengl/demo-support/demo-support.factor

@@ -1,6 +1,6 @@
 USING: arrays kernel math math.functions math.order math.vectors
 namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures
-ui.render accessors combinators ;
+ui.gadgets.worlds ui.render accessors combinators ;
 IN: opengl.demo-support
 
 : FOV ( -- x ) 2.0 sqrt 1+ ; inline
@@ -9,62 +9,62 @@ CONSTANT: KEY-ROTATE-STEP 10.0
 
 SYMBOL: last-drag-loc
 
-TUPLE: demo-gadget < gadget yaw pitch distance ;
+TUPLE: demo-world < world yaw pitch distance ;
 
-: new-demo-gadget ( yaw pitch distance class -- gadget )
+: set-demo-orientation ( world yaw pitch distance -- world )
-    new
+    [ >>yaw ] [ >>pitch ] [ >>distance ] tri* ;
-        swap >>distance
-        swap >>pitch
-        swap >>yaw ; inline
 
 GENERIC: far-plane ( gadget -- z )
 GENERIC: near-plane ( gadget -- z )
 GENERIC: distance-step ( gadget -- dz )
 
-M: demo-gadget far-plane ( gadget -- z )
+M: demo-world far-plane ( gadget -- z )
     drop 4.0 ;
-M: demo-gadget near-plane ( gadget -- z )
+M: demo-world near-plane ( gadget -- z )
     drop 1.0 64.0 / ;
-M: demo-gadget distance-step ( gadget -- dz )
+M: demo-world distance-step ( gadget -- dz )
     drop 1.0 64.0 / ;
 
 : fov-ratio ( gadget -- fov ) dim>> dup first2 min v/n ;
 
-: yaw-demo-gadget ( yaw gadget -- )
+: yaw-demo-world ( yaw gadget -- )
     [ + ] with change-yaw relayout-1 ;
 
-: pitch-demo-gadget ( pitch gadget -- )
+: pitch-demo-world ( pitch gadget -- )
     [ + ] with change-pitch relayout-1 ;
 
-: zoom-demo-gadget ( distance gadget -- )
+: zoom-demo-world ( distance gadget -- )
     [ + ] with change-distance relayout-1 ;
 
-M: demo-gadget pref-dim* ( gadget -- dim )
+M: demo-world focusable-child* ( world -- gadget )
+    drop t ;
+
+M: demo-world pref-dim* ( gadget -- dim )
     drop { 640 480 } ;
 
 : -+ ( x -- -x x )
     [ neg ] keep ;
 
-: demo-gadget-frustum ( gadget -- -x x -y y near far )
+: demo-world-frustum ( world -- -x x -y y near far )
     [ near-plane ] [ far-plane ] [ fov-ratio ] tri [
         nip swap FOV / v*n
         first2 [ -+ ] bi@
     ] 3keep drop ;
 
-: demo-gadget-set-matrices ( gadget -- )
+M: demo-world resize-world
-    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
-    [
     GL_PROJECTION glMatrixMode
     glLoadIdentity
-        demo-gadget-frustum glFrustum
+    [ [ 0 0 ] dip dim>> first2 glViewport ]
-    ] [
+    [ demo-world-frustum glFrustum ] bi ;
+
+: demo-world-set-matrix ( gadget -- )
+    GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
     GL_MODELVIEW glMatrixMode
     glLoadIdentity
     [ [ 0.0 0.0 ] dip distance>> neg glTranslatef ]
     [ pitch>> 1.0 0.0 0.0 glRotatef ]
     [ yaw>>   0.0 1.0 0.0 glRotatef ]
-        tri
+    tri ;
-    ] bi ;
 
 : reset-last-drag-rel ( -- )
     { 0 0 } last-drag-loc set-global ;
@@ -94,16 +94,16 @@ M: demo-gadget pref-dim* ( gadget -- dim )
         swap first swap second glVertex2d
     ] do-state ;
 
-demo-gadget H{
+demo-world H{
-    { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-gadget ] }
+    { T{ key-down f f "LEFT"  } [ KEY-ROTATE-STEP neg swap yaw-demo-world ] }
-    { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-gadget ] }
+    { T{ key-down f f "RIGHT" } [ KEY-ROTATE-STEP     swap yaw-demo-world ] }
-    { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-gadget ] }
+    { T{ key-down f f "DOWN"  } [ KEY-ROTATE-STEP neg swap pitch-demo-world ] }
-    { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-gadget ] }
+    { T{ key-down f f "UP"    } [ KEY-ROTATE-STEP     swap pitch-demo-world ] }
-    { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-gadget ] }
+    { T{ key-down f f "="     } [ dup distance-step neg swap zoom-demo-world ] }
-    { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-gadget ] }
+    { T{ key-down f f "-"     } [ dup distance-step     swap zoom-demo-world ] }
     
     { T{ button-down f f 1 }    [ drop reset-last-drag-rel ] }
-    { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
+    { T{ drag f 1 }             [ drag-yaw-pitch rot [ pitch-demo-world ] keep yaw-demo-world ] }
-    { mouse-scroll              [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
+    { mouse-scroll              [ scroll-direction get second over distance-step * swap zoom-demo-world ] }
 } set-gestures
 

extra/spheres/spheres.factor

@@ -1,7 +1,8 @@
 USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
 opengl.shaders opengl.framebuffers opengl.capabilities multiline
 ui.gadgets accessors sequences ui.render ui math locals arrays
-generalizations combinators ui.gadgets.worlds ;
+generalizations combinators ui.gadgets.worlds
+literals ui.pixel-formats ;
 IN: spheres
 
 STRING: plane-vertex-shader
@@ -110,19 +111,16 @@ main()
 }
 ;
 
-TUPLE: spheres-gadget < demo-gadget
+TUPLE: spheres-world < demo-world
     plane-program solid-sphere-program texture-sphere-program
     reflection-framebuffer reflection-depthbuffer
-    reflection-texture initialized? ;
+    reflection-texture ;
 
-: <spheres-gadget> ( -- gadget )
+M: spheres-world near-plane ( gadget -- z )
-    20.0 10.0 20.0 spheres-gadget new-demo-gadget ;
-
-M: spheres-gadget near-plane ( gadget -- z )
     drop 1.0 ;
-M: spheres-gadget far-plane ( gadget -- z )
+M: spheres-world far-plane ( gadget -- z )
     drop 512.0 ;
-M: spheres-gadget distance-step ( gadget -- dz )
+M: spheres-world distance-step ( gadget -- dz )
     drop 0.5 ;
 
 : (reflection-dim) ( -- w h )
@@ -136,12 +134,14 @@ M: spheres-gadget distance-step ( gadget -- dz )
         GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
         GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
         GL_TEXTURE_CUBE_MAP GL_TEXTURE_WRAP_R GL_CLAMP glTexParameteri
+        ${
             GL_TEXTURE_CUBE_MAP_POSITIVE_X
             GL_TEXTURE_CUBE_MAP_POSITIVE_Y
             GL_TEXTURE_CUBE_MAP_POSITIVE_Z
             GL_TEXTURE_CUBE_MAP_NEGATIVE_X
             GL_TEXTURE_CUBE_MAP_NEGATIVE_Y
-        GL_TEXTURE_CUBE_MAP_NEGATIVE_Z 6 narray
+            GL_TEXTURE_CUBE_MAP_NEGATIVE_Z
+        }
         [ 0 GL_RGBA8 (reflection-dim) 0 GL_RGBA GL_UNSIGNED_BYTE f glTexImage2D ]
         each
     ] keep ;
@@ -171,22 +171,19 @@ M: spheres-gadget distance-step ( gadget -- dz )
     sphere-main-fragment-shader <fragment-shader> check-gl-shader
     3array <gl-program> check-gl-program ;
 
-M: spheres-gadget graft* ( gadget -- )
+M: spheres-world begin-world
-    dup find-gl-context
     "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
     { "GL_EXT_framebuffer_object" } require-gl-extensions
+    20.0 10.0 20.0 set-demo-orientation
     (plane-program) >>plane-program
     (solid-sphere-program) >>solid-sphere-program
     (texture-sphere-program) >>texture-sphere-program
     (make-reflection-texture) >>reflection-texture
     (make-reflection-depthbuffer) [ >>reflection-depthbuffer ] keep
     (make-reflection-framebuffer) >>reflection-framebuffer
-    t >>initialized?
     drop ;
 
-M: spheres-gadget ungraft* ( gadget -- )
+M: spheres-world end-world
-    f >>initialized?
-    dup find-gl-context
     {
         [ reflection-framebuffer>> [ delete-framebuffer ] when* ]
         [ reflection-depthbuffer>> [ delete-renderbuffer ] when* ]
@@ -196,7 +193,7 @@ M: spheres-gadget ungraft* ( gadget -- )
         [ plane-program>> [ delete-gl-program ] when* ]
     } cleave ;
 
-M: spheres-gadget pref-dim* ( gadget -- dim )
+M: spheres-world pref-dim* ( gadget -- dim )
     drop { 640 480 } ;
 
 :: (draw-sphere) ( program center radius -- )
@@ -254,7 +251,7 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
         [ drop 0 0 (reflection-dim) glViewport ]
         [
             GL_PROJECTION glMatrixMode
-            glLoadIdentity
+            glPushMatrix glLoadIdentity
             reflection-frustum glFrustum
             GL_MODELVIEW glMatrixMode
             glLoadIdentity
@@ -277,15 +274,19 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
         [ GL_TEXTURE_CUBE_MAP_POSITIVE_Y (reflection-face)
           glPopMatrix 90.0 1.0 0.0 0.0 glRotatef ]
         [ sphere-scene ]
-        [ dim>> 0 0 rot first2 glViewport ]
+        [
+            [ 0 0 ] dip dim>> first2 glViewport
+            GL_PROJECTION glMatrixMode
+            glPopMatrix
+        ]
     } cleave ] with-framebuffer ;
 
-: (draw-gadget) ( gadget -- )
+M: spheres-world draw-world*
     GL_DEPTH_TEST glEnable
     GL_SCISSOR_TEST glDisable
     0.15 0.15 1.0 1.0 glClearColor {
         [ (draw-reflection-texture) ]
-        [ demo-gadget-set-matrices ]
+        [ demo-world-set-matrix ]
         [ sphere-scene ]
         [ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
         [
@@ -297,10 +298,17 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
         ]
     } cleave ;
 
-M: spheres-gadget draw-gadget* ( gadget -- )
-    dup initialized?>> [ (draw-gadget) ] [ drop ] if ;
-
 : spheres-window ( -- )
-    [ <spheres-gadget> "Spheres" open-window ] with-ui ;
+    [
+        f T{ world-attributes
+            { world-class spheres-world }
+            { title "Spheres" }
+            { pixel-format-attributes {
+                windowed
+                double-buffered
+                T{ depth-bits { value 16 } }
+            } }
+        } open-window
+    ] with-ui ;
 
 MAIN: spheres-window

extra/str-fry/str-fry.factor

@@ -1,4 +1,7 @@
-USING: kernel sequences splitting strings.parser ;
+USING: combinators effects kernel math sequences splitting
+strings.parser ;
 IN: str-fry
-: str-fry ( str -- quot ) "_" split unclip [ [ rot glue ] reduce ] 2curry ;
+: str-fry ( str -- quot ) "_" split
+    [ unclip [ [ rot glue ] reduce ] 2curry ]
+    [ length 1 - 1 <effect> [ call-effect ] 2curry ] bi ;
 SYNTAX: I" parse-string rest str-fry over push-all ;

extra/ui/frp/frp-docs.factor

@@ -36,7 +36,7 @@ HELP: <fold>
 { $values { "oldval" "starting value" } { "quot" "applied to update and previous values" } { "model" model } { "model'" model } }
 { $description "Similar to " { $link reduce } " but works on models, applying a quotation to the previous and new values at each update" } ;
 
-HELP: switch
+HELP: <switch>
 { $values { "signal1" model } { "signal2" model } { "signal'" model } }
 { $description "Creates a model that starts with the behavior of model1 and switches to the behavior of model2 on its update" } ;
 

extra/ui/frp/frp.factor

@@ -1,7 +1,7 @@
-USING: accessors arrays colors fonts fry kernel models
+USING: accessors arrays colors fonts kernel models
 models.product monads sequences ui.gadgets ui.gadgets.buttons
 ui.gadgets.editors ui.gadgets.line-support ui.gadgets.tables
-ui.gadgets.tracks ui.render ;
+ui.gadgets.tracks ui.render ui.gadgets.scrollers ;
 QUALIFIED: make
 IN: ui.frp
 
@@ -18,8 +18,11 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
     frp-table new-line-gadget dup >>renderer [ ] >>quot swap >>model
     f <model> >>selected-value sans-serif-font >>font
     focus-border-color >>focus-border-color
-    transparent >>column-line-color ;
+    transparent >>column-line-color [ ] >>val-quot ;
+: <frp-table*> ( -- table ) f <model> <frp-table> ;
 : <frp-list> ( model -- table ) <frp-table> [ 1array ] >>quot ;
+: <frp-list*> ( -- table ) f <model> <frp-list> ;
+
 : <frp-field> ( -- field ) f <model> <model-field> ;
 
 ! Layout utilities
@@ -27,6 +30,8 @@ M: frp-table row-color color-quot>> [ call( a -- b ) ]  [ drop f ] if* ;
 GENERIC: output-model ( gadget -- model )
 M: gadget output-model model>> ;
 M: frp-table output-model selected-value>> ;
+M: model-field output-model field-model>> ;
+M: scroller output-model children>> first model>> ;
 
 GENERIC: , ( uiitem -- )
 M: gadget , make:, ;
@@ -41,13 +46,16 @@ M: table -> dup , selected-value>> ;
    [ { } make:make ] dip <track> swap [ f track-add ] each ; inline
 : <box*> ( gadgets type -- track ) [ <box> ] [ [ model>> ] map <product> ] bi >>model ; inline
 : <hbox> ( gadgets -- track ) horizontal <box> ; inline
+: <hbox*> ( gadgets -- track ) horizontal <box*> ; inline
 : <vbox> ( gadgets -- track ) vertical <box> ; inline
+: <vbox*> ( gadgets -- track ) vertical <box*> ; inline
 
-! Model utilities
+! !!! Model utilities
 TUPLE: multi-model < model ;
-! M: multi-model model-activated dup model-changed ;
 : <multi-model> ( models kind -- model ) f swap new-model [ [ add-dependency ] curry each ] keep ;
 
+! Events- discrete model utilities
+
 TUPLE: merge-model < multi-model ;
 M: merge-model model-changed [ value>> ] dip set-model ;
 : <merge> ( models -- model ) merge-model <multi-model> ;
@@ -57,15 +65,21 @@ M: filter-model model-changed [ value>> ] dip [ quot>> call( val -- bool ) ] 2ke
    [ set-model ] [ 2drop ] if ;
 : <filter> ( model quot -- filter-model ) [ 1array filter-model <multi-model> ] dip >>quot ;
 
+! Behaviors - continuous model utilities
+
 TUPLE: fold-model < multi-model oldval quot ;
 M: fold-model model-changed [ [ value>> ] [ [ oldval>> ] [ quot>> ] bi ] bi*
    call( val oldval -- newval ) ] keep set-model ;
-: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot swap >>oldval ;
+: <fold> ( oldval quot model -- model' ) 1array fold-model <multi-model> swap >>quot
+   swap [ >>oldval ] [ >>value ] bi ;
 
-TUPLE: switch-model < multi-model switcher on ;
+TUPLE: switch-model < multi-model original switcher on ;
-M: switch-model model-changed tuck [ switcher>> = ] 2keep
+M: switch-model model-changed 2dup switcher>> =
-   '[ on>> [ _ value>> _ set-model ] when ] [ t swap (>>on) ] if ;
+   [ over value>> [ [ value>> ] [ t >>on ] bi* set-model ] [ 2drop ] if ]
-: switch ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] keep >>switcher ;
+   [ dup on>> [ 2drop ] [ [ value>> ] dip set-model ] if ] if ;
+M: switch-model model-activated [ original>> ] keep model-changed ;
+: <switch> ( signal1 signal2 -- signal' ) [ 2array switch-model <multi-model> ] 2keep
+   [ >>original ] [ >>switcher ] bi* ;
 
 TUPLE: mapped < model model quot ;
 
@@ -87,4 +101,4 @@ INSTANCE: gadget-monad monad
 INSTANCE: gadget monad
 M: gadget monad-of drop gadget-monad ;
 M: gadget-monad return drop <gadget> swap >>model ;
-M: gadget >>= model>> '[ _ swap call( x -- y ) ] ; 
+M: gadget >>= output-model [ swap call( x -- y ) ] curry ;