Merge branch 'master' of git://factorcode.org/git/factor

basis/cocoa/dialogs/dialogs.factor

@@ -12,6 +12,9 @@ IN: cocoa.dialogs
     dup 1 -> setResolvesAliases:
     dup 1 -> setAllowsMultipleSelection: ;
 
+: <NSDirPanel> ( -- panel ) <NSOpenPanel>
+   dup 1 -> setCanChooseDirectories: ;
+
 : <NSSavePanel> ( -- panel )
     NSSavePanel -> savePanel
     dup 1 -> setCanChooseFiles:
@@ -21,10 +24,12 @@ IN: cocoa.dialogs
 CONSTANT: NSOKButton 1
 CONSTANT: NSCancelButton 0
 
-: open-panel ( -- paths )
+: (open-panel) ( panel -- paths )
-    <NSOpenPanel>
     dup -> runModal NSOKButton =
     [ -> filenames CF>string-array ] [ drop f ] if ;
+    
+: open-panel ( -- paths ) <NSOpenPanel> (open-panel) ;
+: open-dir-panel ( -- paths ) <NSDirPanel> (open-panel) ;
 
 : split-path ( path -- dir file )
     "/" split1-last [ <NSString> ] bi@ ;

basis/cocoa/views/views-docs.factor

@@ -1,13 +1,9 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup ui.pixel-formats ;
 IN: cocoa.views
 
