Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
9715c3429c
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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>> 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>> ;
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 -- ? )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
*/
|
||||
|
|
@ -0,0 +1,209 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs byte-arrays
|
||||
byte-vectors combinators constructors fry grouping hashtables
|
||||
compression.huffman images io.binary kernel locals
|
||||
math math.bitwise math.order math.ranges multiline sequences
|
||||
sorting ;
|
||||
IN: compression.inflate
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: enum>seq ( assoc -- seq )
|
||||
dup keys [ ] [ max ] map-reduce 1 + f <array>
|
||||
[ '[ swap _ set-nth ] assoc-each ] keep ;
|
||||
|
||||
ERROR: zlib-unimplemented ;
|
||||
ERROR: bad-zlib-data ;
|
||||
ERROR: bad-zlib-header ;
|
||||
|
||||
:: check-zlib-header ( data -- )
|
||||
16 data bs:peek 2 >le be> 31 mod ! checksum
|
||||
0 assert=
|
||||
4 data bs:read 8 assert= ! compression method: deflate
|
||||
4 data bs:read ! log2(max length)-8, 32K max
|
||||
7 <= [ bad-zlib-header ] unless
|
||||
5 data bs:seek ! drop check bits
|
||||
1 data bs:read 0 assert= ! dictionnary - not allowed in png
|
||||
2 data bs:seek ! compression level; ignore
|
||||
;
|
||||
|
||||
:: default-table ( -- table )
|
||||
0 <hashtable> :> table
|
||||
0 143 [a,b] 280 287 [a,b] append 8 table set-at
|
||||
144 255 [a,b] >array 9 table set-at
|
||||
256 279 [a,b] >array 7 table set-at
|
||||
table enum>seq 1 tail ;
|
||||
|
||||
CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }
|
||||
|
||||
: get-table ( values size -- table )
|
||||
16 f <array> clone <enum>
|
||||
[ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;
|
||||
|
||||
:: decode-huffman-tables ( bitstream -- tables )
|
||||
5 bitstream bs:read 257 +
|
||||
5 bitstream bs:read 1 +
|
||||
4 bitstream bs:read 4 +
|
||||
clen-shuffle swap head
|
||||
dup [ drop 3 bitstream bs:read ] map
|
||||
get-table
|
||||
bitstream swap <huffman-decoder>
|
||||
[ 2dup + ] dip swap :> k!
|
||||
'[
|
||||
_ read1-huff2
|
||||
{
|
||||
{ [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }
|
||||
{ [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }
|
||||
[ ]
|
||||
} cond
|
||||
dup array? [ dup second ] [ 1 ] if
|
||||
k swap - dup k! 0 >
|
||||
]
|
||||
[ ] produce swap suffix
|
||||
{ } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat
|
||||
nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;
|
||||
|
||||
CONSTANT: length-table
|
||||
{
|
||||
3 4 5 6 7 8 9 10
|
||||
11 13 15 17
|
||||
19 23 27 31
|
||||
35 43 51 59
|
||||
67 83 99 115
|
||||
131 163 195 227
|
||||
}
|
||||
|
||||
CONSTANT: dist-table
|
||||
{ 1 2 3 4
|
||||
5 7 9 13
|
||||
17 25 33 49
|
||||
65 97 129 193
|
||||
257 385 513 769
|
||||
1025 1537 2049 3073
|
||||
4097 6145 8193 12289
|
||||
16385 24577 }
|
||||
|
||||
: nth* ( n seq -- elt )
|
||||
[ length 1- swap - ] [ nth ] bi ;
|
||||
|
||||
:: inflate-lz77 ( seq -- bytes )
|
||||
1000 <byte-vector> :> bytes
|
||||
seq
|
||||
[
|
||||
dup array?
|
||||
[ first2 '[ _ 1- bytes nth* bytes push ] times ]
|
||||
[ bytes push ] if
|
||||
] each
|
||||
bytes ;
|
||||
|
||||
:: inflate-dynamic ( bitstream -- bytes )
|
||||
bitstream decode-huffman-tables
|
||||
bitstream '[ _ swap <huffman-decoder> ] map :> tables
|
||||
[
|
||||
tables first read1-huff2
|
||||
dup 256 >
|
||||
[
|
||||
dup 285 =
|
||||
[ ]
|
||||
[
|
||||
dup 264 >
|
||||
[
|
||||
dup 261 - 4 /i dup 5 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
] if
|
||||
! 5 bitstream read-bits ! distance
|
||||
tables second read1-huff2
|
||||
dup 3 >
|
||||
[
|
||||
dup 2 - 2 /i dup 13 >
|
||||
[ bad-zlib-data ] when
|
||||
bitstream bs:read 2array
|
||||
]
|
||||
when
|
||||
2array
|
||||
]
|
||||
when
|
||||
dup 256 = not
|
||||
]
|
||||
[ ] produce nip
|
||||
[
|
||||
dup array? [
|
||||
first2
|
||||
[
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ 257 - length-table nth ] [ + ] bi*
|
||||
]
|
||||
[
|
||||
dup array? [ first2 ] [ 0 ] if
|
||||
[ dist-table nth ] [ + ] bi*
|
||||
] bi*
|
||||
2array
|
||||
] when
|
||||
] map ;
|
||||
|
||||
: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
|
||||
:: inflate-loop ( bitstream -- bytes )
|
||||
[ 1 bitstream bs:read 0 = ]
|
||||
[
|
||||
bitstream
|
||||
2 bitstream bs:read ! B
|
||||
{
|
||||
{ 0 [ inflate-raw ] }
|
||||
{ 1 [ inflate-static ] }
|
||||
{ 2 [ inflate-dynamic ] }
|
||||
{ 3 [ bad-zlib-data f ] }
|
||||
}
|
||||
case
|
||||
]
|
||||
[ produce ] keep call suffix concat ;
|
||||
|
||||
! [ produce ] keep dip swap suffix
|
||||
|
||||
:: paeth ( a b c -- p )
|
||||
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
|
||||
sort-keys first second ;
|
||||
|
||||
:: png-unfilter-line ( prev curr filter -- curr' )
|
||||
prev :> c
|
||||
prev 3 tail-slice :> b
|
||||
curr :> a
|
||||
curr 3 tail-slice :> x
|
||||
x length [0,b)
|
||||
filter
|
||||
{
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
|
||||
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
|
||||
|
||||
} case
|
||||
curr 3 tail ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
! for debug -- shows residual values
|
||||
: reverse-png-filter' ( lines -- filtered )
|
||||
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
|
||||
concat [ 128 + 256 wrap ] map ;
|
||||
|
||||
: reverse-png-filter ( lines -- filtered )
|
||||
dup first [ 0 ] replicate prefix
|
||||
[ { 0 0 } prepend ] map
|
||||
2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ;
|
||||
|
||||
: zlib-inflate ( bytes -- bytes )
|
||||
bs:<lsb0-bit-reader>
|
||||
[ check-zlib-header ]
|
||||
[ inflate-loop ] bi
|
||||
inflate-lz77 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application
|
|||
sequences locals combinators.short-circuit threads
|
||||
namespaces assocs vectors arrays combinators hints alien
|
||||
core-foundation.run-loop accessors sequences.private
|
||||
alien.c-types math parser game-input vectors ;
|
||||
alien.c-types math parser game-input vectors bit-arrays ;
|
||||
IN: game-input.iokit
|
||||
|
||||
SINGLETON: iokit-game-input-backend
|
||||
|
|
@ -186,7 +186,7 @@ HINTS: record-controller { controller-state alien } ;
|
|||
rot ?set-nth
|
||||
] [ 3drop ] if ;
|
||||
|
||||
HINTS: record-keyboard { array alien } ;
|
||||
HINTS: record-keyboard { bit-array alien } ;
|
||||
|
||||
: record-mouse ( mouse-state value -- )
|
||||
dup IOHIDValueGetElement {
|
||||
|
|
@ -285,7 +285,7 @@ M: iokit-game-input-backend reset-mouse
|
|||
4 <vector> +controller-states+ set-global
|
||||
0 0 0 0 2 <vector> mouse-state boa
|
||||
+mouse-state+ set-global
|
||||
256 f <array> +keyboard-state+ set-global ;
|
||||
256 <bit-array> +keyboard-state+ set-global ;
|
||||
|
||||
M: iokit-game-input-backend (open-game-input)
|
||||
hid-manager-matching-game-devices {
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors constructors images io io.binary io.encodings.ascii
|
||||
io.encodings.binary io.encodings.string io.files io.files.info kernel
|
||||
sequences io.streams.limited fry combinators arrays math
|
||||
checksums checksums.crc32 ;
|
||||
checksums checksums.crc32 compression.inflate grouping byte-arrays ;
|
||||
IN: images.png
|
||||
|
||||
TUPLE: png-image < image chunks
|
||||
|
|
@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ;
|
|||
|
||||
CONSTRUCTOR: png-chunk ( -- png-chunk ) ;
|
||||
|
||||
CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
|
||||
CONSTANT: png-header
|
||||
B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a }
|
||||
|
||||
ERROR: bad-png-header header ;
|
||||
|
||||
|
|
@ -61,6 +62,18 @@ ERROR: bad-checksum ;
|
|||
: fill-image-data ( image -- image )
|
||||
dup [ width>> ] [ height>> ] bi 2array >>dim ;
|
||||
|
||||
: zlib-data ( png-image -- bytes )
|
||||
chunks>> [ type>> "IDAT" = ] find nip data>> ;
|
||||
|
||||
: decode-png ( image -- image )
|
||||
{
|
||||
[ zlib-data zlib-inflate ]
|
||||
[ dim>> first 3 * 1 + group reverse-png-filter ]
|
||||
[ swap >byte-array >>bitmap drop ]
|
||||
[ RGB >>component-order drop ]
|
||||
[ ]
|
||||
} cleave ;
|
||||
|
||||
: load-png ( path -- image )
|
||||
[ binary <file-reader> ] [ file-info size>> ] bi
|
||||
stream-throws <limited-stream> [
|
||||
|
|
@ -69,4 +82,8 @@ ERROR: bad-checksum ;
|
|||
read-png-chunks
|
||||
parse-ihdr-chunk
|
||||
fill-image-data
|
||||
decode-png
|
||||
] with-input-stream ;
|
||||
|
||||
M: png-image load-image*
|
||||
drop load-png ;
|
||||
|
|
|
|||
|
|
@ -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. ;
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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 ] ;
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
]
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -556,11 +556,9 @@ M: windows-ui-backend do-events
|
|||
[ DispatchMessage drop ] bi
|
||||
] if ;
|
||||
|
||||
: register-wndclassex ( -- class )
|
||||
"WNDCLASSEX" <c-object>
|
||||
f GetModuleHandle
|
||||
class-name-ptr get-global
|
||||
pick GetClassInfoEx zero? [
|
||||
:: register-window-class ( class-name-ptr -- )
|
||||
"WNDCLASSEX" <c-object> 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
|
||||
|
||||
|
|
|
|||
|
|
@ -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" <c-object>
|
||||
[ set-XClientMessageEvent-window ] keep
|
||||
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
|
||||
M: x11-ui-backend (set-fullscreen) ( world ? -- )
|
||||
[
|
||||
handle>> window>> "XClientMessageEvent" <c-object>
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 } } }
|
||||
|
|
|
|||
|
|
@ -209,11 +209,14 @@ PRIVATE>
|
|||
: open-window ( gadget title/attributes -- )
|
||||
?attributes <world> 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* ;
|
||||
|
|
|
|||
|
|
@ -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 ) ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
[ 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
|
||||
|
|
@ -58,13 +58,13 @@ M: single-combination make-default-method
|
|||
] unless ;
|
||||
|
||||
! 1. Flatten methods
|
||||
TUPLE: predicate-engine methods ;
|
||||
TUPLE: predicate-engine class methods ;
|
||||
|
||||
: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
|
||||
C: <predicate-engine> predicate-engine
|
||||
|
||||
: push-method ( method specializer atomic assoc -- )
|
||||
[
|
||||
[ H{ } clone <predicate-engine> ] unless*
|
||||
dupd [
|
||||
[ ] [ H{ } clone <predicate-engine> ] ?if
|
||||
[ methods>> set-at ] keep
|
||||
] change-at ;
|
||||
|
||||
|
|
@ -182,14 +182,27 @@ M: tuple-dispatch-engine compile-engine
|
|||
[ <enum> swap update ] keep
|
||||
] with-variable ;
|
||||
|
||||
PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
|
||||
|
||||
SYMBOL: predicate-engines
|
||||
|
||||
: sort-methods ( assoc -- assoc' )
|
||||
>alist [ keys sort-classes ] keep extract-keys ;
|
||||
|
||||
: quote-methods ( assoc -- assoc' )
|
||||
[ 1quotation \ drop prefix ] assoc-map ;
|
||||
|
||||
: find-predicate-engine ( classes -- word )
|
||||
predicate-engines get [ at ] curry map-find drop ;
|
||||
|
||||
: next-predicate-engine ( engine -- word )
|
||||
class>> superclasses
|
||||
find-predicate-engine
|
||||
default get or ;
|
||||
|
||||
: methods-with-default ( engine -- assoc )
|
||||
methods>> clone default get object bootstrap-word pick set-at ;
|
||||
[ methods>> clone ] [ next-predicate-engine ] bi
|
||||
object bootstrap-word pick set-at ;
|
||||
|
||||
: keep-going? ( assoc -- ? )
|
||||
assumed get swap second first class<= ;
|
||||
|
|
@ -205,8 +218,6 @@ M: tuple-dispatch-engine compile-engine
|
|||
: class-predicates ( assoc -- assoc )
|
||||
[ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ;
|
||||
|
||||
PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
|
||||
|
||||
: <predicate-engine-word> ( -- word )
|
||||
generic-word get name>> "/predicate-engine" append f <word>
|
||||
dup generic-word get "owner-generic" set-word-prop ;
|
||||
|
|
@ -217,7 +228,7 @@ M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ;
|
|||
[ <predicate-engine-word> ] dip
|
||||
[ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
|
||||
|
||||
M: predicate-engine compile-engine
|
||||
: compile-predicate-engine ( engine -- word )
|
||||
methods-with-default
|
||||
sort-methods
|
||||
quote-methods
|
||||
|
|
@ -225,6 +236,10 @@ M: predicate-engine compile-engine
|
|||
class-predicates
|
||||
[ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
|
||||
|
||||
M: predicate-engine compile-engine
|
||||
[ compile-predicate-engine ] [ class>> ] bi
|
||||
[ drop ] [ predicate-engines get set-at ] 2bi ;
|
||||
|
||||
M: word compile-engine ;
|
||||
|
||||
M: f compile-engine ;
|
||||
|
|
@ -251,6 +266,7 @@ HOOK: mega-cache-quot combination ( methods -- quot/f )
|
|||
|
||||
M: single-combination perform-combination
|
||||
[
|
||||
H{ } clone predicate-engines set
|
||||
dup generic-word set
|
||||
dup build-decision-tree
|
||||
[ "decision-tree" set-word-prop ]
|
||||
|
|
|
|||
|
|
@ -6,9 +6,13 @@ generic.single.private quotations kernel.private
|
|||
assocs arrays layouts make ;
|
||||
IN: generic.standard
|
||||
|
||||
ERROR: bad-dispatch-position # ;
|
||||
|
||||
TUPLE: standard-combination < single-combination # ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
: <standard-combination> ( # -- standard-combination )
|
||||
dup 0 < [ bad-dispatch-position ] when
|
||||
standard-combination boa ;
|
||||
|
||||
PREDICATE: standard-generic < generic
|
||||
"combination" word-prop standard-combination? ;
|
||||
|
|
|
|||
|
|
@ -27,16 +27,8 @@ TUPLE: testing x y z ;
|
|||
|
||||
[ save-image-and-exit ] must-fail
|
||||
|
||||
[ ] [
|
||||
num-types get [
|
||||
type>class [
|
||||
dup . flush
|
||||
"predicate" word-prop instances [
|
||||
class drop
|
||||
] each
|
||||
] when*
|
||||
] each
|
||||
] unit-test
|
||||
|
||||
! Erg's bug
|
||||
2 [ [ [ 3 throw ] instances ] must-fail ] times
|
||||
|
||||
! Bug found on Windows build box, having too many words in the image breaks 'become'
|
||||
[ ] [ 100000 [ f f <word> ] replicate { } { } become drop ] unit-test
|
||||
|
|
|
|||
|
|
@ -12,12 +12,12 @@ M: game-world draw*
|
|||
swap >>tick-slice draw-world ;
|
||||
|
||||
M: game-world begin-world
|
||||
open-game-input
|
||||
dup [ tick-length ] [ ] bi <game-loop> [ >>game-loop ] keep start-loop
|
||||
drop
|
||||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,6 +25,7 @@ M: gesture-logger user-input*
|
|||
: gesture-logger ( -- )
|
||||
[
|
||||
<pane> t >>scrolls? dup <scroller>
|
||||
{ 450 500 } >>pref-dim
|
||||
"Gesture log" open-window
|
||||
<pane-stream> <gesture-logger>
|
||||
"Gesture input" open-window
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -33,7 +33,8 @@ TUPLE: irc-profile server port nickname password ;
|
|||
C: <irc-profile> irc-profile
|
||||
|
||||
TUPLE: irc-client profile stream in-messages out-messages
|
||||
chats is-running nick connect reconnect-time is-ready
|
||||
chats is-running nick connect is-ready
|
||||
reconnect-time reconnect-attempts
|
||||
exceptions ;
|
||||
|
||||
: <irc-client> ( profile -- irc-client )
|
||||
|
|
@ -43,8 +44,9 @@ TUPLE: irc-client profile stream in-messages out-messages
|
|||
<mailbox> >>in-messages
|
||||
<mailbox> >>out-messages
|
||||
H{ } clone >>chats
|
||||
15 seconds >>reconnect-time
|
||||
30 seconds >>reconnect-time
|
||||
10 >>reconnect-attempts
|
||||
V{ } clone >>exceptions
|
||||
[ <inet> latin1 <client> ] >>connect ;
|
||||
[ <inet> latin1 <client> drop ] >>connect ;
|
||||
|
||||
SINGLETONS: irc-chat-end irc-end irc-disconnected irc-connected ;
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ M: mb-writer dispose drop ;
|
|||
! Test connect
|
||||
{ V{ "NICK factorbot" "USER factorbot hostname servername :irc.factor" } } [
|
||||
"someserver" irc-port "factorbot" f <irc-profile> <irc-client>
|
||||
[ 2drop <test-stream> t ] >>connect
|
||||
[ 2drop <test-stream> ] >>connect
|
||||
[
|
||||
(connect-irc)
|
||||
(do-login)
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -16,7 +16,7 @@ SYMBOL: current-stream
|
|||
"irc.freenode.org" 6667 "flogger" f <irc-profile> ;
|
||||
|
||||
: add-timestamp ( string timestamp -- string )
|
||||
timestamp>hms "[" prepend "] " append prepend ;
|
||||
timestamp>hms [ "[" % % "] " % % ] "" make ;
|
||||
|
||||
: timestamp-path ( timestamp -- path )
|
||||
timestamp>ymd ".log" append log-directory prepend-path ;
|
||||
|
|
@ -27,7 +27,7 @@ SYMBOL: current-stream
|
|||
] [
|
||||
current-stream get [ dispose ] when*
|
||||
[ day-of-year current-day set ]
|
||||
[ timestamp-path latin1 <file-writer> ] bi
|
||||
[ timestamp-path latin1 <file-appender> ] bi
|
||||
current-stream set
|
||||
] if current-stream get ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
string>irc-message f >>timestamp ] unit-test
|
||||
|
||||
{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :ACTION jumps!"
|
||||
string>irc-message action? ] unit-test
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ] }
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -10,25 +10,25 @@ IN: mason.common
|
|||
|
||||
SYMBOL: current-git-id
|
||||
|
||||
: short-running-process ( command -- )
|
||||
#! Give network operations and shell commands at most
|
||||
#! 15 minutes to complete, to catch hangs.
|
||||
>process
|
||||
15 minutes >>timeout
|
||||
+closed+ >>stdin
|
||||
try-output-process ;
|
||||
|
||||
HOOK: really-delete-tree os ( path -- )
|
||||
|
||||
M: windows really-delete-tree
|
||||
#! Workaround: Cygwin GIT creates read-only files for
|
||||
#! some reason.
|
||||
[ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix try-output-process ]
|
||||
[ { "chmod" "ug+rw" "-R" } swap (normalize-path) suffix short-running-process ]
|
||||
[ delete-tree ]
|
||||
bi ;
|
||||
|
||||
M: unix really-delete-tree delete-tree ;
|
||||
|
||||
: short-running-process ( command -- )
|
||||
#! Give network operations at most 15 minutes to complete.
|
||||
<process>
|
||||
swap >>command
|
||||
15 minutes >>timeout
|
||||
+closed+ >>stdin
|
||||
try-output-process ;
|
||||
|
||||
: retry ( n quot -- )
|
||||
'[ drop @ f ] attempt-all drop ; inline
|
||||
|
||||
|
|
@ -79,8 +79,8 @@ SYMBOL: stamp
|
|||
with-directory ;
|
||||
|
||||
: git-id ( -- id )
|
||||
{ "git" "show" } utf8 [ readln ] with-process-reader
|
||||
" " split second ;
|
||||
{ "git" "show" } utf8 [ lines ] with-process-reader
|
||||
first " " split second ;
|
||||
|
||||
: ?prepare-build-machine ( -- )
|
||||
builds/factor exists? [ prepare-build-machine ] unless ;
|
||||
|
|
|
|||
|
|
@ -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 ( -- )
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ IN: mason.notify
|
|||
<process>
|
||||
_ [ +closed+ ] unless* >>stdin
|
||||
_ >>command
|
||||
try-output-process
|
||||
short-running-process
|
||||
] retry
|
||||
] [ 2drop ] if ;
|
||||
|
||||
|
|
@ -42,8 +42,10 @@ IN: mason.notify
|
|||
: notify-report ( status -- )
|
||||
[ "Build finished with status: " write . flush ]
|
||||
[
|
||||
[ "report" utf8 file-contents ] dip email-report
|
||||
"report" { "report" } status-notify
|
||||
[ "report" ] dip
|
||||
[ [ utf8 file-contents ] dip email-report ]
|
||||
[ "report" swap name>> 2array status-notify ]
|
||||
2bi
|
||||
] bi ;
|
||||
|
||||
: notify-release ( archive-name -- )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,82 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators combinators.smart command-line db
|
||||
db.sqlite db.tuples db.types io kernel namespaces sequences ;
|
||||
IN: mason.notify.server
|
||||
|
||||
CONSTANT: +starting+ "starting"
|
||||
CONSTANT: +make-vm+ "make-vm"
|
||||
CONSTANT: +boot+ "boot"
|
||||
CONSTANT: +test+ "test"
|
||||
CONSTANT: +clean+ "clean"
|
||||
CONSTANT: +dirty+ "dirty"
|
||||
|
||||
TUPLE: builder host-name os cpu clean-git-id last-git-id last-report current-git-id status ;
|
||||
|
||||
builder "BUILDERS" {
|
||||
{ "host-name" "HOST_NAME" TEXT +user-assigned-id+ }
|
||||
{ "os" "OS" TEXT +user-assigned-id+ }
|
||||
{ "cpu" "CPU" TEXT +user-assigned-id+ }
|
||||
{ "clean-git-id" "CLEAN_GIT_ID" TEXT }
|
||||
{ "last-git-id" "LAST_GIT_ID" TEXT }
|
||||
{ "last-report" "LAST_REPORT" TEXT }
|
||||
{ "current-git-id" "CURRENT_GIT_ID" TEXT }
|
||||
{ "status" "STATUS" TEXT }
|
||||
} define-persistent
|
||||
|
||||
SYMBOLS: host-name target-os target-cpu message message-arg ;
|
||||
|
||||
: parse-args ( command-line -- )
|
||||
dup peek message-arg set
|
||||
[
|
||||
{
|
||||
[ host-name set ]
|
||||
[ target-cpu set ]
|
||||
[ target-os set ]
|
||||
[ message set ]
|
||||
} spread
|
||||
] input<sequence ;
|
||||
|
||||
: find-builder ( -- builder )
|
||||
builder new
|
||||
host-name get >>host-name
|
||||
target-os get >>os
|
||||
target-cpu get >>cpu
|
||||
dup select-tuple [ ] [ dup insert-tuple ] ?if ;
|
||||
|
||||
: git-id ( builder id -- )
|
||||
>>current-git-id +starting+ >>status drop ;
|
||||
|
||||
: make-vm ( builder -- ) +make-vm+ >>status drop ;
|
||||
|
||||
: boot ( report -- ) +boot+ >>status drop ;
|
||||
|
||||
: test ( report -- ) +test+ >>status drop ;
|
||||
|
||||
: report ( builder status content -- )
|
||||
[ >>status ] [ >>last-report ] bi*
|
||||
dup status>> +clean+ = [ dup current-git-id>> >>clean-git-id ] when
|
||||
dup current-git-id>> >>last-git-id
|
||||
drop ;
|
||||
|
||||
: update-builder ( builder -- )
|
||||
message get {
|
||||
{ "git-id" [ message-arg get git-id ] }
|
||||
{ "make-vm" [ make-vm ] }
|
||||
{ "boot" [ boot ] }
|
||||
{ "test" [ test ] }
|
||||
{ "report" [ message-arg get contents report ] }
|
||||
} case ;
|
||||
|
||||
: mason-db ( -- db ) "resource:mason.db" <sqlite-db> ;
|
||||
|
||||
: handle-update ( command-line -- )
|
||||
mason-db [
|
||||
parse-args find-builder
|
||||
[ update-builder ] [ update-tuple ] bi
|
||||
] with-db ;
|
||||
|
||||
: main ( -- )
|
||||
command-line get handle-update ;
|
||||
|
||||
MAIN: main
|
||||
|
|
@ -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" ? ;
|
||||
|
|
|
|||
|
|
@ -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 {
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ IN: mason.report
|
|||
:: failed-report ( error file what -- status )
|
||||
[
|
||||
error [ error. ] with-string-writer :> error
|
||||
file utf8 file-contents 400 short tail* :> output
|
||||
file utf8 file-lines 400 short tail* :> output
|
||||
|
||||
[XML
|
||||
<h2><-what-></h2>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Bruno Deferrari
|
||||
|
|
@ -0,0 +1 @@
|
|||
Assoc protocol implementation for Redis
|
||||
|
|
@ -1,6 +1,8 @@
|
|||
! Copyright (C) 2009 Bruno Deferrari
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: io redis.response-parser redis.command-writer ;
|
||||
USING: accessors io io.encodings.8-bit io.sockets
|
||||
io.streams.duplex kernel redis.command-writer
|
||||
redis.response-parser splitting ;
|
||||
IN: redis
|
||||
|
||||
#! Connection
|
||||
|
|
@ -23,7 +25,7 @@ IN: redis
|
|||
: redis-type ( key -- response ) type flush read-response ;
|
||||
|
||||
#! Key space
|
||||
: redis-keys ( pattern -- response ) keys flush read-response ;
|
||||
: redis-keys ( pattern -- response ) keys flush read-response " " split ;
|
||||
: redis-randomkey ( -- response ) randomkey flush read-response ;
|
||||
: redis-rename ( newkey key -- response ) rename flush read-response ;
|
||||
: redis-renamenx ( newkey key -- response ) renamenx flush read-response ;
|
||||
|
|
@ -72,3 +74,24 @@ IN: redis
|
|||
#! Remote server control
|
||||
: redis-info ( -- response ) info flush read-response ;
|
||||
: redis-monitor ( -- response ) monitor flush read-response ;
|
||||
|
||||
#! Redis object
|
||||
TUPLE: redis host port encoding password ;
|
||||
|
||||
CONSTANT: default-redis-port 6379
|
||||
|
||||
: <redis> ( -- redis )
|
||||
redis new
|
||||
"127.0.0.1" >>host
|
||||
default-redis-port >>port
|
||||
latin1 >>encoding ;
|
||||
|
||||
: redis-do-connect ( redis -- stream )
|
||||
[ host>> ] [ port>> ] [ encoding>> ] tri
|
||||
[ <inet> ] dip <client> drop ;
|
||||
|
||||
: with-redis ( redis quot -- )
|
||||
[
|
||||
[ redis-do-connect ] [ password>> ] bi
|
||||
[ swap [ [ redis-auth drop ] with-stream* ] keep ] when*
|
||||
] dip with-stream ; inline
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
|
||||
[ >>sky-image ] keep
|
||||
make-texture [ set-texture-parameters ] keep >>sky-texture
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,84 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays combinators db db.tuples furnace.actions
|
||||
http.server.responses kernel mason.platform mason.notify.server
|
||||
math.order sequences sorting splitting xml.syntax xml.writer
|
||||
io.pathnames io.encodings.utf8 io.files ;
|
||||
IN: webapps.mason
|
||||
|
||||
: log-file ( -- path ) home "mason.log" append-path ;
|
||||
|
||||
: recent-events ( -- xml )
|
||||
log-file utf8 file-lines 10 short tail* "\n" join [XML <pre><-></pre> XML] ;
|
||||
|
||||
: git-link ( id -- link )
|
||||
[ "http://github.com/slavapestov/factor/commit/" prepend ] keep
|
||||
[XML <a href=<->><-></a> XML] ;
|
||||
|
||||
: building ( builder string -- xml )
|
||||
swap current-git-id>> git-link
|
||||
[XML <-> for <-> XML] ;
|
||||
|
||||
: current-status ( builder -- xml )
|
||||
dup status>> {
|
||||
{ "dirty" [ drop "Dirty" ] }
|
||||
{ "clean" [ drop "Clean" ] }
|
||||
{ "starting" [ "Starting" building ] }
|
||||
{ "make-vm" [ "Compiling VM" building ] }
|
||||
{ "boot" [ "Bootstrapping" building ] }
|
||||
{ "test" [ "Testing" building ] }
|
||||
[ 2drop "Unknown" ]
|
||||
} case ;
|
||||
|
||||
: binaries-link ( builder -- link )
|
||||
[ os>> ] [ cpu>> ] bi (platform) "http://downloads.factorcode.org/" prepend
|
||||
dup [XML <a href=<->><-></a> XML] ;
|
||||
|
||||
: clean-image-link ( builder -- link )
|
||||
[ os>> ] [ cpu>> ] bi (platform) "http://factorcode.org/images/clean/" prepend
|
||||
dup [XML <a href=<->><-></a> XML] ;
|
||||
|
||||
: machine-table ( builder -- xml )
|
||||
{
|
||||
[ os>> ]
|
||||
[ cpu>> ]
|
||||
[ host-name>> "." split1 drop ]
|
||||
[ current-status ]
|
||||
[ last-git-id>> dup [ git-link ] when ]
|
||||
[ clean-git-id>> dup [ git-link ] when ]
|
||||
[ binaries-link ]
|
||||
[ clean-image-link ]
|
||||
} cleave
|
||||
[XML
|
||||
<h2><-> / <-></h2>
|
||||
<table border="1">
|
||||
<tr><td>Host name:</td><td><-></td></tr>
|
||||
<tr><td>Current status:</td><td><-></td></tr>
|
||||
<tr><td>Last build:</td><td><-></td></tr>
|
||||
<tr><td>Last clean build:</td><td><-></td></tr>
|
||||
<tr><td>Binaries:</td><td><-></td></tr>
|
||||
<tr><td>Clean images:</td><td><-></td></tr>
|
||||
</table>
|
||||
XML] ;
|
||||
|
||||
: machine-report ( -- xml )
|
||||
builder new select-tuples
|
||||
[ [ [ os>> ] [ cpu>> ] bi 2array ] compare ] sort
|
||||
[ machine-table ] map ;
|
||||
|
||||
: build-farm-report ( -- xml )
|
||||
recent-events
|
||||
machine-report
|
||||
[XML
|
||||
<html>
|
||||
<head><title>Factor build farm</title></head>
|
||||
<body><h1>Recent events</h1><-> <h1>Machine status</h1><-></body>
|
||||
</html>
|
||||
XML] ;
|
||||
|
||||
: <build-farm-report-action> ( -- action )
|
||||
<action>
|
||||
[
|
||||
mason-db [ build-farm-report xml>string ] with-db
|
||||
"text/html" <content>
|
||||
] >>display ;
|
||||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ struct growable_array {
|
|||
cell count;
|
||||
gc_root<array> elements;
|
||||
|
||||
growable_array() : count(0), elements(allot_array(2,F)) {}
|
||||
growable_array(cell capacity = 10) : count(0), elements(allot_array(capacity,F)) {}
|
||||
|
||||
void add(cell elt);
|
||||
void trim();
|
||||
|
|
|
|||
|
|
@ -7,12 +7,11 @@ PRIMITIVE(byte_array);
|
|||
PRIMITIVE(uninitialized_byte_array);
|
||||
PRIMITIVE(resize_byte_array);
|
||||
|
||||
/* Macros to simulate a byte vector in C */
|
||||
struct growable_byte_array {
|
||||
cell count;
|
||||
gc_root<byte_array> elements;
|
||||
|
||||
growable_byte_array() : count(0), elements(allot_byte_array(2)) { }
|
||||
growable_byte_array(cell capacity = 40) : count(0), elements(allot_byte_array(capacity)) { }
|
||||
|
||||
void append_bytes(void *elts, cell len);
|
||||
void append_byte_array(cell elts);
|
||||
|
|
|
|||
|
|
@ -11,22 +11,6 @@ static void check_frame(stack_frame *frame)
|
|||
#endif
|
||||
}
|
||||
|
||||
void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator)
|
||||
{
|
||||
stack_frame *frame = (stack_frame *)bottom - 1;
|
||||
|
||||
while((cell)frame >= top)
|
||||
{
|
||||
iterator(frame);
|
||||
frame = frame_successor(frame);
|
||||
}
|
||||
}
|
||||
|
||||
void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator)
|
||||
{
|
||||
iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
|
||||
}
|
||||
|
||||
callstack *allot_callstack(cell size)
|
||||
{
|
||||
callstack *stack = allot<callstack>(callstack_size(size));
|
||||
|
|
@ -138,36 +122,39 @@ cell frame_scan(stack_frame *frame)
|
|||
return F;
|
||||
}
|
||||
|
||||
/* C doesn't have closures... */
|
||||
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<array>(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> 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<array>(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<array>(frames));
|
||||
dpush(tag<array>(accum.frames));
|
||||
}
|
||||
|
||||
stack_frame *innermost_stack_frame(callstack *stack)
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue