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

basis/bitstreams/bitstreams-tests.factor

@@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary
 io.streams.byte-array ;
 IN: bitstreams.tests
 
-[ 1 t ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
 
-[ 254 8 t ]
+[ BIN: 1111111111 ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
-
-[ 4095 12 t ]
-[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
-
-[ B{ 254 } ]
 [
-    binary <byte-writer> <bitstream-writer> 254 8 rot
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
-    [ write-bits ] keep stream>> >byte-array
+    2 >>byte-pos 6 >>bit-pos
+    10 swap peek
 ] unit-test
 
-[ 255 8 t ]
+[ BIN: 111111111 ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    9 swap peek
+] unit-test
 
-[ 255 8 f ]
+[ BIN: 11111111 ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    8 swap peek
+] unit-test
+
+[ BIN: 1111111 ]
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    7 swap peek
+] unit-test
+
+[ BIN: 111111 ]
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    6 swap peek
+] unit-test
+
+[ BIN: 11111 ]
+[
+    B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+    2 >>byte-pos 6 >>bit-pos
+    5 swap peek
+] unit-test
+
+[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
+
+[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test

basis/bitstreams/bitstreams.factor

@@ -1,96 +1,160 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays destructors fry io kernel locals
+USING: accessors alien.accessors assocs byte-arrays combinators
-math sequences ;
+constructors destructors fry io io.binary io.encodings.binary
+io.streams.byte-array kernel locals macros math math.ranges
+multiline sequences sequences.private vectors byte-vectors
+combinators.short-circuit math.bitwise ;
 IN: bitstreams
 
-TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
+TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
-TUPLE: bitstream-reader < bitstream ;
 
-: reset-bitstream ( stream -- stream )
+ERROR: invalid-widthed bits #bits ;
-    0 >>#bits 0 >>current-bits ; inline
 
-: new-bitstream ( stream class -- bitstream )
+: check-widthed ( bits #bits -- bits #bits )
+    dup 0 < [ invalid-widthed ] when
+    2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when
+    over 0 = [
+        2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when
+    ] unless ;
+
+: <widthed> ( bits #bits -- widthed )
+    check-widthed
+    widthed boa ;
+
+: zero-widthed ( -- widthed ) 0 0 <widthed> ;
+: zero-widthed? ( widthed -- ? ) zero-widthed = ;
+
+TUPLE: bit-reader
+    { bytes byte-array }
+    { byte-pos array-capacity initial: 0 }
+    { bit-pos array-capacity initial: 0 } ;
+
+TUPLE: bit-writer
+    { bytes byte-vector }
+    { widthed widthed } ;
+
+TUPLE: msb0-bit-reader < bit-reader ;
+TUPLE: lsb0-bit-reader < bit-reader ;
+CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
+CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+TUPLE: msb0-bit-writer < bit-writer ;
+TUPLE: lsb0-bit-writer < bit-writer ;
+
+: new-bit-writer ( class -- bs )
     new
-        swap >>stream
+        BV{ } clone >>bytes
-        reset-bitstream ; inline
+        0 0 <widthed> >>widthed ; inline
 
-M: bitstream-reader dispose ( stream -- )
+: <msb0-bit-writer> ( -- bs )
-    stream>> dispose ;
+    msb0-bit-writer new-bit-writer ;
 
-: <bitstream-reader> ( stream -- bitstream )
+: <lsb0-bit-writer> ( -- bs )
-    bitstream-reader new-bitstream ; inline
+    lsb0-bit-writer new-bit-writer ;
 
-: read-next-byte ( bitstream -- bitstream )
+GENERIC: peek ( n bitstream -- value )
-    dup stream>> stream-read1 [
+GENERIC: poke ( value n bitstream -- )
-        >>current-bits 8 >>#bits
+
+: seek ( n bitstream -- )
+    {
+        [ byte-pos>> 8 * ]
+        [ bit-pos>> + + 8 /mod ]
+        [ (>>bit-pos) ]
+        [ (>>byte-pos) ]
+    } cleave ; inline
+
+: read ( n bitstream -- value )
+    [ peek ] [ seek ] 2bi ; inline
+
+<PRIVATE
+
+ERROR: not-enough-bits widthed n ;
+
+: widthed-bits ( widthed n -- bits )
+    dup 0 < [ not-enough-bits ] when
+    2dup [ #bits>> ] dip < [ not-enough-bits ] when
+    [ [ bits>> ] [ #bits>> ] bi ] dip
+    [ - neg shift ] keep <widthed> ;
+
+: split-widthed ( widthed n -- widthed1 widthed2 )
+    2dup [ #bits>> ] dip < [
+        drop zero-widthed
     ] [
-        0 >>#bits
+        [ widthed-bits ]
-        t >>end-of-stream?
+        [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
-    ] if* ;
-
-: maybe-read-next-byte ( bitstream -- bitstream )
-    dup #bits>> 0 = [ read-next-byte ] when ; inline
-
-: shift-one-bit ( bitstream -- n )
-    [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
-
-: next-bit ( bitstream -- n/f ? )
-    maybe-read-next-byte
-    dup end-of-stream?>> [
-        drop f
-    ] [
-        [ shift-one-bit ]
-        [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
-    ] if dup >boolean ;
-
-: read-bit ( bitstream -- n ? )
-    dup #bits>> 1 = [
-        [ current-bits>> 1 bitand ]
-        [ read-next-byte drop ] bi t
-    ] [
-        next-bit
-    ] if ; inline
-
-: bits>integer ( seq -- n )
-    0 [ [ 1 shift ] dip bitor ] reduce ; inline
-
-: read-bits ( width bitstream -- n width ? )
-    [
-        '[ _ read-bit drop ] replicate
-        [ f = ] trim-tail
-        [ bits>integer ] [ length ] bi
-    ] 2keep drop over = ;
-
-TUPLE: bitstream-writer < bitstream ;
-
-: <bitstream-writer> ( stream -- bitstream )
-    bitstream-writer new-bitstream ; inline
-
-: write-bit ( n bitstream -- )
-    [ 1 shift bitor ] change-current-bits
-    [ 1+ ] change-#bits
-    dup #bits>> 8 = [
-        [ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
-        [ reset-bitstream drop ] bi
-    ] [
-        drop
-    ] if ; inline
-
-ERROR: invalid-bit-width n ;
-
-:: write-bits ( n width bitstream -- )
-    n 0 < [ n invalid-bit-width ] when
-    n 0 = [
-        width [ 0 bitstream write-bit ] times
-    ] [
-        width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
-        n-length [
-            n-length swap - 1- neg n swap shift 1 bitand
-            bitstream write-bit
-        ] each
     ] if ;
 
-: flush-bits ( bitstream -- ) stream>> stream-flush ;
+: widthed>bytes ( widthed -- bytes widthed )
+    [ 8 split-widthed dup zero-widthed? not ]
+    [ swap bits>> ] B{ } produce-as nip swap ;
 
-: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
+:: |widthed ( widthed1 widthed2 -- widthed3 )
+    widthed1 bits>> :> bits1
+    widthed1 #bits>> :> #bits1
+    widthed2 bits>> :> bits2
+    widthed2 #bits>> :> #bits2
+    bits1 #bits2 shift bits2 bitor
+    #bits1 #bits2 + <widthed> ;
+
+PRIVATE>
+
+M:: lsb0-bit-writer poke ( value n bs -- )
+    value n <widthed> :> widthed
+    widthed
+    bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+    byte bs widthed>> |widthed :> new-byte
+    new-byte #bits>> dup 8 > [ "oops" throw ] when 8 = [
+        new-byte bits>> bs bytes>> push
+        zero-widthed bs (>>widthed)
+        remainder widthed>bytes
+        [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
+    ] [
+        byte bs (>>widthed)
+    ] if ;
+
+: enough-bits? ( n bs -- ? )
+    [ bytes>> length ]
+    [ byte-pos>> - 8 * ]
+    [ bit-pos>> - ] tri <= ;
+
+ERROR: not-enough-bits n bit-reader ;
+
+: #bits>#bytes ( #bits -- #bytes )
+    8 /mod 0 = [ 1 + ] unless ; inline
+
+:: subseq>bits-le ( bignum n bs -- bits )
+    bignum bs bit-pos>> neg shift n bits ;
+
+:: subseq>bits-be ( bignum n bs -- bits )
+    bignum 
+    8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
+    neg shift n bits ;
+
+:: adjust-bits ( n bs -- )
+    n 8 /mod :> #bits :> #bytes
+    bs [ #bytes + ] change-byte-pos
+    bit-pos>> #bits + dup 8 >= [
+        8 - bs (>>bit-pos)
+        bs [ 1 + ] change-byte-pos drop
+    ] [
+        bs (>>bit-pos)
+    ] if ;
+
+:: (peek) ( n bs endian> subseq-endian -- bits )
+    n bs enough-bits? [ n bs not-enough-bits ] unless
+    bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
+    bs bytes>> subseq endian> execute( seq -- x ) :> bignum
+    bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
+
+M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
+
+M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
+
+:: bit-writer-bytes ( writer -- bytes )
+    writer widthed>> #bits>> :> n
+    n 0 = [
+        writer widthed>> bits>> 8 n - shift
+        writer bytes>> swap push
+    ] unless
+    writer bytes>> ;

basis/circular/circular-docs.factor

@@ -43,6 +43,11 @@ HELP: push-growing-circular
      { "elt" object } { "circular" circular } }
 { $description "Pushes an element onto a " { $link growing-circular } " object." } ;
 
+HELP: rotate-circular
+{ $values
+    { "circular" circular } }
+{ $description "Advances the start index of a circular object by one." } ;
+
 ARTICLE: "circular" "Circular sequences"
 "The " { $vocab-link "circular" } " vocabulary implements the " { $link "sequence-protocol" } " to allow an arbitrary start index and wrap-around indexing." $nl
 "Creating a new circular object:"
@@ -51,6 +56,7 @@ ARTICLE: "circular" "Circular sequences"
 { $subsection <growing-circular> }
 "Changing the start index:"
 { $subsection change-circular-start }
+{ $subsection rotate-circular }
 "Pushing new elements:"
 { $subsection push-circular }
 { $subsection push-growing-circular } ;

basis/circular/circular-tests.factor

@@ -12,6 +12,7 @@ circular strings ;
 [ CHAR: e ] [ "test" <circular> 5 swap nth-unsafe ] unit-test
  
 [ [ 1 2 3 ] ] [ { 1 2 3 } <circular> [ ] like ] unit-test
+[ [ 2 3 1 ] ] [ { 1 2 3 } <circular> [ rotate-circular ] keep [ ] like ] unit-test
 [ [ 2 3 1 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test
 [ [ 3 1 2 ] ] [ { 1 2 3 } <circular> -100 over change-circular-start [ ] like ] unit-test

basis/circular/circular.factor

@@ -27,6 +27,9 @@ M: circular virtual-seq seq>> ;
     #! change start to (start + n) mod length
     circular-wrap (>>start) ;
 
+: rotate-circular ( circular -- )
+    [ start>> 1 + ] keep circular-wrap (>>start) ;
+
 : push-circular ( elt circular -- )
     [ set-first ] [ 1 swap change-circular-start ] bi ;
 

basis/compiler/tests/optimizer.factor

@@ -396,3 +396,19 @@ DEFER: loop-bbb
 
 [ 1 ] [ 257 modular-arithmetic-bug ] unit-test
 [ -10 ] [ -10 modular-arithmetic-bug ] unit-test
+
+! Optimizer needs to ignore invalid generics
+GENERIC# bad-dispatch-position-test* 3 ( -- )
+
+M: object bad-dispatch-position-test* ;
+
+: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
+
+[ 1 2 3 4 bad-dispatch-position-test ] must-fail
+
+[ ] [
+    [
+        \ bad-dispatch-position-test forget
+        \ bad-dispatch-position-test* forget
+    ] with-compilation-unit
+] unit-test

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -59,9 +59,11 @@ M: callable splicing-nodes splicing-body ;
 
 : inlining-standard-method ( #call word -- class/f method/f )
     dup "methods" word-prop assoc-empty? [ 2drop f f ] [
+        2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
             [ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
             [ swap nth value-info class>> dup ] dip
             specific-method
+        ] if
     ] if ;
 
 : inline-standard-method ( #call word -- ? )

basis/compression/huffman/huffman.factor

@@ -0,0 +1,88 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs constructors fry
+hashtables io kernel locals math math.order math.parser
+math.ranges multiline sequences ;
+IN: compression.huffman
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+! huffman codes
+
+TUPLE: huffman-code
+    { value }
+    { size }
+    { code } ;
+
+: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;
+: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;
+: next-code ( code -- ) [ 1+ ] change-code drop ;
+
+:: all-patterns ( huff n -- seq )
+    n log2 huff size>> - :> free-bits
+    free-bits 0 >
+    [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]
+    [ huff code>> free-bits neg 2^ /i 1array ] if ;
+
+:: huffman-each ( tdesc quot: ( huff -- ) -- )
+    <huffman-code> :> code
+    tdesc
+    [
+        code next-size
+        [ code (>>value) code clone quot call code next-code ] each
+    ] each ; inline
+
+: update-reverse-table ( huff n table -- )
+    [ drop all-patterns ]
+    [ nip '[ _ swap _ set-at ] each ] 3bi ;
+
+:: reverse-table ( tdesc n -- rtable )
+   n f <array> <enum> :> table
+   tdesc [ n table update-reverse-table ] huffman-each
+   table seq>> ;
+
+:: huffman-table ( tdesc max -- table )
+   max f <array> :> table
+   tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each
+   table ;
+
+PRIVATE>
+
+! decoder
+
+TUPLE: huffman-decoder
+    { bs }
+    { tdesc }
+    { rtable }
+    { bits/level } ;
+
+CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )
+    16 >>bits/level
+    [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;
+
+: read1-huff ( decoder -- elt )
+    16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last
+    [ size>> swap bs>> bs:seek ] [ value>> ] bi ;
+
+! %remove
+: reverse-bits ( value bits -- value' )
+    [ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;
+
+: read1-huff2 ( decoder -- elt )
+    16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last
+    [ size>> swap bs>> bs:seek ] [ value>> ] bi ;
+
+/*
+: huff>string ( code -- str )
+    [ value>> number>string ]
+    [ [ code>> ] [ size>> bits>string ] bi ] bi
+    " = " glue ;
+
+: huff. ( code -- ) huff>string print ;
+
+:: rtable. ( rtable -- )
+    rtable length>> log2 :> n
+    rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;
+*/

basis/compression/inflate/inflate.factor

@@ -0,0 +1,209 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs byte-arrays
+byte-vectors combinators constructors fry grouping hashtables
+compression.huffman images io.binary kernel locals
+math math.bitwise math.order math.ranges multiline sequences
+sorting ;
+IN: compression.inflate
+
+QUALIFIED-WITH: bitstreams bs
+
+<PRIVATE
+
+: enum>seq ( assoc -- seq )
+    dup keys [ ] [ max ] map-reduce 1 + f <array>
+    [ '[ swap _ set-nth ] assoc-each ] keep ;
+
+ERROR: zlib-unimplemented ;
+ERROR: bad-zlib-data ;
+ERROR: bad-zlib-header ;
+    
+:: check-zlib-header ( data -- )
+    16 data bs:peek 2 >le be> 31 mod    ! checksum
+    0 assert=                           
+    4 data bs:read 8 assert=            ! compression method: deflate
+    4 data bs:read                      ! log2(max length)-8, 32K max
+    7 <= [ bad-zlib-header ] unless     
+    5 data bs:seek                      ! drop check bits 
+    1 data bs:read 0 assert=            ! dictionnary - not allowed in png
+    2 data bs:seek                      ! compression level; ignore
+    ;
+
+:: default-table ( -- table )
+    0 <hashtable> :> table
+    0 143 [a,b] 280 287 [a,b] append 8 table set-at
+    144 255 [a,b] >array 9 table set-at
+    256 279 [a,b] >array 7 table set-at 
+    table enum>seq 1 tail ;
+
+CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
+
+: get-table ( values size -- table ) 
+    16 f <array> clone <enum> 
+    [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
+
+:: decode-huffman-tables ( bitstream -- tables )
+    5 bitstream bs:read 257 +
+    5 bitstream bs:read 1 +
+    4 bitstream bs:read 4 +
+    clen-shuffle swap head
+    dup [ drop 3 bitstream bs:read ] map
+    get-table
+    bitstream swap <huffman-decoder> 
+    [ 2dup + ] dip swap :> k!
+    '[
+        _ read1-huff2
+        {
+            { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
+            { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
+            { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
+            [ ]
+        } cond
+        dup array? [ dup second ] [ 1 ] if
+        k swap - dup k! 0 >
+    ] 
+    [ ] produce swap suffix
+    { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
+    [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
+    nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
+    
+CONSTANT: length-table
+    {
+        3 4 5 6 7 8 9 10
+        11 13 15 17
+        19 23 27 31
+        35 43 51 59
+        67 83 99 115
+        131 163 195 227
+    }
+
+CONSTANT: dist-table
+    { 1 2 3 4 
+      5 7 9 13 
+      17 25 33 49
+      65 97 129 193
+      257 385 513 769
+      1025 1537 2049 3073
+      4097 6145 8193 12289
+      16385 24577 }
+
+: nth* ( n seq -- elt )
+    [ length 1- swap - ] [ nth ] bi ;
+
+:: inflate-lz77 ( seq -- bytes )
+    1000 <byte-vector> :> bytes
+    seq
+    [
+        dup array?
+        [ first2 '[ _ 1- bytes nth* bytes push ] times ]
+        [ bytes push ] if
+    ] each 
+    bytes ;
+
+:: inflate-dynamic ( bitstream -- bytes )
+    bitstream decode-huffman-tables
+    bitstream '[ _ swap <huffman-decoder> ] map :> tables
+    [
+        tables first read1-huff2
+        dup 256 >
+        [
+            dup 285 = 
+            [ ]
+            [ 
+                dup 264 > 
+                [ 
+                    dup 261 - 4 /i dup 5 > 
+                    [ bad-zlib-data ] when 
+                    bitstream bs:read 2array 
+                ]
+                when 
+            ] if
+            ! 5 bitstream read-bits ! distance
+            tables second read1-huff2
+            dup 3 > 
+            [ 
+                dup 2 - 2 /i dup 13 >
+                [ bad-zlib-data ] when
+                bitstream bs:read 2array
+            ] 
+            when
+            2array
+        ]
+        when
+        dup 256 = not
+    ]
+    [ ] produce nip
+    [
+        dup array? [
+            first2
+            [  
+                dup array? [ first2 ] [ 0 ] if
+                [ 257 - length-table nth ] [ + ] bi*
+            ] 
+            [
+                dup array? [ first2 ] [ 0 ] if
+                [ dist-table nth ] [ + ] bi*
+            ] bi*
+            2array
+        ] when
+    ] map ;
+    
+: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
+: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
+
+:: inflate-loop ( bitstream -- bytes )
+    [ 1 bitstream bs:read 0 = ]
+    [
+        bitstream
+        2 bitstream bs:read ! B
+        { 
+            { 0 [ inflate-raw ] }
+            { 1 [ inflate-static ] }
+            { 2 [ inflate-dynamic ] }
+            { 3 [ bad-zlib-data f ] }
+        }
+        case
+    ]
+    [ produce ] keep call suffix concat ;
+    
+  !  [ produce ] keep dip swap suffix
+
+:: paeth ( a b c -- p ) 
+    a b + c - { a b c } [ [ - abs ] keep 2array ] with map 
+    sort-keys first second ;
+    
+:: png-unfilter-line ( prev curr filter -- curr' )
+    prev :> c
+    prev 3 tail-slice :> b
+    curr :> a
+    curr 3 tail-slice :> x
+    x length [0,b)
+    filter
+    {
+        { 0 [ drop ] }
+        { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
+        { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
+        { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
+        { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
+        
+    } case 
+    curr 3 tail ;
+
+PRIVATE>
+
+! for debug -- shows residual values
+: reverse-png-filter' ( lines -- filtered )
+    [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
+    concat [ 128 + 256 wrap ] map ;
+    
+: reverse-png-filter ( lines -- filtered )
+    dup first [ 0 ] replicate prefix
+    [ { 0 0 } prepend  ] map
+    2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ;
+
+: zlib-inflate ( bytes -- bytes )
+    bs:<lsb0-bit-reader>
+    [ check-zlib-header ]
+    [ inflate-loop ] bi
+    inflate-lz77 ;

basis/compression/lzw/lzw.factor

@@ -1,20 +1,19 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs bitstreams byte-vectors combinators io
+USING: accessors alien.accessors assocs byte-arrays combinators
 io.encodings.binary io.streams.byte-array kernel math sequences
 vectors ;
 IN: compression.lzw
 
+QUALIFIED-WITH: bitstreams bs
+
 CONSTANT: clear-code 256
 CONSTANT: end-of-information 257
 
-TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
+TUPLE: lzw input output table code old-code ;
-code old-code ;
 
 SYMBOL: table-full
 
-ERROR: index-too-big n ;
-
 : lzw-bit-width ( n -- n' )
     {
         { [ dup 510 <= ] [ drop 9 ] }
@@ -24,36 +23,14 @@ ERROR: index-too-big n ;
         [ drop table-full ]
     } cond ;
 
-: lzw-bit-width-compress ( lzw -- n )
-    count>> lzw-bit-width ;
-
 : lzw-bit-width-uncompress ( lzw -- n )
     table>> length lzw-bit-width ;
 
-: initial-compress-table ( -- assoc )
-    258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
-
 : initial-uncompress-table ( -- seq )
     258 iota [ 1vector ] V{ } map-as ;
 
-: reset-lzw ( lzw -- lzw )
-    257 >>count
-    V{ } clone >>omega
-    V{ } clone >>omega-k
-    9 >>#bits ;
-
-: reset-lzw-compress ( lzw -- lzw )
-    f >>k
-    initial-compress-table >>table reset-lzw ;
-
 : reset-lzw-uncompress ( lzw -- lzw )
-    initial-uncompress-table >>table reset-lzw ;
+    initial-uncompress-table >>table ;
-
-: <lzw-compress> ( input -- obj )
-    lzw new
-        swap >>input
-        binary <byte-writer> <bitstream-writer> >>output
-        reset-lzw-compress ;
 
 : <lzw-uncompress> ( input -- obj )
     lzw new
@@ -61,79 +38,8 @@ ERROR: index-too-big n ;
         BV{ } clone >>output
         reset-lzw-uncompress ;
 
-: push-k ( lzw -- lzw )
-    [ ]
-    [ k>> ]
-    [ omega>> clone [ push ] keep ] tri >>omega-k ;
-
-: omega-k-in-table? ( lzw -- ? )
-    [ omega-k>> ] [ table>> ] bi key? ;
-
 ERROR: not-in-table value ;
 
-: write-output ( lzw -- )
-    [
-        [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
-    ] [
-        [ lzw-bit-width-compress ]
-        [ output>> write-bits ] bi
-    ] bi ;
-
-: omega-k>omega ( lzw -- lzw )
-    dup omega-k>> clone >>omega ;
-
-: k>omega ( lzw -- lzw )
-    dup k>> 1vector >>omega ;
-
-: add-omega-k ( lzw -- )
-    [ [ 1+ ] change-count count>> ]
-    [ omega-k>> clone ]
-    [ table>> ] tri set-at ;
-
-: lzw-compress-char ( lzw k -- )
-    >>k push-k dup omega-k-in-table? [
-        omega-k>omega drop
-    ] [
-        [ write-output ]
-        [ add-omega-k ]
-        [ k>omega drop ] tri
-    ] if ;
-
-: (lzw-compress-chars) ( lzw -- )
-    dup lzw-bit-width-compress table-full = [
-        drop
-    ] [
-        dup input>> stream-read1
-        [ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
-        [ t >>end-of-input? drop ] if*
-    ] if ;
-
-: lzw-compress-chars ( lzw -- )
-    {
-        ! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
-        [
-            [ clear-code ] dip
-            [ lzw-bit-width-compress ]
-            [ output>> write-bits ] bi
-        ]
-        [ (lzw-compress-chars) ]
-        [
-            [ k>> ]
-            [ lzw-bit-width-compress ]
-            [ output>> write-bits ] tri
-        ]
-        [
-            [ end-of-information ] dip
-            [ lzw-bit-width-compress ]
-            [ output>> write-bits ] bi
-        ]
-        [ ]
-    } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
-
-: lzw-compress ( byte-array -- seq )
-    binary <byte-reader> <lzw-compress>
-    [ lzw-compress-chars ] [ output>> stream>> ] bi ;
-
 : lookup-old-code ( lzw -- vector )
     [ old-code>> ] [ table>> ] bi nth ;
 
@@ -152,7 +58,7 @@ ERROR: not-in-table value ;
 : add-to-table ( seq lzw -- ) table>> push ;
 
 : lzw-read ( lzw -- lzw n )
-    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
+    [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
 
 DEFER: lzw-uncompress-char
 : handle-clear-code ( lzw -- )
@@ -200,5 +106,6 @@ DEFER: lzw-uncompress-char
     ] if* ;
 
 : lzw-uncompress ( seq -- byte-array )
-    binary <byte-reader> <bitstream-reader>
+    bs:<msb0-bit-reader>
-    <lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
+    <lzw-uncompress>
+    [ lzw-uncompress-char ] [ output>> ] bi ;

basis/core-graphics/core-graphics.factor

@@ -110,10 +110,14 @@ FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ;
 FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ;
 FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ;
 
+FUNCTION: CGError CGDisplayMoveCursorToPoint ( CGDirectDisplayID display, CGPoint point ) ;
+
 FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ;
 
 FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ;
 
+FUNCTION: uint GetCurrentButtonState ( ) ;
+
 <PRIVATE
 
 : bitmap-flags ( -- flags )

basis/game-input/iokit/iokit.factor

@@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
 sequences locals combinators.short-circuit threads
 namespaces assocs vectors arrays combinators hints alien
 core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input vectors ;
+alien.c-types math parser game-input vectors bit-arrays ;
 IN: game-input.iokit
 
 SINGLETON: iokit-game-input-backend
@@ -186,7 +186,7 @@ HINTS: record-controller { controller-state alien } ;
         rot ?set-nth
     ] [ 3drop ] if ;
 
-HINTS: record-keyboard { array alien } ;
+HINTS: record-keyboard { bit-array alien } ;
 
 : record-mouse ( mouse-state value -- )
     dup IOHIDValueGetElement {
@@ -285,7 +285,7 @@ M: iokit-game-input-backend reset-mouse
     4 <vector> +controller-states+ set-global
     0 0 0 0 2 <vector> mouse-state boa
         +mouse-state+ set-global
-    256 f <array> +keyboard-state+ set-global ;
+    256 <bit-array> +keyboard-state+ set-global ;
 
 M: iokit-game-input-backend (open-game-input)
     hid-manager-matching-game-devices {

basis/images/jpeg/jpeg.factor

@@ -0,0 +1,304 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators
+constructors grouping compression.huffman images
+images.processing io io.binary io.encodings.binary io.files
+io.streams.byte-array kernel locals math math.bitwise
+math.constants math.functions math.matrices math.order
+math.ranges math.vectors memoize multiline namespaces
+sequences sequences.deep ;
+IN: images.jpeg
+
+QUALIFIED-WITH: bitstreams bs
+
+TUPLE: jpeg-image < image
+    { headers }
+    { bitstream }
+    { color-info initial: { f f f f } }
+    { quant-tables initial: { f f } }
+    { huff-tables initial: { f f f f } }
+    { components } ;
+
+<PRIVATE
+
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
+
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
+APP JPG COM TEM RES ;
+
+! ISO/IEC 10918-1 Table B.1
+:: >marker ( byte -- marker )
+    byte
+    {
+      { [ dup HEX: CC = ] [ { DAC } ] }
+      { [ dup HEX: C4 = ] [ { DHT } ] }
+      { [ dup HEX: C9 = ] [ { JPG } ] }
+      { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }
+
+      { [ dup HEX: D8 = ] [ { SOI } ] }
+      { [ dup HEX: D9 = ] [ { EOI } ] }
+      { [ dup HEX: DA = ] [ { SOS } ] }
+      { [ dup HEX: DB = ] [ { DQT } ] }
+      { [ dup HEX: DC = ] [ { DNL } ] }
+      { [ dup HEX: DD = ] [ { DRI } ] }
+      { [ dup HEX: DE = ] [ { DHP } ] }
+      { [ dup HEX: DF = ] [ { EXP } ] }
+      { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }
+
+      { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }
+      { [ dup HEX: FE = ] [ { COM } ] }
+      { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }
+
+      { [ dup HEX: 01 = ] [ { TEM } ] }
+      [ { RES } ]
+    }
+    cond nip ;
+
+TUPLE: jpeg-chunk length type data ;
+
+CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;
+
+TUPLE: jpeg-color-info
+    h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;
+
+CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
+
+: jpeg> ( -- jpeg-image ) jpeg-image get ;
+
+: apply-diff ( dc color -- dc' )
+    [ diff>> + dup ] [ (>>diff) ] bi ;
+
+: fetch-tables ( component -- )
+    [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]
+    [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]
+    [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;
+
+: read4/4 ( -- a b ) read1 16 /mod ;
+
+
+! headers
+
+: decode-frame ( header -- )
+    data>>
+    binary
+    [
+        read1 8 assert=
+        2 read be>
+        2 read be>
+        swap 2array jpeg> (>>dim)
+        read1
+        [
+            read1 read4/4 read1 <jpeg-color-info>
+            swap [ >>id ] keep jpeg> color-info>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-quant-table ( chunk -- )
+    dup data>>
+    binary
+    [
+        length>>
+        2 - 65 /
+        [
+            read4/4 [ 0 assert= ] dip
+            64 read
+            swap jpeg> quant-tables>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-huff-table ( chunk -- )
+    data>>
+    binary
+    [
+        1 ! %fixme: Should handle multiple tables at once
+        [
+            read4/4 swap 2 * +
+            16 read
+            dup [ ] [ + ] map-reduce read
+            binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader
+            swap jpeg> huff-tables>> set-nth
+        ] times
+    ] with-byte-reader ;
+
+: decode-scan ( chunk -- )
+    data>>
+    binary
+    [
+        read1 [0,b)
+        [   drop
+            read1 jpeg> color-info>> nth clone
+            read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*
+        ] map jpeg> (>>components)
+        read1 0 assert=
+        read1 63 assert=
+        read1 16 /mod [ 0 assert= ] bi@
+    ] with-byte-reader ;
+
+: singleton-first ( seq -- elt )
+    [ length 1 assert= ] [ first ] bi ;
+
+: baseline-parse ( -- )
+    jpeg> headers>>
+    {
+        [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]
+        [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]
+        [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]
+        [ [ type>> { SOS } = ] filter singleton-first decode-scan ]
+    } cleave ;
+
+: parse-marker ( -- marker )
+    read1 HEX: FF assert=
+    read1 >marker ;
+
+: parse-headers ( -- chunks )
+    [ parse-marker dup { SOS } = not ]
+    [
+        2 read be>
+        dup 2 - read <jpeg-chunk>
+    ] [ produce ] keep dip swap suffix ;
+
+MEMO: zig-zag ( -- zz )
+    {
+        {  0  1  5  6 14 15 27 28 }
+        {  2  4  7 13 16 26 29 42 }
+        {  3  8 12 17 25 30 41 43 }
+        {  9 11 18 24 31 40 44 53 }
+        { 10 19 23 32 39 45 52 54 }
+        { 20 22 33 38 46 51 55 60 }
+        { 21 34 37 47 50 56 59 61 }
+        { 35 36 48 49 57 58 62 63 }
+    } flatten ;
+
+MEMO: yuv>bgr-matrix ( -- m )
+    {
+        { 1  2.03211  0       }
+        { 1 -0.39465 -0.58060 }
+        { 1  0        1.13983 }
+    } ;
+
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;
+
+:: dct-vect ( u v -- basis )
+    { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2
+    1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;
+
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;
+
+: mb-dim ( component -- dim )  [ h>> ] [ v>> ] bi 2array ;
+
+: all-macroblocks ( quot: ( mb -- ) -- )
+    [
+        jpeg>
+        [ dim>> 8 v/n ]
+        [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi
+        [ ceiling ] map
+        coord-matrix flip concat
+    ]
+    [ each ] bi* ; inline
+
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;
+
+: idct-factor ( b -- b' ) dct-matrix v.m ;
+
+USE: math.blas.vectors
+USE: math.blas.matrices
+
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;
+
+: idct ( b -- b' ) idct-blas ;
+
+:: draw-block ( block x,y color jpeg-image -- )
+    block dup length>> sqrt >fixnum group flip
+    dup matrix-dim coord-matrix flip
+    [
+        [ first2 spin nth nth ]
+        [ x,y v+ color id>> 1- jpeg-image draw-color ] bi
+    ] with each^2 ;
+
+: sign-extend ( bits v -- v' )
+    swap [ ] [ 1- 2^ < ] 2bi
+    [ -1 swap shift 1+ + ] [ drop ] if ;
+
+: read1-jpeg-dc ( decoder -- dc )
+    [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;
+
+: read1-jpeg-ac ( decoder -- run/ac )
+    [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;
+
+:: decode-block ( pos color -- )
+    color dc-huff-table>> read1-jpeg-dc color apply-diff
+    64 0 <array> :> coefs
+    0 coefs set-nth
+    0 :> k!
+    [
+        color ac-huff-table>> read1-jpeg-ac
+        [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri
+        { 0 0 } = not
+        k 63 < and
+    ] loop
+    coefs color quant-table>> v*
+    reverse-zigzag idct
+    ! %fixme: color hack
+    ! this eat 50% cpu time
+    color h>> 2 =
+    [ 8 group 2 matrix-zoom concat ] unless
+    pos { 8 8 } v* color jpeg> draw-block ;
+
+: decode-macroblock ( mb -- )
+    jpeg> components>>
+    [
+        [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]
+        [ [ decode-block ] curry each ] bi
+    ] with each ;
+
+: cleanup-bitstream ( bytes -- bytes' )
+    binary [
+        [
+            { HEX: FF } read-until
+            read1 tuck HEX: 00 = and
+        ]
+        [ drop ] produce
+        swap >marker {  EOI } assert=
+        swap suffix
+        { HEX: FF } join
+    ] with-byte-reader ;
+
+: setup-bitmap ( image -- )
+    dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim
+    BGR >>component-order
+    f >>upside-down?
+    dup dim>> first2 * 3 * 0 <array> >>bitmap
+    drop ;
+
+: baseline-decompress ( -- )
+    jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
+    >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
+    jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi
+    jpeg> components>> [ fetch-tables ] each
+    jpeg> setup-bitmap
+    [ decode-macroblock ] all-macroblocks ;
+
+! this eats ~25% cpu time
+: color-transform ( yuv -- rgb )
+    { 128 0 0 } v+ yuv>bgr-matrix swap m.v
+    [ 0 max 255 min >fixnum ] map ;
+
+PRIVATE>
+
+: load-jpeg ( path -- image )
+    binary [
+        parse-marker { SOI } assert=
+        parse-headers
+        contents <jpeg-image>
+    ] with-file-reader
+    dup jpeg-image [
+        baseline-parse
+        baseline-decompress
+        jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
+        jpeg> [ >byte-array ] change-bitmap drop
+    ] with-variable ;
+
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )
+    drop load-jpeg ;

basis/images/loader/loader.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.pathnames ;
+accessors images.bitmap images.tiff images io.pathnames
+images.jpeg images.png ;
 IN: images.loader
 
 ERROR: unknown-image-extension extension ;
@@ -11,6 +12,9 @@ ERROR: unknown-image-extension extension ;
         { "bmp" [ bitmap-image ] }
         { "tif" [ tiff-image ] }
         { "tiff" [ tiff-image ] }
+        { "jpg" [ jpeg-image ] }
+        { "jpeg" [ jpeg-image ] }
+        { "png" [ png-image ] }
         [ unknown-image-extension ]
     } case ;
 

basis/images/png/png.factor

@@ -3,7 +3,7 @@
 USING: accessors constructors images io io.binary io.encodings.ascii
 io.encodings.binary io.encodings.string io.files io.files.info kernel
 sequences io.streams.limited fry combinators arrays math
-checksums checksums.crc32 ;
+checksums checksums.crc32 compression.inflate grouping byte-arrays ;
 IN: images.png
 
 TUPLE: png-image < image chunks
@@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ;
 
 CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
 
-CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
+CONSTANT: png-header
+    B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
 
 ERROR: bad-png-header header ;
 
@@ -61,6 +62,18 @@ ERROR: bad-checksum ;
 : fill-image-data ( image -- image )
     dup [ width>> ] [ height>> ] bi 2array >>dim ;
 
+: zlib-data ( png-image -- bytes ) 
+    chunks>> [ type>> "IDAT" = ] find nip data>> ;
+
+: decode-png ( image -- image ) 
+    {
+        [ zlib-data zlib-inflate ] 
+        [ dim>> first 3 * 1 + group reverse-png-filter ]
+        [ swap >byte-array >>bitmap drop ]
+        [ RGB >>component-order drop ]
+        [ ]
+    } cleave ;
+
 : load-png ( path -- image )
     [ binary <file-reader> ] [ file-info size>> ] bi
     stream-throws <limited-stream> [
@@ -69,4 +82,8 @@ ERROR: bad-checksum ;
         read-png-chunks
         parse-ihdr-chunk
         fill-image-data
+        decode-png
     ] with-input-stream ;
+
+M: png-image load-image*
+    drop load-png ;

basis/images/processing/processing.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Marc Fauconneau.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays combinators grouping images
+kernel locals math math.order
+math.ranges math.vectors sequences sequences.deep fry ;
+IN: images.processing
+
+: coord-matrix ( dim -- m )
+    [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;
+
+: map^2 ( m quot -- m' ) '[ _ map ] map ; inline
+: each^2 ( m quot -- m' ) '[ _ each ] each ; inline
+
+: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;
+    
+: matrix>image ( m -- image )
+    <image> over matrix-dim >>dim
+    swap flip flatten
+    [ 128 * 128 + 0 max 255 min  >fixnum ] map
+    >byte-array >>bitmap L >>component-order ;
+
+:: matrix-zoom ( m f -- m' )
+    m matrix-dim f v*n coord-matrix
+    [ [ f /i ] map first2 swap m nth nth ] map^2 ;
+
+:: image-offset ( x,y image -- xy )
+    image dim>> first
+    x,y second * x,y first + ;
+        
+:: draw-grey ( value x,y image -- )
+    x,y image image-offset 3 * { 0 1 2 }
+    [
+        + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth
+    ] with each ;
+
+:: draw-color ( value x,y color-id image -- )
+    x,y image image-offset 3 * color-id + value >fixnum
+    swap image bitmap>> set-nth ;
+
+! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;

basis/io/directories/hierarchy/hierarchy.factor

@@ -20,7 +20,7 @@ DEFER: copy-tree-into
     {
         { +symbolic-link+ [ copy-link ] }
         { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] }
-        [ drop copy-file ]
+        [ drop copy-file-and-info ]
     } case ;
 
 : copy-tree-into ( from to -- )

basis/io/files/info/info.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel system sequences combinators
-vocabs.loader io.files.types math ;
+vocabs.loader io.files.types io.directories math ;
 IN: io.files.info
 
 ! File info
@@ -29,3 +29,7 @@ HOOK: file-system-info os ( path -- file-system-info )
     { [ os unix? ] [ "io.files.info.unix." os name>> append ] }
     { [ os windows? ] [ "io.files.info.windows" ] }
 } cond require
+
+HOOK: copy-file-and-info os ( from to -- )
+
+M: object copy-file-and-info copy-file ;

basis/io/files/info/unix/unix.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel system math math.bitwise strings arrays
 sequences combinators combinators.short-circuit alien.c-types
 vocabs.loader calendar calendar.unix io.files.info
-io.files.types io.backend unix unix.stat unix.time unix.users
+io.files.types io.backend io.directories unix unix.stat unix.time unix.users
 unix.groups ;
 IN: io.files.info.unix
 
@@ -174,6 +174,9 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001
 : file-permissions ( path -- n )
     normalize-path file-info permissions>> ;
 
+M: unix copy-file-and-info ( from to -- )
+    [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ;
+
 <PRIVATE
 
 : make-timeval-array ( array -- byte-array )

basis/opengl/framebuffers/framebuffers.factor

@@ -28,6 +28,7 @@ IN: opengl.framebuffers
         { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
         { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
         { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
+        { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT [ "framebuffer incomplete (multisample counts don't match)" ] }
         [ drop gl-error "unknown framebuffer error" ]
     } case throw ;
 
@@ -35,9 +36,19 @@ IN: opengl.framebuffers
     framebuffer-incomplete? [ framebuffer-error ] when* ;
 
 : with-framebuffer ( id quot -- )
-    GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
+    [ GL_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] dip
     [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
 
+: with-draw-read-framebuffers ( draw-id read-id quot -- )
+    [
+        [ GL_DRAW_FRAMEBUFFER_EXT swap glBindFramebufferEXT ]
+        [ GL_READ_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] bi*
+    ] dip
+    [ 
+        GL_DRAW_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
+        GL_READ_FRAMEBUFFER_EXT 0 glBindFramebufferEXT
+    ] [ ] cleanup ; inline
+
 : framebuffer-attachment ( attachment -- id )
     GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
     0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;

basis/opengl/gl/gl.factor

@@ -1774,6 +1774,33 @@ GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ;
 GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ;
 
 
+! GL_EXT_framebuffer_blit
+
+
+GL-FUNCTION: void glBlitFramebufferEXT { } ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1,
+                                             GLint dstX0, GLint dstY0, GLint dstX1, GLint dstY1,
+                                             GLbitfield mask, GLenum filter ) ;
+
+CONSTANT: GL_READ_FRAMEBUFFER_EXT HEX: 8CA8
+CONSTANT: GL_DRAW_FRAMEBUFFER_EXT HEX: 8CA9
+
+ALIAS: GL_DRAW_FRAMEBUFFER_BINDING_EXT GL_FRAMEBUFFER_BINDING_EXT
+CONSTANT: GL_READ_FRAMEBUFFER_BINDING_EXT HEX: 8CAA
+
+
+! GL_EXT_framebuffer_multisample
+
+
+GL-FUNCTION: void glRenderbufferStorageMultisampleEXT { } (
+            GLenum target, GLsizei samples,
+            GLenum internalformat,
+            GLsizei width, GLsizei height ) ;
+
+CONSTANT: GL_RENDERBUFFER_SAMPLES_EXT HEX: 8CAB
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56
+CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57
+
+
 ! GL_ARB_texture_float
 
 
@@ -1798,3 +1825,218 @@ CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15
 CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16
 CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17
 
+
+! GL_EXT_gpu_shader4
+
+
+GL-FUNCTION: void glVertexAttribI1iEXT { } ( GLuint index, GLint x ) ;
+GL-FUNCTION: void glVertexAttribI2iEXT { } ( GLuint index, GLint x, GLint y ) ;
+GL-FUNCTION: void glVertexAttribI3iEXT { } ( GLuint index, GLint x, GLint y, GLint z ) ;
+GL-FUNCTION: void glVertexAttribI4iEXT { } ( GLuint index, GLint x, GLint y, GLint z, GLint w ) ;
+
+GL-FUNCTION: void glVertexAttribI1uiEXT { } ( GLuint index, GLuint x ) ;
+GL-FUNCTION: void glVertexAttribI2uiEXT { } ( GLuint index, GLuint x, GLuint y ) ;
+GL-FUNCTION: void glVertexAttribI3uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z ) ;
+GL-FUNCTION: void glVertexAttribI4uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z, GLuint w ) ;
+
+GL-FUNCTION: void glVertexAttribI1ivEXT { } ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttribI2ivEXT { } ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttribI3ivEXT { } ( GLuint index, GLint* v ) ;
+GL-FUNCTION: void glVertexAttribI4ivEXT { } ( GLuint index, GLint* v ) ;
+
+GL-FUNCTION: void glVertexAttribI1uivEXT { } ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttribI2uivEXT { } ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttribI3uivEXT { } ( GLuint index, GLuint* v ) ;
+GL-FUNCTION: void glVertexAttribI4uivEXT { } ( GLuint index, GLuint* v ) ;
+
+GL-FUNCTION: void glVertexAttribI4bvEXT { } ( GLuint index, GLbyte* v ) ;
+GL-FUNCTION: void glVertexAttribI4svEXT { } ( GLuint index, GLshort* v ) ;
+GL-FUNCTION: void glVertexAttribI4ubvEXT { } ( GLuint index, GLubyte* v ) ;
+GL-FUNCTION: void glVertexAttribI4usvEXT { } ( GLuint index, GLushort* v ) ;
+
+GL-FUNCTION: void glVertexAttribIPointerEXT { } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ;
+
+GL-FUNCTION: void glGetVertexAttribIivEXT { } ( GLuint index, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetVertexAttribIuivEXT { } ( GLuint index, GLenum pname, GLuint* params ) ;
+
+GL-FUNCTION: void glUniform1uiEXT { } ( GLint location, GLuint v0 ) ;
+GL-FUNCTION: void glUniform2uiEXT { } ( GLint location, GLuint v0, GLuint v1 ) ;
+GL-FUNCTION: void glUniform3uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ;
+GL-FUNCTION: void glUniform4uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ;
+
+GL-FUNCTION: void glUniform1uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform2uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform3uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ;
+
+GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
+
+GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
+GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
+
+CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
+CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
+CONSTANT: GL_SAMPLER_2D_ARRAY_EXT HEX: 8DC1
+CONSTANT: GL_SAMPLER_BUFFER_EXT HEX: 8DC2
+CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW_EXT HEX: 8DC3
+CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW_EXT HEX: 8DC4
+CONSTANT: GL_SAMPLER_CUBE_SHADOW_EXT HEX: 8DC5
+CONSTANT: GL_UNSIGNED_INT_VEC2_EXT HEX: 8DC6
+CONSTANT: GL_UNSIGNED_INT_VEC3_EXT HEX: 8DC7
+CONSTANT: GL_UNSIGNED_INT_VEC4_EXT HEX: 8DC8
+CONSTANT: GL_INT_SAMPLER_1D_EXT HEX: 8DC9
+CONSTANT: GL_INT_SAMPLER_2D_EXT HEX: 8DCA
+CONSTANT: GL_INT_SAMPLER_3D_EXT HEX: 8DCB
+CONSTANT: GL_INT_SAMPLER_CUBE_EXT HEX: 8DCC
+CONSTANT: GL_INT_SAMPLER_2D_RECT_EXT HEX: 8DCD
+CONSTANT: GL_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DCE
+CONSTANT: GL_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DCF
+CONSTANT: GL_INT_SAMPLER_BUFFER_EXT HEX: 8DD0
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_EXT HEX: 8DD1
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_EXT HEX: 8DD2
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D_EXT HEX: 8DD3
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE_EXT HEX: 8DD4
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT_EXT HEX: 8DD5
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DD6
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DD7
+CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER_EXT HEX: 8DD8
+CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET_EXT HEX: 8904
+CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET_EXT HEX: 8905
+
+
+! GL_EXT_geometry_shader4
+
+
+GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ;
+GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment, 
+                                                GLuint texture, GLint level ) ;
+GL-FUNCTION: void glFramebufferTextureLayerEXT { } ( GLenum target, GLenum attachment, 
+                                                     GLuint texture, GLint level, GLint layer ) ;
+GL-FUNCTION: void glFramebufferTextureFaceEXT { } ( GLenum target, GLenum attachment,
+                                                    GLuint texture, GLint level, GLenum face ) ;
+
+CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9
+CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA
+CONSTANT: GL_GEOMETRY_INPUT_TYPE_EXT HEX: 8DDB
+CONSTANT: GL_GEOMETRY_OUTPUT_TYPE_EXT HEX: 8DDC
+CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29
+CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD
+CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE
+CONSTANT: GL_MAX_VARYING_COMPONENTS_EXT HEX: 8B4B
+CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF
+CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0
+CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1
+CONSTANT: GL_LINES_ADJACENCY_EXT HEX: A
+CONSTANT: GL_LINE_STRIP_ADJACENCY_EXT HEX: B
+CONSTANT: GL_TRIANGLES_ADJACENCY_EXT HEX: C
+CONSTANT: GL_TRIANGLE_STRIP_ADJACENCY_EXT HEX: D
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8
+CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9
+CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7
+ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER_EXT GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT
+CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642
+
+
+! GL_EXT_texture_integer
+
+
+GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
+GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
+GL-FUNCTION: void glTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
+GL-FUNCTION: void glGetTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ;
+GL-FUNCTION: void glGetTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ;
+
+CONSTANT: GL_RGBA_INTEGER_MODE_EXT HEX: 8D9E
+
+CONSTANT: GL_RGBA32UI_EXT HEX: 8D70
+CONSTANT: GL_RGB32UI_EXT HEX: 8D71
+CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72
+CONSTANT: GL_INTENSITY32UI_EXT HEX: 8D73
+CONSTANT: GL_LUMINANCE32UI_EXT HEX: 8D74
+CONSTANT: GL_LUMINANCE_ALPHA32UI_EXT HEX: 8D75
+
+CONSTANT: GL_RGBA16UI_EXT HEX: 8D76
+CONSTANT: GL_RGB16UI_EXT HEX: 8D77
+CONSTANT: GL_ALPHA16UI_EXT HEX: 8D78
+CONSTANT: GL_INTENSITY16UI_EXT HEX: 8D79
+CONSTANT: GL_LUMINANCE16UI_EXT HEX: 8D7A
+CONSTANT: GL_LUMINANCE_ALPHA16UI_EXT HEX: 8D7B
+
+CONSTANT: GL_RGBA8UI_EXT HEX: 8D7C
+CONSTANT: GL_RGB8UI_EXT HEX: 8D7D
+CONSTANT: GL_ALPHA8UI_EXT HEX: 8D7E
+CONSTANT: GL_INTENSITY8UI_EXT HEX: 8D7F
+CONSTANT: GL_LUMINANCE8UI_EXT HEX: 8D80
+CONSTANT: GL_LUMINANCE_ALPHA8UI_EXT HEX: 8D81
+
+CONSTANT: GL_RGBA32I_EXT HEX: 8D82
+CONSTANT: GL_RGB32I_EXT HEX: 8D83
+CONSTANT: GL_ALPHA32I_EXT HEX: 8D84
+CONSTANT: GL_INTENSITY32I_EXT HEX: 8D85
+CONSTANT: GL_LUMINANCE32I_EXT HEX: 8D86
+CONSTANT: GL_LUMINANCE_ALPHA32I_EXT HEX: 8D87
+
+CONSTANT: GL_RGBA16I_EXT HEX: 8D88
+CONSTANT: GL_RGB16I_EXT HEX: 8D89
+CONSTANT: GL_ALPHA16I_EXT HEX: 8D8A
+CONSTANT: GL_INTENSITY16I_EXT HEX: 8D8B
+CONSTANT: GL_LUMINANCE16I_EXT HEX: 8D8C
+CONSTANT: GL_LUMINANCE_ALPHA16I_EXT HEX: 8D8D
+
+CONSTANT: GL_RGBA8I_EXT HEX: 8D8E
+CONSTANT: GL_RGB8I_EXT HEX: 8D8F
+CONSTANT: GL_ALPHA8I_EXT HEX: 8D90
+CONSTANT: GL_INTENSITY8I_EXT HEX: 8D91
+CONSTANT: GL_LUMINANCE8I_EXT HEX: 8D92
+CONSTANT: GL_LUMINANCE_ALPHA8I_EXT HEX: 8D93
+
+CONSTANT: GL_RED_INTEGER_EXT HEX: 8D94
+CONSTANT: GL_GREEN_INTEGER_EXT HEX: 8D95
+CONSTANT: GL_BLUE_INTEGER_EXT HEX: 8D96
+CONSTANT: GL_ALPHA_INTEGER_EXT HEX: 8D97
+CONSTANT: GL_RGB_INTEGER_EXT HEX: 8D98
+CONSTANT: GL_RGBA_INTEGER_EXT HEX: 8D99
+CONSTANT: GL_BGR_INTEGER_EXT HEX: 8D9A
+CONSTANT: GL_BGRA_INTEGER_EXT HEX: 8D9B
+CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C
+CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
+
+
+! GL_EXT_transform_feedback
+
+
+GL-FUNCTION: void glBindBufferRangeEXT { } ( GLenum target, GLuint index, GLuint buffer,
+                           GLintptr offset, GLsizeiptr size ) ;
+GL-FUNCTION: void glBindBufferOffsetEXT { } ( GLenum target, GLuint index, GLuint buffer,
+                            GLintptr offset ) ;
+GL-FUNCTION: void glBindBufferBaseEXT { } ( GLenum target, GLuint index, GLuint buffer ) ;
+
+GL-FUNCTION: void glBeginTransformFeedbackEXT { } ( GLenum primitiveMode ) ;
+GL-FUNCTION: void glEndTransformFeedbackEXT { } ( ) ;
+
+GL-FUNCTION: void glTransformFeedbackVaryingsEXT { } ( GLuint program, GLsizei count,
+                                      GLchar** varyings, GLenum bufferMode ) ;
+GL-FUNCTION: void glGetTransformFeedbackVaryingEXT { } ( GLuint program, GLuint index,
+                                        GLsizei bufSize, GLsizei* length, 
+                                        GLsizei* size, GLenum* type, GLchar* name ) ;
+
+GL-FUNCTION: void glGetIntegerIndexedvEXT { } ( GLenum param, GLuint index, GLint* values ) ;
+GL-FUNCTION: void glGetBooleanIndexedvEXT { } ( GLenum param, GLuint index, GLboolean* values ) ;
+
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_EXT HEX: 8C8E
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START_EXT HEX: 8C84
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE_EXT HEX: 8C85
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING_EXT HEX: 8C8F
+CONSTANT: GL_INTERLEAVED_ATTRIBS_EXT HEX: 8C8C
+CONSTANT: GL_SEPARATE_ATTRIBS_EXT HEX: 8C8D
+CONSTANT: GL_PRIMITIVES_GENERATED_EXT HEX: 8C87
+CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN_EXT HEX: 8C88
+CONSTANT: GL_RASTERIZER_DISCARD_EXT HEX: 8C89
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS_EXT HEX: 8C8A
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS_EXT HEX: 8C8B
+CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS_EXT HEX: 8C80
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS_EXT HEX: 8C83
+CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE_EXT HEX: 8C7F
+CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH_EXT HEX: 8C76
+

basis/openssl/libcrypto/libcrypto.factor

@@ -13,6 +13,7 @@ IN: openssl.libcrypto
 <<
 {
     { [ os openbsd? ] [ ] } ! VM is linked with it
+    { [ os netbsd? ] [ ] }
     { [ os winnt? ] [ "libcrypto" "libeay32.dll" "cdecl" add-library ] }
     { [ os macosx? ] [ "libcrypto" "libcrypto.dylib" "cdecl" add-library ] }
     { [ os unix? ] [ "libcrypto" "libcrypto.so" "cdecl" add-library ] }

basis/openssl/libssl/libssl.factor

@@ -9,6 +9,7 @@ IN: openssl.libssl
 
 << {
     { [ os openbsd? ] [ ] } ! VM is linked with it
+    { [ os netbsd? ] [ ] }
     { [ os winnt? ] [ "libssl" "ssleay32.dll" "cdecl" add-library ] }
     { [ os macosx? ] [ "libssl" "libssl.dylib" "cdecl" add-library ] }
     { [ os unix? ] [ "libssl" "libssl.so" "cdecl" add-library ] }

basis/tools/annotations/annotations.factor

@@ -43,29 +43,17 @@ PRIVATE>
 
 <PRIVATE
 
-: word-inputs ( word -- seq )
+: stack-values ( names -- alist )
-    stack-effect [
+    [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
-        [ datastack ] dip in>> length tail*
-    ] [
-        datastack
-    ] if* ;
 
-: entering ( str -- )
+: trace-message ( word quot str -- )
-    "/-- Entering: " write dup .
+    "--- " write write bl over .
-    word-inputs stack.
+    [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
-    "\\--" print flush ;
+    [ simple-table. ] unless-empty flush ; inline
 
-: word-outputs ( word -- seq )
+: entering ( str -- ) [ in>> ] "Entering" trace-message ;
-    stack-effect [
-        [ datastack ] dip out>> length tail*
-    ] [
-        datastack
-    ] if* ;
 
-: leaving ( str -- )
+: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
-    "/-- Leaving: " write dup .
-    word-outputs stack.
-     "\\--" print flush ;
 
 : (watch) ( word def -- def )
     over '[ _ entering @ _ leaving ] ;

basis/tools/deploy/shaker/shaker.factor

@@ -195,10 +195,12 @@ IN: tools.deploy.shaker
     2drop ;
 
 : strip-compiler-classes ( -- )
+    strip-dictionary? [
         "Stripping compiler classes" show
         { "compiler" "stack-checker" }
         [ child-vocabs [ words ] map concat [ class? ] filter ] map concat
-    [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+        [ dup implementors [ "methods" word-prop delete-at ] with each ] each
+    ] when ;
 
 : strip-default-methods ( -- )
     strip-debugger? [

basis/ui/backend/backend.factor

@@ -7,9 +7,9 @@ SYMBOL: ui-backend
 
 HOOK: set-title ui-backend ( string world -- )
 
-HOOK: set-fullscreen* ui-backend ( ? world -- )
+HOOK: (set-fullscreen) ui-backend ( world ? -- )
 
-HOOK: fullscreen* ui-backend ( world -- ? )
+HOOK: (fullscreen?) ui-backend ( world -- ? )
 
 HOOK: (open-window) ui-backend ( world -- )
 

basis/ui/backend/cocoa/cocoa.factor

@@ -99,12 +99,14 @@ M: cocoa-ui-backend set-title ( string world -- )
     drop ;
 
 : exit-fullscreen ( world -- )
-    handle>> view>> f -> exitFullScreenModeWithOptions: ;
+    handle>>
+    [ view>> f -> exitFullScreenModeWithOptions: ] 
+    [ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ;
 
-M: cocoa-ui-backend set-fullscreen* ( ? world -- )
+M: cocoa-ui-backend (set-fullscreen) ( world ? -- )
-    swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+    [ enter-fullscreen ] [ exit-fullscreen ] if ;
 
-M: cocoa-ui-backend fullscreen* ( world -- ? )
+M: cocoa-ui-backend (fullscreen?) ( world -- ? )
     handle>> view>> -> isInFullScreenMode zero? not ;
 
 M:: cocoa-ui-backend (open-window) ( world -- )
@@ -120,13 +122,20 @@ M:: cocoa-ui-backend (open-window) ( world -- )
     window f -> makeKeyAndOrderFront: ;
 
 M: cocoa-ui-backend (close-window) ( handle -- )
-    window>> -> release ;
+    [
+        view>> dup -> isInFullScreenMode zero?
+        [ drop ]
+        [ f -> exitFullScreenModeWithOptions: ] if
+    ] [ window>> -> release ] bi ;
 
 M: cocoa-ui-backend (grab-input) ( handle -- )
     0 CGAssociateMouseAndMouseCursorPosition drop
     CGMainDisplayID CGDisplayHideCursor drop
     window>> -> frame CGRect>rect rect-center
-    first2 <CGPoint> CGWarpMouseCursorPosition drop ;
+    NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h
+    [ drop first ] [ swap second - ] 2bi <CGPoint>
+    [ GetCurrentButtonState zero? not ] [ yield ] while
+    CGWarpMouseCursorPosition drop ;
 
 M: cocoa-ui-backend (ungrab-input) ( handle -- )
     drop

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

@@ -391,7 +391,10 @@ CLASS: {
 { "windowDidResignKey:" "void" { "id" "SEL" "id" }
     [
         forget-rollover
-        2nip -> object -> contentView window unfocus-world
+        2nip -> object -> contentView
+        dup -> isInFullScreenMode zero? 
+        [ window unfocus-world ]
+        [ drop ] if
     ]
 }
 

basis/ui/backend/windows/windows.factor

@@ -556,11 +556,9 @@ M: windows-ui-backend do-events
         [ DispatchMessage drop ] bi
     ] if ;
 
-: register-wndclassex ( -- class )
+:: register-window-class ( class-name-ptr -- )
-    "WNDCLASSEX" <c-object>
+    "WNDCLASSEX" <c-object> f GetModuleHandle
-    f GetModuleHandle
+    class-name-ptr pick GetClassInfoEx 0 = [
-    class-name-ptr get-global
-    pick GetClassInfoEx zero? [
         "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize
         { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style
         ui-wndproc over set-WNDCLASSEX-lpfnWndProc
@@ -571,9 +569,9 @@ M: windows-ui-backend do-events
         over set-WNDCLASSEX-hIcon
         f IDC_ARROW LoadCursor over set-WNDCLASSEX-hCursor
 
-        class-name-ptr get-global over set-WNDCLASSEX-lpszClassName
+        class-name-ptr over set-WNDCLASSEX-lpszClassName
-        RegisterClassEx dup win32-error=0/f
+        RegisterClassEx win32-error=0/f
-    ] when ;
+    ] [ drop ] if ;
 
 : adjust-RECT ( RECT -- )
     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
@@ -594,9 +592,16 @@ M: windows-ui-backend do-events
     dup adjust-RECT
     swap [ dup default-position-RECT ] when ;
 
+: get-window-class ( -- class-name )
+    class-name-ptr [
+        dup expired? [ drop "Factor-window" utf16n malloc-string ] when
+        dup register-window-class
+        dup
+    ] change-global ;
+
 : create-window ( rect -- hwnd )
     make-adjusted-RECT
-    [ class-name-ptr get-global f ] dip
+    [ get-window-class f ] dip
     [
         [ ex-style ] 2dip
         { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
@@ -611,8 +616,6 @@ M: windows-ui-backend do-events
 : init-win32-ui ( -- )
     V{ } clone nc-buttons set-global
     "MSG" malloc-object msg-obj set-global
-    "Factor-window" utf16n malloc-string class-name-ptr set-global
-    register-wndclassex drop
     GetDoubleClickTime milliseconds double-click-timeout set-global ;
 
 : cleanup-win32-ui ( -- )
@@ -758,8 +761,13 @@ M: windows-ui-backend (ungrab-input) ( handle -- )
         [ SW_RESTORE ShowWindow win32-error=0/f ]
     } cleave ;
 
-M: windows-ui-backend set-fullscreen* ( ? world -- )
+M: windows-ui-backend (set-fullscreen) ( ? world -- )
-    swap [ enter-fullscreen ] [ exit-fullscreen ] if ;
+    [ enter-fullscreen ] [ exit-fullscreen ] if ;
+
+M: windows-ui-backend (fullscreen?) ( world -- ? )
+    [ handle>> hWnd>> hwnd>RECT ]
+    [ handle>> hWnd>> fullscreen-RECT ] bi
+    [ get-RECT-dimensions 2array 2nip ] bi@ = ;
 
 windows-ui-backend ui-backend set-global
 

basis/ui/backend/x11/x11.factor

@@ -268,10 +268,12 @@ M: x11-ui-backend set-title ( string world -- )
     handle>> window>> swap
     [ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
 
-M: x11-ui-backend set-fullscreen* ( ? world -- )
+M: x11-ui-backend (set-fullscreen) ( world ? -- )
+    [
         handle>> window>> "XClientMessageEvent" <c-object>
         [ set-XClientMessageEvent-window ] keep
-    swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
+    ] dip
+    _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
     over set-XClientMessageEvent-data0
     ClientMessage over set-XClientMessageEvent-type
     dpy get over set-XClientMessageEvent-display

basis/ui/tools/debugger/debugger.factor

@@ -60,7 +60,7 @@ M: debugger focusable-child*
 
 GENERIC: error-in-debugger? ( error -- ? )
 
-M: world-error error-in-debugger? world>> gadget-child debugger? ;
+M: world-error error-in-debugger? world>> children>> [ f ] [ first debugger? ] if-empty ;
 
 M: object error-in-debugger? drop f ;
 

basis/ui/ui-docs.factor

@@ -25,15 +25,15 @@ HELP: world-attributes
     { { $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?
+HELP: set-fullscreen
-{ $values { "?" "a boolean" } { "gadget" gadget } }
+{ $values { "gadget" gadget } { "?" "a boolean" } }
 { $description "Sets and unsets fullscreen mode for the gadget's world." } ;
 
 HELP: fullscreen?
 { $values { "gadget" gadget } { "?" "a boolean" } }
 { $description "Queries the gadget's world to see if it is running in fullscreen mode." } ;
 
-{ fullscreen? set-fullscreen? } related-words
+{ fullscreen? set-fullscreen } related-words
 
 HELP: find-window
 { $values { "quot" { $quotation "( world -- ? )" } } { "world" { $maybe world } } }

basis/ui/ui.factor

@@ -209,11 +209,14 @@ PRIVATE>
 : open-window ( gadget title/attributes -- )
     ?attributes <world> open-world-window ;
 
-: set-fullscreen? ( ? gadget -- )
+: set-fullscreen ( gadget ? -- )
-    find-world set-fullscreen* ;
+    [ find-world ] dip (set-fullscreen) ;
 
 : fullscreen? ( gadget -- ? )
-    find-world fullscreen* ;
+    find-world (fullscreen?) ;
+
+: toggle-fullscreen ( gadget -- )
+    dup fullscreen? not set-fullscreen ;
 
 : raise-window ( gadget -- )
     find-world raise-window* ;

basis/unix/stat/linux/64/64.factor

@@ -2,24 +2,26 @@ USING: kernel alien.syntax math sequences unix
 alien.c-types arrays accessors combinators ;
 IN: unix.stat
 
-! stat64
+! Ubuntu 7.10 64-bit
+
 C-STRUCT: stat
     { "dev_t"     "st_dev" }
-    { "ushort"     "__pad1" }
+    { "ino_t"     "st_ino" }
-    { "__ino_t"     "__st_ino" }
-    { "mode_t"     "st_mode" }
     { "nlink_t"   "st_nlink" }
+    { "mode_t"    "st_mode" }
     { "uid_t"     "st_uid" }
     { "gid_t"     "st_gid" }
+    { "int"       "pad0" }
     { "dev_t"     "st_rdev" }
-    { { "ushort" 2 } "__pad2" }
     { "off64_t"     "st_size" }
     { "blksize_t" "st_blksize" }
     { "blkcnt64_t"  "st_blocks" }
     { "timespec"  "st_atimespec" }
     { "timespec"  "st_mtimespec" }
     { "timespec"  "st_ctimespec" }
-    { "ulonglong"  "st_ino" } ;
+    { "long"      "__unused0" }
+    { "long"      "__unused1" }
+    { "long"      "__unused2" } ;
 
 FUNCTION: int __xstat64  ( int ver, char* pathname, stat* buf ) ;
 FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;

core/classes/predicate/predicate-tests.factor

@@ -1,5 +1,6 @@
-USING: math tools.test classes.algebra words kernel sequences assocs ;
+USING: math tools.test classes.algebra words kernel sequences assocs
-IN: classes.predicate
+accessors eval definitions compiler.units generic ;
+IN: classes.predicate.tests
 
 PREDICATE: negative < integer 0 < ;
 PREDICATE: positive < integer 0 > ;
@@ -19,3 +20,15 @@ M: positive abs ;
 [ 10 ] [ -10 abs ] unit-test
 [ 10 ] [ 10 abs ] unit-test
 [ 0 ] [ 0 abs ] unit-test
+
+! Bug report from Bruno Deferrari
+TUPLE: tuple-a slot ;
+TUPLE: tuple-b < tuple-a ;
+
+PREDICATE: tuple-c < tuple-b slot>> ;
+
+GENERIC: ptest ( tuple -- )
+M: tuple-a ptest drop ;
+IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ;
+
+[ ] [ tuple-b new ptest ] unit-test

core/generic/single/single-tests.factor

@@ -275,3 +275,8 @@ M: growable call-next-hooker call-next-method "growable " prepend ;
 
 [ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
 [ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
+
+! Corner case
+[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
+[ error>> bad-dispatch-position? ]
+must-fail-with

core/generic/single/single.factor

@@ -58,13 +58,13 @@ M: single-combination make-default-method
     ] unless ;
 
 ! 1. Flatten methods
-TUPLE: predicate-engine methods ;
+TUPLE: predicate-engine class methods ;
 
-: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+C: <predicate-engine> predicate-engine
 
 : push-method ( method specializer atomic assoc -- )
-    [
+    dupd [
-        [ H{ } clone <predicate-engine> ] unless*
+        [ ] [ H{ } clone <predicate-engine> ] ?if
         [ methods>> set-at ] keep
     ] change-at ;
 
@@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine
         [ <enum> swap update ] keep
     ] with-variable ;
 
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+SYMBOL: predicate-engines
+
 : sort-methods ( assoc -- assoc' )
     >alist [ keys sort-classes ] keep extract-keys ;
 
 : quote-methods ( assoc -- assoc' )
     [ 1quotation \ drop prefix ] assoc-map ;
 
+: find-predicate-engine ( classes -- word )
+    predicate-engines get [ at ] curry map-find drop ;
+
+: next-predicate-engine ( engine -- word )
+    class>> superclasses
+    find-predicate-engine
+    default get or ;
+
 : methods-with-default ( engine -- assoc )
-    methods>> clone default get object bootstrap-word pick set-at ;
+    [ methods>> clone ] [ next-predicate-engine ] bi
+    object bootstrap-word pick set-at ;
 
 : keep-going? ( assoc -- ? )
     assumed get swap second first class<= ;
@@ -205,8 +218,6 @@ M: tuple-dispatch-engine compile-engine
 : class-predicates ( assoc -- assoc )
     [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
 
-PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
-
 : <predicate-engine-word> ( -- word )
     generic-word get name>> "/predicate-engine" append f <word>
     dup generic-word get "owner-generic" set-word-prop ;
@@ -217,7 +228,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
     [ <predicate-engine-word> ] dip
     [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
 
-M: predicate-engine compile-engine
+: compile-predicate-engine ( engine -- word )
     methods-with-default
     sort-methods
     quote-methods
@@ -225,6 +236,10 @@ M: predicate-engine compile-engine
     class-predicates
     [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
 
+M: predicate-engine compile-engine
+    [ compile-predicate-engine ] [ class>> ] bi
+    [ drop ] [ predicate-engines get set-at ] 2bi ;
+
 M: word compile-engine ;
 
 M: f compile-engine ;
@@ -251,6 +266,7 @@ HOOK: mega-cache-quot combination ( methods -- quot/f )
 
 M: single-combination perform-combination
     [
+        H{ } clone predicate-engines set
         dup generic-word set
         dup build-decision-tree
         [ "decision-tree" set-word-prop ]

core/generic/standard/standard.factor

@@ -6,9 +6,13 @@ generic.single.private quotations kernel.private
 assocs arrays layouts make ;
 IN: generic.standard
 
+ERROR: bad-dispatch-position # ;
+
 TUPLE: standard-combination < single-combination # ;
 
-C: <standard-combination> standard-combination
+: <standard-combination> ( # -- standard-combination )
+    dup 0 < [ bad-dispatch-position ] when
+    standard-combination boa ;
 
 PREDICATE: standard-generic < generic
     "combination" word-prop standard-combination? ;

core/memory/memory-tests.factor

@@ -27,16 +27,8 @@ TUPLE: testing x y z ;
 
 [ save-image-and-exit ] must-fail
 
-[ ] [
-    num-types get [
-        type>class [
-            dup . flush
-            "predicate" word-prop instances [
-                class drop
-            ] each
-        ] when*
-    ] each
-] unit-test
-
 ! Erg's bug
 2 [ [ [ 3 throw ] instances ] must-fail ] times
+
+! Bug found on Windows build box, having too many words in the image breaks 'become'
+[ ] [ 100000 [ f f <word> ] replicate { } { } become drop ] unit-test

extra/game-worlds/game-worlds.factor

@@ -12,12 +12,12 @@ M: game-world draw*
     swap >>tick-slice draw-world ;
 
 M: game-world begin-world
+    open-game-input 
     dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
-    drop
+    drop ;
-    open-game-input ;
+
-
+M: game-world end-world
-M: game-world end-world
+    [ [ stop-loop ] when* f ] change-game-loop
-    close-game-input
+    close-game-input
-    [ [ stop-loop ] when* f ] change-game-loop
     drop ;
 

extra/gesture-logger/gesture-logger.factor

@@ -25,6 +25,7 @@ M: gesture-logger user-input*
 : gesture-logger ( -- )
     [
         <pane> t >>scrolls? dup <scroller>
+        { 450 500 } >>pref-dim
         "Gesture log" open-window
         <pane-stream> <gesture-logger>
         "Gesture input" open-window

extra/irc/client/base/base.factor

@@ -19,7 +19,7 @@ SYMBOL: current-irc-client
 
 UNION: to-target privmsg notice ;
 UNION: to-channel join part topic kick rpl-channel-modes
-                  rpl-notopic rpl-topic rpl-names rpl-names-end ;
+                  topic rpl-names rpl-names-end ;
 UNION: to-one-chat to-target to-channel mode ;
 UNION: to-many-chats nick quit ;
 UNION: to-all-chats irc-end irc-disconnected irc-connected ;

extra/irc/client/chats/chats.factor

@@ -33,7 +33,8 @@ TUPLE: irc-profile server port nickname password ;
 C: <irc-profile> irc-profile
 
 TUPLE: irc-client profile stream in-messages out-messages
-       chats is-running nick connect reconnect-time is-ready
+       chats is-running nick connect is-ready
+       reconnect-time reconnect-attempts
        exceptions ;
 
 : <irc-client> ( profile -- irc-client )
@@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages
         <mailbox>  >>in-messages
         <mailbox>  >>out-messages
         H{ } clone >>chats
-        15 seconds >>reconnect-time
+        30 seconds >>reconnect-time
+        10         >>reconnect-attempts
         V{ } clone >>exceptions
-        [ <inet> latin1 <client> ] >>connect ;
+        [ <inet> latin1 <client> drop ] >>connect ;
 
 SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;

extra/irc/client/internals/internals-tests.factor

@@ -76,7 +76,7 @@ M: mb-writer dispose drop ;
 ! Test connect
 { V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
     "someserver" irc-port "factorbot" f <irc-profile> <irc-client>
-    [ 2drop <test-stream> t ] >>connect
+    [ 2drop <test-stream> ] >>connect
     [
         (connect-irc)
         (do-login)

extra/irc/client/internals/internals.factor

@@ -3,10 +3,17 @@
 USING: accessors assocs arrays concurrency.mailboxes continuations destructors
 hashtables io irc.client.base irc.client.chats irc.messages kernel namespaces
 strings words.symbol irc.messages.base irc.client.participants fry threads
-combinators irc.messages.parser ;
+combinators irc.messages.parser math ;
 EXCLUDE: sequences => join ;
 IN: irc.client.internals
 
+: do-connect ( server port quot: ( host port -- stream ) attempts -- stream/f )
+    dup 0 > [
+        [ drop call( host port -- stream ) ]
+        [ drop 15 sleep 1- do-connect ]
+        recover
+    ] [ 2drop 2drop f ] if ;
+
 : /NICK ( nick -- ) "NICK " prepend irc-print ;
 : /PONG ( text -- ) "PONG " prepend irc-print ;
 
@@ -15,18 +22,27 @@ IN: irc.client.internals
     "USER " prepend " hostname servername :irc.factor" append irc-print ;
 
 : /CONNECT ( server port -- stream )
-    irc> connect>> call( host port -- stream local ) drop ;
+    irc> [ connect>> ] [ reconnect-attempts>> ] bi do-connect ;
 
 : /JOIN ( channel password -- )
     [ " :" swap 3append ] when* "JOIN " prepend irc-print ;
 
+: try-connect ( -- stream/f )
+    irc> profile>> [ server>> ] [ port>> ] bi /CONNECT ;
+
+: (terminate-irc) ( -- )
+    irc> dup is-running>> [
+        f >>is-running
+        [ stream>> dispose ] keep
+        [ in-messages>> ] [ out-messages>> ] bi 2array
+        [ irc-end swap mailbox-put ] each
+    ] [ drop ] if ;
+
 : (connect-irc) ( -- )
-    irc> {
+    try-connect [
-        [ profile>> [ server>> ] [ port>> ] bi /CONNECT ]
+        [ irc> ] dip >>stream t >>is-running
-        [ (>>stream) ]
+        in-messages>> [ irc-connected ] dip mailbox-put
-        [ t swap (>>is-running) ]
+    ] [ (terminate-irc) ] if* ;
-        [ in-messages>> [ irc-connected ] dip mailbox-put ]
-    } cleave ;
 
 : (do-login) ( -- ) irc> nick>> /LOGIN ;
 
@@ -92,9 +108,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
 
 : (handle-disconnect) ( -- )
     irc-disconnected irc> in-messages>> mailbox-put
-    irc> reconnect-time>> sleep
+    (connect-irc) (do-login) ;
-    (connect-irc)
-    (do-login) ;
 
 : handle-disconnect ( error -- ? )
     [ irc> exceptions>> push ] when*
@@ -155,12 +169,4 @@ M: irc-channel-chat remove-chat
     [ part new annotate-message irc-send ]
     [ name>> unregister-chat ] bi ;
 
-: (terminate-irc) ( -- )
-    irc> dup is-running>> [
-        f >>is-running
-        [ stream>> dispose ] keep
-        [ in-messages>> ] [ out-messages>> ] bi 2array
-        [ irc-end swap mailbox-put ] each
-    ] [ drop ] if ;
-
 : (speak) ( message irc-chat -- ) swap annotate-message irc-send ;

extra/irc/logbot/log-line/log-line.factor

@@ -11,6 +11,12 @@ GENERIC: >log-line ( object -- line )
 
 M: irc-message >log-line line>> ;
 
+M: ctcp >log-line
+    [ "CTCP: " % dup sender>> % " " % text>> % ] "" make ;
+
+M: action >log-line
+    [ "* " % dup sender>> % " " % text>> % ] "" make ;
+
 M: privmsg >log-line
     [ "<" % dup sender>> % "> " % text>> % ] "" make ;
 
@@ -35,3 +41,7 @@ M: participant-mode >log-line
 
 M: nick >log-line
     [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;
+
+M: topic >log-line
+    [ "* " % dup sender>> % " has set the topic for " % dup channel>> %
+      ": \"" % topic>> % "\"" % ] "" make ;

extra/irc/logbot/logbot.factor

@@ -16,7 +16,7 @@ SYMBOL: current-stream
     "irc.freenode.org" 6667 "flogger" f <irc-profile> ;
 
 : add-timestamp ( string timestamp -- string )
-    timestamp>hms "[" prepend "] " append prepend ;
+    timestamp>hms [ "[" % % "] " % % ] "" make ;
 
 : timestamp-path ( timestamp -- path )
     timestamp>ymd ".log" append log-directory prepend-path ;
@@ -27,7 +27,7 @@ SYMBOL: current-stream
     ] [
         current-stream get [ dispose ] when*
         [ day-of-year current-day set ]
-        [ timestamp-path latin1 <file-writer> ] bi
+        [ timestamp-path latin1 <file-appender> ] bi
         current-stream set
     ] if current-stream get ;
 

extra/irc/messages/base/base.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes.parser classes.tuple
+USING: accessors arrays assocs calendar classes.parser classes.tuple
        combinators fry generic.parser kernel lexer
        mirrors namespaces parser sequences splitting strings words ;
 IN: irc.messages.base
@@ -51,6 +51,7 @@ M: irc-message post-process-irc-message drop ;
 
 GENERIC: fill-irc-message-slots ( irc-message -- )
 M: irc-message fill-irc-message-slots
+    gmt >>timestamp
     {
         [ process-irc-trailing ]
         [ process-irc-prefix ]

extra/irc/messages/messages-tests.factor

@@ -72,3 +72,6 @@ IN: irc.messages.tests
      { trailing "Nickname is already in use" } } }
 [ ":ircserver.net 433 * nickname :Nickname is already in use"
   string>irc-message f >>timestamp ] unit-test
+
+{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :
ACTION jumps!
"
+        string>irc-message action? ] unit-test

extra/irc/messages/messages.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel fry splitting ascii calendar accessors combinators
-arrays classes.tuple math.order words assocs strings irc.messages.base ;
+arrays classes.tuple math.order words assocs strings irc.messages.base
+combinators.short-circuit math ;
 EXCLUDE: sequences => join ;
 IN: irc.messages
 
@@ -61,8 +62,17 @@ IRC: rpl-names-end       "366" nickname channel : comment ;
 IRC: rpl-nickname-in-use "433" _ name ;
 IRC: rpl-nick-collision  "436" nickname : comment ;
 
+PREDICATE: channel-mode < mode name>> first "#&" member? ;
+PREDICATE: participant-mode < channel-mode parameter>> ;
+PREDICATE: ctcp < privmsg
+    trailing>> { [ length 1 > ] [ first 1 = ] [ peek 1 = ] } 1&& ;
+PREDICATE: action < ctcp trailing>> rest "ACTION" head? ;
+
 M: rpl-names post-process-irc-message ( rpl-names -- )
     [ [ blank? ] trim " " split ] change-nicks drop ;
 
-PREDICATE: channel-mode < mode name>> first "#&" member? ;
+M: ctcp post-process-irc-message ( ctcp -- )
-PREDICATE: participant-mode < channel-mode parameter>> ;
+    [ rest but-last ] change-text drop ;
+
+M: action post-process-irc-message ( action -- )
+    [ 7 tail ] change-text call-next-method ;

extra/irc/messages/parser/parser.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel fry splitting ascii calendar accessors combinators
+USING: kernel fry splitting ascii accessors combinators
        arrays classes.tuple math.order words assocs
        irc.messages.base sequences ;
 IN: irc.messages.parser
@@ -32,4 +32,4 @@ PRIVATE>
     [ >>trailing ]
     tri*
     [ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
-    now >>timestamp dup sender >>sender ;
+    dup sender >>sender ;

extra/jamshred/jamshred.factor

@@ -26,15 +26,6 @@ M: jamshred-gadget draw-gadget* ( gadget -- )
         [ 100 milliseconds sleep jamshred-loop ] tri 
     ] if ;
 
-: fullscreen ( gadget -- )
-    find-world t swap set-fullscreen* ;
-
-: no-fullscreen ( gadget -- )
-    find-world f swap set-fullscreen* ;
-
-: toggle-fullscreen ( world -- )
-    [ fullscreen? not ] keep set-fullscreen* ;
-
 M: jamshred-gadget graft* ( gadget -- )
     [ find-gl-context init-graphics ]
     [ [ jamshred-loop ] curry in-thread ] bi ;
@@ -73,12 +64,12 @@ M: jamshred-gadget ungraft* ( gadget -- )
     [ second mouse-scroll-y ] 2bi ;
 
 : quit ( gadget -- )
-    [ no-fullscreen ] [ close-window ] bi ;
+    [ f set-fullscreen ] [ close-window ] bi ;
 
 jamshred-gadget H{
     { T{ key-down f f "r" } [ jamshred-restart ] }
     { T{ key-down f f " " } [ jamshred>> toggle-running ] }
-    { T{ key-down f f "f" } [ find-world toggle-fullscreen ] }
+    { T{ key-down f f "f" } [ toggle-fullscreen ] }
     { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
     { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
     { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }

extra/mason/build/build.factor

@@ -15,7 +15,7 @@ QUALIFIED: continuations
 : enter-build-dir  ( -- ) build-dir set-current-directory ;
 
 : clone-builds-factor ( -- )
-    "git" "clone" builds/factor 3array try-output-process ;
+    "git" "clone" builds/factor 3array short-running-process ;
 
 : begin-build ( -- )
     "factor" [ git-id ] with-directory

extra/mason/cleanup/cleanup.factor

@@ -6,7 +6,7 @@ mason.common mason.config mason.platform namespaces ;
 IN: mason.cleanup
 
 : compress ( filename -- )
-    dup exists? [ "bzip2" swap 2array try-output-process ] [ drop ] if ;
+    dup exists? [ "bzip2" swap 2array short-running-process ] [ drop ] if ;
 
 : compress-image ( -- )
     boot-image-name compress ;

extra/mason/common/common.factor

@@ -10,25 +10,25 @@ IN: mason.common
 
 SYMBOL: current-git-id
 
+: short-running-process ( command -- )
+    #! Give network operations and shell commands at most
+    #! 15 minutes to complete, to catch hangs.
+    >process
+        15 minutes >>timeout
+        +closed+ >>stdin
+    try-output-process ;
+
 HOOK: really-delete-tree os ( path -- )
 
 M: windows really-delete-tree
     #! Workaround: Cygwin GIT creates read-only files for
     #! some reason.
-    [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
+    [ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix short-running-process ]
     [ delete-tree ]
     bi ;
 
 M: unix really-delete-tree delete-tree ;
 
-: short-running-process ( command -- )
-    #! Give network operations at most 15 minutes to complete.
-    <process>
-        swap >>command
-        15 minutes >>timeout
-        +closed+ >>stdin
-    try-output-process ;
-
 : retry ( n quot -- )
     '[ drop @ f ] attempt-all drop ; inline
 
@@ -79,8 +79,8 @@ SYMBOL: stamp
     with-directory ;
 
 : git-id ( -- id )
-    { "git" "show" } utf8 [ readln ] with-process-reader
+    { "git" "show" } utf8 [ lines ] with-process-reader
-    " " split second ;
+    first " " split second ;
 
 : ?prepare-build-machine ( -- )
     builds/factor exists? [ prepare-build-machine ] unless ;

extra/mason/help/help.factor

@@ -6,7 +6,7 @@ IN: mason.help
 
 : make-help-archive ( -- )
     "factor/temp" [
-        { "tar" "cfz" "docs.tar.gz" "docs" } try-output-process
+        { "tar" "cfz" "docs.tar.gz" "docs" } short-running-process
     ] with-directory ;
 
 : upload-help-archive ( -- )

extra/mason/notify/notify.factor

@@ -18,7 +18,7 @@ IN: mason.notify
             <process>
                 _ [ +closed+ ] unless* >>stdin
                 _ >>command
-            try-output-process
+            short-running-process
         ] retry
     ] [ 2drop ] if ;
 
@@ -42,8 +42,10 @@ IN: mason.notify
 : notify-report ( status -- )
     [ "Build finished with status: " write . flush ]
     [
-        [ "report" utf8 file-contents ] dip email-report
+        [ "report" ] dip
-        "report" { "report" } status-notify
+        [ [ utf8 file-contents ] dip email-report ]
+        [ "report" swap name>> 2array status-notify ]
+        2bi
     ] bi ;
 
 : notify-release ( archive-name -- )

extra/mason/notify/server/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/mason/notify/server/server.factor

@@ -0,0 +1,82 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors combinators combinators.smart command-line db
+db.sqlite db.tuples db.types io kernel namespaces sequences ;
+IN: mason.notify.server
+
+CONSTANT: +starting+ "starting"
+CONSTANT: +make-vm+ "make-vm"
+CONSTANT: +boot+ "boot"
+CONSTANT: +test+ "test"
+CONSTANT: +clean+ "clean"
+CONSTANT: +dirty+ "dirty"
+
+TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
+
+builder "BUILDERS" {
+    { "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
+    { "os" "OS" TEXT +user-assigned-id+ }
+    { "cpu" "CPU" TEXT +user-assigned-id+ }
+    { "clean-git-id" "CLEAN_GIT_ID" TEXT }
+    { "last-git-id" "LAST_GIT_ID" TEXT }
+    { "last-report" "LAST_REPORT" TEXT }
+    { "current-git-id" "CURRENT_GIT_ID" TEXT }
+    { "status" "STATUS" TEXT }
+} define-persistent
+
+SYMBOLS: host-name target-os target-cpu message message-arg ;
+
+: parse-args ( command-line -- )
+    dup peek message-arg set
+    [
+        {
+            [ host-name set ]
+            [ target-cpu set ]
+            [ target-os set ]
+            [ message set ]
+        } spread
+    ] input<sequence ;
+
+: find-builder ( -- builder )
+    builder new
+        host-name get >>host-name
+        target-os get >>os
+        target-cpu get >>cpu
+    dup select-tuple [ ] [ dup insert-tuple ] ?if ;
+
+: git-id ( builder id -- )
+    >>current-git-id +starting+ >>status drop ;
+
+: make-vm ( builder -- ) +make-vm+ >>status drop ;
+
+: boot ( report -- ) +boot+ >>status drop ;
+
+: test ( report -- ) +test+ >>status drop ;
+
+: report ( builder status content -- )
+    [ >>status ] [ >>last-report ] bi*
+    dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
+    dup current-git-id>> >>last-git-id
+    drop ;
+
+: update-builder ( builder -- )
+    message get {
+        { "git-id" [ message-arg get git-id ] }
+        { "make-vm" [ make-vm ] }
+        { "boot" [ boot ] }
+        { "test" [ test ] }
+        { "report" [ message-arg get contents report ] }
+    } case ;
+
+: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
+
+: handle-update ( command-line -- )
+    mason-db [
+        parse-args find-builder
+        [ update-builder ] [ update-tuple ] bi
+    ] with-db ;
+
+: main ( -- )
+    command-line get handle-update ;
+
+MAIN: main

extra/mason/platform/platform.factor

@@ -1,11 +1,14 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel system accessors namespaces splitting sequences
-mason.config bootstrap.image ;
+mason.config bootstrap.image assocs ;
 IN: mason.platform
 
+: (platform) ( os cpu -- string )
+    { { CHAR: . CHAR: - } } substitute "-" glue ;
+
 : platform ( -- string )
-    target-os get "-" target-cpu get "." split "-" join 3append ;
+    target-os get target-cpu get (platform) ;
 
 : gnu-make ( -- string )
     target-os get { "freebsd" "openbsd" "netbsd" } member? "gmake" "make" ? ;

extra/mason/release/archive/archive.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2008 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators io.directories
+USING: arrays combinators locals io.directories
 io.directories.hierarchy io.files io.launcher io.pathnames
 kernel make mason.common mason.config mason.platform namespaces
 prettyprint sequences ;
@@ -18,21 +18,20 @@ IN: mason.release.archive
 
 : archive-name ( -- string ) base-name extension append ;
 
-: make-windows-archive ( archive-name -- )
+:: make-windows-archive ( archive-name -- )
-    [ "zip" , "-r" , , "factor" , ] { } make try-output-process ;
+    { "zip" "-r" archive-name "factor" } short-running-process ;
+
+:: make-disk-image ( archive-name volume-name dmg-root -- )
+    { "hdiutil" "create" "-srcfolder" dmg-root "-fs" "HFS+" "-volname" volume-name archive-name } short-running-process ;
 
 : make-macosx-archive ( archive-name -- )
-    { "mkdir" "dmg-root" } try-output-process
+    "dmg-root" make-directory
-    { "cp" "-R" "factor" "dmg-root" } try-output-process
+    "factor" "dmg-root" copy-tree-into
-    { "hdiutil" "create"
+    "factor" "dmg-root" make-disk-image
-        "-srcfolder" "dmg-root"
-        "-fs" "HFS+"
-    "-volname" "factor" }
-    swap suffix try-output-process
     "dmg-root" really-delete-tree ;
 
-: make-unix-archive ( archive-name -- )
+:: make-unix-archive ( archive-name -- )
-    [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ;
+    { "tar" "-cvzf" archive-name "factor" } short-running-process ;
 
 : make-archive ( archive-name -- )
     target-os get {

extra/mason/report/report.factor

@@ -34,7 +34,7 @@ IN: mason.report
 :: failed-report ( error file what -- status )
     [
         error [ error. ] with-string-writer :> error
-        file utf8 file-contents 400 short tail* :> output
+        file utf8 file-lines 400 short tail* :> output
         
         [XML
         <h2><-what-></h2>

extra/redis/assoc/assoc.factor

@@ -0,0 +1,22 @@
+! Copyright (C) 2009 Bruno Deferrari
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel redis sequences ;
+IN: redis.assoc
+
+INSTANCE: redis assoc
+
+M: redis at* [ redis-get dup >boolean ] with-redis ;
+
+M: redis assoc-size [ redis-dbsize ] with-redis ;
+
+M: redis >alist [ "*" redis-keys dup redis-mget zip ] with-redis ;
+
+M: redis set-at [ redis-set drop ] with-redis ;
+
+M: redis delete-at [ redis-del drop ] with-redis ;
+
+M: redis clear-assoc [ redis-flushdb drop ] with-redis ;
+
+M: redis equal? assoc= ;
+
+M: redis hashcode* assoc-hashcode ;

extra/redis/assoc/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/redis/assoc/summary.txt

@@ -0,0 +1 @@
+Assoc protocol implementation for Redis

extra/redis/redis.factor

@@ -1,6 +1,8 @@
 ! Copyright (C) 2009 Bruno Deferrari
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io redis.response-parser redis.command-writer ;
+USING: accessors io io.encodings.8-bit io.sockets
+io.streams.duplex kernel redis.command-writer
+redis.response-parser splitting ;
 IN: redis
 
 #! Connection
@@ -23,7 +25,7 @@ IN: redis
 : redis-type ( key -- response ) type flush read-response ;
 
 #! Key space
-: redis-keys ( pattern -- response ) keys flush read-response ;
+: redis-keys ( pattern -- response ) keys flush read-response " " split ;
 : redis-randomkey ( -- response ) randomkey flush read-response ;
 : redis-rename ( newkey key -- response ) rename flush read-response ;
 : redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
@@ -72,3 +74,24 @@ IN: redis
 #! Remote server control
 : redis-info ( -- response ) info flush read-response ;
 : redis-monitor ( -- response ) monitor flush read-response ;
+
+#! Redis object
+TUPLE: redis host port encoding password ;
+
+CONSTANT: default-redis-port 6379
+
+: <redis> ( -- redis )
+    redis new
+        "127.0.0.1" >>host
+        default-redis-port >>port
+        latin1 >>encoding ;
+
+: redis-do-connect ( redis -- stream )
+    [ host>> ] [ port>> ] [ encoding>> ] tri
+    [ <inet> ] dip <client> drop ;
+
+: with-redis ( redis quot -- )
+    [
+        [ redis-do-connect ] [ password>> ] bi
+        [ swap [ [ redis-auth drop ] with-stream* ] keep ] when*
+    ] dip with-stream ; inline

extra/terrain/shaders/shaders.factor

@@ -11,7 +11,8 @@ void main()
     vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0);
     gl_Position = v;
 
-    vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1);
+    vec4 p = gl_ProjectionMatrixInverse * v;
+    p.z = -abs(p.z);
     
     float s = sin(sky_theta), c = cos(sky_theta);
     direction = mat3(1, 0, 0,  0, c, s,  0, -s, c)

extra/terrain/terrain.factor

@@ -6,7 +6,7 @@ opengl.shaders opengl.textures opengl.textures.private
 sequences sequences.product specialized-arrays.float
 terrain.generation terrain.shaders ui ui.gadgets
 ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
-math.affine-transforms noise ;
+math.affine-transforms noise ui.gestures ;
 IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
@@ -18,7 +18,7 @@ CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
 CONSTANT: JUMP $[ 1.0 1024.0 / ]
 CONSTANT: MOUSE-SCALE $[ 1.0 10.0 / ]
 CONSTANT: MOVEMENT-SPEED $[ 1.0 16384.0 / ]
-CONSTANT: FRICTION 0.95
+CONSTANT: FRICTION { 0.95 0.99 0.95 }
 CONSTANT: COMPONENT-SCALE { 0.5 0.01 0.0005 0.0 }
 CONSTANT: SKY-PERIOD 1200
 CONSTANT: SKY-SPEED 0.0005
@@ -28,7 +28,7 @@ CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] }
 CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
 
 TUPLE: player
-    location yaw pitch velocity ;
+    location yaw pitch velocity velocity-modifier ;
 
 TUPLE: terrain-world < game-world
     player
@@ -100,10 +100,13 @@ M: terrain-world tick-length
 
 : forward-vector ( player -- v )
     yaw>> 0.0
-    { 0.0 0.0 $ MOVEMENT-SPEED } vneg eye-rotate ;
+    ${ 0.0 0.0 MOVEMENT-SPEED } vneg eye-rotate ;
 : rightward-vector ( player -- v )
     yaw>> 0.0
-    { $ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
+    ${ MOVEMENT-SPEED 0.0 0.0 } eye-rotate ;
+: clamp-pitch ( pitch -- pitch' )
+    90.0 min -90.0 max ;
+
 
 : walk-forward ( player -- )
     dup forward-vector [ v+ ] curry change-velocity drop ;
@@ -114,30 +117,53 @@ M: terrain-world tick-length
 : walk-rightward ( player -- )
     dup rightward-vector [ v+ ] curry change-velocity drop ;
 : jump ( player -- )
-    [ { 0.0 $ JUMP 0.0 } v+ ] change-velocity drop ;
+    [ ${ 0.0 JUMP 0.0 } v+ ] change-velocity drop ;
+: rotate-leftward ( player x -- )
+    [ - ] curry change-yaw drop ;
+: rotate-rightward ( player x -- )
+    [ + ] curry change-yaw drop ;
+: look-horizontally ( player x -- )
+    [ + ] curry change-yaw drop ;
+: look-vertically ( player x -- )
+    [ + clamp-pitch ] curry change-pitch drop ;
 
-: clamp-pitch ( pitch -- pitch' )
-    90.0 min -90.0 max ;
 
 : rotate-with-mouse ( player mouse -- )
-    [ dx>> MOUSE-SCALE * [ + ] curry change-yaw ]
+    [ dx>> MOUSE-SCALE * look-horizontally ]
-    [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi
+    [ dy>> MOUSE-SCALE * look-vertically ] 2bi ;
-    drop ;
+
+
+terrain-world H{
+    { T{ key-down { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] }
+} set-gestures
 
 :: handle-input ( world -- )
     world player>> :> player
     read-keyboard keys>> :> keys
+    key-left-shift keys nth [
+        { 2.0 1.0 2.0 } player (>>velocity-modifier)
+    ] when
+    key-left-shift keys nth [
+        { 1.0 1.0 1.0 } player (>>velocity-modifier)
+    ] unless
+
     key-w keys nth [ player walk-forward ] when 
     key-s keys nth [ player walk-backward ] when 
     key-a keys nth [ player walk-leftward ] when 
     key-d keys nth [ player walk-rightward ] when 
+    key-q keys nth [ player -1 look-horizontally ] when 
+    key-e keys nth [ player 1 look-horizontally ] when 
+    key-left-arrow keys nth [ player -1 look-horizontally ] when 
+    key-right-arrow keys nth [ player 1 look-horizontally ] when 
+    key-down-arrow keys nth [ player 1 look-vertically ] when 
+    key-up-arrow keys nth [ player -1 look-vertically ] when 
     key-space keys nth [ player jump ] when 
     key-escape keys nth [ world close-window ] when
     player read-mouse rotate-with-mouse
     reset-mouse ;
 
 : apply-friction ( velocity -- velocity' )
-    FRICTION v*n ;
+    FRICTION v* ;
 
 : apply-gravity ( velocity -- velocity' )
     1 over [ GRAVITY - ] change-nth ;
@@ -170,9 +196,12 @@ M: terrain-world tick-length
     [ [ 1 ] 2dip [ max ] with change-nth ]
     [ ] tri ;
 
+: scaled-velocity ( player -- velocity )
+    [ velocity>> ] [ velocity-modifier>> ] bi v* ;
+
 : tick-player ( world player -- )
     [ apply-friction apply-gravity ] change-velocity
-    dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
+    dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
     drop ;
 
 M: terrain-world tick*
@@ -197,7 +226,7 @@ BEFORE: terrain-world begin-world
     GL_DEPTH_TEST glEnable
     GL_TEXTURE_2D glEnable
     GL_VERTEX_ARRAY glEnableClientState
-    PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
+    PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player
     <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
     [ >>sky-image ] keep
     make-texture [ set-texture-parameters ] keep >>sky-texture

extra/webapps/mason/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

extra/webapps/mason/mason.factor

@@ -0,0 +1,84 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators db db.tuples furnace.actions
+http.server.responses kernel mason.platform mason.notify.server
+math.order sequences sorting splitting xml.syntax xml.writer
+io.pathnames io.encodings.utf8 io.files ;
+IN: webapps.mason
+
+: log-file ( -- path ) home "mason.log" append-path ;
+
+: recent-events ( -- xml )
+    log-file utf8 file-lines 10 short tail* "\n" join [XML <pre><-></pre> XML] ;
+
+: git-link ( id -- link )
+    [ "http://github.com/slavapestov/factor/commit/" prepend ] keep
+    [XML <a href=<->><-></a> XML] ;
+
+: building ( builder string -- xml )
+    swap current-git-id>> git-link
+    [XML <-> for <-> XML] ;
+
+: current-status ( builder -- xml )
+    dup status>> {
+        { "dirty" [ drop "Dirty" ] }
+        { "clean" [ drop "Clean" ] }
+        { "starting" [ "Starting" building ] }
+        { "make-vm" [ "Compiling VM" building ] }
+        { "boot" [ "Bootstrapping" building ] }
+        { "test" [ "Testing" building ] }
+        [ 2drop "Unknown" ]
+    } case ;
+
+: binaries-link ( builder -- link )
+    [ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
+    dup [XML <a href=<->><-></a> XML] ;
+
+: clean-image-link ( builder -- link )
+    [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
+    dup [XML <a href=<->><-></a> XML] ;
+
+: machine-table ( builder -- xml )
+    {
+        [ os>> ]
+        [ cpu>> ]
+        [ host-name>> "." split1 drop ]
+        [ current-status ]
+        [ last-git-id>> dup [ git-link ] when ]
+        [ clean-git-id>> dup [ git-link ] when ]
+        [ binaries-link ]
+        [ clean-image-link ]
+    } cleave
+    [XML
+    <h2><-> / <-></h2>
+    <table border="1">
+    <tr><td>Host name:</td><td><-></td></tr>
+    <tr><td>Current status:</td><td><-></td></tr>
+    <tr><td>Last build:</td><td><-></td></tr>
+    <tr><td>Last clean build:</td><td><-></td></tr>
+    <tr><td>Binaries:</td><td><-></td></tr>
+    <tr><td>Clean images:</td><td><-></td></tr>
+    </table>
+    XML] ;
+
+: machine-report ( -- xml )
+    builder new select-tuples
+    [ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
+    [ machine-table ] map ;
+
+: build-farm-report ( -- xml )
+    recent-events
+    machine-report
+    [XML
+    <html>
+    <head><title>Factor build farm</title></head>
+    <body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
+    </html>
+    XML] ;
+
+: <build-farm-report-action> ( -- action )
+    <action>
+        [
+            mason-db [ build-farm-report xml>string ] with-db
+            "text/html" <content>
+        ] >>display ;

vm/Config.netbsd

@@ -2,4 +2,4 @@ include vm/Config.unix
 PLAF_DLL_OBJS += vm/os-genunix.o vm/os-netbsd.o
 CFLAGS += -export-dynamic
 LIBPATH = -L/usr/X11R6/lib -Wl,-rpath,/usr/X11R6/lib -L/usr/pkg/lib -Wl,-rpath,/usr/pkg/lib
-LIBS = -lm -lopenal -lalut $(X11_UI_LIBS)
+LIBS = -lm -lssl -lcrypto $(X11_UI_LIBS)

vm/arrays.hpp

@@ -34,7 +34,7 @@ struct growable_array {
 	cell count;
 	gc_root<array> elements;
 
-	growable_array() : count(0), elements(allot_array(2,F)) {}
+	growable_array(cell capacity = 10) : count(0), elements(allot_array(capacity,F)) {}
 
 	void add(cell elt);
 	void trim();

vm/byte_arrays.hpp

@@ -7,12 +7,11 @@ PRIMITIVE(byte_array);
 PRIMITIVE(uninitialized_byte_array);
 PRIMITIVE(resize_byte_array);
 
-/* Macros to simulate a byte vector in C */
 struct growable_byte_array {
 	cell count;
 	gc_root<byte_array> elements;
 
-	growable_byte_array() : count(0), elements(allot_byte_array(2)) { }
+	growable_byte_array(cell capacity = 40) : count(0), elements(allot_byte_array(capacity)) { }
 
 	void append_bytes(void *elts, cell len);
 	void append_byte_array(cell elts);

vm/callstack.cpp

@@ -11,22 +11,6 @@ static void check_frame(stack_frame *frame)
 #endif
 }
 
-void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
-{
-	stack_frame *frame = (stack_frame *)bottom - 1;
-
-	while((cell)frame >= top)
-	{
-		iterator(frame);
-		frame = frame_successor(frame);
-	}
-}
-
-void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
-{
-	iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
-}
-
 callstack *allot_callstack(cell size)
 {
 	callstack *stack = allot<callstack>(callstack_size(size));
@@ -138,36 +122,39 @@ cell frame_scan(stack_frame *frame)
 		return F;
 }
 
-/* C doesn't have closures... */
+namespace
-static cell frame_count;
-
-void count_stack_frame(stack_frame *frame)
 {
-	frame_count += 2; 
+
+struct stack_frame_counter {
+	cell count;
+	stack_frame_counter() : count(0) {}
+	void operator()(stack_frame *frame) { count += 2; }
+};
+
+struct stack_frame_accumulator {
+	cell index;
+	array *frames;
+	stack_frame_accumulator(cell count) : index(0), frames(allot_array_internal<array>(count)) {}
+	void operator()(stack_frame *frame)
+	{
+		set_array_nth(frames,index++,frame_executing(frame));
+		set_array_nth(frames,index++,frame_scan(frame));
 	}
+};
 
-static cell frame_index;
-static array *frames;
-
-void stack_frame_to_array(stack_frame *frame)
-{
-	set_array_nth(frames,frame_index++,frame_executing(frame));
-	set_array_nth(frames,frame_index++,frame_scan(frame));
 }
 
 PRIMITIVE(callstack_to_array)
 {
 	gc_root<callstack> callstack(dpop());
 
-	frame_count = 0;
+	stack_frame_counter counter;
-	iterate_callstack_object(callstack.untagged(),count_stack_frame);
+	iterate_callstack_object(callstack.untagged(),counter);
 
-	frames = allot_array_internal<array>(frame_count);
+	stack_frame_accumulator accum(counter.count);
+	iterate_callstack_object(callstack.untagged(),accum);
 
-	frame_index = 0;
+	dpush(tag<array>(accum.frames));
-	iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
-
-	dpush(tag<array>(frames));
 }
 
 stack_frame *innermost_stack_frame(callstack *stack)