-HELP: <PixelFormat>
-{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
-{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
-
 HELP: <GLView>
-{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } }
+{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } }
-{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ;
+{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ;
 
 HELP: view-dim
 { $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } }
@@ -18,7 +14,6 @@ HELP: mouse-location
 { $description "Outputs the current mouse location." } ;
 
 ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
-{ $subsection <PixelFormat> }
 { $subsection <GLView> }
 { $subsection view-dim }
 { $subsection mouse-location } ;

basis/cocoa/views/views.factor

@@ -42,39 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
 CONSTANT: NSOpenGLPFAVirtualScreenCount 128
 CONSTANT: NSOpenGLCPSwapInterval 222
 
-<PRIVATE
+: <GLView> ( class dim pixel-format -- view )
-
+    [ -> alloc ]
-SYMBOL: software-renderer?
+    [ [ 0 0 ] dip first2 <CGRect> ]
-SYMBOL: multisample?
+    [ handle>> ] tri*
-
-PRIVATE>
-
-: with-software-renderer ( quot -- )
-    [ t software-renderer? ] dip with-variable ; inline
-
-: with-multisample ( quot -- )
-    [ t multisample? ] dip with-variable ; inline
-
-: <PixelFormat> ( attributes -- pixelfmt )
-    NSOpenGLPixelFormat -> alloc swap [
-        %
-        NSOpenGLPFADepthSize , 16 ,
-        software-renderer? get [
-            NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
-        ] when
-        multisample? get [
-            NSOpenGLPFASupersample ,
-            NSOpenGLPFASampleBuffers , 1 ,
-            NSOpenGLPFASamples , 8 ,
-        ] when
-        0 ,
-    ] int-array{ } make
-    -> initWithAttributes:
-    -> autorelease ;
-
-: <GLView> ( class dim -- view )
-    [ -> alloc 0 0 ] dip first2 <CGRect>
-    NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
     -> initWithFrame:pixelFormat:
     dup 1 -> setPostsBoundsChangedNotifications:
     dup 1 -> setPostsFrameChangedNotifications: ;

basis/delegate/delegate-docs.factor

@@ -24,7 +24,7 @@ HELP: CONSULT:
 
 HELP: SLOT-PROTOCOL:
 { $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
-{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ;
 
 { define-protocol POSTPONE: PROTOCOL: } related-words
 

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 ]
+    [
-      [ month>> month-abbreviation ]
+       {
-      [ day>> pad-00 ]
+          [ day-of-week day-abbreviation3 ]
-      [ >time ]
+          [ month>> month-abbreviation ]
-      [ year>> number>string ]
+          [ day>> pad-00 ]
-    } cleave 5 narray " " join ; inline
+          [ >time ]
+          [ year>> number>string ]
+       } 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/ftp/client/client.factor

@@ -66,7 +66,7 @@ ERROR: ftp-error got expected ;
 : list ( url -- ftp-response )
     utf8 open-passive-client
     ftp-list
-    lines
+    stream-lines
     <ftp-response> swap >>strings
     read-response 226 ftp-assert
     parse-list ;

basis/functors/functors-tests.factor

@@ -81,7 +81,26 @@ SYMBOL: W
 
 [ blorgh ] [ blorgh ] unit-test
 
-GENERIC: some-generic ( a -- b )
+<<
+
+FUNCTOR: generic-test ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+GENERIC: W ( a -- b )
+M: object W ;
+M: integer W 1 + ;
+
+;FUNCTOR
+
+"snurv" generic-test
+
+>>
+
+[ 2   ] [ 1   snurv ] unit-test
+[ 3.0 ] [ 3.0 snurv ] unit-test
 
 ! Does replacing an ordinary word with a functor-generated one work?
 [ [ ] ] [
@@ -89,6 +108,7 @@ GENERIC: some-generic ( a -- b )
 
     TUPLE: some-tuple ;
     : some-word ( -- ) ;
+    GENERIC: some-generic ( a -- b )
     M: some-tuple some-generic ;
     SYMBOL: some-symbol
     "> <string-reader> "functors-test" parse-stream
@@ -97,6 +117,7 @@ GENERIC: some-generic ( a -- b )
 : test-redefinition ( -- )
     [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
     [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
+    [ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
     [ t ] [
         "some-tuple" "functors.tests" lookup
         "some-generic" "functors.tests" lookup method >boolean
@@ -109,13 +130,14 @@ FUNCTOR: redefine-test ( W -- )
 
 W-word DEFINES ${W}-word
 W-tuple DEFINES-CLASS ${W}-tuple
-W-generic IS ${W}-generic
+W-generic DEFINES ${W}-generic
 W-symbol DEFINES ${W}-symbol
 
 WHERE
 
 TUPLE: W-tuple ;
 : W-word ( -- ) ;
+GENERIC: W-generic ( a -- b )
 M: W-tuple W-generic ;
 SYMBOL: W-symbol
 

basis/functors/functors.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel quotations classes.tuple make combinators generic
+USING: accessors arrays classes.mixin classes.parser
-words interpolate namespaces sequences io.streams.string fry
+classes.tuple classes.tuple.parser combinators effects
-classes.mixin effects lexer parser classes.tuple.parser
+effects.parser fry generic generic.parser generic.standard
-effects.parser locals.types locals.parser generic.parser
+interpolate io.streams.string kernel lexer locals.parser
-locals.rewrite.closures vocabs.parser classes.parser
+locals.rewrite.closures locals.types make namespaces parser
-arrays accessors words.symbol ;
+quotations sequences vocabs.parser words words.symbol ;
 IN: functors
 
 ! This is a hack
@@ -18,6 +18,8 @@ IN: functors
 
 : define-declared* ( word def effect -- ) pick set-word define-declared ;
 
+: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+
 TUPLE: fake-call-next-method ;
 
 TUPLE: fake-quotation seq ;
@@ -104,6 +106,11 @@ SYNTAX: `INSTANCE:
     scan-param parsed
     \ add-mixin-instance parsed ;
 
+SYNTAX: `GENERIC:
+    scan-param parsed
+    complete-effect parsed
+    \ define-simple-generic* parsed ;
+
 SYNTAX: `inline [ word make-inline ] over push-all ;
 
 SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
@@ -130,6 +137,7 @@ DEFER: ;FUNCTOR delimiter
         { "M:" POSTPONE: `M: }
         { "C:" POSTPONE: `C: }
         { ":" POSTPONE: `: }
+        { "GENERIC:" POSTPONE: `GENERIC: }
         { "INSTANCE:" POSTPONE: `INSTANCE: }
         { "SYNTAX:" POSTPONE: `SYNTAX: }
         { "SYMBOL:" POSTPONE: `SYMBOL: }

basis/inverse/inverse-tests.factor

@@ -1,5 +1,7 @@
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
 USING: inverse tools.test arrays math kernel sequences
-math.functions math.constants continuations ;
+math.functions math.constants continuations combinators.smart ;
 IN: inverse-tests
 
 [ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@@ -69,7 +71,7 @@ C: <nil> nil
 
 [ t ] [ pi [ pi ] matches? ] unit-test
 [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
-[ ] [ 3 [ _ ] undo ] unit-test
+[ ] [ 3 [ __ ] undo ] unit-test
 
 [ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
 [ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
@@ -88,4 +90,7 @@ TUPLE: funny-tuple ;
 : <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
 : funny-tuple ( -- ) "OOPS" throw ;
 
-[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
+
+[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
+[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test

basis/inverse/inverse.factor

@@ -1,12 +1,12 @@
-! Copyright (C) 2007, 2008 Daniel Ehrenberg.
+! Copyright (C) 2007, 2009 Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel words summary slots quotations
 sequences assocs math arrays stack-checker effects generalizations
 continuations debugger classes.tuple namespaces make vectors
 bit-arrays byte-arrays strings sbufs math.functions macros
-sequences.private combinators mirrors splitting
+sequences.private combinators mirrors splitting combinators.smart
-combinators.short-circuit fry words.symbol generalizations ;
+combinators.short-circuit fry words.symbol generalizations
-RENAME: _ fry => __
+classes ;
 IN: inverse
 
 ERROR: fail ;
@@ -14,7 +14,7 @@ M: fail summary drop "Matching failed" ;
 
 : assure ( ? -- ) [ fail ] unless ; inline
 
-: =/fail ( obj1 obj2 -- ) = assure ;
+: =/fail ( obj1 obj2 -- ) = assure ; inline
 
 ! Inverse of a quotation
 
@@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
 \ pick [ [ pick ] dip =/fail ] define-inverse
 \ tuck [ swapd [ =/fail ] keep ] define-inverse
 
+\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
+\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
+\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
+\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
+
 \ not define-involution
-\ >boolean [ { t f } memq? assure ] define-inverse
+\ >boolean [ dup { t f } memq? assure ] define-inverse
 
 \ tuple>array \ >tuple define-dual
 \ reverse define-involution
 
-\ undo 1 [ [ call ] curry ] define-pop-inverse
+\ undo 1 [ ] define-pop-inverse
-\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
+\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
 
 \ exp \ log define-dual
 \ sq \ sqrt define-dual
@@ -173,16 +178,13 @@ ERROR: missing-literal ;
     2curry
 ] define-pop-inverse
 
-DEFER: _
+DEFER: __
-\ _ [ drop ] define-inverse
+\ __ [ drop ] define-inverse
 
 : both ( object object -- object )
     dupd assert= ;
 \ both [ dup ] define-inverse
 
-: assure-length ( seq length -- seq )
-    over length =/fail ;
-
 {
     { >array array? }
     { >vector vector? }
@@ -194,14 +196,23 @@ DEFER: _
     { >string string? }
     { >sbuf sbuf? }
     { >quotation quotation? }
-} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
+} [ '[ dup _ execute assure ] define-inverse ] assoc-each
 
-! These actually work on all seqs--should they?
+: assure-length ( seq length -- )
-\ 1array [ 1 assure-length first ] define-inverse
+    swap length =/fail ; inline
-\ 2array [ 2 assure-length first2 ] define-inverse
+
-\ 3array [ 3 assure-length first3 ] define-inverse
+: assure-array ( array -- array )
-\ 4array [ 4 assure-length first4 ] define-inverse
+    dup array? assure ; inline
-\ narray 1 [ [ firstn ] curry ] define-pop-inverse
+
+: undo-narray ( array n -- ... )
+    [ assure-array ] dip
+    [ assure-length ] [ firstn ] 2bi ; inline
+
+\ 1array [ 1 undo-narray ] define-inverse
+\ 2array [ 2 undo-narray ] define-inverse
+\ 3array [ 3 undo-narray ] define-inverse
+\ 4array [ 4 undo-narray ] define-inverse
+\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
 
 \ first [ 1array ] define-inverse
 \ first2 [ 2array ] define-inverse
@@ -214,6 +225,12 @@ DEFER: _
 \ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
 \ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
 
+: assure-same-class ( obj1 obj2 -- )
+    [ class ] bi@ = assure ; inline
+
+\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
+\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
+
 ! Constructor inverse
 : deconstruct-pred ( class -- quot )
     "predicate" word-prop [ dupd call assure ] curry ;
@@ -245,7 +262,7 @@ DEFER: _
     ] recover ; inline
 
 : true-out ( quot effect -- quot' )
-    out>> '[ @ __ ndrop t ] ;
+    out>> '[ @ _ ndrop t ] ;
 
 : false-recover ( effect -- quot )
     in>> [ ndrop f ] curry [ recover-fail ] curry ;

basis/io/encodings/string/string.factor

@@ -4,7 +4,7 @@ USING: io io.streams.byte-array ;
 IN: io.encodings.string
 
 : decode ( byte-array encoding -- string )
-    <byte-reader> contents ;
+    <byte-reader> stream-contents ;
 
 : encode ( string encoding -- byte-array )
     [ write ] with-byte-writer ;

basis/io/launcher/launcher.factor

@@ -3,9 +3,9 @@
 USING: system kernel namespaces strings hashtables sequences 
 assocs combinators vocabs.loader init threads continuations
 math accessors concurrency.flags destructors environment
-io io.backend io.timeouts io.pipes io.pipes.private io.encodings
+io io.encodings.ascii io.backend io.timeouts io.pipes
-io.streams.duplex io.ports debugger prettyprint summary
+io.pipes.private io.encodings io.streams.duplex io.ports
-calendar ;
+debugger prettyprint summary calendar ;
 IN: io.launcher
 
 TUPLE: process < identity-tuple
@@ -265,3 +265,5 @@ M: object run-pipeline-element
     { [ os winnt? ] [ "io.launcher.windows.nt" require ] }
     [ ]
 } cond
+
+: run-desc ( desc -- result ) ascii <process-reader> f swap stream-read-until drop ;

basis/io/launcher/unix/unix-tests.factor

@@ -33,7 +33,7 @@ concurrency.promises threads unix.process ;
     "cat"
     "launcher-test-1" temp-file
     2array
-    ascii <process-reader> contents
+    ascii <process-reader> stream-contents
 ] unit-test
 
 [ ] [
@@ -52,7 +52,7 @@ concurrency.promises threads unix.process ;
     "cat"
     "launcher-test-1" temp-file
     2array
-    ascii <process-reader> contents
+    ascii <process-reader> stream-contents
 ] unit-test
 
 [ ] [
@@ -70,14 +70,14 @@ concurrency.promises threads unix.process ;
     "cat"
     "launcher-test-1" temp-file
     2array
-    ascii <process-reader> contents
+    ascii <process-reader> stream-contents
 ] unit-test
 
 [ t ] [
     <process>
         "env" >>command
         { { "A" "B" } } >>environment
-    ascii <process-reader> lines
+    ascii <process-reader> stream-lines
     "A=B" swap member?
 ] unit-test
 
@@ -86,7 +86,7 @@ concurrency.promises threads unix.process ;
         "env" >>command
         { { "A" "B" } } >>environment
         +replace-environment+ >>environment-mode
-    ascii <process-reader> lines
+    ascii <process-reader> stream-lines
 ] unit-test
 
 [ "hi\n" ] [
@@ -113,13 +113,13 @@ concurrency.promises threads unix.process ;
     "append-test" temp-file utf8 file-contents
 ] unit-test
 
-[ t ] [ "ls" utf8 <process-stream> contents >boolean ] unit-test
+[ t ] [ "ls" utf8 <process-stream> stream-contents >boolean ] unit-test
 
 [ "Hello world.\n" ] [
     "cat" utf8 <process-stream> [
         "Hello world.\n" write
         output-stream get dispose
-        input-stream get contents
+        input-stream get stream-contents
     ] with-stream
 ] unit-test
 

basis/io/servers/connection/connection-tests.factor

@@ -35,4 +35,4 @@ concurrency.promises io.encodings.ascii io threads calendar ;
     dup start-server* sockets>> first addr>> port>> "port" set
 ] unit-test
 
-[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop contents ] unit-test
+[ "Hello world." ] [ "localhost" "port" get <inet> ascii <client> drop stream-contents ] unit-test

basis/io/sockets/secure/unix/unix-tests.factor

@@ -23,7 +23,7 @@ io.sockets.secure.unix.debug ;
 
 : client-test ( -- string )
     <secure-config> [
-        "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop contents
+        "127.0.0.1" "port" get ?promise <inet4> <secure> ascii <client> drop stream-contents
     ] with-secure-context ;
 
 [ ] [ [ class name>> write ] server-test ] unit-test

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/math/rectangles/rectangles-tests.factor

@@ -1,42 +1,42 @@
 USING: tools.test math.rectangles ;
 IN: math.rectangles.tests
 
-[ T{ rect f { 10 10 } { 20 20 } } ]
+[ RECT: { 10 10 } { 20 20 } ]
 [
-    T{ rect f { 10 10 } { 50 50 } }
+    RECT: { 10 10 } { 50 50 }
-    T{ rect f { -10 -10 } { 40 40 } }
+    RECT: { -10 -10 } { 40 40 }
     rect-intersect
 ] unit-test
 
-[ T{ rect f { 200 200 } { 0 0 } } ]
+[ RECT: { 200 200 } { 0 0 } ]
 [
-    T{ rect f { 100 100 } { 50 50 } }
+    RECT: { 100 100 } { 50 50 }
-    T{ rect f { 200 200 } { 40 40 } }
+    RECT: { 200 200 } { 40 40 }
     rect-intersect
 ] unit-test
 
 [ f ] [
-    T{ rect f { 100 100 } { 50 50 } }
+    RECT: { 100 100 } { 50 50 }
-    T{ rect f { 200 200 } { 40 40 } }
+    RECT: { 200 200 } { 40 40 }
     contains-rect?
 ] unit-test
 
 [ t ] [
-    T{ rect f { 100 100 } { 50 50 } }
+    RECT: { 100 100 } { 50 50 }
-    T{ rect f { 120 120 } { 40 40 } }
+    RECT: { 120 120 } { 40 40 }
     contains-rect?
 ] unit-test
 
 [ f ] [
-    T{ rect f { 1000 100 } { 50 50 } }
+    RECT: { 1000 100 } { 50 50 }
-    T{ rect f { 120 120 } { 40 40 } }
+    RECT: { 120 120 } { 40 40 }
     contains-rect?
 ] unit-test
 
-[ T{ rect f { 10 20 } { 20 20 } } ] [
+[ RECT: { 10 20 } { 20 20 } ] [
     {
         { 20 20 }
         { 10 40 }
         { 30 30 }
     } rect-containing
-] unit-test
+] unit-test

basis/math/rectangles/rectangles.factor

@@ -1,12 +1,18 @@
 ! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.vectors accessors ;
+USING: kernel arrays sequences math math.vectors accessors
+parser prettyprint.custom prettyprint.backend ;
 IN: math.rectangles
 
 TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
 
 : <rect> ( loc dim -- rect ) rect boa ; inline
 
+SYNTAX: RECT: scan-object scan-object <rect> parsed ;
+
+M: rect pprint*
+    \ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
+
 : <zero-rect> ( -- rect ) rect new ; inline
 
 : point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@@ -55,4 +61,4 @@ M: rect contains-point?
 : set-rect-bounds ( rect1 rect -- )
     [ [ loc>> ] dip (>>loc) ]
     [ [ dim>> ] dip (>>dim) ]
-    2bi ; inline
+    2bi ; inline

basis/opengl/gl/windows/windows.factor

@@ -1,6 +1,11 @@
-USING: kernel windows.opengl32 ;
+USING: alien.syntax kernel windows.types ;
 IN: opengl.gl.windows
 
+LIBRARY: gl
+
+FUNCTION: HGLRC wglGetCurrentContext ( ) ;
+FUNCTION: void* wglGetProcAddress ( char* name ) ;
+
 : gl-function-context ( -- context ) wglGetCurrentContext ; inline
 : gl-function-address ( name -- address ) wglGetProcAddress ; inline
 : gl-function-calling-convention ( -- str ) "stdcall" ; inline

basis/prettyprint/backend/backend.factor

@@ -134,8 +134,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
@@ -148,6 +148,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/random/random.factor

@@ -54,7 +54,7 @@ PRIVATE>
 
 : randomize ( seq -- seq )
     dup length [ dup 1 > ]
-    [ [ random ] [ 1- ] bi [ pick exchange ] keep ]
+    [ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
     while drop ;
 
 : delete-random ( seq -- elt )

basis/ui/backend/cocoa/cocoa.factor

@@ -1,14 +1,16 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors math arrays assocs cocoa cocoa.application
+USING: accessors alien.c-types arrays assocs classes cocoa
-command-line kernel memory namespaces cocoa.messages
+cocoa.application cocoa.classes cocoa.messages cocoa.nibs
-cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
+cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
-cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private
+cocoa.views cocoa.windows combinators command-line
-ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
+core-foundation core-foundation.run-loop core-graphics
-ui.backend.cocoa.views core-foundation core-foundation.run-loop
+core-graphics.types destructors fry generalizations io.thread
-core-graphics.types threads math.rectangles fry libc
+kernel libc literals locals math math.rectangles memory
-generalizations alien.c-types cocoa.views
+namespaces sequences specialized-arrays.int threads ui
-combinators io.thread locals ;
+ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
+ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
+ui.private words.symbol ;
 IN: ui.backend.cocoa
 
 TUPLE: handle ;
@@ -20,6 +22,42 @@ C: <offscreen-handle> offscreen-handle
 
 SINGLETON: cocoa-ui-backend
 
+PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
+    { double-buffered { $ NSOpenGLPFADoubleBuffer } }
+    { stereo { $ NSOpenGLPFAStereo } }
+    { offscreen { $ NSOpenGLPFAOffScreen } }
+    { fullscreen { $ NSOpenGLPFAFullScreen } }
+    { windowed { $ NSOpenGLPFAWindow } }
+    { accelerated { $ NSOpenGLPFAAccelerated } }
+    { software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
+    { backing-store { $ NSOpenGLPFABackingStore } }
+    { multisampled { $ NSOpenGLPFAMultisample } }
+    { supersampled { $ NSOpenGLPFASupersample } }
+    { sample-alpha { $ NSOpenGLPFASampleAlpha } }
+    { color-float { $ NSOpenGLPFAColorFloat } }
+    { color-bits { $ NSOpenGLPFAColorSize } }
+    { alpha-bits { $ NSOpenGLPFAAlphaSize } }
+    { accum-bits { $ NSOpenGLPFAAccumSize } }
+    { depth-bits { $ NSOpenGLPFADepthSize } }
+    { stencil-bits { $ NSOpenGLPFAStencilSize } }
+    { aux-buffers { $ NSOpenGLPFAAuxBuffers } }
+    { sample-buffers { $ NSOpenGLPFASampleBuffers } }
+    { samples { $ NSOpenGLPFASamples } }
+}
+
+M: cocoa-ui-backend (make-pixel-format)
+    nip >NSOpenGLPFA-int-array
+    NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ;
+
+M: cocoa-ui-backend (free-pixel-format)
+    handle>> -> release ;
+
+M: cocoa-ui-backend (pixel-format-attribute)
+    [ handle>> ] [ >NSOpenGLPFA ] bi*
+    [ drop f ]
+    [ first 0 <int> [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ]
+    if-empty ;
+
 TUPLE: pasteboard handle ;
 
 C: <pasteboard> pasteboard
@@ -70,7 +108,8 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
     handle>> view>> -> isInFullScreenMode zero? not ;
 
 M:: cocoa-ui-backend (open-window) ( world -- )
-    world dim>> <FactorView> :> view
+    world [ [ dim>> ] dip <FactorView> ]
+    with-world-pixel-format :> view
     view world world>NSRect <ViewWindow> :> window
     view -> release
     world view register-window
@@ -97,18 +136,19 @@ M: cocoa-ui-backend raise-window* ( world -- )
     ] when* ;
 
 : pixel-size ( pixel-format -- size )
-    0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
+    color-bits pixel-format-attribute -3 shift ;
-    keep *int -3 shift ;
 
 : offscreen-buffer ( world pixel-format -- alien w h pitch )
     [ dim>> first2 ] [ pixel-size ] bi*
     { [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
 
-: gadget-offscreen-context ( world -- context buffer )
+:: gadget-offscreen-context ( world -- context buffer )
-    NSOpenGLPFAOffScreen 1array <PixelFormat>
+    world [
-    [ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
+        nip :> pf
-    [ offscreen-buffer ] 2bi
+        NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext:
-    4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
+        dup world pf offscreen-buffer
+        4 npick [ -> setOffScreen:width:height:rowbytes: ] dip
+    ] with-world-pixel-format ;
 
 M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
     dup gadget-offscreen-context <offscreen-handle> >>handle drop ;

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
@@ -365,8 +365,8 @@ CLASS: {
     -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
     CGLSetParameter drop ;
 
-: <FactorView> ( dim -- view )
+: <FactorView> ( dim pixel-format -- view )
-    FactorView swap <GLView> [ sync-refresh-to-screen ] keep ;
+    [ FactorView ] 2dip <GLView> [ sync-refresh-to-screen ] keep ;
 
 : save-position ( world window -- )
     -> frame CGRect-top-left 2array >>window-loc drop ;

basis/ui/backend/windows/windows.factor

@@ -10,11 +10,161 @@ windows.messages windows.types windows.offscreen windows.nt
 threads libc combinators fry combinators.short-circuit continuations
 command-line shuffle opengl ui.render ascii math.bitwise locals
 accessors math.rectangles math.order ascii calendar
-io.encodings.utf16n windows.errors ;
+io.encodings.utf16n windows.errors literals ui.pixel-formats 
+ui.pixel-formats.private memoize classes ;
 IN: ui.backend.windows
 
 SINGLETON: windows-ui-backend
 
+TUPLE: win-base hDC hRC ;
+TUPLE: win < win-base hWnd world title ;
+TUPLE: win-offscreen < win-base hBitmap bits ;
+C: <win> win
+C: <win-offscreen> win-offscreen
+
+<PRIVATE
+
+PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
+    { double-buffered { $ WGL_DOUBLE_BUFFER_ARB 1 } }
+    { stereo { $ WGL_STEREO_ARB 1 } }
+    { offscreen { $ WGL_DRAW_TO_BITMAP_ARB 1 } }
+    { fullscreen { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
+    { windowed { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
+    { accelerated { $ WGL_ACCELERATION_ARB $ WGL_FULL_ACCELERATION_ARB } }
+    { software-rendered { $ WGL_ACCELERATION_ARB $ WGL_NO_ACCELERATION_ARB } }
+    { backing-store { $ WGL_SWAP_METHOD_ARB $ WGL_SWAP_COPY_ARB } }
+    { color-float { $ WGL_TYPE_RGBA_FLOAT_ARB 1 } }
+    { color-bits { $ WGL_COLOR_BITS_ARB } }
+    { red-bits { $ WGL_RED_BITS_ARB } }
+    { green-bits { $ WGL_GREEN_BITS_ARB } }
+    { blue-bits { $ WGL_BLUE_BITS_ARB } }
+    { alpha-bits { $ WGL_ALPHA_BITS_ARB } }
+    { accum-bits { $ WGL_ACCUM_BITS_ARB } }
+    { accum-red-bits { $ WGL_ACCUM_RED_BITS_ARB } }
+    { accum-green-bits { $ WGL_ACCUM_GREEN_BITS_ARB } }
+    { accum-blue-bits { $ WGL_ACCUM_BLUE_BITS_ARB } }
+    { accum-alpha-bits { $ WGL_ACCUM_ALPHA_BITS_ARB } }
+    { depth-bits { $ WGL_DEPTH_BITS_ARB } }
+    { stencil-bits { $ WGL_STENCIL_BITS_ARB } }
+    { aux-buffers { $ WGL_AUX_BUFFERS_ARB } }
+    { sample-buffers { $ WGL_SAMPLE_BUFFERS_ARB } }
+    { samples { $ WGL_SAMPLES_ARB } }
+}
+
+MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? )
+    { "WGL_ARB_pixel_format" } has-wgl-extensions? ;
+: has-wglChoosePixelFormatARB? ( world -- ? )
+    handle>> hDC>> (has-wglChoosePixelFormatARB?) ;
+
+: arb-make-pixel-format ( world attributes -- pf )
+    [ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
+    [ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
+
+: arb-pixel-format-attribute ( pixel-format attribute -- value )
+    >WGL_ARB
+    [ drop f ] [
+        [ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
+        first <int> 0 <int>
+        [ wglGetPixelFormatAttribivARB win32-error=0/f ]
+        keep *int
+    ] if-empty ;
+
+CONSTANT: pfd-flag-map H{
+    { double-buffered $ PFD_DOUBLEBUFFER }
+    { stereo $ PFD_STEREO }
+    { offscreen $ PFD_DRAW_TO_BITMAP }
+    { fullscreen $ PFD_DRAW_TO_WINDOW }
+    { windowed $ PFD_DRAW_TO_WINDOW }
+    { backing-store $ PFD_SWAP_COPY }
+    { software-rendered $ PFD_GENERIC_FORMAT }
+}
+
+: >pfd-flag ( attribute -- value )
+    pfd-flag-map at [ ] [ 0 ] if* ;
+
+: >pfd-flags ( attributes -- flags )
+    [ >pfd-flag ] [ bitor ] map-reduce
+    PFD_SUPPORT_OPENGL bitor ;
+
+: attr-value ( attributes name -- value )
+    [ instance? ] curry find nip
+    [ value>> ] [ 0 ] if* ;
+
+: >pfd ( attributes -- pfd )
+    "PIXELFORMATDESCRIPTOR" <c-object>
+    "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
+    1 over set-PIXELFORMATDESCRIPTOR-nVersion
+    over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags
+    PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
+    over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits
+    over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits
+    over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits
+    over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits
+    over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits
+    over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits
+    over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits
+    over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits
+    over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits
+    over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits
+    over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits
+    over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits
+    over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers
+    PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask
+    nip ;
+
+: pfd-make-pixel-format ( world attributes -- pf )
+    [ handle>> hDC>> ] [ >pfd ] bi*
+    ChoosePixelFormat dup win32-error=0/f ;
+
+: get-pfd ( pixel-format -- pfd )
+    [ world>> handle>> hDC>> ] [ handle>> ] bi
+    "PIXELFORMATDESCRIPTOR" heap-size
+    "PIXELFORMATDESCRIPTOR" <c-object>
+    [ DescribePixelFormat win32-error=0/f ] keep ;
+
+: pfd-flag? ( pfd flag -- ? )
+    [ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ;
+
+: (pfd-pixel-format-attribute) ( pfd attribute -- value )
+    {
+        { double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] }
+        { stereo [ PFD_STEREO pfd-flag? ] }
+        { offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] }
+        { fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
+        { windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
+        { software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
+        { color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] }
+        { red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] }
+        { green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] }
+        { blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] }
+        { alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] }
+        { accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] }
+        { accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] }
+        { accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] }
+        { accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] }
+        { accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] }
+        { depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] }
+        { stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] }
+        { aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] }
+        [ 2drop f ]
+    } case ;
+
+: pfd-pixel-format-attribute ( pixel-format attribute -- value )
+    [ get-pfd ] dip (pfd-pixel-format-attribute) ;
+
+M: windows-ui-backend (make-pixel-format)
+    over has-wglChoosePixelFormatARB?
+    [ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ;
+
+M: windows-ui-backend (free-pixel-format)
+    drop ;
+
+M: windows-ui-backend (pixel-format-attribute)
+    over world>> has-wglChoosePixelFormatARB?
+    [ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
+
+PRIVATE>
+
 : lo-word ( wparam -- lo ) <short> *short ; inline
 : hi-word ( wparam -- hi ) -16 shift lo-word ; inline
 : >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
@@ -73,12 +223,6 @@ M: pasteboard set-clipboard-contents drop copy ;
     <pasteboard> clipboard set-global
     <clipboard> selection set-global ;
 
-TUPLE: win-base hDC hRC ;
-TUPLE: win < win-base hWnd world title ;
-TUPLE: win-offscreen < win-base hBitmap bits ;
-C: <win> win
-C: <win-offscreen> win-offscreen
-
 SYMBOLS: msg-obj class-name-ptr mouse-captured ;
 
 : style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
@@ -477,25 +621,24 @@ M: windows-ui-backend do-events
     f class-name-ptr set-global
     f msg-obj set-global ;
 
-: setup-pixel-format ( hdc flags -- )
+: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
-    32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
-    swapd SetPixelFormat win32-error=0/f ;
 
-: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
+: get-rc ( world -- )
+    handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
+    [ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
 
-: get-rc ( hDC -- hRC )
+: set-pixel-format ( pixel-format hdc -- )
-    dup wglCreateContext dup win32-error=0/f
+    swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
-    [ wglMakeCurrent win32-error=0/f ] keep ;
 
-: setup-gl ( hwnd -- hDC hRC )
+: setup-gl ( world -- )
-    get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
+    [ get-dc ] keep
+    [ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
+    with-world-pixel-format ;
 
 M: windows-ui-backend (open-window) ( world -- )
-    [ create-window [ setup-gl ] keep ] keep
+    [ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
-    [ f <win> ] keep
+    [ dup handle>> hWnd>> register-window ]
-    [ swap hWnd>> register-window ] 2keep
+    [ handle>> hWnd>> show-window ] tri ;
-    dupd (>>handle)
-    hWnd>> show-window ;
 
 M: win-base select-gl-context ( handle -- )
     [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
@@ -504,15 +647,15 @@ M: win-base select-gl-context ( handle -- )
 M: win-base flush-gl-context ( handle -- )
     hDC>> SwapBuffers win32-error=0/f ;
 
-: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
+: setup-offscreen-gl ( world -- )
-    make-offscreen-dc-and-bitmap [
+    dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap
-        [ dup offscreen-pfd-dwFlags setup-pixel-format ]
+    [ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [
-        [ get-rc ] bi
+        swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi
-    ] 2dip ;
+    ] with-world-pixel-format ;
 
 M: windows-ui-backend (open-offscreen-buffer) ( world -- )
-    dup dim>> setup-offscreen-gl <win-offscreen>
+    win-offscreen new >>handle
-    >>handle drop ;
+    setup-offscreen-gl ;
 
 M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
     [ hDC>> DeleteDC drop ]

basis/ui/backend/x11/x11.factor

@@ -7,7 +7,8 @@ namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
 x11.glx x11.clipboard x11.constants x11.windows x11.io
 io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
 command-line math.vectors classes.tuple opengl.gl threads
-math.rectangles environment ascii ;
+math.rectangles environment ascii literals
+ui.pixel-formats ui.pixel-formats.private ;
 IN: ui.backend.x11
 
 SINGLETON: x11-ui-backend
@@ -29,6 +30,40 @@ M: world configure-event
     ! In case dimensions didn't change
     relayout-1 ;
 
+PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
+    { double-buffered { $ GLX_DOUBLEBUFFER } }
+    { stereo { $ GLX_STEREO } }
+    { color-bits { $ GLX_BUFFER_SIZE } }
+    { red-bits { $ GLX_RED_SIZE } }
+    { green-bits { $ GLX_GREEN_SIZE } }
+    { blue-bits { $ GLX_BLUE_SIZE } }
+    { alpha-bits { $ GLX_ALPHA_SIZE } }
+    { accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
+    { accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
+    { accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
+    { accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
+    { depth-bits { $ GLX_DEPTH_SIZE } }
+    { stencil-bits { $ GLX_STENCIL_SIZE } }
+    { aux-buffers { $ GLX_AUX_BUFFERS } }
+    { sample-buffers { $ GLX_SAMPLE_BUFFERS } }
+    { samples { $ GLX_SAMPLES } }
+}
+
+M: x11-ui-backend (make-pixel-format)
+    [ drop dpy get scr get ] dip
+    >glx-visual-int-array glXChooseVisual ;
+
+M: x11-ui-backend (free-pixel-format)
+    handle>> XFree ;
+
+M: x11-ui-backend (pixel-format-attribute)
+    [ dpy get ] 2dip
+    [ handle>> ] [ >glx-visual ] bi*
+    [ 2drop f ] [
+        first
+        0 <int> [ glXGetConfig drop ] keep *int
+    ] if-empty ;
+
 CONSTANT: modifiers
     {
         { S+ HEX: 1 }
@@ -187,7 +222,8 @@ M: world client-event
 
 : gadget-window ( world -- )
     dup
-    [ window-loc>> ] [ dim>> ] bi glx-window swap
+    [ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
+    with-world-pixel-format swap
     dup "Factor" create-xic
     <x11-handle>
     [ window>> register-window ] [ >>handle drop ] 2bi ;
@@ -274,7 +310,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- )
     drop ;
 
 M: x11-ui-backend (open-offscreen-buffer) ( world -- )
-    dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
+    dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
+    with-world-pixel-format
+    <x11-pixmap-handle> >>handle drop ;
 M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
     dpy get swap
     [ glx-pixmap>> glXDestroyGLXPixmap ]

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 } ;
 
@@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help"
 { $subsection hide-status }
 { $link "ui.gadgets.presentations" } " use the status bar to display object summary." ;
 
-ABOUT: "ui.gadgets.status-bar"
+ABOUT: "ui.gadgets.status-bar"

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

@@ -1,6 +1,6 @@
 USING: ui.gadgets ui.render ui.text ui.text.private
 ui.gestures ui.backend help.markup help.syntax
-models opengl strings ;
+models opengl sequences strings ;
 IN: ui.gadgets.worlds
 
 HELP: user-input
@@ -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.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 -- )
-        check-extensions
+
-        {
+GENERIC: resize-world ( world -- )
-            [ init-gl ]
+
-            [ draw-gadget ]
+M: world begin-world
-            [ text-handle>> [ purge-cache ] when* ]
+    drop ;
-            [ images>> [ purge-cache ] when* ]
+M: world end-world
-        } cleave
+    drop ;
-    ] with-gl-context
+M: world resize-world
-    flush-layout-cache-hook get call( -- ) ;
+    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 ;
 
 : 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
@@ -149,3 +189,14 @@ M: world handle-gesture ( gesture gadget -- ? )
 
 : close-global ( world global -- )
     [ get-global find-world eq? ] keep '[ f _ set-global ] when ;
+
+M: world world-pixel-format-attributes
+    pixel-format-attributes>> ;
+
+M: world check-world-pixel-format
+    2drop ;
+
+: 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

@@ -0,0 +1,198 @@
+USING: destructors help.markup help.syntax kernel math multiline sequences
+vocabs vocabs.parser words ;
+IN: ui.pixel-formats
+
+! break circular dependency
+<<
+    "ui.gadgets.worlds" create-vocab drop
+    "world" "ui.gadgets.worlds" create drop
+    "ui.gadgets.worlds" (use+)
+>>
+
+ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
+"The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:"
+{ $subsection double-buffered }
+{ $subsection stereo }
+{ $subsection offscreen }
+{ $subsection fullscreen }
+{ $subsection windowed }
+{ $subsection accelerated }
+{ $subsection software-rendered }
+{ $subsection backing-store }
+{ $subsection multisampled }
+{ $subsection supersampled }
+{ $subsection sample-alpha }
+{ $subsection color-float }
+"Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:"
+{ $subsection color-bits }
+{ $subsection red-bits }
+{ $subsection green-bits }
+{ $subsection blue-bits }
+{ $subsection alpha-bits }
+{ $subsection accum-bits }
+{ $subsection accum-red-bits }
+{ $subsection accum-green-bits }
+{ $subsection accum-blue-bits }
+{ $subsection accum-alpha-bits }
+{ $subsection depth-bits }
+{ $subsection stencil-bits }
+{ $subsection aux-buffers }
+{ $subsection sample-buffers }
+{ $subsection samples }
+{ $examples
+"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
+{ $code <"
+USING: kernel ui.worlds ui.pixel-formats ;
+IN: ui.pixel-formats.examples
+
+TUPLE: picky-depth-buffered-world < world ;
+
+M: picky-depth-buffered-world world-pixel-format-attributes
+    drop {
+        double-buffered
+        T{ color-bits { value 24 } }
+        T{ depth-bits { value 24 } }
+    } ;
+
+M: picky-depth-buffered-world check-world-pixel-format
+    nip
+    [ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ]
+    [ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
+    [ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
+    tri ;
+"> } }
+;
+
+HELP: double-buffered
+{ $class-description "Requests a double-buffered pixel format." } ;
+HELP: stereo
+{ $class-description "Requests a stereoscopic pixel format." } ;
+
+HELP: offscreen
+{ $class-description "Requests a pixel format suitable for offscreen rendering." } ;
+HELP: fullscreen
+{ $class-description "Requests a pixel format suitable for fullscreen rendering." }
+{ $notes "On some window systems this is not distinct from " { $link windowed } "." } ;
+HELP: windowed
+{ $class-description "Requests a pixel format suitable for rendering to a window." } ;
+
+{ offscreen fullscreen windowed } related-words
+
+HELP: accelerated
+{ $class-description "Requests a pixel format supported by GPU hardware acceleration." } ;
+HELP: software-rendered
+{ $class-description "Requests a pixel format only supported by the window system's default software renderer." } ;
+
+{ accelerated software-rendered } related-words
+
+HELP: backing-store
+{ $class-description "Used with " { $link double-buffered } " to request a double-buffered pixel format where the back buffer contents are preserved and copied to the front when buffers are swapped." } ;
+
+{ 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 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 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 color buffer is stored in floating-point format." } ;
+
+HELP: color-bits
+{ $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 a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
+HELP: green-bits
+{ $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 a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
+HELP: alpha-bits
+{ $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
+
+HELP: accum-bits
+{ $class-description "Requests a pixel format with an accumulation buffer of at least " { $snippet "value" } " bits per pixel." } ;
+HELP: accum-red-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " red bits per pixel." } ;
+HELP: accum-green-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " green bits per pixel." } ;
+HELP: accum-blue-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
+HELP: accum-alpha-bits
+{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
+
+{ accum-bits accum-red-bits accum-green-bits accum-blue-bits accum-alpha-bits } related-words
+
+HELP: depth-bits
+{ $class-description "Requests a pixel format with a depth buffer of at least " { $snippet "value" } " bits per pixel." } ;
+
+HELP: stencil-bits
+{ $class-description "Requests a pixel format with a stencil buffer of at least " { $snippet "value" } " bits per pixel." } ;
+
+HELP: aux-buffers
+{ $class-description "Requests a pixel format with at least " { $snippet "value" } " auxiliary buffers." } ;
+
+HELP: sample-buffers
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request a pixel format with at least " { $snippet "value" } " sampling buffers." } ;
+
+HELP: samples
+{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request at least " { $snippet "value" } " samples per pixel." } ;
+
+{ multisampled supersampled sample-alpha sample-buffers samples } related-words
+
+HELP: world-pixel-format-attributes
+{ $values { "world" world } { "attributes" sequence } }
+{ $description "Returns the set of " { $link "ui.pixel-formats-attributes" } " that " { $snippet "world" } " requests when grafted. This generic can be overridden by subclasses of " { $snippet "world" } "." }
+{ $notes "The pixel format provided by the window system will not necessarily exactly match the requested attributes. To verify required pixel format attributes, override " { $link check-world-pixel-format } "." } ;
+
+HELP: check-world-pixel-format
+{ $values { "world" world } { "pixel-format" pixel-format } }
+{ $description "Verifies that " { $snippet "pixel-format" } " fulfills the requirements of " { $snippet "world" } ". The default method does nothing. Subclasses can override this generic to perform their own checks on the pixel format." } ;
+
+HELP: pixel-format
+{ $class-description "The type of pixel format objects. The tuple slot contents should be considered opaque by user code. To check the value of a pixel format's attributes, use the " { $link pixel-format-attribute } " word. Pixel format objects must be freed using the " { $link dispose } " word when they are no longer needed." } ;
+
+HELP: <pixel-format>
+{ $values { "world" world } { "attributes" sequence } { "pixel-format" pixel-format } }
+{ $description "Requests a pixel format suitable for " { $snippet "world" } " with a set of " { $link "ui.pixel-formats-attributes" } ". If no pixel format can be found that satisfies the given attributes, an " { $link invalid-pixel-format-attributes } " error is thrown. Pixel format attributes not supported by the window system are ignored. The returned " { $snippet "pixel-format" } " must be released using the " { $link dispose } " word when it is no longer needed." }
+{ $notes "Pixel formats don't normally need to be directly allocated by user code. If you need to control the pixel format requested by a window, subclass " { $snippet "world" } " and override the " { $link world-pixel-format-attributes } " and " { $link check-world-pixel-format } " words."
+$nl
+"The returned pixel format does not necessarily exactly match the requested attributes; the window system will try to find the format that best matches the given attributes. Use " { $link pixel-format-attribute } " to check the actual values of the attributes on the returned pixel format." }
+;
+
+HELP: pixel-format-attribute
+{ $values { "pixel-format" pixel-format } { "attribute-name" "one of the " { $link "ui.pixel-formats-attributes" } } { "value" object } }
+{ $description "Returns the value of the requested " { $snippet "attribute-name" } " in " { $snippet "pixel-format" } ". If " { "attribute-name" } " is unsupported by the window system, " { $link f } " is returned." } ;
+
+HELP: invalid-pixel-format-attributes
+{ $values { "world" world } { "attributes" sequence } }
+{ $class-description "Thrown by " { $link <pixel-format> } " when the window system is unable to find a pixel format for " { $snippet "world" } " that satisfies the requested " { $snippet "attributes" } "." } ;
+
+{ world-pixel-format-attributes check-world-pixel-format pixel-format <pixel-format> pixel-format-attribute }
+related-words
+
+ARTICLE: "ui.pixel-formats" "Pixel formats"
+"The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:"
+{ $subsection "ui.pixel-formats-attributes" }
+
+"Pixel formats can be requested using these attributes:"
+{ $subsection pixel-format }
+{ $subsection <pixel-format> }
+{ $subsection pixel-format-attribute }
+
+"If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:"
+{ $subsection invalid-pixel-format-attributes }
+
+"Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:"
+{ $subsection world-pixel-format-attributes }
+{ $subsection check-world-pixel-format }
+;
+
+ABOUT: "ui.pixel-formats"

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

@@ -0,0 +1,94 @@
+USING: accessors assocs classes destructors functors kernel
+lexer math parser sequences specialized-arrays.int ui.backend
+words.symbol ;
+IN: ui.pixel-formats
+
+SYMBOLS:
+    double-buffered
+    stereo
+    offscreen
+    fullscreen
+    windowed
+    accelerated
+    software-rendered
+    backing-store
+    multisampled
+    supersampled 
+    sample-alpha
+    color-float ;
+
+TUPLE: pixel-format-attribute { value integer } ;
+
+TUPLE: color-bits < pixel-format-attribute ;
+TUPLE: red-bits < pixel-format-attribute ;
+TUPLE: green-bits < pixel-format-attribute ;
+TUPLE: blue-bits < pixel-format-attribute ;
+TUPLE: alpha-bits < pixel-format-attribute ;
+
+TUPLE: accum-bits < pixel-format-attribute ;
+TUPLE: accum-red-bits < pixel-format-attribute ;
+TUPLE: accum-green-bits < pixel-format-attribute ;
+TUPLE: accum-blue-bits < pixel-format-attribute ;
+TUPLE: accum-alpha-bits < pixel-format-attribute ;
+
+TUPLE: depth-bits < pixel-format-attribute ;
+
+TUPLE: stencil-bits < pixel-format-attribute ;
+
+TUPLE: aux-buffers < pixel-format-attribute ;
+
+TUPLE: sample-buffers < pixel-format-attribute ;
+TUPLE: samples < pixel-format-attribute ;
+
+HOOK: (make-pixel-format) ui-backend ( world attributes -- pixel-format-handle )
+HOOK: (free-pixel-format) ui-backend ( pixel-format -- )
+HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value )
+
+ERROR: invalid-pixel-format-attributes world attributes ;
+
+TUPLE: pixel-format world handle ;
+
+: <pixel-format> ( world attributes -- pixel-format )
+    2dup (make-pixel-format)
+    [ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ;
+
+M: pixel-format dispose
+    [ (free-pixel-format) ] [ f >>handle drop ] bi ;
+
+: pixel-format-attribute ( pixel-format attribute-name -- value )
+    (pixel-format-attribute) ;
+
+<PRIVATE
+
+FUNCTOR: define-pixel-format-attribute-table ( NAME PERM TABLE -- )
+
+>PFA              DEFINES >${NAME}
+>PFA-int-array    DEFINES >${NAME}-int-array
+
+WHERE
+
+GENERIC: >PFA ( attribute -- pfas )
+
+M: object >PFA
+    drop { } ;
+M: symbol >PFA
+    TABLE at [ { } ] unless* ;
+M: pixel-format-attribute >PFA
+    dup class TABLE at
+    [ swap value>> suffix ]
+    [ drop { } ] if* ;
+
+: >PFA-int-array ( attribute -- int-array )
+    [ >PFA ] map concat PERM prepend 0 suffix >int-array ;
+
+;FUNCTOR
+
+SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE:
+    scan scan-object scan-object define-pixel-format-attribute-table ;
+
+PRIVATE>
+
+GENERIC: world-pixel-format-attributes ( world -- attributes )
+
+GENERIC# check-world-pixel-format 1 ( world pixel-format -- )
+

basis/ui/pixel-formats/summary.txt

@@ -0,0 +1 @@
+Cross-platform OpenGL context pixel format specifiers

basis/ui/text/text.factor

@@ -75,10 +75,8 @@ M: array draw-text
 
 USING: vocabs.loader namespaces system combinators ;
 
-"ui-backend" get [
+{
-    {
+    { [ os macosx? ] [ "core-text" ] }
-        { [ os macosx? ] [ "core-text" ] }
+    { [ os windows? ] [ "uniscribe" ] }
-        { [ os windows? ] [ "uniscribe" ] }
+    { [ os unix? ] [ "pango" ] }
-        { [ os unix? ] [ "pango" ] }
+} cond "ui.text." prepend require
-    } cond
-] unless* "ui.text." prepend require

basis/ui/tools/listener/listener-tests.factor

@@ -75,7 +75,7 @@ CONSTANT: text "Hello world.\nThis is a test."
 [ ] [
     [
         "interactor" get register-self
-        "interactor" get contents "promise" get fulfill
+        "interactor" get stream-contents "promise" get fulfill
     ] in-thread
 ] unit-test
 
@@ -150,4 +150,4 @@ CONSTANT: text "Hello world.\nThis is a test."
 
 [ ] [ <listener-gadget> "l" set ] unit-test
 [ ] [ "l" get com-scroll-up ] unit-test
-[ ] [ "l" get com-scroll-down ] unit-test
+[ ] [ "l" get com-scroll-down ] unit-test

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 ;
 
+: 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*
-    [ (open-window) ]
+    [ 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_SUCCESS
-    ERROR_IO_PENDING
+        ERROR_IO_INCOMPLETE
-    WAIT_TIMEOUT 4array ; foldable
+        ERROR_IO_PENDING
+        WAIT_TIMEOUT
+    }
 
 : expected-io-error? ( error-code -- ? )
     expected-io-errors member? ;

basis/windows/gdi32/gdi32.factor

@@ -1419,7 +1419,7 @@ DESTRUCTOR: DeleteDC
 ! FUNCTION: DeleteMetaFile
 FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
 DESTRUCTOR: DeleteObject
-! FUNCTION: DescribePixelFormat
+FUNCTION: int DescribePixelFormat ( HDC hdc, int iPixelFormat, UINT nBytes, PIXELFORMATDESCRIPTOR* ppfd ) ;
 ! FUNCTION: DeviceCapabilitiesExA
 ! FUNCTION: DeviceCapabilitiesExW
 ! FUNCTION: DPtoLP

basis/windows/opengl32/opengl32.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.syntax parser namespaces kernel
-math math.bitwise windows.types windows.types init assocs
+math math.bitwise windows.types init assocs splitting
-sequences libc ;
+sequences libc opengl.gl opengl.gl.extensions opengl.gl.windows ;
 IN: windows.opengl32
 
 ! PIXELFORMATDESCRIPTOR flags
@@ -71,22 +71,6 @@ CONSTANT: WGL_SWAP_UNDERLAY13     HEX: 10000000
 CONSTANT: WGL_SWAP_UNDERLAY14     HEX: 20000000
 CONSTANT: WGL_SWAP_UNDERLAY15     HEX: 40000000
 
-: windowed-pfd-dwFlags ( -- n )
-    { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ;
-: offscreen-pfd-dwFlags ( -- n )
-    { PFD_DRAW_TO_BITMAP PFD_SUPPORT_OPENGL } flags ;
-
-! TODO: compare to http://www.nullterminator.net/opengl32.html
-: make-pfd ( flags bits -- pfd )
-    "PIXELFORMATDESCRIPTOR" <c-object>
-    "PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
-    1 over set-PIXELFORMATDESCRIPTOR-nVersion
-    rot over set-PIXELFORMATDESCRIPTOR-dwFlags
-    PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
-    [ set-PIXELFORMATDESCRIPTOR-cColorBits ] keep
-    16 over set-PIXELFORMATDESCRIPTOR-cDepthBits
-    PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask ;
-
 
 LIBRARY: gl
 
@@ -100,5 +84,112 @@ LIBRARY: gl
 FUNCTION: HGLRC wglCreateContext ( HDC hDC ) ;
 FUNCTION: BOOL wglDeleteContext ( HGLRC hRC ) ;
 FUNCTION: BOOL wglMakeCurrent ( HDC hDC, HGLRC hglrc ) ;
-FUNCTION: HGLRC wglGetCurrentContext ( ) ;
+
-FUNCTION: void* wglGetProcAddress ( char* name ) ;
+! WGL_ARB_extensions_string extension
+
+GL-FUNCTION: char* wglGetExtensionsStringARB { } ( HDC hDC ) ;
+
+! WGL_ARB_pixel_format extension
+
+CONSTANT: WGL_NUMBER_PIXEL_FORMATS_ARB    HEX: 2000
+CONSTANT: WGL_DRAW_TO_WINDOW_ARB          HEX: 2001
+CONSTANT: WGL_DRAW_TO_BITMAP_ARB          HEX: 2002
+CONSTANT: WGL_ACCELERATION_ARB            HEX: 2003
+CONSTANT: WGL_NEED_PALETTE_ARB            HEX: 2004
+CONSTANT: WGL_NEED_SYSTEM_PALETTE_ARB     HEX: 2005
+CONSTANT: WGL_SWAP_LAYER_BUFFERS_ARB      HEX: 2006
+CONSTANT: WGL_SWAP_METHOD_ARB             HEX: 2007
+CONSTANT: WGL_NUMBER_OVERLAYS_ARB         HEX: 2008
+CONSTANT: WGL_NUMBER_UNDERLAYS_ARB        HEX: 2009
+CONSTANT: WGL_TRANSPARENT_ARB             HEX: 200A
+CONSTANT: WGL_TRANSPARENT_RED_VALUE_ARB   HEX: 2037
+CONSTANT: WGL_TRANSPARENT_GREEN_VALUE_ARB HEX: 2038
+CONSTANT: WGL_TRANSPARENT_BLUE_VALUE_ARB  HEX: 2039
+CONSTANT: WGL_TRANSPARENT_ALPHA_VALUE_ARB HEX: 203A
+CONSTANT: WGL_TRANSPARENT_INDEX_VALUE_ARB HEX: 203B
+CONSTANT: WGL_SHARE_DEPTH_ARB             HEX: 200C
+CONSTANT: WGL_SHARE_STENCIL_ARB           HEX: 200D
+CONSTANT: WGL_SHARE_ACCUM_ARB             HEX: 200E
+CONSTANT: WGL_SUPPORT_GDI_ARB             HEX: 200F
+CONSTANT: WGL_SUPPORT_OPENGL_ARB          HEX: 2010
+CONSTANT: WGL_DOUBLE_BUFFER_ARB           HEX: 2011
+CONSTANT: WGL_STEREO_ARB                  HEX: 2012
+CONSTANT: WGL_PIXEL_TYPE_ARB              HEX: 2013
+CONSTANT: WGL_COLOR_BITS_ARB              HEX: 2014
+CONSTANT: WGL_RED_BITS_ARB                HEX: 2015
+CONSTANT: WGL_RED_SHIFT_ARB               HEX: 2016
+CONSTANT: WGL_GREEN_BITS_ARB              HEX: 2017
+CONSTANT: WGL_GREEN_SHIFT_ARB             HEX: 2018
+CONSTANT: WGL_BLUE_BITS_ARB               HEX: 2019
+CONSTANT: WGL_BLUE_SHIFT_ARB              HEX: 201A
+CONSTANT: WGL_ALPHA_BITS_ARB              HEX: 201B
+CONSTANT: WGL_ALPHA_SHIFT_ARB             HEX: 201C
+CONSTANT: WGL_ACCUM_BITS_ARB              HEX: 201D
+CONSTANT: WGL_ACCUM_RED_BITS_ARB          HEX: 201E
+CONSTANT: WGL_ACCUM_GREEN_BITS_ARB        HEX: 201F
+CONSTANT: WGL_ACCUM_BLUE_BITS_ARB         HEX: 2020
+CONSTANT: WGL_ACCUM_ALPHA_BITS_ARB        HEX: 2021
+CONSTANT: WGL_DEPTH_BITS_ARB              HEX: 2022
+CONSTANT: WGL_STENCIL_BITS_ARB            HEX: 2023
+CONSTANT: WGL_AUX_BUFFERS_ARB             HEX: 2024
+
+CONSTANT: WGL_NO_ACCELERATION_ARB         HEX: 2025
+CONSTANT: WGL_GENERIC_ACCELERATION_ARB    HEX: 2026
+CONSTANT: WGL_FULL_ACCELERATION_ARB       HEX: 2027
+
+CONSTANT: WGL_SWAP_EXCHANGE_ARB           HEX: 2028
+CONSTANT: WGL_SWAP_COPY_ARB               HEX: 2029
+CONSTANT: WGL_SWAP_UNDEFINED_ARB          HEX: 202A
+
+CONSTANT: WGL_TYPE_RGBA_ARB               HEX: 202B
+CONSTANT: WGL_TYPE_COLORINDEX_ARB         HEX: 202C
+
+GL-FUNCTION: BOOL wglGetPixelFormatAttribivARB { } (
+        HDC hdc,
+        int iPixelFormat,
+        int iLayerPlane,
+        UINT nAttributes,
+        int* piAttributes,
+        int* piValues
+    ) ;
+
+GL-FUNCTION: BOOL wglGetPixelFormatAttribfvARB { } (
+        HDC hdc,
+        int iPixelFormat,
+        int iLayerPlane,
+        UINT nAttributes,
+        int* piAttributes,
+        FLOAT* pfValues
+    ) ;
+
+GL-FUNCTION: BOOL wglChoosePixelFormatARB { } (
+        HDC hdc,
+        int* piAttribIList,
+        FLOAT* pfAttribFList,
+        UINT nMaxFormats,
+        int* piFormats,
+        UINT* nNumFormats
+    ) ;
+
+! WGL_ARB_multisample extension
+
+CONSTANT: WGL_SAMPLE_BUFFERS_ARB HEX: 2041
+CONSTANT: WGL_SAMPLES_ARB        HEX: 2042
+
+! WGL_ARB_pixel_format_float extension
+
+CONSTANT: WGL_TYPE_RGBA_FLOAT_ARB HEX: 21A0
+
+! wgl extensions querying
+
+: has-wglGetExtensionsStringARB? ( -- ? )
+    "wglGetExtensionsStringARB" wglGetProcAddress >boolean ;
+
+: wgl-extensions ( hdc -- extensions )
+    has-wglGetExtensionsStringARB? [ wglGetExtensionsStringARB " " split ] [ drop { } ] if ;
+
+: has-wgl-extensions? ( hdc extensions -- ? )
+    swap wgl-extensions [ member? ] curry all? ;
+
+: has-wgl-pixel-format-extension? ( hdc -- ? )
+    { "WGL_ARB_pixel_format" } has-wgl-extensions? ;

basis/x11/glx/glx.factor

@@ -84,20 +84,17 @@ X-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
 ! GLX_ARB_get_proc_address extension
 X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
 
+! GLX_ARB_multisample
+CONSTANT: GLX_SAMPLE_BUFFERS 100000
+CONSTANT: GLX_SAMPLES 100001
+
+! GLX_ARB_fbconfig_float
+CONSTANT: GLX_RGBA_FLOAT_TYPE HEX: 20B9
+CONSTANT: GLX_RGBA_FLOAT_BIT  HEX: 0004
+
 ! GLX Events
 ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)
 
-: choose-visual ( flags -- XVisualInfo* )
-    [ dpy get scr get ] dip
-    [
-        %
-        GLX_RGBA ,
-        GLX_DEPTH_SIZE , 16 ,
-        0 ,
-    ] int-array{ } make
-    glXChooseVisual
-    [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
-
 : create-glx ( XVisualInfo* -- GLXContext )
     [ dpy get ] dip f 1 glXCreateContext
     [ "Failed to create GLX context" throw ] unless* ;

basis/x11/windows/windows.factor

@@ -53,11 +53,8 @@ IN: x11.windows
         dup
     ] dip auto-position ;
 
-: glx-window ( loc dim -- window glx )
+: glx-window ( loc dim visual -- window glx )
-    GLX_DOUBLEBUFFER 1array choose-visual
+    [ create-window ] [ create-glx ] bi ;
-    [ create-window ] keep
-    [ create-glx ] keep
-    XFree ;
 
 : create-pixmap ( dim visual -- pixmap )
     [ [ { 0 0 } swap ] dip create-window ] [
@@ -74,9 +71,8 @@ IN: x11.windows
 : create-glx-pixmap ( dim visual -- pixmap glx-pixmap )
     [ create-pixmap ] [ (create-glx-pixmap) ] bi ;
 
-: glx-pixmap ( dim -- glx pixmap glx-pixmap )
+: glx-pixmap ( dim visual -- glx pixmap glx-pixmap )
-    { } choose-visual
+    [ nip create-glx ] [ create-glx-pixmap ] 2bi ;
-    [ nip create-glx ] [ create-glx-pixmap ] [ nip XFree ] 2tri ;
 
 : destroy-window ( win -- )
     dpy get swap XDestroyWindow drop ;

basis/xmode/code2html/code2html.factor

@@ -24,7 +24,7 @@ IN: xmode.code2html
     [XML <style><-></style> XML] ;
 
 :: htmlize-stream ( path stream -- xml )
-    stream lines
+    stream stream-lines
     [ "" ] [ path over first find-mode htmlize-lines ]
     if-empty :> input
     default-stylesheet :> stylesheet

core/assocs/assocs.factor

@@ -32,7 +32,7 @@ M: assoc assoc-like drop ;
         3drop f
     ] [
         3dup nth-unsafe at*
-        [ [ 3drop ] dip ] [ drop [ 1- ] dip (assoc-stack) ] if
+        [ [ 3drop ] dip ] [ drop [ 1 - ] dip (assoc-stack) ] if
     ] if ; inline recursive
 
 : search-alist ( key alist -- pair/f i/f )
@@ -105,7 +105,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
     assoc-size 0 = ;
 
 : assoc-stack ( key seq -- value )
-    [ length 1- ] keep (assoc-stack) ; flushable
+    [ length 1 - ] keep (assoc-stack) ; flushable
 
 : assoc-subset? ( assoc1 assoc2 -- ? )
     [ at* [ = ] [ 2drop f ] if ] with-assoc assoc-all? ;

core/bootstrap/primitives.factor

@@ -515,4 +515,4 @@ tuple
 } [ [ first3 ] dip swap make-primitive ] each-index
 
 ! Bump build number
-"build" "kernel" create build 1+ [ ] curry (( -- n )) define-declared
+"build" "kernel" create build 1 + [ ] curry (( -- n )) define-declared

core/checksums/checksums.factor

@@ -13,7 +13,7 @@ GENERIC: checksum-stream ( stream checksum -- value )
 GENERIC: checksum-lines ( lines checksum -- value )
 
 M: checksum checksum-stream
-    [ contents ] dip checksum-bytes ;
+    [ stream-contents ] dip checksum-bytes ;
 
 M: checksum checksum-lines
     [ B{ CHAR: \n } join ] dip checksum-bytes ;

core/checksums/crc32/crc32.factor

@@ -9,7 +9,7 @@ CONSTANT: crc32-polynomial HEX: edb88320
 
 CONSTANT: crc32-table V{ }
 
-256 [
+256 iota [
     8 [
         [ 2/ ] [ even? ] bi [ crc32-polynomial bitxor ] unless
     ] times >bignum

core/classes/tuple/tuple-docs.factor

@@ -254,7 +254,7 @@ ARTICLE: "tuple-examples" "Tuple examples"
     "    } ;"
     ""
     ": next-position ( role -- newrole )"
-    "    positions [ index 1+ ] keep nth ;"
+    "    positions [ index 1 + ] keep nth ;"
     ""
     ": promote ( employee -- employee )"
     "    [ 1.2 * ] change-salary"

core/classes/tuple/tuple.factor

@@ -165,7 +165,7 @@ ERROR: bad-superclass class ;
         {
             [ , ]
             [ [ superclass class-size ] [ "slots" word-prop length ] bi + , ]
-            [ superclasses length 1- , ]
+            [ superclasses length 1 - , ]
             [ superclasses [ [ , ] [ hashcode , ] bi ] each ]
         } cleave
     ] { } make ;
@@ -331,7 +331,7 @@ GENERIC: tuple-hashcode ( n tuple -- x )
 
 M: tuple tuple-hashcode
     [
-        [ class hashcode ] [ tuple-size ] [ ] tri
+        [ class hashcode ] [ tuple-size iota ] [ ] tri
         [ rot ] dip [
             swapd array-nth hashcode* sequence-hashcode-step
         ] 2curry each

core/combinators/combinators.factor

@@ -123,7 +123,7 @@ ERROR: no-case object ;
     [ [ [ literalize ] dip ] assoc-map linear-case-quot ] with map ;
 
 : hash-dispatch-quot ( table -- quot )
-    [ length 1- [ fixnum-bitand ] curry ] keep
+    [ length 1 - [ fixnum-bitand ] curry ] keep
     [ dispatch ] curry append ;
 
 : hash-case-quot ( default assoc -- quot )
@@ -162,7 +162,7 @@ ERROR: no-case object ;
 
 ! recursive-hashcode
 : recursive-hashcode ( n obj quot -- code )
-    pick 0 <= [ 3drop 0 ] [ [ 1- ] 2dip call ] if ; inline
+    pick 0 <= [ 3drop 0 ] [ [ 1 - ] 2dip call ] if ; inline
 
 ! These go here, not in sequences and hashtables, since those
 ! two cannot depend on us

core/continuations/continuations-tests.factor

@@ -4,7 +4,7 @@ kernel.private accessors eval ;
 IN: continuations.tests
 
 : (callcc1-test) ( n obj -- n' obj )
-    [ 1- dup ] dip ?push
+    [ 1 - dup ] dip ?push
     over 0 = [ "test-cc" get continue-with ] when
     (callcc1-test) ;
 

core/generic/single/single.factor

@@ -178,7 +178,7 @@ M: echelon-dispatch-engine compile-engine
 M: tuple-dispatch-engine compile-engine
     tuple assumed [
         echelons>> compile-engines
-        dup keys supremum 1+ f <array>
+        dup keys supremum 1 + f <array>
         [ <enum> swap update ] keep
     ] with-variable ;
 
@@ -253,4 +253,4 @@ M: single-combination perform-combination
         [ mega-cache-quot define ]
         [ define-inline-cache-quot ]
         2tri
-    ] with-combination ;
+    ] with-combination ;

core/generic/standard/standard.factor

@@ -28,7 +28,7 @@ CONSTANT: simple-combination T{ standard-combination f 0 }
         { 0 [ [ dup ] ] }
         { 1 [ [ over ] ] }
         { 2 [ [ pick ] ] }
-        [ 1- (picker) [ dip swap ] curry ]
+        [ 1 - (picker) [ dip swap ] curry ]
     } case ;
 
 M: standard-combination picker

core/growable/growable.factor

@@ -35,7 +35,7 @@ M: growable set-length ( n seq -- )
     ] if
     (>>length) ;
 
-: new-size ( old -- new ) 1+ 3 * ; inline
+: new-size ( old -- new ) 1 + 3 * ; inline
 
 : ensure ( n seq -- n seq )
     growable-check

core/hashtables/hashtables.factor

@@ -34,7 +34,7 @@ TUPLE: hashtable
     [ no-key ] [ 2dup hash@ (key@) ] if ; inline
 
 : <hash-array> ( n -- array )
-    1+ next-power-of-2 4 * ((empty)) <array> ; inline
+    1 + next-power-of-2 4 * ((empty)) <array> ; inline
 
 : init-hash ( hash -- )
     0 >>count 0 >>deleted drop ; inline
@@ -61,10 +61,10 @@ TUPLE: hashtable
     1 fixnum+fast set-slot ; inline
 
 : hash-count+ ( hash -- )
-    [ 1+ ] change-count drop ; inline
+    [ 1 + ] change-count drop ; inline
 
 : hash-deleted+ ( hash -- )
-    [ 1+ ] change-deleted drop ; inline
+    [ 1 + ] change-deleted drop ; inline
 
 : (rehash) ( hash alist -- )
     swap [ swapd set-at ] curry assoc-each ; inline
@@ -77,7 +77,7 @@ TUPLE: hashtable
     [ deleted>> 10 fixnum*fast ] [ count>> ] bi fixnum> ; inline
 
 : grow-hash ( hash -- )
-    [ [ >alist ] [ assoc-size 1+ ] bi ] keep
+    [ [ >alist ] [ assoc-size 1 + ] bi ] keep
     [ reset-hash ] keep
     swap (rehash) ;
 
@@ -139,7 +139,7 @@ M: hashtable set-at ( value key hash -- )
 PRIVATE>
 
 M: hashtable >alist
-    [ array>> [ length 2/ ] keep ] [ assoc-size <vector> ] bi [
+    [ array>> [ length 2/ iota ] keep ] [ assoc-size <vector> ] bi [
         [
             [
                 [ 1 fixnum-shift-fast ] dip

core/io/files/files.factor

@@ -21,13 +21,13 @@ HOOK: (file-appender) io-backend ( path -- stream )
     swap normalize-path (file-appender) swap <encoder> ;
 
 : file-lines ( path encoding -- seq )
-    <file-reader> lines ;
+    <file-reader> stream-lines ;
 
 : with-file-reader ( path encoding quot -- )
     [ <file-reader> ] dip with-input-stream ; inline
 
 : file-contents ( path encoding -- seq )
-    <file-reader> contents ;
+    <file-reader> stream-contents ;
 
 : with-file-writer ( path encoding quot -- )
     [ <file-writer> ] dip with-output-stream ; inline

core/io/io-docs.factor

@@ -221,10 +221,14 @@ HELP: bl
 { $description "Outputs a space character (" { $snippet "\" \"" } ") to " { $link output-stream } "." }
 $io-error ;
 
-HELP: lines
+HELP: stream-lines
 { $values { "stream" "an input stream" } { "seq" "a sequence of strings" } }
 { $description "Reads lines of text until the stream is exhausted, collecting them in a sequence of strings." } ;
 
+HELP: lines
+{ $values { "seq" "a sequence of strings" } }
+{ $description "Reads lines of text until from the " { $link input-stream } " until it is exhausted, collecting them in a sequence of strings." } ;
+
 HELP: each-line
 { $values { "quot" { $quotation "( str -- )" } } }
 { $description "Calls the quotation with successive lines of text, until the current " { $link input-stream } " is exhausted." } ;
@@ -233,9 +237,14 @@ HELP: each-block
 { $values { "quot" { $quotation "( block -- )" } } }
 { $description "Calls the quotation with successive blocks of data, until the current " { $link input-stream } " is exhausted." } ;
 
-HELP: contents
+HELP: stream-contents
 { $values { "stream" "an input stream" } { "seq" "a string, byte array or " { $link f } } }
-{ $description "Reads the entire contents of a stream. If the stream is empty, outputs"  { $link f } "." }
+{ $description "Reads the entire contents of a stream. If the stream is empty, outputs "  { $link f } "." }
+$io-error ;
+
+HELP: contents
+{ $values { "seq" "a string, byte array or " { $link f } } }
+{ $description "Reads the entire contents of a the stream stored in " { $link input-stream } ". If the stream is empty, outputs " { $link f } "." }
 $io-error ;
 
 ARTICLE: "stream-protocol" "Stream protocol"
@@ -347,9 +356,11 @@ $nl
 "First, a simple composition of " { $link stream-write } " and " { $link stream-nl } ":"
 { $subsection stream-print }
 "Processing lines one by one:"
+{ $subsection stream-lines }
 { $subsection lines }
 { $subsection each-line }
 "Processing blocks of data:"
+{ $subsection stream-contents }
 { $subsection contents }
 { $subsection each-block }
 "Copying the contents of one stream to another:"

core/io/io.factor

@@ -68,9 +68,12 @@ SYMBOL: error-stream
 
 : bl ( -- ) " " write ;
 
-: lines ( stream -- seq )
+: stream-lines ( stream -- seq )
     [ [ readln dup ] [ ] produce nip ] with-input-stream ;
 
+: lines ( -- seq )
+    input-stream get stream-lines ;
+
 <PRIVATE
 
 : each-morsel ( handler: ( data -- ) reader: ( -- data ) -- )
@@ -81,11 +84,14 @@ PRIVATE>
 : each-line ( quot -- )
     [ readln ] each-morsel ; inline
 
-: contents ( stream -- seq )
+: stream-contents ( stream -- seq )
     [
         [ 65536 read-partial dup ] [ ] produce nip concat f like
     ] with-input-stream ;
 
+: contents ( -- seq )
+    input-stream get stream-contents ;
+
 : each-block ( quot: ( block -- ) -- )
     [ 8192 read-partial ] each-morsel ; inline
 

core/io/pathnames/pathnames.factor

@@ -17,7 +17,7 @@ SYMBOL: current-directory
     [ path-separator? ] trim-head ;
 
 : last-path-separator ( path -- n ? )
-    [ length 1- ] keep [ path-separator? ] find-last-from ;
+    [ length 1 - ] keep [ path-separator? ] find-last-from ;
 
 HOOK: root-directory? io-backend ( path -- ? )
 
@@ -30,7 +30,7 @@ ERROR: no-parent-directory path ;
     dup root-directory? [
         trim-tail-separators
         dup last-path-separator [
-            1+ cut
+            1 + cut
         ] [
             drop "." swap
         ] if
@@ -113,7 +113,7 @@ PRIVATE>
 : file-name ( path -- string )
     dup root-directory? [
         trim-tail-separators
-        dup last-path-separator [ 1+ tail ] [
+        dup last-path-separator [ 1 + tail ] [
             drop special-path? [ file-name ] when
         ] if
     ] unless ;

core/io/streams/byte-array/byte-array-tests.factor

@@ -6,7 +6,7 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
 
 [ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
 [ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } >string utf8 [ write ] with-byte-writer ] unit-test
-[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> stream-contents dup >array swap string? ] unit-test
 
 [ B{ 121 120 } 0 ] [
     B{ 0 121 120 0 0 0 0 0 0 } binary
@@ -26,4 +26,4 @@ io.encodings.utf8 io kernel arrays strings namespaces ;
         0 seek-end input-stream get stream-seek
         read1
     ] with-byte-reader
-] unit-test
+] unit-test

core/io/streams/c/c-tests.factor

@@ -5,6 +5,6 @@ IN: io.streams.c.tests
 [ "hello world" ] [
     "hello world" "test.txt" temp-file ascii set-file-contents
 
-    "test.txt" temp-file "rb" fopen <c-reader> contents
+    "test.txt" temp-file "rb" fopen <c-reader> stream-contents
     >string
 ] unit-test

core/io/streams/sequence/sequence.factor

@@ -12,7 +12,7 @@ SLOT: i
     [ i>> ] [ underlying>> ] bi ; inline
 
 : next ( stream -- )
-    [ 1+ ] change-i drop ; inline
+    [ 1 + ] change-i drop ; inline
 
 : sequence-read1 ( stream -- elt/f )
     [ >sequence-stream< ?nth ] [ next ] bi ; inline
@@ -45,4 +45,4 @@ M: growable stream-write1 push ;
 M: growable stream-write push-all ;
 M: growable stream-flush drop ;
 
-INSTANCE: growable plain-writer
+INSTANCE: growable plain-writer

core/kernel/kernel-tests.factor

@@ -114,7 +114,7 @@ IN: kernel.tests
 ! Regression
 : (loop) ( a b c d -- )
     [ pick ] dip swap [ pick ] dip swap
-    < [ [ 1+ ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
+    < [ [ 1 + ] 3dip (loop) ] [ 2drop 2drop ] if ; inline recursive
 
 : loop ( obj -- )
     H{ } values swap [ dup length swap ] dip 0 -roll (loop) ;

core/layouts/layouts.factor

@@ -49,13 +49,13 @@ SYMBOL: mega-cache-size
     cell-bits (first-bignum) ; inline
 
 : most-positive-fixnum ( -- n )
-    first-bignum 1- ; inline
+    first-bignum 1 - ; inline
 
 : most-negative-fixnum ( -- n )
     first-bignum neg ; inline
 
 : (max-array-capacity) ( b -- n )
-    5 - 2^ 1- ; inline
+    5 - 2^ 1 - ; inline
 
 : max-array-capacity ( -- n )
     cell-bits (max-array-capacity) ; inline
@@ -64,7 +64,7 @@ SYMBOL: mega-cache-size
     bootstrap-cell-bits (first-bignum) ;
 
 : bootstrap-most-positive-fixnum ( -- n )
-    bootstrap-first-bignum 1- ;
+    bootstrap-first-bignum 1 - ;
 
 : bootstrap-most-negative-fixnum ( -- n )
     bootstrap-first-bignum neg ;

core/lexer/lexer.factor

@@ -9,7 +9,7 @@ TUPLE: lexer text line line-text line-length column ;
 : next-line ( lexer -- )
     dup [ line>> ] [ text>> ] bi ?nth >>line-text
     dup line-text>> length >>line-length
-    [ 1+ ] change-line
+    [ 1 + ] change-line
     0 >>column
     drop ;
 
@@ -39,7 +39,7 @@ GENERIC: skip-word ( lexer -- )
 
 M: lexer skip-word ( lexer -- )
     [
-        2dup nth CHAR: " eq? [ drop 1+ ] [ f skip ] if
+        2dup nth CHAR: " eq? [ drop 1 + ] [ f skip ] if
     ] change-lexer-column ;
 
 : still-parsing? ( lexer -- ? )

core/math/floats/floats-tests.factor

@@ -50,8 +50,8 @@ IN: math.floats.tests
 [ BIN: 11111111111000000000000000000000000000000000000000000000000000 bits>double ]
 unit-test
 
-[ 2.0 ] [ 1.0 1+ ] unit-test
+[ 2.0 ] [ 1.0 1 + ] unit-test
-[ 0.0 ] [ 1.0 1- ] unit-test
+[ 0.0 ] [ 1.0 1 - ] unit-test
 
 [ t ] [ 0.0 zero? ] unit-test
 [ t ] [ -0.0 zero? ] unit-test

core/math/integers/integers-tests.factor

@@ -206,8 +206,8 @@ unit-test
 [ 2. ] [ 2 1 ratio>float ] unit-test
 [ .5 ] [ 1 2 ratio>float ] unit-test
 [ .75 ] [ 3 4 ratio>float ] unit-test
-[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
+[ 1. ] [ 2000 2^ 2000 2^ 1 + ratio>float ] unit-test
-[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
+[ -1. ] [ 2000 2^ neg 2000 2^ 1 + ratio>float ] unit-test
 [ 0.4 ] [ 6 15 ratio>float ] unit-test
 
 [ HEX: 3fe553522d230931 ]

core/math/integers/integers.factor

@@ -41,7 +41,7 @@ M: fixnum bitnot fixnum-bitnot ;
 M: fixnum bit? neg shift 1 bitand 0 > ;
 
 : fixnum-log2 ( x -- n )
-    0 swap [ dup 1 eq? ] [ [ 1+ ] [ 2/ ] bi* ] until drop ;
+    0 swap [ dup 1 eq? ] [ [ 1 + ] [ 2/ ] bi* ] until drop ;
 
 M: fixnum (log2) fixnum-log2 ;
 
@@ -86,7 +86,7 @@ M: bignum (log2) bignum-log2 ;
 ! provided with absolutely no warranty."
 
 ! First step: pre-scaling
-: twos ( x -- y ) dup 1- bitxor log2 ; inline
+: twos ( x -- y ) dup 1 - bitxor log2 ; inline
 
 : scale-denonimator ( den -- scaled-den scale' )
     dup twos neg [ shift ] keep ; inline
@@ -98,7 +98,7 @@ M: bignum (log2) bignum-log2 ;
 
 ! Second step: loop
 : shift-mantissa ( scale mantissa -- scale' mantissa' )
-    [ 1+ ] [ 2/ ] bi* ; inline
+    [ 1 + ] [ 2/ ] bi* ; inline
 
 : /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
     [ 2dup /i log2 53 > ]
@@ -107,7 +107,7 @@ M: bignum (log2) bignum-log2 ;
 
 ! Third step: post-scaling
 : unscaled-float ( mantissa -- n )
-    52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
+    52 2^ 1 - bitand 1022 52 shift bitor bits>double ; inline
 
 : scale-float ( scale mantissa -- float' )
     [ dup 0 < [ neg 2^ recip ] [ 2^ ] if ] dip * ; inline
@@ -126,7 +126,7 @@ M: bignum (log2) bignum-log2 ;
         ] [
             pre-scale
             /f-loop over odd?
-            [ zero? [ 1+ ] unless ] [ drop ] if
+            [ zero? [ 1 + ] unless ] [ drop ] if
             post-scale
         ] if
     ] if ; inline

core/math/math.factor

@@ -63,7 +63,7 @@ PRIVATE>
 : neg ( x -- -x ) 0 swap - ; inline
 : recip ( x -- y ) 1 swap / ; inline
 : sgn ( x -- n ) dup 0 < [ drop -1 ] [ 0 > 1 0 ? ] if ; inline
-: ?1+ ( x -- y ) [ 1+ ] [ 0 ] if* ; inline
+: ?1+ ( x -- y ) [ 1 + ] [ 0 ] if* ; inline
 : rem ( x y -- z ) abs [ mod ] [ + ] [ mod ] tri ; foldable
 : 2^ ( n -- 2^n ) 1 swap shift ; inline
 : even? ( n -- ? ) 1 bitand zero? ;
@@ -103,13 +103,13 @@ M: float fp-infinity? ( float -- ? )
     ] if ;
 
 : next-power-of-2 ( m -- n )
-    dup 2 <= [ drop 2 ] [ 1- log2 1+ 2^ ] if ; inline
+    dup 2 <= [ drop 2 ] [ 1 - log2 1 + 2^ ] if ; inline
 
 : power-of-2? ( n -- ? )
-    dup 0 <= [ drop f ] [ dup 1- bitand zero? ] if ; foldable
+    dup 0 <= [ drop f ] [ dup 1 - bitand zero? ] if ; foldable
 
 : align ( m w -- n )
-    1- [ + ] keep bitnot bitand ; inline
+    1 - [ + ] keep bitnot bitand ; inline
 
 <PRIVATE
 
@@ -121,7 +121,7 @@ M: float fp-infinity? ( float -- ? )
     #! Apply quot to i, keep i and quot, hide n.
     [ nip call ] 3keep ; inline
 
-: iterate-next ( i n quot -- i' n quot ) [ 1+ ] 2dip ; inline
+: iterate-next ( i n quot -- i' n quot ) [ 1 + ] 2dip ; inline
 
 PRIVATE>
 
@@ -160,6 +160,6 @@ PRIVATE>
         [ call ] 2keep rot [
             drop
         ] [
-            [ 1- ] dip find-last-integer
+            [ 1 - ] dip find-last-integer
         ] if
     ] if ; inline recursive

core/namespaces/namespaces.factor

@@ -29,8 +29,8 @@ PRIVATE>
 : inc ( variable -- ) 1 swap +@ ; inline
 : dec ( variable -- ) -1 swap +@ ; inline
 : bind ( ns quot -- ) swap >n call ndrop ; inline
-: counter ( variable -- n ) [ 0 or 1+ dup ] change-global ;
+: counter ( variable -- n ) [ 0 or 1 + dup ] change-global ;
 : make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
 : with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
 : with-variable ( value key quot -- ) [ associate ] dip bind ; inline
-: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline
+: initialize ( variable quot -- ) [ unless* ] curry change-global ; inline

core/parser/parser.factor

@@ -272,7 +272,7 @@ print-use-hook [ [ ] ] initialize
 : parse-stream ( stream name -- quot )
     [
         [
-            lines dup parse-fresh
+            stream-lines dup parse-fresh
             [ nip ] [ finish-parsing ] 2bi
             forget-smudged
         ] with-source-file

core/quotations/quotations.factor

@@ -48,12 +48,12 @@ M: object literalize ;
 
 M: wrapper literalize <wrapper> ;
 
-M: curry length quot>> length 1+ ;
+M: curry length quot>> length 1 + ;
 
 M: curry nth
     over 0 =
     [ nip obj>> literalize ]
-    [ [ 1- ] dip quot>> nth ]
+    [ [ 1 - ] dip quot>> nth ]
     if ;
 
 INSTANCE: curry immutable-sequence

core/sequences/sequences.factor

@@ -198,7 +198,7 @@ C: <reversed> reversed
 
 M: reversed virtual-seq seq>> ;
 
-M: reversed virtual@ seq>> [ length swap - 1- ] keep ;
+M: reversed virtual@ seq>> [ length swap - 1 - ] keep ;
 
 M: reversed length seq>> length ;
 
@@ -276,7 +276,7 @@ INSTANCE: repetition immutable-sequence
     ] 3keep ; inline
 
 : (copy) ( dst i src j n -- dst )
-    dup 0 <= [ 2drop 2drop ] [ 1- ((copy)) (copy) ] if ;
+    dup 0 <= [ 2drop 2drop ] [ 1 - ((copy)) (copy) ] if ;
     inline recursive
 
 : prepare-subseq ( from to seq -- dst i src j n )
@@ -460,7 +460,7 @@ PRIVATE>
     [ nip find-last-integer ] (find-from) ; inline
 
 : find-last ( seq quot -- i elt )
-    [ [ 1- ] dip find-last-integer ] (find) ; inline
+    [ [ 1 - ] dip find-last-integer ] (find) ; inline
 
 : all? ( seq quot -- ? )
     (each) all-integers? ; inline
@@ -556,7 +556,7 @@ PRIVATE>
     [ empty? not ] filter ;
 
 : mismatch ( seq1 seq2 -- i )
-    [ min-length ] 2keep
+    [ min-length iota ] 2keep
     [ 2nth-unsafe = not ] 2curry
     find drop ; inline
 
@@ -595,8 +595,8 @@ M: slice equal? over slice? [ sequence= ] [ 2drop f ] if ;
 : (filter-here) ( quot: ( elt -- ? ) store scan seq -- )
     2dup length < [
         [ move ] 3keep
-        [ nth-unsafe pick call [ 1+ ] when ] 2keep
+        [ nth-unsafe pick call [ 1 + ] when ] 2keep
-        [ 1+ ] dip
+        [ 1 + ] dip
         (filter-here)
     ] [ nip set-length drop ] if ; inline recursive
 
@@ -612,20 +612,20 @@ PRIVATE>
     [ eq? not ] with filter-here ;
 
 : prefix ( seq elt -- newseq )
-    over [ over length 1+ ] dip [
+    over [ over length 1 + ] dip [
         [ 0 swap set-nth-unsafe ] keep
         [ 1 swap copy ] keep
     ] new-like ;
 
 : suffix ( seq elt -- newseq )
-    over [ over length 1+ ] dip [
+    over [ over length 1 + ] dip [
         [ [ over length ] dip set-nth-unsafe ] keep
         [ 0 swap copy ] keep
     ] new-like ;
 
-: peek ( seq -- elt ) [ length 1- ] [ nth ] bi ;
+: peek ( seq -- elt ) [ length 1 - ] [ nth ] bi ;
 
-: pop* ( seq -- ) [ length 1- ] [ shorten ] bi ;
+: pop* ( seq -- ) [ length 1 - ] [ shorten ] bi ;
 
 <PRIVATE
 
@@ -633,7 +633,7 @@ PRIVATE>
     2over = [
         2drop 2drop
     ] [
-        [ [ 2over + pick ] dip move [ 1+ ] dip ] keep
+        [ [ 2over + pick ] dip move [ 1 + ] dip ] keep
         move-backward
     ] if ;
 
@@ -641,13 +641,13 @@ PRIVATE>
     2over = [
         2drop 2drop
     ] [
-        [ [ pick [ dup dup ] dip + swap ] dip move 1- ] keep
+        [ [ pick [ dup dup ] dip + swap ] dip move 1 - ] keep
         move-forward
     ] if ;
 
 : (open-slice) ( shift from to seq ? -- )
     [
-        [ [ 1- ] bi@ ] dip move-forward
+        [ [ 1 - ] bi@ ] dip move-forward
     ] [
         [ over - ] 2dip move-backward
     ] if ;
@@ -667,7 +667,7 @@ PRIVATE>
     check-slice [ over [ - ] dip ] dip open-slice ;
 
 : delete-nth ( n seq -- )
-    [ dup 1+ ] dip delete-slice ;
+    [ dup 1 + ] dip delete-slice ;
 
 : snip ( from to seq -- head tail )
     [ swap head ] [ swap tail ] bi-curry bi* ; inline
@@ -679,10 +679,10 @@ PRIVATE>
     snip-slice surround ;
 
 : remove-nth ( n seq -- seq' )
-    [ [ { } ] dip dup 1+ ] dip replace-slice ;
+    [ [ { } ] dip dup 1 + ] dip replace-slice ;
 
 : pop ( seq -- elt )
-    [ length 1- ] [ [ nth ] [ shorten ] 2bi ] bi ;
+    [ length 1 - ] [ [ nth ] [ shorten ] 2bi ] bi ;
 
 : exchange ( m n seq -- )
     [ nip bounds-check 2drop ]
@@ -692,7 +692,7 @@ PRIVATE>
 
 : reverse-here ( seq -- )
     [ length 2/ ] [ length ] [ ] tri
-    [ [ over - 1- ] dip exchange-unsafe ] 2curry each ;
+    [ [ over - 1 - ] dip exchange-unsafe ] 2curry each ;
 
 : reverse ( seq -- newseq )
     [
@@ -799,7 +799,7 @@ PRIVATE>
 PRIVATE>
 
 : start* ( subseq seq n -- i )
-    pick length pick length swap - 1+
+    pick length pick length swap - 1 +
     [ (start) ] find-from
     swap [ 3drop ] dip ;
 

core/sorting/sorting.factor

@@ -29,13 +29,13 @@ TUPLE: merge
     [ [ [ 2drop ] dip nth-unsafe ] dip push ] [
         pick 2 = [
             [
-                [ 2drop dup 1+ ] dip
+                [ 2drop dup 1 + ] dip
                 [ nth-unsafe ] curry bi@
             ] dip [ push ] curry bi@
         ] [
             pick 3 = [
                 [
-                    [ 2drop dup 1+ dup 1+ ] dip
+                    [ 2drop dup 1 + dup 1 + ] dip
                     [ nth-unsafe ] curry tri@
                 ] dip [ push ] curry tri@
             ] [ [ nip subseq ] dip push-all ] if
@@ -57,10 +57,10 @@ TUPLE: merge
     [ [ from2>> ] [ to2>> ] [ seq>> ] tri ] [ accum>> ] bi dump ; inline
 
 : l-next ( merge -- )
-    [ [ l-elt ] [ [ 1+ ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
+    [ [ l-elt ] [ [ 1 + ] change-from1 drop ] bi ] [ accum>> ] bi push ; inline
 
 : r-next ( merge -- )
-    [ [ r-elt ] [ [ 1+ ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
+    [ [ r-elt ] [ [ 1 + ] change-from2 drop ] bi ] [ accum>> ] bi push ; inline
 
 : decide ( merge -- ? )
     [ [ l-elt ] [ r-elt ] bi ] dip call +gt+ eq? ; inline
@@ -129,8 +129,8 @@ TUPLE: merge
     while 2drop ; inline
 
 : each-pair ( seq quot -- )
-    [ [ length 1+ 2/ ] keep ] dip
+    [ [ length 1 + 2/ ] keep ] dip
-    [ [ 1 shift dup 1+ ] dip ] prepose curry each-integer ; inline
+    [ [ 1 shift dup 1 + ] dip ] prepose curry each-integer ; inline
 
 : (sort-pairs) ( i1 i2 seq quot accum -- )
     [ 2dup length = ] 2dip rot [

core/splitting/splitting.factor

@@ -55,7 +55,7 @@ PRIVATE>
 
 : (split) ( separators n seq -- )
     3dup rot [ member? ] curry find-from drop
-    [ [ swap subseq , ] 2keep 1+ swap (split) ]
+    [ [ swap subseq , ] 2keep 1 + swap (split) ]
     [ swap dup zero? [ drop ] [ tail ] if , drop ] if* ; inline recursive
 
 : split, ( seq separators -- ) 0 rot (split) ;

core/syntax/syntax-docs.factor

@@ -749,7 +749,7 @@ HELP: <PRIVATE
         "<PRIVATE"
         ""
         ": (fac) ( accum n -- n! )"
-        "    dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+        "    dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
         ""
         "PRIVATE>"
         ""
@@ -760,7 +760,7 @@ HELP: <PRIVATE
         "IN: factorial.private"
         ""
         ": (fac) ( accum n -- n! )"
-        "    dup 1 <= [ drop ] [ [ * ] keep 1- (fac) ] if ;"
+        "    dup 1 <= [ drop ] [ [ * ] keep 1 - (fac) ] if ;"
         ""
         "IN: factorial"
         ""

extra/bson/authors.txt

@@ -0,0 +1 @@
+Sascha Matzke

extra/bson/constants/authors.txt

@@ -0,0 +1 @@
+Sascha Matzke

extra/bson/constants/summary.txt

@@ -0,0 +1 @@
+Shared constants and classes

extra/bson/reader/authors.txt

@@ -0,0 +1 @@
+Sascha Matzke

extra/bson/reader/summary.txt

@@ -0,0 +1 @@
+BSON to Factor deserializer

extra/bson/summary.txt

@@ -0,0 +1 @@
+BSON reader and writer

extra/bson/writer/authors.txt

@@ -0,0 +1 @@
+Sascha Matzke

extra/bson/writer/summary.txt

@@ -0,0 +1 @@
+Factor to BSON serializer

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/contributors/contributors.factor

@@ -7,7 +7,7 @@ IN: contributors
 
 : changelog ( -- authors )
     image parent-directory [
-        "git log --pretty=format:%an" ascii <process-reader> lines
+        "git log --pretty=format:%an" ascii <process-reader> stream-lines
     ] with-directory ;
 
 : patch-counts ( authors -- assoc )

extra/file-trees/file-trees-tests.factor

@@ -0,0 +1,4 @@
+USING: kernel file-trees ;
+IN: file-trees.tests
+{ "/sample/1" "/sample/2" "/killer/1" "/killer/2/3"
+"/killer/2/4" "/killer/2/4/6" "/megakiller" } create-tree drop

extra/file-trees/file-trees.factor

@@ -0,0 +1,28 @@
+USING: accessors arrays delegate delegate.protocols
+io.pathnames kernel locals namespaces prettyprint sequences
+ui.frp vectors ;
+IN: file-trees
+
+TUPLE: tree node children ;
+CONSULT: sequence-protocol tree children>> ;
+
+: <tree> ( start -- tree ) V{ } clone
+   [ tree boa dup children>> ] [ ".." swap tree boa ] bi swap push ;
+
+DEFER: (tree-insert)
+
+: tree-insert ( path tree -- ) [ unclip <tree> ] [ children>> ] bi* (tree-insert) ;
+:: (tree-insert) ( path-rest path-head tree-children -- )
+   tree-children [ node>> path-head node>> = ] find nip
+   [ path-rest swap tree-insert ]
+   [ 
+      path-head tree-children push
+      path-rest [ path-head tree-insert ] unless-empty
+   ] 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/irc/gitbot/gitbot.factor

@@ -33,7 +33,7 @@ M: object handle-message drop ;
         "--pretty=format:%h %an: %s" ,
         ".." glue ,
     ] { } make
-    latin1 [ input-stream get lines ] with-process-reader ;
+    latin1 [ lines ] with-process-reader ;
 
 : updates ( from to -- lines )
     git-log reverse

extra/mason/common/common.factor

@@ -16,7 +16,7 @@ M: output-process-error error.
 
 : try-output-process ( command -- )
     >process +stdout+ >>stderr utf8 <process-reader*>
-    [ contents ] [ dup wait-for-process ] bi*
+    [ stream-contents ] [ dup wait-for-process ] bi*
     0 = [ 2drop ] [ output-process-error ] if ;
 
 HOOK: really-delete-tree os ( path -- )

extra/mongodb/authors.txt

@@ -0,0 +1 @@
+Sascha Matzke

extra/mongodb/benchmark/authors.txt

@@ -0,0 +1 @@
+Sascha Matzke

extra/mongodb/benchmark/summary.txt

@@ -0,0 +1 @@
+serialization/deserialization and insert/query benchmarks for mongodb.driver