Fix conflict

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>> 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/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/editors/gvim/gvim.factor

@@ -11,7 +11,10 @@ SINGLETON: gvim
 HOOK: gvim-path io-backend ( -- path )
 
 M: gvim vim-command ( file line -- string )
-    [ gvim-path , "+" swap number>string append , , ] { } make ;
+    [
+        gvim-path ,
+        number>string "+" prepend , ,
+    ] { } make ;
 
 gvim vim-editor set-global
 

basis/editors/macvim/macvim.factor

@@ -3,11 +3,9 @@ namespaces prettyprint editors make ;
 
 IN: editors.macvim
 
-: macvim-location ( file line -- )
+: macvim ( file line -- )
     drop
     [ "open" , "-a" , "MacVim", , ] { } make
-    try-process ;
+    run-detached drop ;
-
-[ macvim-location ] edit-hook set-global
-
 
+[ macvim ] edit-hook set-global

basis/editors/scite/scite.factor

@@ -25,7 +25,7 @@ IN: editors.scite
         number>string "-goto:" prepend ,
     ] { } make ;
 
-: scite-location ( file line -- )
+: scite ( file line -- )
     scite-command run-detached drop ;
 
-[ scite-location ] edit-hook set-global
+[ scite ] edit-hook set-global

basis/editors/textedit/textedit.factor

@@ -2,9 +2,9 @@ USING: definitions io.launcher kernel math math.parser parser
 namespaces prettyprint editors make ;
 IN: editors.textedit
 
-: textedit-location ( file line -- )
+: textedit ( file line -- )
     drop
     [ "open" , "-a" , "TextEdit", , ] { } make
-    try-process ;
+    run-detached drop ;
 
-[ textedit-location ] edit-hook set-global
+[ textedit ] edit-hook set-global

basis/editors/textmate/textmate.factor

@@ -1,10 +1,9 @@
 USING: definitions io.launcher kernel math math.parser parser
 namespaces prettyprint editors make ;
-
 IN: editors.textmate
 
-: textmate-location ( file line -- )
+: textmate ( file line -- )
     [ "mate" , "-a" , "-l" , number>string , , ] { } make
-    try-process ;
+    run-detached drop ;
 
-[ textmate-location ] edit-hook set-global
+[ textmate ] edit-hook set-global

basis/editors/vim/vim-docs.factor

@@ -3,7 +3,7 @@ USING: definitions editors help help.markup help.syntax io io.files
 IN: editors.vim
 
 ARTICLE: { "vim" "vim" } "Vim support"
