Merge branch 'master' into checksums

db4
Doug Coleman 2009-05-16 09:05:29 -05:00
commit b37d9d670d
217 changed files with 2626 additions and 858 deletions

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture
io.encodings.utf8 io.encodings.utf16n ;
io.encodings.utf8 ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -95,5 +95,4 @@ M: string-type c-type-setter
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
{ "char*" utf16n } "wchar_t*" typedef

View File

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

View File

@ -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 ;
: <widthed> ( bits #bits -- widthed )
check-widthed
widthed boa ;
: zero-widthed ( -- widthed ) 0 0 <widthed> ;
: zero-widthed? ( widthed -- ? ) zero-widthed = ;
TUPLE: bit-reader
{ bytes byte-array }
{ byte-pos array-capacity initial: 0 }
{ bit-pos array-capacity initial: 0 } ;
TUPLE: bit-writer
{ bytes byte-vector }
{ widthed widthed } ;
TUPLE: msb0-bit-reader < bit-reader ;
TUPLE: lsb0-bit-reader < bit-reader ;
CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
TUPLE: msb0-bit-writer < bit-writer ;
TUPLE: lsb0-bit-writer < bit-writer ;
: new-bit-writer ( class -- bs )
new
swap >>stream
reset-bitstream ; inline
BV{ } clone >>bytes
0 0 <widthed> >>widthed ; inline
M: bitstream-reader dispose ( stream -- )
stream>> dispose ;
: <msb0-bit-writer> ( -- bs )
msb0-bit-writer new-bit-writer ;
: <bitstream-reader> ( stream -- bitstream )
bitstream-reader new-bitstream ; inline
: <lsb0-bit-writer> ( -- 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
<PRIVATE
ERROR: not-enough-bits widthed n ;
: widthed-bits ( widthed n -- bits )
dup 0 < [ not-enough-bits ] when
2dup [ #bits>> ] dip < [ not-enough-bits ] when
[ [ bits>> ] [ #bits>> ] bi ] dip
[ - neg shift ] keep <widthed> ;
: split-widthed ( widthed n -- widthed1 widthed2 )
2dup [ #bits>> ] dip < [
drop zero-widthed
] [
0 >>#bits
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 ;
: <bitstream-writer> ( stream -- bitstream )
bitstream-writer new-bitstream ; inline
: write-bit ( n bitstream -- )
[ 1 shift bitor ] change-current-bits
[ 1+ ] change-#bits
dup #bits>> 8 = [
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
[ reset-bitstream drop ] bi
] [
drop
] if ; inline
ERROR: invalid-bit-width n ;
:: write-bits ( n width bitstream -- )
n 0 < [ n invalid-bit-width ] when
n 0 = [
width [ 0 bitstream write-bit ] times
] [
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
n-length [
n-length swap - 1- neg n swap shift 1 bitand
bitstream write-bit
] each
[ widthed-bits ]
[ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 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 + <widthed> ;
PRIVATE>
M:: lsb0-bit-writer poke ( value n bs -- )
value n <widthed> :> widthed
widthed
bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
byte bs widthed>> |widthed :> new-byte
new-byte #bits>> 8 = [
new-byte bits>> bs bytes>> push
zero-widthed bs (>>widthed)
remainder widthed>bytes
[ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
] [
byte bs (>>widthed)
] if ;
: enough-bits? ( n bs -- ? )
[ bytes>> length ]
[ byte-pos>> - 8 * ]
[ bit-pos>> - ] tri <= ;
ERROR: not-enough-bits n bit-reader ;
: #bits>#bytes ( #bits -- #bytes )
8 /mod 0 = [ 1 + ] unless ; inline
:: subseq>bits-le ( bignum n bs -- bits )
bignum bs bit-pos>> neg shift n bits ;
:: subseq>bits-be ( bignum n bs -- bits )
bignum
8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
neg shift n bits ;
:: adjust-bits ( n bs -- )
n 8 /mod :> #bits :> #bytes
bs [ #bytes + ] change-byte-pos
bit-pos>> #bits + dup 8 >= [
8 - bs (>>bit-pos)
bs [ 1 + ] change-byte-pos drop
] [
bs (>>bit-pos)
] if ;
:: (peek) ( n bs endian> subseq-endian -- bits )
n bs enough-bits? [ n bs not-enough-bits ] unless
bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
bs bytes>> subseq endian> execute( seq -- x ) :> bignum
bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
:: bit-writer-bytes ( writer -- bytes )
writer widthed>> #bits>> :> n
n 0 = [
writer widthed>> bits>> 8 n - shift
writer bytes>> swap push
] unless
writer bytes>> ;

View File

@ -448,7 +448,6 @@ M: quotation '
array>> '
quotation [
emit ! array
f ' emit ! compiled
f ' emit ! cached-effect
f ' emit ! cache-counter
0 emit ! xt

View File

@ -12,6 +12,16 @@ SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time
: strip-encodings ( -- )
os unix? [
[
P" resource:core/io/encodings/utf16/utf16.factor"
P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
"io.encodings.utf16"
"io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
] with-compilation-unit
] when ;
: default-image-name ( -- string )
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
@ -55,6 +65,8 @@ SYMBOL: bootstrap-time
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
strip-encodings
(command-line) parse-command-line
! Set dll paths

View File

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

View File

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

View File

@ -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 ;

View File

@ -68,7 +68,7 @@ MACRO: (send) ( selector super? -- quot )
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
'[ _ call _ execute ] ;
1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline

View File

@ -11,8 +11,8 @@ MACRO: output>sequence ( quot exemplar -- newquot )
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
: output>array ( quot -- newquot )
{ } output>sequence ; inline
MACRO: output>array ( quot -- newquot )
'[ _ { } output>sequence ] ;
MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
@ -25,8 +25,8 @@ MACRO: input<sequence-unsafe ( quot -- newquot )
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
: sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline
MACRO: sum-outputs ( quot -- n )
'[ _ [ + ] reduce-outputs ] ;
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
[ dup infer out>> ] 2dip
@ -37,5 +37,5 @@ MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
: append-outputs ( quot -- seq )
{ } append-outputs-as ; inline
MACRO: append-outputs ( quot -- seq )
'[ _ { } append-outputs-as ] ;

View File

@ -20,7 +20,7 @@ CONSTANT: deck-bits 18
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline

View File

@ -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
[ -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

View File

@ -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>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method
2dup [ in-d>> length ] [ dispatch# ] bi* <= [ 2drop f f ] [
[ in-d>> <reversed> ] [ [ dispatch# ] keep ] bi*
[ swap nth value-info class>> dup ] dip
specific-method
] if
] if ;
: inline-standard-method ( #call word -- ? )

View File

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

View File

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

View File

@ -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 ;
: <lzw-compress> ( input -- obj )
lzw new
swap >>input
binary <byte-writer> <bitstream-writer> >>output
reset-lzw-compress ;
initial-uncompress-table >>table ;
: <lzw-uncompress> ( input -- obj )
lzw new
@ -61,79 +38,8 @@ ERROR: index-too-big n ;
BV{ } clone >>output
reset-lzw-uncompress ;
: push-k ( lzw -- lzw )
[ ]
[ k>> ]
[ omega>> clone [ push ] keep ] tri >>omega-k ;
: omega-k-in-table? ( lzw -- ? )
[ omega-k>> ] [ table>> ] bi key? ;
ERROR: not-in-table value ;
: write-output ( lzw -- )
[
[ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless
] [
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
] bi ;
: omega-k>omega ( lzw -- lzw )
dup omega-k>> clone >>omega ;
: k>omega ( lzw -- lzw )
dup k>> 1vector >>omega ;
: add-omega-k ( lzw -- )
[ [ 1+ ] change-count count>> ]
[ omega-k>> clone ]
[ table>> ] tri set-at ;
: lzw-compress-char ( lzw k -- )
>>k push-k dup omega-k-in-table? [
omega-k>omega drop
] [
[ write-output ]
[ add-omega-k ]
[ k>omega drop ] tri
] if ;
: (lzw-compress-chars) ( lzw -- )
dup lzw-bit-width-compress table-full = [
drop
] [
dup input>> stream-read1
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
[ t >>end-of-input? drop ] if*
] if ;
: lzw-compress-chars ( lzw -- )
{
! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
[
[ clear-code ] dip
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
]
[ (lzw-compress-chars) ]
[
[ k>> ]
[ lzw-bit-width-compress ]
[ output>> write-bits ] tri
]
[
[ end-of-information ] dip
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
]
[ ]
} cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
: lzw-compress ( byte-array -- seq )
binary <byte-reader> <lzw-compress>
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
: lookup-old-code ( lzw -- vector )
[ old-code>> ] [ table>> ] bi nth ;
@ -152,7 +58,7 @@ ERROR: not-in-table value ;
: add-to-table ( seq lzw -- ) table>> push ;
: lzw-read ( lzw -- lzw n )
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ;
DEFER: lzw-uncompress-char
: handle-clear-code ( lzw -- )
@ -200,5 +106,6 @@ DEFER: lzw-uncompress-char
] if* ;
: lzw-uncompress ( seq -- byte-array )
binary <byte-reader> <bitstream-reader>
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
bs:<msb0-bit-reader>
<lzw-uncompress>
[ lzw-uncompress-char ] [ output>> ] bi ;

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

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

View File

@ -0,0 +1,8 @@
IN: game-input.tests
USING: ui game-input tools.test kernel system threads calendar ;
os windows? os macosx? or [
[ ] [ open-game-input ] unit-test
[ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
] when

View File

@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
sequences locals combinators.short-circuit threads
namespaces assocs vectors arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
alien.c-types math parser game-input vectors ;
alien.c-types math parser game-input vectors bit-arrays ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
@ -12,10 +12,11 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
iokit-game-input-backend game-input-backend set-global
: hid-manager-matching ( matching-seq -- alien )
f 0 IOHIDManagerCreate
[ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
keep ;
: make-hid-manager ( -- alien )
f 0 IOHIDManagerCreate ;
: set-hid-manager-matching ( alien matching-seq -- )
>plist IOHIDManagerSetDeviceMatchingMultiple ;
: devices-from-hid-manager ( manager -- vector )
[
@ -85,9 +86,6 @@ CONSTANT: hat-switch-matching-hash
: ?hat-switch ( device -- ? )
hat-switch-matching-hash ?axis ;
: hid-manager-matching-game-devices ( -- alien )
game-devices-matching-seq hid-manager-matching ;
: device-property ( device key -- value )
<NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
: element-property ( element key -- value )
@ -186,7 +184,7 @@ HINTS: record-controller { controller-state alien } ;
rot ?set-nth
] [ 3drop ] if ;
HINTS: record-keyboard { array alien } ;
HINTS: record-keyboard { bit-array alien } ;
: record-mouse ( mouse-state value -- )
dup IOHIDValueGetElement {
@ -285,15 +283,16 @@ M: iokit-game-input-backend reset-mouse
4 <vector> +controller-states+ set-global
0 0 0 0 2 <vector> mouse-state boa
+mouse-state+ set-global
256 f <array> +keyboard-state+ set-global ;
256 <bit-array> +keyboard-state+ set-global ;
M: iokit-game-input-backend (open-game-input)
hid-manager-matching-game-devices {
make-hid-manager {
[ initialize-variables ]
[ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
[ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
[ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
[ 0 IOHIDManagerOpen mach-error ]
[ game-devices-matching-seq set-hid-manager-matching ]
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerScheduleWithRunLoop

304
basis/images/jpeg/jpeg.factor Executable file
View File

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

View File

@ -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 ;

View File

@ -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,46 @@ 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>> ;
ERROR: unknown-color-type n ;
ERROR: unimplemented-color-type image ;
: inflate-data ( image -- bytes )
zlib-data zlib-inflate ;
: decode-greyscale ( image -- image )
unimplemented-color-type ;
: decode-truecolor ( image -- image )
{
[ inflate-data ]
[ dim>> first 3 * 1 + group reverse-png-filter ]
[ swap >byte-array >>bitmap drop ]
[ RGB >>component-order drop ]
[ ]
} cleave ;
: decode-indexed-color ( image -- image )
unimplemented-color-type ;
: decode-greyscale-alpha ( image -- image )
unimplemented-color-type ;
: decode-truecolor-alpha ( image -- image )
unimplemented-color-type ;
: decode-png ( image -- image )
dup color-type>> {
{ 0 [ decode-greyscale ] }
{ 2 [ decode-truecolor ] }
{ 3 [ decode-indexed-color ] }
{ 4 [ decode-greyscale-alpha ] }
{ 6 [ decode-truecolor-alpha ] }
[ unknown-color-type ]
} case ;
: load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi
stream-throws <limited-stream> [
@ -69,4 +110,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 ;

View File

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

View File

@ -173,10 +173,11 @@ M: stdin refill
size-read-fd <fd> init-fd <input-port> >>size
data-read-fd <fd> >>data ;
M: unix (init-stdio)
M: unix init-stdio
<stdin> <input-port>
1 <fd> <output-port>
2 <fd> <output-port> t ;
2 <fd> <output-port>
set-stdio ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;

View File

@ -1,9 +1,9 @@
USING: alien alien.c-types arrays assocs combinators
continuations destructors io io.backend io.ports io.timeouts
io.backend.windows io.files.windows io.files.windows.nt io.files
io.pathnames io.buffers io.streams.c libc kernel math namespaces
sequences threads windows windows.errors windows.kernel32
strings splitting ascii system accessors locals ;
USING: alien alien.c-types arrays assocs combinators continuations
destructors io io.backend io.ports io.timeouts io.backend.windows
io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
io.streams.c io.streams.null libc kernel math namespaces sequences
threads windows windows.errors windows.kernel32 strings splitting
ascii system accessors locals ;
QUALIFIED: windows.winsock
IN: io.backend.windows.nt
@ -140,7 +140,9 @@ M: winnt (wait-to-read) ( port -- )
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
M: winnt (init-stdio)
console-app? [ init-c-stdio t ] [ f f f f ] if ;
M: winnt init-stdio
console-app?
[ init-c-stdio ]
[ null-reader null-writer null-writer set-stdio ] if ;
winnt set-io-backend

View File

@ -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 -- )

View File

@ -0,0 +1,10 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types io.directories.unix kernel system unix ;
IN: io.directories.unix.linux
M: unix find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
f <void*>
[ readdir64_r 0 = [ (io-error) ] unless ] 2keep
*void* [ drop f ] unless ;

View File

@ -0,0 +1 @@
unportable

View File

@ -4,7 +4,7 @@ USING: accessors alien.c-types alien.strings combinators
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
unix unix.stat ;
unix unix.stat vocabs.loader ;
IN: io.directories.unix
: touch-mode ( -- n )
@ -34,7 +34,9 @@ M: unix copy-file ( from to -- )
[ opendir dup [ (io-error) ] unless ] dip
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
: find-next-file ( DIR* -- byte-array )
HOOK: find-next-file os ( DIR* -- byte-array )
M: unix find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
@ -54,8 +56,10 @@ M: unix copy-file ( from to -- )
} case ;
M: unix >directory-entry ( byte-array -- directory-entry )
[ dirent-d_name utf8 alien>string ]
[ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
{
[ dirent-d_name utf8 alien>string ]
[ dirent-d_type dirent-type>file-type ]
} cleave directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
@ -63,3 +67,5 @@ M: unix (directory-entries) ( path -- seq )
[ >directory-entry ]
produce nip
] with-unix-directory ;
os linux? [ "io.directories.unix.linux" require ] when

View File

@ -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 ;
vocabs.loader io.files.types io.directories math ;
IN: io.files.info
! File info
@ -14,6 +14,9 @@ HOOK: link-info os ( path -- info )
: directory? ( file-info -- ? ) type>> +directory+ = ;
: sparse-file? ( file-info -- ? )
[ size-on-disk>> ] [ size>> ] bi < ;
! File systems
HOOK: file-systems os ( -- array )
@ -26,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 ;

View File

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

View File

@ -1,11 +1,11 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: system kernel namespaces strings hashtables sequences
assocs combinators vocabs.loader init threads continuations
math accessors concurrency.flags destructors environment
io io.encodings.ascii io.backend io.timeouts io.pipes
io.pipes.private io.encodings io.streams.duplex io.ports
debugger prettyprint summary calendar ;
USING: system kernel namespaces strings hashtables sequences assocs
combinators vocabs.loader init threads continuations math accessors
concurrency.flags destructors environment io io.encodings.ascii
io.backend io.timeouts io.pipes io.pipes.private io.encodings
io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
summary calendar ;
IN: io.launcher
TUPLE: process < identity-tuple
@ -254,6 +254,21 @@ M: object run-pipeline-element
swap [ with-stream ] dip
wait-for-success ; inline
ERROR: output-process-error { output string } { process process } ;
M: output-process-error error.
[ "Process:" print process>> . nl ]
[ "Output:" print output>> print ]
bi ;
: try-output-process ( command -- )
>process
+stdout+ >>stderr
+closed+ >>stdin
utf8 <process-reader*>
[ stream-contents ] [ dup wait-for-process ] bi*
0 = [ 2drop ] [ output-process-error ] if ;
: notify-exit ( process status -- )
>>status
[ processes get delete-at* drop [ resume ] each ] keep

View File

@ -6,7 +6,6 @@ H{
{ deploy-name "none" }
{ "stop-after-last-window?" t }
{ deploy-c-types? f }
{ deploy-compiler? f }
{ deploy-io 1 }
{ deploy-ui? f }
{ deploy-reflection 1 }

View File

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

View File

@ -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

View File

@ -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 ] }

View File

@ -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 ] }

View File

@ -35,6 +35,6 @@ ERROR: bad-byte-array-length byte-array ;
heap-size struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array )
[ heap-size calloc ] 2keep <direct-struct-array> ;
[ heap-size calloc ] 2keep <direct-struct-array> ; inline
INSTANCE: struct-array sequence

View File

@ -43,29 +43,17 @@ PRIVATE>
<PRIVATE
: word-inputs ( word -- seq )
stack-effect [
[ datastack ] dip in>> 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 ] ;

View File

@ -43,14 +43,14 @@ CONSTANT: theme-path "basis/ui/gadgets/theme/"
[ my-arch make-image ] unless ;
: bootstrap-profile ( -- profile )
{
{ "math" deploy-math? }
{ "compiler" deploy-compiler? }
{ "threads" deploy-threads? }
{ "ui" deploy-ui? }
{ "unicode" deploy-unicode? }
} [ nip get ] assoc-filter keys
native-io? [ "io" suffix ] when ;
[
deploy-math? get [ "math" , ] when
deploy-threads? get [ "threads" , ] when
"compiler" ,
deploy-ui? get [ "ui" , ] when
deploy-unicode? get [ "unicode" , ] when
native-io? [ "io" , ] when
] { } make ;
: staging-image-name ( profile -- name )
"staging."

View File

@ -5,7 +5,6 @@ IN: tools.deploy.config
ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
{ $subsection deploy-compiler? }
{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
@ -53,11 +52,6 @@ HELP: deploy-math?
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
HELP: deploy-compiler?
{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
$nl
"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
HELP: deploy-unicode?
{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl

View File

@ -7,7 +7,6 @@ IN: tools.deploy.config
SYMBOL: deploy-name
SYMBOL: deploy-ui?
SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
@ -55,7 +54,6 @@ SYMBOL: deploy-image
{ deploy-ui? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ deploy-math? t }

View File

@ -29,6 +29,8 @@ ARTICLE: "tools.deploy.caveats" "Deploy tool caveats"
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
{ $heading "Behavior of " { $link POSTPONE: execute( } }
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
{ $heading "Error reporting" }
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
{ $heading "Choosing the right deploy flags" }

View File

@ -11,7 +11,7 @@ io.directories tools.deploy.test ;
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test
[ "staging.math-compiler-threads-ui-strip.image" ] [
[ "staging.math-threads-compiler-ui-strip.image" ] [
"hello-ui" deploy-config
[ bootstrap-profile staging-image-name file-name ] bind
] unit-test
@ -20,6 +20,10 @@ io.directories tools.deploy.test ;
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test
[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test
[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test
os macosx? [
@ -84,7 +88,6 @@ M: quit-responder call-responder*
{
"tools.deploy.test.6"
"tools.deploy.test.7"
"tools.deploy.test.8"
"tools.deploy.test.9"
"tools.deploy.test.10"
"tools.deploy.test.11"
@ -94,4 +97,8 @@ M: quit-responder call-responder*
shake-and-bake
run-temp-image
] curry unit-test
] each
] each
os windows? os macosx? or [
[ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test
] when

View File

@ -1,13 +1,13 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors io.backend io.streams.c init fry
namespaces make assocs kernel parser lexer strings.parser vocabs
sequences words memory kernel.private
continuations io vocabs.loader system strings sets
vectors quotations byte-arrays sorting compiler.units
definitions generic generic.standard tools.deploy.config ;
USING: arrays accessors io.backend io.streams.c init fry namespaces
math make assocs kernel parser lexer strings.parser vocabs sequences
sequences.private words memory kernel.private continuations io
vocabs.loader system strings sets vectors quotations byte-arrays
sorting compiler.units definitions generic generic.standard
generic.single tools.deploy.config combinators classes
slots.private ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors
QUALIFIED: continuations
@ -40,10 +40,11 @@ IN: tools.deploy.shaker
strip-io? [
"io.files" init-hooks get delete-at
"io.backend" init-hooks get delete-at
"io.thread" init-hooks get delete-at
] when
strip-dictionary? [
{
"compiler.units"
! "compiler.units"
"vocabs"
"vocabs.cache"
"source-files.errors"
@ -193,6 +194,14 @@ IN: tools.deploy.shaker
strip-word-names? [ dup strip-word-names ] when
2drop ;
: strip-compiler-classes ( -- )
strip-dictionary? [
"Stripping compiler classes" show
{ "compiler" "stack-checker" }
[ child-vocabs [ words ] map concat [ class? ] filter ] map concat
[ dup implementors [ "methods" word-prop delete-at ] with each ] each
] when ;
: strip-default-methods ( -- )
strip-debugger? [
"Stripping default methods" show
@ -255,20 +264,20 @@ IN: tools.deploy.shaker
{
gensym
name>char-hook
classes:next-method-quot-cache
classes:class-and-cache
classes:class-not-cache
classes:class-or-cache
classes:class<=-cache
classes:classes-intersect-cache
classes:implementors-map
classes:update-map
next-method-quot-cache
class-and-cache
class-not-cache
class-or-cache
class<=-cache
classes-intersect-cache
implementors-map
update-map
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
compiler-impl
compiler.errors:compiler-errors
definition-observers
! definition-observers
interactive-vocabs
lexer-factory
print-use-hook
@ -298,16 +307,16 @@ IN: tools.deploy.shaker
compiler.errors:compiler-errors
continuations:thread-error-hook
} %
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
] when
deploy-c-types? get [
"c-types" "alien.c-types" lookup ,
] unless
deploy-ui? get [
"ui-error-hook" "ui.gadgets.worlds" lookup ,
] when
"windows-messages" "windows.messages" lookup [ , ] when*
] { } make ;
@ -322,26 +331,40 @@ IN: tools.deploy.shaker
] [ drop ] if ;
: strip-c-io ( -- )
deploy-io get 2 = os windows? or [
strip-io?
deploy-io get 3 = os windows? not and
or [
[
c-io-backend forget
"io.streams.c" forget-vocab
"io-thread-running?" "io.thread" lookup [
global delete-at
] when*
] with-compilation-unit
] unless ;
] when ;
: compress ( pred post-process string -- )
"Compressing " prepend show
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
: compress-byte-arrays ( -- )
[ byte-array? ] [ ] "byte arrays" compress ;
: compress-object? ( obj -- ? )
{
{ [ dup array? ] [ empty? ] }
{ [ dup byte-array? ] [ drop t ] }
{ [ dup string? ] [ drop t ] }
{ [ dup wrapper? ] [ drop t ] }
[ drop f ]
} cond ;
: compress-objects ( -- )
[ compress-object? ] [ ] "objects" compress ;
: remain-compiled ( old new -- old new )
#! Quotations which were formerly compiled must remain
#! compiled.
2dup [
2dup [ compiled>> ] [ compiled>> not ] bi* and
2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
[ nip jit-compile ] [ 2drop ] if
] 2each ;
@ -349,12 +372,6 @@ IN: tools.deploy.shaker
[ quotation? ] [ remain-compiled ] "quotations" compress
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
: compress-strings ( -- )
[ string? ] [ ] "strings" compress ;
: compress-wrappers ( -- )
[ wrapper? ] [ ] "wrappers" compress ;
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
@ -385,18 +402,40 @@ SYMBOL: deploy-vocab
t "quiet" set-global
f output-stream set-global ;
: unsafe-next-method-quot ( method -- quot )
[ "method-class" word-prop ]
[ "method-generic" word-prop ] bi
next-method 1quotation ;
: compute-next-methods ( -- )
[ standard-generic? ] instances [
"methods" word-prop [
nip
dup next-method-quot "next-method-quot" set-word-prop
nip dup
unsafe-next-method-quot
"next-method-quot" set-word-prop
] assoc-each
] each
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
: (clear-megamorphic-cache) ( i array -- )
2dup 1 slot < [
2dup [ f ] 2dip set-array-nth
[ 1 + ] dip (clear-megamorphic-cache)
] [ 2drop ] if ;
: clear-megamorphic-cache ( array -- )
[ 0 ] dip (clear-megamorphic-cache) ;
: find-megamorphic-caches ( -- seq )
"Finding megamorphic caches" show
[ standard-generic? ] instances [ def>> third ] map ;
: clear-megamorphic-caches ( cache -- )
"Clearing megamorphic caches" show
[ clear-megamorphic-cache ] each ;
: strip ( -- )
init-stripper
strip-default-methods
strip-libc
strip-call
strip-cocoa
@ -404,15 +443,17 @@ SYMBOL: deploy-vocab
compute-next-methods
strip-init-hooks
strip-c-io
strip-compiler-classes
strip-default-methods
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-boot-quot
find-megamorphic-caches
stripped-word-props
stripped-globals strip-globals
compress-byte-arrays
compress-objects
compress-quotations
compress-strings
compress-wrappers
strip-words ;
strip-words
clear-megamorphic-caches ;
: deploy-error-handler ( quot -- )
[
@ -432,6 +473,9 @@ SYMBOL: deploy-vocab
strip-debugger? [
"debugger" require
"inspector" require
deploy-ui? get [
"ui.debugger" require
] when
] unless
deploy-vocab set
deploy-vocab get require

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
init vocabs ;
init vocabs memoize accessors ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
@ -42,3 +42,8 @@ H{ } clone \ pool [
[ get values compile ] each
] bind
] with-variable
\ make-prepare-send reset-memoized
\ <selector> reset-memoized
\ (send) def>> second clear-assoc

View File

@ -8,7 +8,6 @@ H{
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.1" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

View File

@ -4,7 +4,6 @@ H{
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-word-props? f }
{ deploy-compiler? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }

View File

@ -9,7 +9,6 @@ H{
{ deploy-math? f }
{ deploy-unicode? f }
{ deploy-threads? f }
{ deploy-compiler? f }
{ deploy-io 2 }
{ deploy-ui? f }
}

View File

@ -9,7 +9,6 @@ H{
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-name "tools.deploy.test.12" }
{ deploy-compiler? f }
{ deploy-word-defs? f }
{ deploy-threads? f }
}

View File

@ -1,7 +1,6 @@
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
{ deploy-compiler? t }
{ deploy-math? t }
{ deploy-io 2 }
{ "stop-after-last-window?" t }

View File

@ -8,7 +8,6 @@ H{
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

View File

@ -6,7 +6,6 @@ H{
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? t }
{ deploy-io 3 }
{ deploy-math? t }

View File

@ -8,7 +8,6 @@ H{
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

View File

@ -8,7 +8,6 @@ H{
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
{ deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}

View File

@ -5,7 +5,6 @@ H{
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
{ deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }

View File

@ -6,7 +6,6 @@ H{
{ deploy-io 2 }
{ deploy-math? t }
{ "stop-after-last-window?" t }
{ deploy-compiler? t }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-reflection 1 }

View File

@ -1,11 +1,21 @@
USING: kernel ;
USING: calendar game-input threads ui ui.gadgets.worlds kernel
method-chains system ;
IN: tools.deploy.test.8
: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
TUPLE: my-world < world ;
: literal-merge-test ( -- )
literal-merge-test-1
literal-merge-test-2 eq? t assert= ;
BEFORE: my-world begin-world drop open-game-input ;
MAIN: literal-merge-test
AFTER: my-world end-world drop close-game-input ;
: test-game-input ( -- )
[
f T{ world-attributes
{ world-class my-world }
{ title "Test" }
} open-window
1 seconds sleep
0 exit
] with-ui ;
MAIN: test-game-input

View File

@ -1,15 +1,14 @@
USING: tools.deploy.config ;
H{
{ deploy-name "tools.deploy.test.8" }
{ deploy-c-types? f }
{ deploy-word-props? f }
{ deploy-ui? f }
{ deploy-reflection 1 }
{ deploy-compiler? f }
{ deploy-unicode? f }
{ deploy-io 1 }
{ deploy-word-defs? f }
{ deploy-threads? f }
{ deploy-name "tools.deploy.test.8" }
{ "stop-after-last-window?" t }
{ deploy-math? f }
{ deploy-reflection 1 }
{ deploy-ui? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-word-props? f }
{ deploy-threads? t }
}

View File

@ -6,7 +6,6 @@ H{
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-compiler? t }
{ deploy-threads? f }
{ deploy-io 1 }
{ deploy-math? t }

View File

@ -1,5 +1,5 @@
USING: accessors arrays continuations io.directories io.files.info
io.files.temp io.launcher kernel layouts math sequences system
io.files.temp io.launcher io.backend kernel layouts math sequences system
tools.deploy.backend tools.deploy.config.editor ;
IN: tools.deploy.test
@ -14,7 +14,6 @@ IN: tools.deploy.test
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
: run-temp-image ( -- )
vm
"-i=" "test.image" temp-file append
2array
<process> swap >>command +closed+ >>stdin try-process ;
os macosx?
"resource:Factor.app/Contents/MacOS/factor" normalize-path vm ?
"-i=" "test.image" temp-file append 2array try-output-process ;

View File

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

View File

@ -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 -- )

View File

@ -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 <CGPoint> CGWarpMouseCursorPosition drop ;
NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h
[ drop first ] [ swap second - ] 2bi <CGPoint>
[ GetCurrentButtonState zero? not ] [ yield ] while
CGWarpMouseCursorPosition drop ;
M: cocoa-ui-backend (ungrab-input) ( handle -- )
drop

Some files were not shown because too many files have changed in this diff Show More