diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 769efcbb04..a5b1b43acd 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/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 read-bit ] unit-test -[ 254 8 t ] -[ B{ 254 } binary 8 swap read-bits ] unit-test - -[ 4095 12 t ] -[ B{ 255 255 } binary 12 swap read-bits ] unit-test - -[ B{ 254 } ] +[ BIN: 1111111111 ] [ - binary 254 8 rot - [ write-bits ] keep stream>> >byte-array + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 10 swap peek ] unit-test -[ 255 8 t ] -[ B{ 255 } binary 8 swap read-bits ] unit-test +[ BIN: 111111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 9 swap peek +] unit-test -[ 255 8 f ] -[ B{ 255 } binary 9 swap read-bits ] unit-test +[ BIN: 11111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 8 swap peek +] unit-test + +[ BIN: 1111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 7 swap peek +] unit-test + +[ BIN: 111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 6 swap peek +] unit-test + +[ BIN: 11111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 5 swap peek +] unit-test + +[ B{ } 5 swap peek ] must-fail +[ B{ } 1 swap peek ] must-fail +[ B{ } 8 swap peek ] must-fail + +[ 0 ] [ B{ } 0 swap peek ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 7113b650fd..300ab5c1bf 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/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 -math sequences ; +USING: accessors alien.accessors assocs byte-arrays combinators +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: bitstream-reader < bitstream ; +TUPLE: widthed { bits integer read-only } { #bits integer read-only } ; -: reset-bitstream ( stream -- stream ) - 0 >>#bits 0 >>current-bits ; inline +ERROR: invalid-widthed bits #bits ; -: 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 ; + +: ( bits #bits -- widthed ) + check-widthed + widthed boa ; + +: zero-widthed ( -- widthed ) 0 0 ; +: 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 - reset-bitstream ; inline + BV{ } clone >>bytes + 0 0 >>widthed ; inline -M: bitstream-reader dispose ( stream -- ) - stream>> dispose ; +: ( -- bs ) + msb0-bit-writer new-bit-writer ; -: ( stream -- bitstream ) - bitstream-reader new-bitstream ; inline +: ( -- bs ) + lsb0-bit-writer new-bit-writer ; -: read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 [ - >>current-bits 8 >>#bits +GENERIC: peek ( n bitstream -- value ) +GENERIC: poke ( value n bitstream -- ) + +: seek ( n bitstream -- ) + { + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] + [ (>>byte-pos) ] + } cleave ; inline + +: read ( n bitstream -- value ) + [ peek ] [ seek ] 2bi ; inline + +> ] dip < [ not-enough-bits ] when + [ [ bits>> ] [ #bits>> ] bi ] dip + [ - neg shift ] keep ; + +: split-widthed ( widthed n -- widthed1 widthed2 ) + 2dup [ #bits>> ] dip < [ + drop zero-widthed ] [ - 0 >>#bits - t >>end-of-stream? - ] 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 ; - -: ( 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 + [ widthed-bits ] + [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] 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 + ; + +PRIVATE> + +M:: lsb0-bit-writer poke ( value n bs -- ) + value n :> 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>> ; diff --git a/basis/circular/circular-docs.factor b/basis/circular/circular-docs.factor index c7af57c1fe..235d5db2c7 100644 --- a/basis/circular/circular-docs.factor +++ b/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 } "Changing the start index:" { $subsection change-circular-start } +{ $subsection rotate-circular } "Pushing new elements:" { $subsection push-circular } { $subsection push-growing-circular } ; diff --git a/basis/circular/circular-tests.factor b/basis/circular/circular-tests.factor index 105e3790aa..3a94e14640 100644 --- a/basis/circular/circular-tests.factor +++ b/basis/circular/circular-tests.factor @@ -12,6 +12,7 @@ circular strings ; [ CHAR: e ] [ "test" 5 swap nth-unsafe ] unit-test [ [ 1 2 3 ] ] [ { 1 2 3 } [ ] like ] unit-test +[ [ 2 3 1 ] ] [ { 1 2 3 } [ rotate-circular ] keep [ ] like ] unit-test [ [ 2 3 1 ] ] [ { 1 2 3 } 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } 1 over change-circular-start 1 over change-circular-start [ ] like ] unit-test [ [ 3 1 2 ] ] [ { 1 2 3 } -100 over change-circular-start [ ] like ] unit-test diff --git a/basis/circular/circular.factor b/basis/circular/circular.factor index 9f3a71f2a8..909b2ed713 100644 --- a/basis/circular/circular.factor +++ b/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 ; diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor index fa1248435b..72618db456 100644 --- a/basis/compiler/tests/optimizer.factor +++ b/basis/compiler/tests/optimizer.factor @@ -395,4 +395,20 @@ DEFER: loop-bbb : modular-arithmetic-bug ( a -- b ) >integer 256 mod ; [ 1 ] [ 257 modular-arithmetic-bug ] unit-test -[ -10 ] [ -10 modular-arithmetic-bug ] unit-test \ No newline at end of file +[ -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 \ No newline at end of file diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index ee9abf00ec..6be3bed8d3 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/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 ] [ - [ in-d>> ] [ [ dispatch# ] keep ] bi* - [ swap nth value-info class>> dup ] dip - specific-method + 2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [ + [ in-d>> ] [ [ dispatch# ] keep ] bi* + [ swap nth value-info class>> dup ] dip + specific-method + ] if ] if ; : inline-standard-method ( #call word -- ? ) diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor new file mode 100755 index 0000000000..6ef9c2fabc --- /dev/null +++ b/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 + + ( -- 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 -- ) -- ) + :> 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 :> table + tdesc [ n table update-reverse-table ] huffman-each + table seq>> ; + +:: huffman-table ( tdesc max -- table ) + max f :> 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 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 [ swap n bits. [ huff. ] each ] assoc-each ; +*/ diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor new file mode 100755 index 0000000000..3e67b11cc7 --- /dev/null +++ b/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 + +seq ( assoc -- seq ) + dup keys [ ] [ max ] map-reduce 1 + f + [ '[ 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 :> 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 clone + [ '[ _ 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 + [ 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 append ] bi* ] [ suffix ] if ] reduce + [ dup array? [ second 0 ] [ 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 :> 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 ] 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: + [ check-zlib-header ] + [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 29cbe96d69..46a319662e 100644 --- a/basis/compression/lzw/lzw.factor +++ b/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 -code old-code ; +TUPLE: lzw input output table 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 ; - -: ( input -- obj ) - lzw new - swap >>input - binary >>output - reset-lzw-compress ; + initial-uncompress-table >>table ; : ( 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 - [ 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 - [ lzw-uncompress-char ] [ output>> ] bi ; + bs: + + [ lzw-uncompress-char ] [ output>> ] bi ; diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 924f7130f0..6612a43dca 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/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 ( ) ; + +controller-states+ set-global 0 0 0 0 2 mouse-state boa +mouse-state+ set-global - 256 f +keyboard-state+ set-global ; + 256 +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) hid-manager-matching-game-devices { diff --git a/extra/game-input/iokit/summary.txt b/basis/game-input/iokit/summary.txt similarity index 100% rename from extra/game-input/iokit/summary.txt rename to basis/game-input/iokit/summary.txt diff --git a/extra/game-input/iokit/tags.txt b/basis/game-input/iokit/tags.txt similarity index 100% rename from extra/game-input/iokit/tags.txt rename to basis/game-input/iokit/tags.txt diff --git a/extra/game-input/scancodes/authors.txt b/basis/game-input/scancodes/authors.txt similarity index 100% rename from extra/game-input/scancodes/authors.txt rename to basis/game-input/scancodes/authors.txt diff --git a/extra/game-input/scancodes/scancodes.factor b/basis/game-input/scancodes/scancodes.factor similarity index 100% rename from extra/game-input/scancodes/scancodes.factor rename to basis/game-input/scancodes/scancodes.factor diff --git a/extra/game-input/scancodes/summary.txt b/basis/game-input/scancodes/summary.txt similarity index 100% rename from extra/game-input/scancodes/summary.txt rename to basis/game-input/scancodes/summary.txt diff --git a/extra/game-input/scancodes/tags.txt b/basis/game-input/scancodes/tags.txt similarity index 100% rename from extra/game-input/scancodes/tags.txt rename to basis/game-input/scancodes/tags.txt diff --git a/extra/game-input/summary.txt b/basis/game-input/summary.txt similarity index 100% rename from extra/game-input/summary.txt rename to basis/game-input/summary.txt diff --git a/extra/game-input/tags.txt b/basis/game-input/tags.txt similarity index 100% rename from extra/game-input/tags.txt rename to basis/game-input/tags.txt diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor new file mode 100755 index 0000000000..648923704a --- /dev/null +++ b/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 } ; + +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 + 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 + ] [ 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 :> 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 >>bitmap + drop ; + +: baseline-decompress ( -- ) + jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append + >byte-array bs: jpeg> (>>bitstream) + jpeg> [ bitstream>> ] [ [ [ ] 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 + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + jpeg> bitmap>> 3 [ color-transform ] change-each + jpeg> [ >byte-array ] change-bitmap drop + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index fe33cc8f00..27b726f3c0 100644 --- a/basis/images/loader/loader.factor +++ b/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 ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b027362977..bf13c43546 100755 --- a/basis/images/png/png.factor +++ b/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-info size>> ] bi stream-throws [ @@ -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 ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor new file mode 100755 index 0000000000..fc463731b3 --- /dev/null +++ b/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 ) + 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. ; diff --git a/basis/io/directories/hierarchy/hierarchy.factor b/basis/io/directories/hierarchy/hierarchy.factor index 555f001bfc..4a2955ccaf 100644 --- a/basis/io/directories/hierarchy/hierarchy.factor +++ b/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 -- ) diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index f16db428a8..60a9308f38 100644 --- a/basis/io/files/info/info.factor +++ b/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 ; diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 80f4b74ac8..94cb60a2c6 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/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 ; + [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 6181a72ffc..39a8a2c4fe 100644 --- a/basis/opengl/gl/gl.factor +++ b/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 + diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index b9e00b6c8d..0eba1d2854 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/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 ] } diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index 21f712fdc8..520c7175c6 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/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 ] } diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index 2639d48be2..3cb74fb00b 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -43,29 +43,17 @@ PRIVATE> > length tail* - ] [ - datastack - ] if* ; +: stack-values ( names -- alist ) + [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ; -: entering ( str -- ) - "/-- Entering: " write dup . - word-inputs stack. - "\\--" print flush ; +: trace-message ( word quot str -- ) + "--- " write write bl over . + [ stack-effect ] dip '[ @ stack-values ] [ f ] if* + [ simple-table. ] unless-empty flush ; inline -: word-outputs ( word -- seq ) - stack-effect [ - [ datastack ] dip out>> length tail* - ] [ - datastack - ] if* ; +: entering ( str -- ) [ in>> ] "Entering" trace-message ; -: leaving ( str -- ) - "/-- Leaving: " write dup . - word-outputs stack. - "\\--" print flush ; +: leaving ( str -- ) [ out>> ] "Leaving" trace-message ; : (watch) ( word def -- def ) over '[ _ entering @ _ leaving ] ; diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor index 6816445508..5a64878aee 100755 --- a/basis/tools/deploy/shaker/shaker.factor +++ b/basis/tools/deploy/shaker/shaker.factor @@ -195,10 +195,12 @@ IN: tools.deploy.shaker 2drop ; : strip-compiler-classes ( -- ) - "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 ; + 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 + ] when ; : strip-default-methods ( -- ) strip-debugger? [ diff --git a/basis/ui/backend/backend.factor b/basis/ui/backend/backend.factor index 63d551798c..3d38439f69 100755 --- a/basis/ui/backend/backend.factor +++ b/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 -- ) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 47a3bfc1a6..b6c9b43271 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/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 -- ) - swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) + [ 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 CGWarpMouseCursorPosition drop ; + NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h + [ drop first ] [ swap second - ] 2bi + [ GetCurrentButtonState zero? not ] [ yield ] while + CGWarpMouseCursorPosition drop ; M: cocoa-ui-backend (ungrab-input) ( handle -- ) drop diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index aab851c783..a9568d4f75 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/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 ] } diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor index afed121fb6..1ca3e85232 100755 --- a/basis/ui/backend/windows/windows.factor +++ b/basis/ui/backend/windows/windows.factor @@ -556,11 +556,9 @@ M: windows-ui-backend do-events [ DispatchMessage drop ] bi ] if ; -: register-wndclassex ( -- class ) - "WNDCLASSEX" - f GetModuleHandle - class-name-ptr get-global - pick GetClassInfoEx zero? [ +:: register-window-class ( class-name-ptr -- ) + "WNDCLASSEX" f GetModuleHandle + class-name-ptr pick GetClassInfoEx 0 = [ "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 - RegisterClassEx dup win32-error=0/f - ] when ; + class-name-ptr over set-WNDCLASSEX-lpszClassName + RegisterClassEx win32-error=0/f + ] [ 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 -- ) - swap [ enter-fullscreen ] [ exit-fullscreen ] if ; +M: windows-ui-backend (set-fullscreen) ( ? world -- ) + [ 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 diff --git a/basis/ui/backend/x11/x11.factor b/basis/ui/backend/x11/x11.factor index 76fd9fa30c..aca80cbc96 100755 --- a/basis/ui/backend/x11/x11.factor +++ b/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 -- ) - handle>> window>> "XClientMessageEvent" - [ set-XClientMessageEvent-window ] keep - swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? +M: x11-ui-backend (set-fullscreen) ( world ? -- ) + [ + handle>> window>> "XClientMessageEvent" + [ set-XClientMessageEvent-window ] keep + ] dip + _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ? over set-XClientMessageEvent-data0 ClientMessage over set-XClientMessageEvent-type dpy get over set-XClientMessageEvent-display diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index f3f533e681..4d6960306c 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/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 ; diff --git a/basis/ui/ui-docs.factor b/basis/ui/ui-docs.factor index e206c7d408..7e83265926 100644 --- a/basis/ui/ui-docs.factor +++ b/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? -{ $values { "?" "a boolean" } { "gadget" gadget } } +HELP: set-fullscreen +{ $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 } } } diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 0a6f26fd5b..b1bfce26e6 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -209,11 +209,14 @@ PRIVATE> : open-window ( gadget title/attributes -- ) ?attributes open-world-window ; -: set-fullscreen? ( ? gadget -- ) - find-world set-fullscreen* ; +: set-fullscreen ( gadget ? -- ) + [ 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* ; diff --git a/basis/unix/stat/linux/64/64.factor b/basis/unix/stat/linux/64/64.factor index 98c4b90f32..581525dda0 100644 --- a/basis/unix/stat/linux/64/64.factor +++ b/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" } - { "mode_t" "st_mode" } - { "nlink_t" "st_nlink" } - { "uid_t" "st_uid" } - { "gid_t" "st_gid" } - { "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" } ; + { "dev_t" "st_dev" } + { "ino_t" "st_ino" } + { "nlink_t" "st_nlink" } + { "mode_t" "st_mode" } + { "uid_t" "st_uid" } + { "gid_t" "st_gid" } + { "int" "pad0" } + { "dev_t" "st_rdev" } + { "off64_t" "st_size" } + { "blksize_t" "st_blksize" } + { "blkcnt64_t" "st_blocks" } + { "timespec" "st_atimespec" } + { "timespec" "st_mtimespec" } + { "timespec" "st_ctimespec" } + { "long" "__unused0" } + { "long" "__unused1" } + { "long" "__unused2" } ; FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ; FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ; diff --git a/core/classes/predicate/predicate-tests.factor b/core/classes/predicate/predicate-tests.factor index a947b9ddc0..80613f4f2e 100644 --- a/core/classes/predicate/predicate-tests.factor +++ b/core/classes/predicate/predicate-tests.factor @@ -1,5 +1,6 @@ -USING: math tools.test classes.algebra words kernel sequences assocs ; -IN: classes.predicate +USING: math tools.test classes.algebra words kernel sequences assocs +accessors eval definitions compiler.units generic ; +IN: classes.predicate.tests PREDICATE: negative < integer 0 < ; PREDICATE: positive < integer 0 > ; @@ -18,4 +19,16 @@ M: positive abs ; [ 10 ] [ -10 abs ] unit-test [ 10 ] [ 10 abs ] unit-test -[ 0 ] [ 0 abs ] unit-test \ No newline at end of file +[ 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 diff --git a/core/generic/single/single-tests.factor b/core/generic/single/single-tests.factor index e48d404b92..61ae4e1ba1 100644 --- a/core/generic/single/single-tests.factor +++ b/core/generic/single/single-tests.factor @@ -274,4 +274,9 @@ M: growable call-next-hooker call-next-method "growable " prepend ; [ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test [ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test -[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test \ No newline at end of file +[ 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 \ No newline at end of file diff --git a/core/generic/single/single.factor b/core/generic/single/single.factor index 8d84b21bf7..747963256d 100644 --- a/core/generic/single/single.factor +++ b/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 ; -: ( methods -- engine ) predicate-engine boa ; +C: predicate-engine : push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* + dupd [ + [ ] [ H{ } clone ] ?if [ methods>> set-at ] keep ] change-at ; @@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine [ 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 ; - : ( -- word ) generic-word get name>> "/predicate-engine" append f 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 ; [ ] 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 ] diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index b76bcaa582..0d1220beac 100644 --- a/core/generic/standard/standard.factor +++ b/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 ) + dup 0 < [ bad-dispatch-position ] when + standard-combination boa ; PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; diff --git a/core/memory/memory-tests.factor b/core/memory/memory-tests.factor old mode 100644 new mode 100755 index a6ecdc005e..8ecf673b8a --- a/core/memory/memory-tests.factor +++ b/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 ] replicate { } { } become drop ] unit-test diff --git a/extra/game-worlds/game-worlds.factor b/extra/game-worlds/game-worlds.factor index c9ea03e333..2fb115b5d0 100644 --- a/extra/game-worlds/game-worlds.factor +++ b/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 ] keep start-loop - drop - open-game-input ; - -M: game-world end-world - close-game-input - [ [ stop-loop ] when* f ] change-game-loop + drop ; + +M: game-world end-world + [ [ stop-loop ] when* f ] change-game-loop + close-game-input drop ; diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index e03204dc35..0dc0f05205 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -25,6 +25,7 @@ M: gesture-logger user-input* : gesture-logger ( -- ) [ t >>scrolls? dup + { 450 500 } >>pref-dim "Gesture log" open-window "Gesture input" open-window diff --git a/extra/irc/client/base/base.factor b/extra/irc/client/base/base.factor index f54e18ac4b..318a1ab1e3 100644 --- a/extra/irc/client/base/base.factor +++ b/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 ; diff --git a/extra/irc/client/chats/chats.factor b/extra/irc/client/chats/chats.factor index 7910afb22a..3f6cf4945d 100644 --- a/extra/irc/client/chats/chats.factor +++ b/extra/irc/client/chats/chats.factor @@ -33,7 +33,8 @@ TUPLE: irc-profile server port nickname password ; C: 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 ; : ( profile -- irc-client ) @@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages >>in-messages >>out-messages H{ } clone >>chats - 15 seconds >>reconnect-time + 30 seconds >>reconnect-time + 10 >>reconnect-attempts V{ } clone >>exceptions - [ latin1 ] >>connect ; + [ latin1 drop ] >>connect ; SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ; diff --git a/extra/irc/client/internals/internals-tests.factor b/extra/irc/client/internals/internals-tests.factor index 27b5648f97..2c26188e04 100644 --- a/extra/irc/client/internals/internals-tests.factor +++ b/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 - [ 2drop t ] >>connect + [ 2drop ] >>connect [ (connect-irc) (do-login) diff --git a/extra/irc/client/internals/internals.factor b/extra/irc/client/internals/internals.factor index 5bae054e18..0a4fe11830 100644 --- a/extra/irc/client/internals/internals.factor +++ b/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> { - [ profile>> [ server>> ] [ port>> ] bi /CONNECT ] - [ (>>stream) ] - [ t swap (>>is-running) ] - [ in-messages>> [ irc-connected ] dip mailbox-put ] - } cleave ; + try-connect [ + [ irc> ] dip >>stream t >>is-running + in-messages>> [ irc-connected ] dip mailbox-put + ] [ (terminate-irc) ] if* ; : (do-login) ( -- ) irc> nick>> /LOGIN ; @@ -52,7 +68,7 @@ M: to-all-chats message-forwards drop chats> ; M: to-many-chats message-forwards sender>> participant-chats ; GENERIC: process-message ( irc-message -- ) -M: object process-message drop ; +M: object process-message drop ; M: ping process-message trailing>> /PONG ; M: join process-message [ sender>> ] [ chat> ] bi join-participant ; M: part process-message [ sender>> ] [ chat> ] bi part-participant ; @@ -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 ; \ No newline at end of file +: (speak) ( message irc-chat -- ) swap annotate-message irc-send ; diff --git a/extra/irc/logbot/log-line/log-line.factor b/extra/irc/logbot/log-line/log-line.factor index b3af41ad3d..0960a3cedb 100644 --- a/extra/irc/logbot/log-line/log-line.factor +++ b/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 ; diff --git a/extra/irc/logbot/logbot.factor b/extra/irc/logbot/logbot.factor index a389304b14..ff8085a9a9 100644 --- a/extra/irc/logbot/logbot.factor +++ b/extra/irc/logbot/logbot.factor @@ -16,7 +16,7 @@ SYMBOL: current-stream "irc.freenode.org" 6667 "flogger" f ; : 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 ] bi + [ timestamp-path latin1 ] bi current-stream set ] if current-stream get ; diff --git a/extra/irc/messages/base/base.factor b/extra/irc/messages/base/base.factor index d67d226d9b..b785970520 100644 --- a/extra/irc/messages/base/base.factor +++ b/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 ] diff --git a/extra/irc/messages/messages-tests.factor b/extra/irc/messages/messages-tests.factor index 539fba54eb..347bdd00fa 100644 --- a/extra/irc/messages/messages-tests.factor +++ b/extra/irc/messages/messages-tests.factor @@ -71,4 +71,7 @@ IN: irc.messages.tests { name "nickname" } { trailing "Nickname is already in use" } } } [ ":ircserver.net 433 * nickname :Nickname is already in use" - string>irc-message f >>timestamp ] unit-test \ No newline at end of file + string>irc-message f >>timestamp ] unit-test + +{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :ACTION jumps!" + string>irc-message action? ] unit-test diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index a6bf02f8a7..2006cc24c3 100755 --- a/extra/irc/messages/messages.factor +++ b/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? ; -PREDICATE: participant-mode < channel-mode parameter>> ; +M: ctcp post-process-irc-message ( ctcp -- ) + [ rest but-last ] change-text drop ; + +M: action post-process-irc-message ( action -- ) + [ 7 tail ] change-text call-next-method ; diff --git a/extra/irc/messages/parser/parser.factor b/extra/irc/messages/parser/parser.factor index 1fa07fc772..06a41b0aaa 100644 --- a/extra/irc/messages/parser/parser.factor +++ b/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 ; diff --git a/extra/jamshred/jamshred.factor b/extra/jamshred/jamshred.factor index fd683e3bc4..ae981ae1b3 100644 --- a/extra/jamshred/jamshred.factor +++ b/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 ] } diff --git a/extra/mason/build/build.factor b/extra/mason/build/build.factor index 5031b5d930..a9e32e5315 100644 --- a/extra/mason/build/build.factor +++ b/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 diff --git a/extra/mason/cleanup/cleanup.factor b/extra/mason/cleanup/cleanup.factor index 3e6209fed0..fb8e2e893a 100755 --- a/extra/mason/cleanup/cleanup.factor +++ b/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 ; diff --git a/extra/mason/common/common.factor b/extra/mason/common/common.factor index a743c3fe9a..a33e3c5831 100755 --- a/extra/mason/common/common.factor +++ b/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. - - 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 - " " split second ; + { "git" "show" } utf8 [ lines ] with-process-reader + first " " split second ; : ?prepare-build-machine ( -- ) builds/factor exists? [ prepare-build-machine ] unless ; diff --git a/extra/mason/help/help.factor b/extra/mason/help/help.factor index 9ed9653a08..6b44e49c61 100644 --- a/extra/mason/help/help.factor +++ b/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 ( -- ) diff --git a/extra/mason/notify/notify.factor b/extra/mason/notify/notify.factor index 6c643d64d5..ccabccdf8b 100644 --- a/extra/mason/notify/notify.factor +++ b/extra/mason/notify/notify.factor @@ -18,7 +18,7 @@ IN: mason.notify _ [ +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" { "report" } status-notify + [ "report" ] dip + [ [ utf8 file-contents ] dip email-report ] + [ "report" swap name>> 2array status-notify ] + 2bi ] bi ; : notify-release ( archive-name -- ) diff --git a/extra/mason/notify/server/authors.txt b/extra/mason/notify/server/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/mason/notify/server/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/mason/notify/server/server.factor b/extra/mason/notify/server/server.factor new file mode 100644 index 0000000000..cc055e38d8 --- /dev/null +++ b/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>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" ; + +: 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 diff --git a/extra/mason/platform/platform.factor b/extra/mason/platform/platform.factor index 59c525f5ea..d6be8654c5 100644 --- a/extra/mason/platform/platform.factor +++ b/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" ? ; diff --git a/extra/mason/release/archive/archive.factor b/extra/mason/release/archive/archive.factor index 79d6993a91..51534edccd 100755 --- a/extra/mason/release/archive/archive.factor +++ b/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 -- ) - [ "zip" , "-r" , , "factor" , ] { } make try-output-process ; +:: make-windows-archive ( archive-name -- ) + { "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 - { "cp" "-R" "factor" "dmg-root" } try-output-process - { "hdiutil" "create" - "-srcfolder" "dmg-root" - "-fs" "HFS+" - "-volname" "factor" } - swap suffix try-output-process + "dmg-root" make-directory + "factor" "dmg-root" copy-tree-into + "factor" "dmg-root" make-disk-image "dmg-root" really-delete-tree ; -: make-unix-archive ( archive-name -- ) - [ "tar" , "-cvzf" , , "factor" , ] { } make try-output-process ; +:: make-unix-archive ( archive-name -- ) + { "tar" "-cvzf" archive-name "factor" } short-running-process ; : make-archive ( archive-name -- ) target-os get { diff --git a/extra/mason/report/report.factor b/extra/mason/report/report.factor index 6e48e7cf04..1b5aaf39ec 100644 --- a/extra/mason/report/report.factor +++ b/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

<-what->

diff --git a/extra/redis/assoc/assoc.factor b/extra/redis/assoc/assoc.factor new file mode 100644 index 0000000000..e8bdbbb935 --- /dev/null +++ b/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 ; diff --git a/extra/redis/assoc/authors.txt b/extra/redis/assoc/authors.txt new file mode 100644 index 0000000000..f4a8cb1dc2 --- /dev/null +++ b/extra/redis/assoc/authors.txt @@ -0,0 +1 @@ +Bruno Deferrari diff --git a/extra/redis/assoc/summary.txt b/extra/redis/assoc/summary.txt new file mode 100644 index 0000000000..72a76ab9f0 --- /dev/null +++ b/extra/redis/assoc/summary.txt @@ -0,0 +1 @@ +Assoc protocol implementation for Redis diff --git a/extra/redis/redis.factor b/extra/redis/redis.factor index 1f6d732407..466fdc9937 100644 --- a/extra/redis/redis.factor +++ b/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 new + "127.0.0.1" >>host + default-redis-port >>port + latin1 >>encoding ; + +: redis-do-connect ( redis -- stream ) + [ host>> ] [ port>> ] [ encoding>> ] tri + [ ] dip drop ; + +: with-redis ( redis quot -- ) + [ + [ redis-do-connect ] [ password>> ] bi + [ swap [ [ redis-auth drop ] with-stream* ] keep ] when* + ] dip with-stream ; inline diff --git a/extra/terrain/shaders/shaders.factor b/extra/terrain/shaders/shaders.factor index e5b517ad59..9233ab3f36 100644 --- a/extra/terrain/shaders/shaders.factor +++ b/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) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 411d34f44c..fb326ef534 100644 --- a/extra/terrain/terrain.factor +++ b/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 ] - [ dy>> MOUSE-SCALE * [ + clamp-pitch ] curry change-pitch ] bi - drop ; + [ dx>> MOUSE-SCALE * look-horizontally ] + [ dy>> MOUSE-SCALE * look-vertically ] 2bi ; + + +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 0.01 0.01 { 512 512 } perlin-noise-image [ >>sky-image ] keep make-texture [ set-texture-parameters ] keep >>sky-texture diff --git a/extra/webapps/mason/authors.txt b/extra/webapps/mason/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/extra/webapps/mason/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/extra/webapps/mason/mason.factor b/extra/webapps/mason/mason.factor new file mode 100644 index 0000000000..ea7040ac6e --- /dev/null +++ b/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 
<->
XML] ; + +: git-link ( id -- link ) + [ "http://github.com/slavapestov/factor/commit/" prepend ] keep + [XML ><-> 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 ><-> XML] ; + +: clean-image-link ( builder -- link ) + [ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend + dup [XML ><-> 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 +

<-> / <->

+ + + + + + + +
Host name:<->
Current status:<->
Last build:<->
Last clean build:<->
Binaries:<->
Clean images:<->
+ 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 + + Factor build farm +

Recent events

<->

Machine status

<-> + + XML] ; + +: ( -- action ) + + [ + mason-db [ build-farm-report xml>string ] with-db + "text/html" + ] >>display ; \ No newline at end of file diff --git a/vm/Config.netbsd b/vm/Config.netbsd index d126747589..a6ec997ecd 100644 --- a/vm/Config.netbsd +++ b/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) diff --git a/vm/arrays.hpp b/vm/arrays.hpp old mode 100644 new mode 100755 index 82da3bb71d..06e6ed6e4d --- a/vm/arrays.hpp +++ b/vm/arrays.hpp @@ -34,7 +34,7 @@ struct growable_array { cell count; gc_root 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(); diff --git a/vm/byte_arrays.hpp b/vm/byte_arrays.hpp old mode 100644 new mode 100755 index ebdc6bead6..6de8ee4e9f --- a/vm/byte_arrays.hpp +++ b/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 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); diff --git a/vm/callstack.cpp b/vm/callstack.cpp index e7009183e9..4ef6db10bd 100755 --- a/vm/callstack.cpp +++ b/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_size(size)); @@ -138,36 +122,39 @@ cell frame_scan(stack_frame *frame) return F; } -/* C doesn't have closures... */ -static cell frame_count; - -void count_stack_frame(stack_frame *frame) +namespace { - frame_count += 2; -} -static cell frame_index; -static array *frames; +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(count)) {} + void operator()(stack_frame *frame) + { + set_array_nth(frames,index++,frame_executing(frame)); + set_array_nth(frames,index++,frame_scan(frame)); + } +}; -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(dpop()); - frame_count = 0; - iterate_callstack_object(callstack.untagged(),count_stack_frame); + stack_frame_counter counter; + iterate_callstack_object(callstack.untagged(),counter); - frames = allot_array_internal(frame_count); + stack_frame_accumulator accum(counter.count); + iterate_callstack_object(callstack.untagged(),accum); - frame_index = 0; - iterate_callstack_object(callstack.untagged(),stack_frame_to_array); - - dpush(tag(frames)); + dpush(tag(accum.frames)); } stack_frame *innermost_stack_frame(callstack *stack) diff --git a/vm/callstack.hpp b/vm/callstack.hpp index a128cfee47..d92e5f69e0 100755 --- a/vm/callstack.hpp +++ b/vm/callstack.hpp @@ -6,11 +6,7 @@ inline static cell callstack_size(cell size) return sizeof(callstack) + size; } -typedef void (*CALLSTACK_ITER)(stack_frame *frame); - stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom); -void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator); -void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator); stack_frame *frame_successor(stack_frame *frame); code_block *frame_code(stack_frame *frame); cell frame_executing(stack_frame *frame); @@ -26,4 +22,20 @@ PRIMITIVE(set_innermost_stack_frame_quot); VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom); +template void iterate_callstack(cell top, cell bottom, T &iterator) +{ + stack_frame *frame = (stack_frame *)bottom - 1; + + while((cell)frame >= top) + { + iterator(frame); + frame = frame_successor(frame); + } +} + +template void iterate_callstack_object(callstack *stack, T &iterator) +{ + iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator); +} + } diff --git a/vm/code_heap.cpp b/vm/code_heap.cpp index 2260d133fc..2d2e975fb4 100755 --- a/vm/code_heap.cpp +++ b/vm/code_heap.cpp @@ -173,8 +173,7 @@ void forward_object_xts() } } - /* End the heap scan */ - gc_off = false; + end_scan(); } /* Set the XT fields now that the heap has been compacted */ @@ -203,8 +202,7 @@ void fixup_object_xts() } } - /* End the heap scan */ - gc_off = false; + end_scan(); } /* Move all free space to the end of the code heap. This is not very efficient, diff --git a/vm/data_heap.cpp b/vm/data_heap.cpp index d921d373da..5b20ec890f 100755 --- a/vm/data_heap.cpp +++ b/vm/data_heap.cpp @@ -318,6 +318,11 @@ void begin_scan() gc_off = true; } +void end_scan() +{ + gc_off = false; +} + PRIMITIVE(begin_scan) { begin_scan(); @@ -348,24 +353,40 @@ PRIMITIVE(end_scan) gc_off = false; } -cell find_all_words() +template void each_object(T &functor) { - growable_array words; - begin_scan(); - cell obj; while((obj = next_object()) != F) - { - if(tagged(obj).type_p(WORD_TYPE)) - words.add(obj); - } + functor(tagged(obj)); + end_scan(); +} - /* End heap scan */ - gc_off = false; +namespace +{ - words.trim(); - return words.elements.value(); +struct word_counter { + cell count; + word_counter() : count(0) {} + void operator()(tagged obj) { if(obj.type_p(WORD_TYPE)) count++; } +}; + +struct word_accumulator { + growable_array words; + word_accumulator(int count) : words(count) {} + void operator()(tagged obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); } +}; + +} + +cell find_all_words() +{ + word_counter counter; + each_object(counter); + word_accumulator accum(counter.count); + each_object(accum); + accum.words.trim(); + return accum.words.elements.value(); } } diff --git a/vm/data_heap.hpp b/vm/data_heap.hpp old mode 100644 new mode 100755 index 567c8f9944..4ef72a6fcb --- a/vm/data_heap.hpp +++ b/vm/data_heap.hpp @@ -89,6 +89,7 @@ cell binary_payload_start(object *pointer); cell object_size(cell tagged); void begin_scan(); +void end_scan(); cell next_object(); PRIMITIVE(data_room); diff --git a/vm/debug.cpp b/vm/debug.cpp index 49fdd92541..22e92809a7 100755 --- a/vm/debug.cpp +++ b/vm/debug.cpp @@ -253,8 +253,7 @@ void dump_objects(cell type) } } - /* end scan */ - gc_off = false; + end_scan(); } cell look_for; @@ -280,8 +279,7 @@ void find_data_references(cell look_for_) while((obj = next_object()) != F) do_slots(UNTAG(obj),find_data_references_step); - /* end scan */ - gc_off = false; + end_scan(); } /* Dump all code blocks for debugging */ diff --git a/vm/layouts.hpp b/vm/layouts.hpp index f8672e4522..3fe89cb558 100755 --- a/vm/layouts.hpp +++ b/vm/layouts.hpp @@ -90,7 +90,7 @@ inline static cell tag_for(cell type) return type < HEADER_TYPE ? type : OBJECT_TYPE; } -class object; +struct object; struct header { cell value; diff --git a/vm/master.hpp b/vm/master.hpp index 6164c9ea30..83f0920f5b 100755 --- a/vm/master.hpp +++ b/vm/master.hpp @@ -19,8 +19,6 @@ #include #include #include -#include -#include /* C++ headers */ #if __GNUC__ == 4 diff --git a/vm/os-linux.cpp b/vm/os-linux.cpp index f5814d7f18..2bc121ffc7 100644 --- a/vm/os-linux.cpp +++ b/vm/os-linux.cpp @@ -23,36 +23,36 @@ const char *vm_executable_path() #ifdef SYS_inotify_init -int inotify_init() +VM_C_API int inotify_init() { return syscall(SYS_inotify_init); } -int inotify_add_watch(int fd, const char *name, u32 mask) +VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask) { return syscall(SYS_inotify_add_watch, fd, name, mask); } -int inotify_rm_watch(int fd, u32 wd) +VM_C_API int inotify_rm_watch(int fd, u32 wd) { return syscall(SYS_inotify_rm_watch, fd, wd); } #else -int inotify_init() +VM_C_API int inotify_init() { not_implemented_error(); return -1; } -int inotify_add_watch(int fd, const char *name, u32 mask) +VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask) { not_implemented_error(); return -1; } -int inotify_rm_watch(int fd, u32 wd) +VM_C_API int inotify_rm_watch(int fd, u32 wd) { not_implemented_error(); return -1; diff --git a/vm/os-linux.hpp b/vm/os-linux.hpp index 257a6b0692..de13896b9a 100644 --- a/vm/os-linux.hpp +++ b/vm/os-linux.hpp @@ -3,8 +3,8 @@ namespace factor { -int inotify_init(); -int inotify_add_watch(int fd, const char *name, u32 mask); -int inotify_rm_watch(int fd, u32 wd); +VM_C_API int inotify_init(); +VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask); +VM_C_API int inotify_rm_watch(int fd, u32 wd); } diff --git a/vm/os-unix.hpp b/vm/os-unix.hpp index 07ec385763..8aff18364e 100755 --- a/vm/os-unix.hpp +++ b/vm/os-unix.hpp @@ -1,3 +1,5 @@ +#include +#include #include #include #include @@ -24,13 +26,13 @@ typedef char symbol_char; #define FSEEK fseeko #define FIXNUM_FORMAT "%ld" -#define cell_FORMAT "%lu" -#define cell_HEX_FORMAT "%lx" +#define CELL_FORMAT "%lu" +#define CELL_HEX_FORMAT "%lx" #ifdef FACTOR_64 - #define cell_HEX_PAD_FORMAT "%016lx" + #define CELL_HEX_PAD_FORMAT "%016lx" #else - #define cell_HEX_PAD_FORMAT "%08lx" + #define CELL_HEX_PAD_FORMAT "%08lx" #endif #define FIXNUM_FORMAT "%ld" diff --git a/vm/os-windows.hpp b/vm/os-windows.hpp index 5422216593..27e2775289 100755 --- a/vm/os-windows.hpp +++ b/vm/os-windows.hpp @@ -22,14 +22,14 @@ typedef wchar_t vm_char; #define FSEEK fseek #ifdef WIN64 - #define cell_FORMAT "%Iu" - #define cell_HEX_FORMAT "%Ix" - #define cell_HEX_PAD_FORMAT "%016Ix" + #define CELL_FORMAT "%Iu" + #define CELL_HEX_FORMAT "%Ix" + #define CELL_HEX_PAD_FORMAT "%016Ix" #define FIXNUM_FORMAT "%Id" #else - #define cell_FORMAT "%lu" - #define cell_HEX_FORMAT "%lx" - #define cell_HEX_PAD_FORMAT "%08lx" + #define CELL_FORMAT "%lu" + #define CELL_HEX_FORMAT "%lx" + #define CELL_HEX_PAD_FORMAT "%08lx" #define FIXNUM_FORMAT "%ld" #endif diff --git a/vm/tagged.hpp b/vm/tagged.hpp old mode 100644 new mode 100755 diff --git a/vm/utilities.cpp b/vm/utilities.cpp index df5c09847d..37fe28948e 100755 --- a/vm/utilities.cpp +++ b/vm/utilities.cpp @@ -32,17 +32,17 @@ void print_string(const char *str) void print_cell(cell x) { - printf(cell_FORMAT,x); + printf(CELL_FORMAT,x); } void print_cell_hex(cell x) { - printf(cell_HEX_FORMAT,x); + printf(CELL_HEX_FORMAT,x); } void print_cell_hex_pad(cell x) { - printf(cell_HEX_PAD_FORMAT,x); + printf(CELL_HEX_PAD_FORMAT,x); } void print_fixnum(fixnum x) @@ -53,7 +53,7 @@ void print_fixnum(fixnum x) cell read_cell_hex() { cell cell; - if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1); + if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1); return cell; };