-"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable.  The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
+"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable.  The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
 $nl
 "If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
 { $code

basis/editors/vim/vim.factor

@@ -4,7 +4,6 @@ make ;
 IN: editors.vim
 
 SYMBOL: vim-path
-
 SYMBOL: vim-editor
 HOOK: vim-command vim-editor ( file line -- array )
 
@@ -12,12 +11,13 @@ SINGLETON: vim
 
 M: vim vim-command
     [
-        vim-path get , swap , "+" swap number>string append ,
+        vim-path get ,
+        [ , ] [ number>string "+" prepend , ] bi*
     ] { } make ;
 
-: vim-location ( file line -- )
+: vim ( file line -- )
-    vim-command try-process ;
+    vim-command run-detached drop ;
 
 "vim" vim-path set-global
-[ vim-location ] edit-hook set-global
+[ vim ] edit-hook set-global
-vim vim-editor set-global
+\ vim vim-editor set-global

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 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
@@ -12,10 +12,11 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
 
 iokit-game-input-backend game-input-backend set-global
 
-: hid-manager-matching ( matching-seq -- alien )
+: make-hid-manager ( -- alien )
-    f 0 IOHIDManagerCreate
+    f 0 IOHIDManagerCreate ;
-    [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
+
-    keep ;
+: set-hid-manager-matching ( alien matching-seq -- )
+    >plist IOHIDManagerSetDeviceMatchingMultiple ;
 
 : devices-from-hid-manager ( manager -- vector )
     [
@@ -85,9 +86,6 @@ CONSTANT: hat-switch-matching-hash
 : ?hat-switch ( device -- ? )
     hat-switch-matching-hash ?axis ;
 
-: hid-manager-matching-game-devices ( -- alien )
-    game-devices-matching-seq hid-manager-matching ;
-
 : device-property ( device key -- value )
     <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
 : element-property ( element key -- value )
@@ -186,7 +184,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,15 +283,16 @@ 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 {
+    make-hid-manager {
         [ initialize-variables ]
         [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
         [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
         [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
         [ 0 IOHIDManagerOpen mach-error ]
+        [ game-devices-matching-seq set-hid-manager-matching ]
         [
             CFRunLoopGetMain CFRunLoopDefaultMode
             IOHIDManagerScheduleWithRunLoop

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/tools/files/files.factor

@@ -74,7 +74,7 @@ M: object file-spec>string ( file-listing spec -- string )
 
 : list-files-slow ( listing-tool -- array )
     [ path>> ] [ sort>> ] [ specs>> ] tri '[
-            [ dup name>> file-info file-listing boa ] map
+        [ dup name>> link-info file-listing boa ] map
         _ [ sort-by ] when*
         [ _ [ file-spec>string ] with map ] map
     ] with-directory-entries ; inline
@@ -115,11 +115,14 @@ SYMBOLS: +device-name+ +mount-point+ +type+
     [ file-systems-info ]
     [ [ unparse ] map ] bi prefix simple-table. ;
 
-: file-systems. ( -- )
+CONSTANT: default-file-systems-spec
     {
         +device-name+ +available-space+ +free-space+ +used-space+
         +total-space+ +percent-used+ +mount-point+
-    } print-file-systems ;
+    }
+
+: file-systems. ( -- )
+    default-file-systems-spec print-file-systems ;
 
 {
     { [ os unix? ] [ "tools.files.unix" ] }

basis/ui/backend/cocoa/cocoa.factor

@@ -99,7 +99,9 @@ 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 ? -- )
     [ enter-fullscreen ] [ exit-fullscreen ] if ;
@@ -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
     ]
 }
 

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

@@ -6,13 +6,15 @@ 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 ui.gestures ;
+math.affine-transforms noise ui.gestures combinators.short-circuit ;
 IN: terrain
 
 CONSTANT: FOV $[ 2.0 sqrt 1+ ]
 CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
 CONSTANT: FAR-PLANE 2.0
 CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: VELOCITY-MODIFIER-NORMAL { 1.0 1.0 1.0 }
+CONSTANT: VELOCITY-MODIFIER-FAST { 2.0 1.0 2.0 }
 CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
 CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
 CONSTANT: JUMP $[ 1.0 1024.0 / ]
@@ -28,13 +30,23 @@ 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 velocity-modifier ;
+    location yaw pitch velocity velocity-modifier
+    reverse-time ;
 
 TUPLE: terrain-world < game-world
     player
     sky-image sky-texture sky-program
     terrain terrain-segment terrain-texture terrain-program
-    terrain-vertex-buffer ;
+    terrain-vertex-buffer
+    history ;
+
+: <player> ( -- player )
+    player new
+        PLAYER-START-LOCATION >>location
+        0.0 >>yaw
+        0.0 >>pitch
+        { 0.0 0.0 0.0 } >>velocity
+        VELOCITY-MODIFIER-NORMAL >>velocity-modifier ;
 
 M: terrain-world tick-length
     drop 1000 30 /i ;
@@ -134,18 +146,23 @@ M: terrain-world tick-length
 
 
 terrain-world H{
-    { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] }
+    { 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)
+    key-left-shift keys nth
-    ] when
+    VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier)
-    key-left-shift keys nth [
+
-        { 1.0 1.0 1.0 } player (>>velocity-modifier)
+    {
-    ] unless
+        [ key-1 keys nth 1  f ? ]
+        [ key-2 keys nth 2  f ? ]
+        [ key-3 keys nth 3  f ? ]
+        [ key-4 keys nth 4  f ? ]
+        [ key-5 keys nth 10000 f ? ]
+    } 0|| player (>>reverse-time)
 
     key-w keys nth [ player walk-forward ] when 
     key-s keys nth [ player walk-backward ] when 
@@ -199,11 +216,30 @@ terrain-world H{
 : scaled-velocity ( player -- velocity )
     [ velocity>> ] [ velocity-modifier>> ] bi v* ;
 
-: tick-player ( world player -- )
+: save-history ( world player -- )
+    clone swap history>> push ;
+
+:: tick-player-reverse ( world player -- )
+    player reverse-time>> :> reverse-time
+    world history>> :> history
+    history length 0 > [
+        history length reverse-time 1 - - 1 max history set-length
+        history pop world (>>player)
+    ] when ;
+
+: tick-player-forward ( world player -- )
+    2dup save-history
     [ apply-friction apply-gravity ] change-velocity
     dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
     drop ;
 
+: tick-player ( world player -- )
+    dup reverse-time>> [
+        tick-player-reverse
+    ] [
+        tick-player-forward
+    ] if ;
+
 M: terrain-world tick*
     [ dup focused?>> [ handle-input ] [ drop ] if ]
     [ dup player>> tick-player ] bi ;
@@ -226,7 +262,8 @@ 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 } { 1.0 1.0 1.0 } player boa >>player
+    <player> >>player
+    V{ } clone >>history
     <perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
     [ >>sky-image ] keep
     make-texture [ set-texture-parameters ] keep >>sky-texture