! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture
-io.encodings.utf8 io.encodings.utf16n ;
+io.encodings.utf8 ;
IN: alien.arrays
UNION: value-type array struct-type ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
-{ "char*" utf16n } "wchar_t*" typedef
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
+[ BIN: 1111111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 10 swap peek
+] unit-test
-[ 4095 12 t ]
-[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 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
+
+[ 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
-[ B{ 254 } ]
+[ BIN: 11111 ]
[
- 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
+ 5 swap peek
] unit-test
-[ 255 8 t ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] 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
-[ 255 8 f ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
+[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
! 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
- ] [
- 0 >>#bits
- t >>end-of-stream?
- ] if* ;
+GENERIC: peek ( n bitstream -- value )
+GENERIC: poke ( value n bitstream -- )
-: maybe-read-next-byte ( bitstream -- bitstream )
- dup #bits>> 0 = [ read-next-byte ] when ; inline
+: seek ( n bitstream -- )
+ {
+ [ byte-pos>> 8 * ]
+ [ bit-pos>> + + 8 /mod ]
+ [ (>>bit-pos) ]
+ [ (>>byte-pos) ]
+ } cleave ; inline
-: shift-one-bit ( bitstream -- n )
- [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
+: read ( n bitstream -- value )
+ [ peek ] [ seek ] 2bi ; 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
+<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
] [
- 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
+ [ widthed-bits ]
+ [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
+ ] if ;
+
+: widthed>bytes ( widthed -- bytes widthed )
+ [ 8 split-widthed dup zero-widthed? not ]
+ [ swap bits>> ] B{ } produce-as nip swap ;
+
+:: |widthed ( widthed1 widthed2 -- widthed3 )
+ widthed1 bits>> :> bits1
+ widthed1 #bits>> :> #bits1
+ widthed2 bits>> :> bits2
+ widthed2 #bits>> :> #bits2
+ bits1 #bits2 shift bits2 bitor
+ #bits1 #bits2 + <widthed> ;
+
+PRIVATE>
+
+M:: lsb0-bit-writer poke ( value n bs -- )
+ value n <widthed> :> widthed
+ widthed
+ bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+ byte bs widthed>> |widthed :> new-byte
+ new-byte #bits>> 8 = [
+ new-byte bits>> bs bytes>> push
+ zero-widthed bs (>>widthed)
+ remainder widthed>bytes
+ [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
] [
- drop
- ] if ; inline
+ byte bs (>>widthed)
+ ] if ;
-ERROR: invalid-bit-width n ;
+: enough-bits? ( n bs -- ? )
+ [ bytes>> length ]
+ [ byte-pos>> - 8 * ]
+ [ bit-pos>> - ] tri <= ;
-:: write-bits ( n width bitstream -- )
- n 0 < [ n invalid-bit-width ] when
- n 0 = [
- width [ 0 bitstream write-bit ] times
+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
] [
- 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
+ bs (>>bit-pos)
] if ;
-: flush-bits ( bitstream -- ) stream>> stream-flush ;
+:: (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) ;
-: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
+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>> ;
array>> '
quotation [
emit ! array
- f ' emit ! compiled
f ' emit ! cached-effect
f ' emit ! cache-counter
0 emit ! xt
SYMBOL: bootstrap-time
+: strip-encodings ( -- )
+ os unix? [
+ [
+ P" resource:core/io/encodings/utf16/utf16.factor"
+ P" resource:core/io/encodings/utf16n/utf16n.factor" [ forget ] bi@
+ "io.encodings.utf16"
+ "io.encodings.utf16n" [ child-vocabs [ forget-vocab ] each ] bi@
+ ] with-compilation-unit
+ ] when ;
+
: default-image-name ( -- string )
vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
"math compiler threads help io tools ui ui.tools unicode handbook" "include" set-global
"" "exclude" set-global
+ strip-encodings
+
(command-line) parse-command-line
! Set dll paths
{ "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:"
{ $subsection <growing-circular> }
"Changing the start index:"
{ $subsection change-circular-start }
+{ $subsection rotate-circular }
"Pushing new elements:"
{ $subsection push-circular }
{ $subsection push-growing-circular } ;
[ 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
#! 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 ;
[ dup lookup-method ] dip
[ make-prepare-send ] 2keep
super-message-senders message-senders ? get at
- '[ _ call _ execute ] ;
+ 1quotation append ;
: send ( receiver args... selector -- return... ) f (send) ; inline
[ dup infer out>> ] dip
'[ @ _ _ nsequence ] ;
-: output>array ( quot -- newquot )
- { } output>sequence ; inline
+MACRO: output>array ( quot -- newquot )
+ '[ _ { } output>sequence ] ;
MACRO: input<sequence ( quot -- newquot )
[ infer in>> ] keep
MACRO: reduce-outputs ( quot operation -- newquot )
[ dup infer out>> 1 [-] ] dip n*quot compose ;
-: sum-outputs ( quot -- n )
- [ + ] reduce-outputs ; inline
+MACRO: sum-outputs ( quot -- n )
+ '[ _ [ + ] reduce-outputs ] ;
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
[ dup infer out>> ] 2dip
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
-: append-outputs ( quot -- seq )
- { } append-outputs-as ; inline
+MACRO: append-outputs ( quot -- seq )
+ '[ _ { } append-outputs-as ] ;
: underlying-alien-offset ( -- n ) bootstrap-cell alien tag-number - ; inline
: tuple-class-offset ( -- n ) bootstrap-cell tuple tag-number - ; inline
: word-xt-offset ( -- n ) 10 bootstrap-cells \ word tag-number - ; inline
-: quot-xt-offset ( -- n ) 5 bootstrap-cells quotation tag-number - ; inline
+: quot-xt-offset ( -- n ) 4 bootstrap-cells quotation tag-number - ; inline
: word-code-offset ( -- n ) 11 bootstrap-cells \ word tag-number - ; inline
: array-start-offset ( -- n ) 2 bootstrap-cells array tag-number - ; inline
: compiled-header-size ( -- n ) 4 bootstrap-cells ; inline
: modular-arithmetic-bug ( a -- b ) >integer 256 mod ;
[ 1 ] [ 257 modular-arithmetic-bug ] unit-test
-[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
\ No newline at end of file
+[ -10 ] [ -10 modular-arithmetic-bug ] unit-test
+
+! Optimizer needs to ignore invalid generics
+GENERIC# bad-dispatch-position-test* 3 ( -- )
+
+M: object bad-dispatch-position-test* ;
+
+: bad-dispatch-position-test ( -- ) bad-dispatch-position-test* ;
+
+[ 1 2 3 4 bad-dispatch-position-test ] must-fail
+
+[ ] [
+ [
+ \ bad-dispatch-position-test forget
+ \ bad-dispatch-position-test* forget
+ ] with-compilation-unit
+] unit-test
\ No newline at end of file
: 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 -- ? )
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays assocs constructors fry\r
+hashtables io kernel locals math math.order math.parser\r
+math.ranges multiline sequences ;\r
+IN: compression.huffman\r
+\r
+QUALIFIED-WITH: bitstreams bs\r
+\r
+<PRIVATE\r
+\r
+! huffman codes\r
+\r
+TUPLE: huffman-code\r
+ { value }\r
+ { size }\r
+ { code } ;\r
+\r
+: <huffman-code> ( -- code ) 0 0 0 huffman-code boa ;\r
+: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ;\r
+: next-code ( code -- ) [ 1+ ] change-code drop ;\r
+\r
+:: all-patterns ( huff n -- seq )\r
+ n log2 huff size>> - :> free-bits\r
+ free-bits 0 >\r
+ [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ]\r
+ [ huff code>> free-bits neg 2^ /i 1array ] if ;\r
+\r
+:: huffman-each ( tdesc quot: ( huff -- ) -- )\r
+ <huffman-code> :> code\r
+ tdesc\r
+ [\r
+ code next-size\r
+ [ code (>>value) code clone quot call code next-code ] each\r
+ ] each ; inline\r
+\r
+: update-reverse-table ( huff n table -- )\r
+ [ drop all-patterns ]\r
+ [ nip '[ _ swap _ set-at ] each ] 3bi ;\r
+\r
+:: reverse-table ( tdesc n -- rtable )\r
+ n f <array> <enum> :> table\r
+ tdesc [ n table update-reverse-table ] huffman-each\r
+ table seq>> ;\r
+\r
+:: huffman-table ( tdesc max -- table )\r
+ max f <array> :> table\r
+ tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each\r
+ table ;\r
+\r
+PRIVATE>\r
+\r
+! decoder\r
+\r
+TUPLE: huffman-decoder\r
+ { bs }\r
+ { tdesc }\r
+ { rtable }\r
+ { bits/level } ;\r
+\r
+CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder )\r
+ 16 >>bits/level\r
+ [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ;\r
+\r
+: read1-huff ( decoder -- elt )\r
+ 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last\r
+ [ size>> swap bs>> bs:seek ] [ value>> ] bi ;\r
+\r
+! %remove\r
+: reverse-bits ( value bits -- value' )\r
+ [ >bin ] [ CHAR: 0 pad-head <reversed> bin> ] bi* ;\r
+\r
+: read1-huff2 ( decoder -- elt )\r
+ 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last\r
+ [ size>> swap bs>> bs:seek ] [ value>> ] bi ;\r
+\r
+/*\r
+: huff>string ( code -- str )\r
+ [ value>> number>string ]\r
+ [ [ code>> ] [ size>> bits>string ] bi ] bi\r
+ " = " glue ;\r
+\r
+: huff. ( code -- ) huff>string print ;\r
+\r
+:: rtable. ( rtable -- )\r
+ rtable length>> log2 :> n\r
+ rtable <enum> [ swap n bits. [ huff. ] each ] assoc-each ;\r
+*/\r
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays assocs byte-arrays\r
+byte-vectors combinators constructors fry grouping hashtables\r
+compression.huffman images io.binary kernel locals\r
+math math.bitwise math.order math.ranges multiline sequences\r
+sorting ;\r
+IN: compression.inflate\r
+\r
+QUALIFIED-WITH: bitstreams bs\r
+\r
+<PRIVATE\r
+\r
+: enum>seq ( assoc -- seq )\r
+ dup keys [ ] [ max ] map-reduce 1 + f <array>\r
+ [ '[ swap _ set-nth ] assoc-each ] keep ;\r
+\r
+ERROR: zlib-unimplemented ;\r
+ERROR: bad-zlib-data ;\r
+ERROR: bad-zlib-header ;\r
+ \r
+:: check-zlib-header ( data -- )\r
+ 16 data bs:peek 2 >le be> 31 mod ! checksum\r
+ 0 assert= \r
+ 4 data bs:read 8 assert= ! compression method: deflate\r
+ 4 data bs:read ! log2(max length)-8, 32K max\r
+ 7 <= [ bad-zlib-header ] unless \r
+ 5 data bs:seek ! drop check bits \r
+ 1 data bs:read 0 assert= ! dictionnary - not allowed in png\r
+ 2 data bs:seek ! compression level; ignore\r
+ ;\r
+\r
+:: default-table ( -- table )\r
+ 0 <hashtable> :> table\r
+ 0 143 [a,b] 280 287 [a,b] append 8 table set-at\r
+ 144 255 [a,b] >array 9 table set-at\r
+ 256 279 [a,b] >array 7 table set-at \r
+ table enum>seq 1 tail ;\r
+\r
+CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 }\r
+\r
+: get-table ( values size -- table ) \r
+ 16 f <array> clone <enum> \r
+ [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ;\r
+\r
+:: decode-huffman-tables ( bitstream -- tables )\r
+ 5 bitstream bs:read 257 +\r
+ 5 bitstream bs:read 1 +\r
+ 4 bitstream bs:read 4 +\r
+ clen-shuffle swap head\r
+ dup [ drop 3 bitstream bs:read ] map\r
+ get-table\r
+ bitstream swap <huffman-decoder> \r
+ [ 2dup + ] dip swap :> k!\r
+ '[\r
+ _ read1-huff2\r
+ {\r
+ { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] }\r
+ { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] }\r
+ { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] }\r
+ [ ]\r
+ } cond\r
+ dup array? [ dup second ] [ 1 ] if\r
+ k swap - dup k! 0 >\r
+ ] \r
+ [ ] produce swap suffix\r
+ { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap <repetition> append ] bi* ] [ suffix ] if ] reduce\r
+ [ dup array? [ second 0 <repetition> ] [ 1array ] if ] map concat\r
+ nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ;\r
+ \r
+CONSTANT: length-table\r
+ {\r
+ 3 4 5 6 7 8 9 10\r
+ 11 13 15 17\r
+ 19 23 27 31\r
+ 35 43 51 59\r
+ 67 83 99 115\r
+ 131 163 195 227\r
+ }\r
+\r
+CONSTANT: dist-table\r
+ { 1 2 3 4 \r
+ 5 7 9 13 \r
+ 17 25 33 49\r
+ 65 97 129 193\r
+ 257 385 513 769\r
+ 1025 1537 2049 3073\r
+ 4097 6145 8193 12289\r
+ 16385 24577 }\r
+\r
+: nth* ( n seq -- elt )\r
+ [ length 1- swap - ] [ nth ] bi ;\r
+\r
+:: inflate-lz77 ( seq -- bytes )\r
+ 1000 <byte-vector> :> bytes\r
+ seq\r
+ [\r
+ dup array?\r
+ [ first2 '[ _ 1- bytes nth* bytes push ] times ]\r
+ [ bytes push ] if\r
+ ] each \r
+ bytes ;\r
+\r
+:: inflate-dynamic ( bitstream -- bytes )\r
+ bitstream decode-huffman-tables\r
+ bitstream '[ _ swap <huffman-decoder> ] map :> tables\r
+ [\r
+ tables first read1-huff2\r
+ dup 256 >\r
+ [\r
+ dup 285 = \r
+ [ ]\r
+ [ \r
+ dup 264 > \r
+ [ \r
+ dup 261 - 4 /i dup 5 > \r
+ [ bad-zlib-data ] when \r
+ bitstream bs:read 2array \r
+ ]\r
+ when \r
+ ] if\r
+ ! 5 bitstream read-bits ! distance\r
+ tables second read1-huff2\r
+ dup 3 > \r
+ [ \r
+ dup 2 - 2 /i dup 13 >\r
+ [ bad-zlib-data ] when\r
+ bitstream bs:read 2array\r
+ ] \r
+ when\r
+ 2array\r
+ ]\r
+ when\r
+ dup 256 = not\r
+ ]\r
+ [ ] produce nip\r
+ [\r
+ dup array? [\r
+ first2\r
+ [ \r
+ dup array? [ first2 ] [ 0 ] if\r
+ [ 257 - length-table nth ] [ + ] bi*\r
+ ] \r
+ [\r
+ dup array? [ first2 ] [ 0 ] if\r
+ [ dist-table nth ] [ + ] bi*\r
+ ] bi*\r
+ 2array\r
+ ] when\r
+ ] map ;\r
+ \r
+: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ;\r
+: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;\r
+\r
+:: inflate-loop ( bitstream -- bytes )\r
+ [ 1 bitstream bs:read 0 = ]\r
+ [\r
+ bitstream\r
+ 2 bitstream bs:read ! B\r
+ { \r
+ { 0 [ inflate-raw ] }\r
+ { 1 [ inflate-static ] }\r
+ { 2 [ inflate-dynamic ] }\r
+ { 3 [ bad-zlib-data f ] }\r
+ }\r
+ case\r
+ ]\r
+ [ produce ] keep call suffix concat ;\r
+ \r
+ ! [ produce ] keep dip swap suffix\r
+\r
+:: paeth ( a b c -- p ) \r
+ a b + c - { a b c } [ [ - abs ] keep 2array ] with map \r
+ sort-keys first second ;\r
+ \r
+:: png-unfilter-line ( prev curr filter -- curr' )\r
+ prev :> c\r
+ prev 3 tail-slice :> b\r
+ curr :> a\r
+ curr 3 tail-slice :> x\r
+ x length [0,b)\r
+ filter\r
+ {\r
+ { 0 [ drop ] }\r
+ { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }\r
+ { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }\r
+ { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }\r
+ { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }\r
+ \r
+ } case \r
+ curr 3 tail ;\r
+\r
+PRIVATE>\r
+\r
+! for debug -- shows residual values\r
+: reverse-png-filter' ( lines -- filtered )\r
+ [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip\r
+ concat [ 128 + 256 wrap ] map ;\r
+ \r
+: reverse-png-filter ( lines -- filtered )\r
+ dup first [ 0 ] replicate prefix\r
+ [ { 0 0 } prepend ] map\r
+ 2 clump [\r
+ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line\r
+ ] map concat ;\r
+\r
+: zlib-inflate ( bytes -- bytes )\r
+ bs:<lsb0-bit-reader>\r
+ [ check-zlib-header ]\r
+ [ inflate-loop ] bi\r
+ inflate-lz77 ;\r
! 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 ] }
[ 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
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 ;
: 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 -- )
] 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 ;
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 )
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
- [ gvim-path , "+" swap number>string append , , ] { } make ;
+ [
+ gvim-path ,
+ number>string "+" prepend , ,
+ ] { } make ;
gvim vim-editor set-global
IN: editors.macvim
-: macvim-location ( file line -- )
+: macvim ( file line -- )
drop
[ "open" , "-a" , "MacVim", , ] { } make
- try-process ;
-
-[ macvim-location ] edit-hook set-global
-
+ run-detached drop ;
+[ macvim ] edit-hook set-global
number>string "-goto:" prepend ,
] { } make ;
-: scite-location ( file line -- )
+: scite ( file line -- )
scite-command run-detached drop ;
-[ scite-location ] edit-hook set-global
+[ scite ] edit-hook set-global
namespaces prettyprint editors make ;
IN: editors.textedit
-: textedit-location ( file line -- )
+: textedit ( file line -- )
drop
[ "open" , "-a" , "TextEdit", , ] { } make
- try-process ;
+ run-detached drop ;
-[ textedit-location ] edit-hook set-global
+[ textedit ] edit-hook set-global
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.textmate
-: textmate-location ( file line -- )
+: textmate ( file line -- )
[ "mate" , "-a" , "-l" , number>string , , ] { } make
- try-process ;
+ run-detached drop ;
-[ textmate-location ] edit-hook set-global
+[ textmate ] edit-hook set-global
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support"
-"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
+"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
$nl
"If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
{ $code
IN: editors.vim
SYMBOL: vim-path
-
SYMBOL: vim-editor
HOOK: vim-command vim-editor ( file line -- array )
M: vim vim-command
[
- vim-path get , swap , "+" swap number>string append ,
+ vim-path get ,
+ [ , ] [ number>string "+" prepend , ] bi*
] { } make ;
-: vim-location ( file line -- )
- vim-command try-process ;
+: vim ( file line -- )
+ vim-command run-detached drop ;
"vim" vim-path set-global
-[ vim-location ] edit-hook set-global
-vim vim-editor set-global
+[ vim ] edit-hook set-global
+\ vim vim-editor set-global
--- /dev/null
+USING: windows.dinput windows.dinput.constants parser
+alien.c-types windows.ole32 namespaces assocs kernel arrays
+vectors windows.kernel32 windows.com windows.dinput shuffle
+windows.user32 windows.messages sequences combinators locals
+math.rectangles accessors math alien alien.strings
+io.encodings.utf16 io.encodings.utf16n continuations
+byte-arrays game-input.dinput.keys-array game-input
+ui.backend.windows windows.errors struct-arrays
+math.bitwise ;
+IN: game-input.dinput
+
+CONSTANT: MOUSE-BUFFER-SIZE 16
+
+SINGLETON: dinput-game-input-backend
+
+dinput-game-input-backend game-input-backend set-global
+
+SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ +mouse-device+ +mouse-state+ +mouse-buffer+ ;
+
+: create-dinput ( -- )
+ f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
+ f <void*> [ f DirectInput8Create ole32-error ] keep *void*
+ +dinput+ set-global ;
+
+: delete-dinput ( -- )
+ +dinput+ [ com-release f ] change-global ;
+
+: device-for-guid ( guid -- device )
+ +dinput+ get swap f <void*>
+ [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
+
+: set-coop-level ( device -- )
+ +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
+ IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
+
+: set-data-format ( device format-symbol -- )
+ get IDirectInputDevice8W::SetDataFormat ole32-error ;
+
+: <buffer-size-diprop> ( size -- DIPROPDWORD )
+ "DIPROPDWORD" <c-object>
+ "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
+ "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
+ 0 over set-DIPROPHEADER-dwObj
+ DIPH_DEVICE over set-DIPROPHEADER-dwHow
+ swap over set-DIPROPDWORD-dwData ;
+
+: set-buffer-size ( device size -- )
+ DIPROP_BUFFERSIZE swap <buffer-size-diprop>
+ IDirectInputDevice8W::SetProperty ole32-error ;
+
+: configure-keyboard ( keyboard -- )
+ [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
+: configure-mouse ( mouse -- )
+ [ c_dfDIMouse2 set-data-format ]
+ [ MOUSE-BUFFER-SIZE set-buffer-size ]
+ [ set-coop-level ] tri ;
+: configure-controller ( controller -- )
+ [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
+
+: find-keyboard ( -- )
+ GUID_SysKeyboard device-for-guid
+ [ configure-keyboard ]
+ [ +keyboard-device+ set-global ] bi
+ 256 <byte-array> <keys-array> keyboard-state boa
+ +keyboard-state+ set-global ;
+
+: find-mouse ( -- )
+ GUID_SysMouse device-for-guid
+ [ configure-mouse ]
+ [ +mouse-device+ set-global ] bi
+ 0 0 0 0 8 f <array> mouse-state boa
+ +mouse-state+ set-global
+ MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
+ +mouse-buffer+ set-global ;
+
+: device-info ( device -- DIDEVICEIMAGEINFOW )
+ "DIDEVICEINSTANCEW" <c-object>
+ "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
+ [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
+: device-caps ( device -- DIDEVCAPS )
+ "DIDEVCAPS" <c-object>
+ "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
+ [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
+
+: <guid> ( memory -- byte-array )
+ "GUID" heap-size memory>byte-array ;
+
+: device-guid ( device -- guid )
+ device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
+
+: device-attached? ( device -- ? )
+ +dinput+ get swap device-guid
+ IDirectInput8W::GetDeviceStatus S_OK = ;
+
+: find-device-axes-callback ( -- alien )
+ [ ! ( lpddoi pvRef -- BOOL )
+ +controller-devices+ get at
+ swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
+ { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
+ { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
+ { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
+ { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
+ { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
+ { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
+ { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
+ [ drop ]
+ } cond drop
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
+
+: find-device-axes ( device controller-state -- controller-state )
+ swap [ +controller-devices+ get set-at ] 2keep
+ find-device-axes-callback over DIDFT_AXIS
+ IDirectInputDevice8W::EnumObjects ole32-error ;
+
+: controller-state-template ( device -- controller-state )
+ controller-state new
+ over device-caps
+ [ DIDEVCAPS-dwButtons f <array> >>buttons ]
+ [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
+ find-device-axes ;
+
+: device-known? ( guid -- ? )
+ +controller-guids+ get key? ; inline
+
+: (add-controller) ( guid -- )
+ device-for-guid {
+ [ configure-controller ]
+ [ controller-state-template ]
+ [ dup device-guid +controller-guids+ get set-at ]
+ [ +controller-devices+ get set-at ]
+ } cleave ;
+
+: add-controller ( guid -- )
+ dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
+
+: remove-controller ( device -- )
+ [ +controller-devices+ get delete-at ]
+ [ device-guid +controller-guids+ get delete-at ]
+ [ com-release ] tri ;
+
+: find-controller-callback ( -- alien )
+ [ ! ( lpddi pvRef -- BOOL )
+ drop DIDEVICEINSTANCEW-guidInstance add-controller
+ DIENUM_CONTINUE
+ ] LPDIENUMDEVICESCALLBACKW ;
+
+: find-controllers ( -- )
+ +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
+ f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
+
+: set-up-controllers ( -- )
+ 4 <vector> +controller-devices+ set-global
+ 4 <vector> +controller-guids+ set-global
+ find-controllers ;
+
+: find-and-remove-detached-devices ( -- )
+ +controller-devices+ get keys
+ [ device-attached? not ] filter
+ [ remove-controller ] each ;
+
+: device-interface? ( dbt-broadcast-hdr -- ? )
+ DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
+
+: device-arrived ( dbt-broadcast-hdr -- )
+ device-interface? [ find-controllers ] when ;
+
+: device-removed ( dbt-broadcast-hdr -- )
+ device-interface? [ find-and-remove-detached-devices ] when ;
+
+: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
+ [ 2drop ] 2dip swap {
+ { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
+ { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
+ [ 2drop ]
+ } cond ;
+
+TUPLE: window-rect < rect window-loc ;
+: <zero-window-rect> ( -- window-rect )
+ window-rect new
+ { 0 0 } >>window-loc
+ { 0 0 } >>loc
+ { 0 0 } >>dim ;
+
+: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
+ "DEV_BROADCAST_DEVICEW" <c-object>
+ "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
+ DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
+
+: create-device-change-window ( -- )
+ <zero-window-rect> create-window
+ [
+ (device-notification-filter)
+ DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
+ RegisterDeviceNotification
+ +device-change-handle+ set-global
+ ]
+ [ +device-change-window+ set-global ] bi ;
+
+: close-device-change-window ( -- )
+ +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
+ +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
+
+: add-wm-devicechange ( -- )
+ [ 4dup handle-wm-devicechange DefWindowProc ]
+ WM_DEVICECHANGE add-wm-handler ;
+
+: remove-wm-devicechange ( -- )
+ WM_DEVICECHANGE wm-handlers get-global delete-at ;
+
+: release-controllers ( -- )
+ +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
+ f +controller-guids+ set-global ;
+
+: release-keyboard ( -- )
+ +keyboard-device+ [ com-release f ] change-global
+ f +keyboard-state+ set-global ;
+
+: release-mouse ( -- )
+ +mouse-device+ [ com-release f ] change-global
+ f +mouse-state+ set-global ;
+
+M: dinput-game-input-backend (open-game-input)
+ create-dinput
+ create-device-change-window
+ find-keyboard
+ find-mouse
+ set-up-controllers
+ add-wm-devicechange ;
+
+M: dinput-game-input-backend (close-game-input)
+ remove-wm-devicechange
+ release-controllers
+ release-mouse
+ release-keyboard
+ close-device-change-window
+ delete-dinput ;
+
+M: dinput-game-input-backend (reset-game-input)
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ f swap set-global ] each ;
+
+M: dinput-game-input-backend get-controllers
+ +controller-devices+ get
+ [ drop controller boa ] { } assoc>map ;
+
+M: dinput-game-input-backend product-string
+ handle>> device-info DIDEVICEINSTANCEW-tszProductName
+ utf16n alien>string ;
+
+M: dinput-game-input-backend product-id
+ handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
+M: dinput-game-input-backend instance-id
+ handle>> device-guid ;
+
+:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
+ device IDirectInputDevice8W::Acquire succeeded? [
+ device acquired-quot call
+ succeeded-quot call
+ ] failed-quot if ; inline
+
+CONSTANT: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ }
+
+: >axis ( long -- float )
+ 32767 - 32767.0 /f ;
+: >slider ( long -- float )
+ 65535.0 /f ;
+: >pov ( long -- symbol )
+ dup HEX: FFFF bitand HEX: FFFF =
+ [ drop pov-neutral ]
+ [ 2750 + 4500 /i pov-values nth ] if ;
+: >buttons ( alien length -- array )
+ memory>byte-array <keys-array> ;
+
+: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
+ [ drop ] compose [ 2drop ] if ; inline
+
+: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
+ {
+ [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
+ [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
+ [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
+ [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
+ [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
+ [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
+ [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
+ [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
+ [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
+ } 2cleave ;
+
+: read-device-buffer ( device buffer count -- buffer count' )
+ [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
+ [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
+
+: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
+ [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
+ { DIMOFS_X [ [ + ] curry change-dx ] }
+ { DIMOFS_Y [ [ + ] curry change-dy ] }
+ { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
+ [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
+ } case ;
+
+: fill-mouse-state ( buffer count -- state )
+ [ +mouse-state+ get ] 2dip swap
+ [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
+
+: get-device-state ( device byte-array -- )
+ [ dup IDirectInputDevice8W::Poll ole32-error ] dip
+ [ length ] keep
+ IDirectInputDevice8W::GetDeviceState ole32-error ;
+
+: (read-controller) ( handle template -- state )
+ swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
+ [ fill-controller-state ] [ drop f ] with-acquisition ;
+
+M: dinput-game-input-backend read-controller
+ handle>> dup +controller-devices+ get at
+ [ (read-controller) ] [ drop f ] if* ;
+
+M: dinput-game-input-backend calibrate-controller
+ handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
+
+M: dinput-game-input-backend read-keyboard
+ +keyboard-device+ get
+ [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ [ ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend read-mouse
+ +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ fill-mouse-state ] [ f ] with-acquisition ;
+
+M: dinput-game-input-backend reset-mouse
+ +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ 2drop ] [ ] with-acquisition
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
--- /dev/null
+USING: sequences sequences.private math alien.c-types
+accessors ;
+IN: game-input.dinput.keys-array
+
+TUPLE: keys-array underlying ;
+C: <keys-array> keys-array
+
+: >key ( byte -- ? )
+ HEX: 80 bitand c-bool> ;
+
+M: keys-array length underlying>> length ;
+M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
+
+INSTANCE: keys-array sequence
+
--- /dev/null
+DirectInput backend for game-input
--- /dev/null
+unportable
+games
--- /dev/null
+USING: help.markup help.syntax kernel ui.gestures quotations
+sequences strings math ;
+IN: game-input
+
+ARTICLE: "game-input" "Game controller input"
+"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
+"The game input interface must be initialized before being used:"
+{ $subsection open-game-input }
+{ $subsection close-game-input }
+{ $subsection with-game-input }
+"Once the game input interface is open, connected controller devices can be enumerated:"
+{ $subsection get-controllers }
+{ $subsection find-controller-products }
+{ $subsection find-controller-instance }
+"These " { $link controller } " objects can be queried of their identity:"
+{ $subsection product-string }
+{ $subsection product-id }
+{ $subsection instance-id }
+"A hook is provided for invoking the system calibration tool:"
+{ $subsection calibrate-controller }
+"The current state of a controller, the keyboard, and the mouse can be read:"
+{ $subsection read-controller }
+{ $subsection read-keyboard }
+{ $subsection read-mouse }
+{ $subsection controller-state }
+{ $subsection keyboard-state }
+{ $subsection mouse-state } ;
+
+HELP: open-game-input
+{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
+
+HELP: close-game-input
+{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
+
+HELP: game-input-opened?
+{ $values { "?" "a boolean" } }
+{ $description "Returns true if the game input interface is open, false otherwise." } ;
+
+HELP: with-game-input
+{ $values { "quot" quotation } }
+{ $description "Initializes the game input interface for the dynamic extent of " { $snippet "quotation" } "." } ;
+
+{ open-game-input close-game-input with-game-input game-input-opened? } related-words
+
+HELP: get-controllers
+{ $values { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
+{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers. The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "get-controllers" } "." } ;
+
+HELP: find-controller-products
+{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
+{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers with the given " { $link product-id } ". The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "find-controller-products" } "." } ;
+
+HELP: find-controller-instance
+{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "instance-id" "An instance ID as returned by " { $link instance-id } "." } { "controller/f" "A " { $link controller } " object, or " { $link f } } }
+{ $description "Returns the " { $link controller } " instance identified by " { $snippet "product-id" } " and " { $snippet "instance-id" } ". If the identified device is not currently attached, " { $link f } " is returned." } ;
+
+HELP: controller
+{ $class-description "Objects of this class represent game controller devices such as joysticks and gamepads. They should be treated as opaque by client code." } ;
+
+HELP: product-string
+{ $values { "controller" controller } { "string" string } }
+{ $description "Returns a human-readable string describing the game controller device represented by " { $snippet "controller" } ". This string is not necessarily unique to the product or instance; to uniquely identify the device, see " { $link product-id } " and " { $link instance-id } "." } ;
+
+HELP: product-id
+{ $values { "controller" controller } { "id" "A unique identifier" } }
+{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } ". This identifier will be the same for devices of the same make and manufacturer. The type of the identifier value is platform-specific, but equivalent " { $snippet "product-id" } "s are guaranteed to be testable with the " { $link = } " word. The identifier can be used to find devices of the same kind with the " { $link find-controller-products } " word." } ;
+
+HELP: instance-id
+{ $values { "controller" controller } { "id" "A unique identifier" } }
+{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } ". This identifier paired with the device's " { $link product-id } " provides a unique identifier for a particular device that persists between reboots (but not necessarily between computers). This unique identifier can be used to find the same device again with the " { $snippet "find-controller-instance" } " word. Depending on the platform, the instance-id may change if the device is plugged into a different port. The type of the identifier value is platform-specific, but equivalent " { $snippet "instance-id" } "s are guaranteed to be testable with the " { $link = } " word." } ;
+
+{ product-string product-id instance-id find-controller-products find-controller-instance } related-words
+
+HELP: calibrate-controller
+{ $values { "controller" controller } }
+{ $description "Invokes the operating system's calibration tool for " { $snippet "controller" } ". If the operating system does not have a calibration tool, this word does nothing." } ;
+
+HELP: read-controller
+{ $values { "controller" controller } { "controller-state" controller-state } }
+{ $description "Reads the current state of " { $snippet "controller" } ". See the documentation for the " { $link controller-state } " class for details of the returned value's format. If the device is no longer available, " { $link f } " is returned." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "controller-state" } " object next time " { $snippet "read-controller" } " is called on the same controller. You should " { $link clone } " any values from the returned tuple you need to preserve." } ;
+
+{ controller-state controller read-controller } related-words
+
+HELP: read-keyboard
+{ $values { "keyboard-state" keyboard-state } }
+{ $description "Reads the current raw state of the keyboard. See the documentation for the " { $link keyboard-state } " class for details on the returned value's format." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
+$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
+
+HELP: read-mouse
+{ $values { "mouse-state" mouse-state } }
+{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
+{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
+
+HELP: reset-mouse
+{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
+
+HELP: controller-state
+{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
+{ $list
+ { { $snippet "x" } " contains the position of the device's X axis." }
+ { { $snippet "y" } " contains the position of the device's Y axis." }
+ { { $snippet "z" } " contains the position of the device's Z axis, if any." }
+ { { $snippet "rx" } " contains the rotational position of the device's X axis, if available." }
+ { { $snippet "ry" } " contains the rotational position of the device's Y axis, if available." }
+ { { $snippet "rz" } " contains the rotational position of the device's Z axis, if available." }
+ { { $snippet "slider" } " contains the position of the device's throttle slider, if any." }
+ { { $snippet "pov" } " contains the state of the device's POV hat, if any." }
+ { { $snippet "buttons" } " contains a sequence of values indicating the state of every button on the device." }
+}
+"The values are formatted as follows:"
+{ $list
+ { "For the axis slots (" { $snippet "x" } ", " { $snippet "y" } ", " { $snippet "z" } ", " { $snippet "rx" } ", " { $snippet "ry" } ", " { $snippet "rz" } "), a " { $link float } " value between -1.0 and 1.0 is returned." }
+ { "For the " { $snippet "slider" } " slot, a value between 0.0 and 1.0 is returned." }
+ { "For the " { $snippet "pov" } " slot, one of the following symbols is returned:" { $list
+ { { $link pov-neutral } }
+ { { $link pov-up } }
+ { { $link pov-up-right } }
+ { { $link pov-right } }
+ { { $link pov-down-right } }
+ { { $link pov-down } }
+ { { $link pov-down-left } }
+ { { $link pov-left } }
+ { { $link pov-up-left } }
+ } }
+ { "For each element of the " { $snippet "buttons" } " array, " { $link f } " indicates that the corresponding button is released. If the button is pressed, a value between 0.0 and 1.0 is returned indicating the pressure on the button (or simply 1.0 if the device's buttons are on/off only)." }
+ { "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
+
+HELP: keyboard-state
+{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
+{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
+
+HELP: mouse-state
+{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
+{ $list
+ { { $snippet "dx" } " contains the mouse's X axis movement." }
+ { { $snippet "dy" } " contains the mouse's Y axis movement." }
+ { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
+ { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
+ { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
+}
+"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
+} ;
+
+
+{ keyboard-state read-keyboard } related-words
+
+ABOUT: "game-input"
--- /dev/null
+IN: game-input.tests
+USING: ui game-input tools.test kernel system threads calendar ;
+
+os windows? os macosx? or [
+ [ ] [ open-game-input ] unit-test
+ [ ] [ 1 seconds sleep ] unit-test
+ [ ] [ close-game-input ] unit-test
+] when
\ No newline at end of file
--- /dev/null
+USING: arrays accessors continuations kernel math system
+sequences namespaces init vocabs vocabs.loader combinators ;
+IN: game-input
+
+SYMBOLS: game-input-backend game-input-opened ;
+
+game-input-opened [ 0 ] initialize
+
+HOOK: (open-game-input) game-input-backend ( -- )
+HOOK: (close-game-input) game-input-backend ( -- )
+HOOK: (reset-game-input) game-input-backend ( -- )
+
+HOOK: get-controllers game-input-backend ( -- sequence )
+
+HOOK: product-string game-input-backend ( controller -- string )
+HOOK: product-id game-input-backend ( controller -- id )
+HOOK: instance-id game-input-backend ( controller -- id )
+
+HOOK: read-controller game-input-backend ( controller -- controller-state )
+HOOK: calibrate-controller game-input-backend ( controller -- )
+
+HOOK: read-keyboard game-input-backend ( -- keyboard-state )
+
+HOOK: read-mouse game-input-backend ( -- mouse-state )
+
+HOOK: reset-mouse game-input-backend ( -- )
+
+: game-input-opened? ( -- ? )
+ game-input-opened get zero? not ;
+
+<PRIVATE
+
+M: f (reset-game-input) ;
+
+: reset-game-input ( -- )
+ (reset-game-input) ;
+
+[ reset-game-input ] "game-input" add-init-hook
+
+PRIVATE>
+
+ERROR: game-input-not-open ;
+
+: open-game-input ( -- )
+ game-input-opened? [
+ (open-game-input)
+ ] unless
+ game-input-opened [ 1+ ] change-global
+ reset-mouse ;
+: close-game-input ( -- )
+ game-input-opened [
+ dup zero? [ game-input-not-open ] when
+ 1-
+ ] change-global
+ game-input-opened? [
+ (close-game-input)
+ reset-game-input
+ ] unless ;
+
+: with-game-input ( quot -- )
+ open-game-input [ close-game-input ] [ ] cleanup ; inline
+
+TUPLE: controller handle ;
+TUPLE: controller-state x y z rx ry rz slider pov buttons ;
+
+M: controller-state clone
+ call-next-method dup buttons>> clone >>buttons ;
+
+SYMBOLS:
+ pov-neutral
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left ;
+
+: find-controller-products ( product-id -- sequence )
+ get-controllers [ product-id = ] with filter ;
+: find-controller-instance ( product-id instance-id -- controller/f )
+ get-controllers [
+ tuck
+ [ product-id = ]
+ [ instance-id = ] 2bi* and
+ ] with with find nip ;
+
+TUPLE: keyboard-state keys ;
+
+M: keyboard-state clone
+ call-next-method dup keys>> clone >>keys ;
+
+TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
+
+M: mouse-state clone
+ call-next-method dup buttons>> clone >>buttons ;
+
+{
+ { [ os windows? ] [ "game-input.dinput" require ] }
+ { [ os macosx? ] [ "game-input.iokit" require ] }
+ { [ t ] [ ] }
+} cond
--- /dev/null
+USING: cocoa cocoa.plists core-foundation iokit iokit.hid
+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 bit-arrays ;
+IN: game-input.iokit
+
+SINGLETON: iokit-game-input-backend
+
+SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
+
+iokit-game-input-backend game-input-backend set-global
+
+: make-hid-manager ( -- alien )
+ f 0 IOHIDManagerCreate ;
+
+: set-hid-manager-matching ( alien matching-seq -- )
+ >plist IOHIDManagerSetDeviceMatchingMultiple ;
+
+: devices-from-hid-manager ( manager -- vector )
+ [
+ IOHIDManagerCopyDevices
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+CONSTANT: game-devices-matching-seq
+ {
+ H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
+ H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
+ H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
+ H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
+ H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
+ H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
+ }
+
+CONSTANT: buttons-matching-hash
+ H{ { "UsagePage" 9 } { "Type" 2 } }
+CONSTANT: keys-matching-hash
+ H{ { "UsagePage" 7 } { "Type" 2 } }
+CONSTANT: x-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } }
+CONSTANT: y-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } }
+CONSTANT: z-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } }
+CONSTANT: rx-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } }
+CONSTANT: ry-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } }
+CONSTANT: rz-axis-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
+CONSTANT: slider-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
+CONSTANT: wheel-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
+CONSTANT: hat-switch-matching-hash
+ H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
+
+: device-elements-matching ( device matching-hash -- vector )
+ [
+ >plist 0 IOHIDDeviceCopyMatchingElements
+ [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
+ ] with-destructors ;
+
+: button-count ( device -- button-count )
+ buttons-matching-hash device-elements-matching length ;
+
+: ?axis ( device hash -- axis/f )
+ device-elements-matching [ f ] [ first ] if-empty ;
+
+: ?x-axis ( device -- ? )
+ x-axis-matching-hash ?axis ;
+: ?y-axis ( device -- ? )
+ y-axis-matching-hash ?axis ;
+: ?z-axis ( device -- ? )
+ z-axis-matching-hash ?axis ;
+: ?rx-axis ( device -- ? )
+ rx-axis-matching-hash ?axis ;
+: ?ry-axis ( device -- ? )
+ ry-axis-matching-hash ?axis ;
+: ?rz-axis ( device -- ? )
+ rz-axis-matching-hash ?axis ;
+: ?slider ( device -- ? )
+ slider-matching-hash ?axis ;
+: ?hat-switch ( device -- ? )
+ hat-switch-matching-hash ?axis ;
+
+: device-property ( device key -- value )
+ <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
+: element-property ( element key -- value )
+ <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
+: set-element-property ( element key value -- )
+ [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
+: transfer-element-property ( element from-key to-key -- )
+ [ dupd element-property ] dip swap
+ [ set-element-property ] [ 2drop ] if* ;
+
+: mouse-device? ( device -- ? )
+ 1 2 IOHIDDeviceConformsTo ;
+
+: controller-device? ( device -- ? )
+ {
+ [ 1 4 IOHIDDeviceConformsTo ]
+ [ 1 5 IOHIDDeviceConformsTo ]
+ [ 1 8 IOHIDDeviceConformsTo ]
+ } 1|| ;
+
+: element-usage ( element -- {usage-page,usage} )
+ [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
+ 2array ;
+
+: button? ( element -- ? )
+ IOHIDElementGetUsagePage 9 = ; inline
+: keyboard-key? ( element -- ? )
+ IOHIDElementGetUsagePage 7 = ; inline
+: axis? ( element -- ? )
+ IOHIDElementGetUsagePage 1 = ; inline
+
+: x-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 30 = ; inline
+: y-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 31 = ; inline
+: z-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 32 = ; inline
+: rx-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 33 = ; inline
+: ry-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 34 = ; inline
+: rz-axis? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 35 = ; inline
+: slider? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 36 = ; inline
+: wheel? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 38 = ; inline
+: hat-switch? ( {usage-page,usage} -- ? )
+ IOHIDElementGetUsage HEX: 39 = ; inline
+
+CONSTANT: pov-values
+ {
+ pov-up pov-up-right pov-right pov-down-right
+ pov-down pov-down-left pov-left pov-up-left
+ pov-neutral
+ }
+
+: button-value ( value -- f/(0,1] )
+ IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
+: axis-value ( value -- [-1,1] )
+ kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
+: mouse-axis-value ( value -- n )
+ IOHIDValueGetIntegerValue ;
+: pov-value ( value -- pov-direction )
+ IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
+
+: record-button ( state hid-value element -- )
+ [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
+
+: record-controller ( controller-state value -- )
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop axis-value >>x drop ] }
+ { [ dup y-axis? ] [ drop axis-value >>y drop ] }
+ { [ dup z-axis? ] [ drop axis-value >>z drop ] }
+ { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
+ { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
+ { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
+ { [ dup slider? ] [ drop axis-value >>slider drop ] }
+ { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
+ [ 3drop ]
+ } cond ] }
+ [ 3drop ]
+ } cond ;
+
+HINTS: record-controller { controller-state alien } ;
+
+: ?set-nth ( value nth seq -- )
+ 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
+
+: record-keyboard ( keyboard-state value -- )
+ dup IOHIDValueGetElement dup keyboard-key? [
+ [ IOHIDValueGetIntegerValue c-bool> ]
+ [ IOHIDElementGetUsage ] bi*
+ rot ?set-nth
+ ] [ 3drop ] if ;
+
+HINTS: record-keyboard { bit-array alien } ;
+
+: record-mouse ( mouse-state value -- )
+ dup IOHIDValueGetElement {
+ { [ dup button? ] [ record-button ] }
+ { [ dup axis? ] [ {
+ { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
+ { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
+ { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
+ { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
+ [ 3drop ]
+ } cond ] }
+ [ 3drop ]
+ } cond ;
+
+HINTS: record-mouse { mouse-state alien } ;
+
+M: iokit-game-input-backend read-mouse
+ +mouse-state+ get ;
+
+M: iokit-game-input-backend reset-mouse
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
+
+: default-calibrate-saturation ( element -- )
+ [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
+ [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
+ bi ;
+
+: default-calibrate-axis ( element -- )
+ [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: default-calibrate-slider ( element -- )
+ [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
+ [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
+ [ default-calibrate-saturation ]
+ tri ;
+
+: (default) ( ? quot -- )
+ [ f ] if* ; inline
+
+: <device-controller-state> ( device -- controller-state )
+ {
+ [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
+ [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
+ [ ?hat-switch pov-neutral and ]
+ [ button-count f <array> ]
+ } cleave controller-state boa ;
+
+: ?add-mouse-buttons ( device -- )
+ button-count +mouse-state+ get buttons>>
+ 2dup length >
+ [ set-length ] [ 2drop ] if ;
+
+: device-matched-callback ( -- alien )
+ [| context result sender device |
+ {
+ { [ device controller-device? ] [
+ device <device-controller-state>
+ device +controller-states+ get set-at
+ ] }
+ { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
+ [ ]
+ } cond
+ ] IOHIDDeviceCallback ;
+
+: device-removed-callback ( -- alien )
+ [| context result sender device |
+ device +controller-states+ get delete-at
+ ] IOHIDDeviceCallback ;
+
+: device-input-callback ( -- alien )
+ [| context result sender value |
+ {
+ { [ sender controller-device? ] [
+ sender +controller-states+ get at value record-controller
+ ] }
+ { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
+ [ +keyboard-state+ get value record-keyboard ]
+ } cond
+ ] IOHIDValueCallback ;
+
+: initialize-variables ( manager -- )
+ +hid-manager+ set-global
+ 4 <vector> +controller-states+ set-global
+ 0 0 0 0 2 <vector> mouse-state boa
+ +mouse-state+ set-global
+ 256 <bit-array> +keyboard-state+ set-global ;
+
+M: iokit-game-input-backend (open-game-input)
+ make-hid-manager {
+ [ initialize-variables ]
+ [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
+ [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
+ [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
+ [ 0 IOHIDManagerOpen mach-error ]
+ [ game-devices-matching-seq set-hid-manager-matching ]
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerScheduleWithRunLoop
+ ]
+ } cleave ;
+
+M: iokit-game-input-backend (reset-game-input)
+ { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
+ [ f swap set-global ] each ;
+
+M: iokit-game-input-backend (close-game-input)
+ +hid-manager+ get-global [
+ +hid-manager+ [
+ [
+ CFRunLoopGetMain CFRunLoopDefaultMode
+ IOHIDManagerUnscheduleFromRunLoop
+ ]
+ [ 0 IOHIDManagerClose drop ]
+ [ CFRelease ] tri
+ f
+ ] change-global
+ f +keyboard-state+ set-global
+ f +mouse-state+ set-global
+ f +controller-states+ set-global
+ ] when ;
+
+M: iokit-game-input-backend get-controllers ( -- sequence )
+ +controller-states+ get keys [ controller boa ] map ;
+
+: ?join ( pre post sep -- string )
+ 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
+
+M: iokit-game-input-backend product-string ( controller -- string )
+ handle>>
+ [ kIOHIDManufacturerKey device-property ]
+ [ kIOHIDProductKey device-property ] bi " " ?join ;
+M: iokit-game-input-backend product-id ( controller -- integer )
+ handle>>
+ [ kIOHIDVendorIDKey device-property ]
+ [ kIOHIDProductIDKey device-property ] bi 2array ;
+M: iokit-game-input-backend instance-id ( controller -- integer )
+ handle>> kIOHIDLocationIDKey device-property ;
+
+M: iokit-game-input-backend read-controller ( controller -- controller-state )
+ handle>> +controller-states+ get at clone ;
+
+M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
+ +keyboard-state+ get clone keyboard-state boa ;
+
+M: iokit-game-input-backend calibrate-controller ( controller -- )
+ drop ;
--- /dev/null
+IOKit HID Manager backend for game-input
--- /dev/null
+unportable
+games
--- /dev/null
+IN: game-input.scancodes
+
+CONSTANT: key-undefined HEX: 0000
+CONSTANT: key-error-roll-over HEX: 0001
+CONSTANT: key-error-post-fail HEX: 0002
+CONSTANT: key-error-undefined HEX: 0003
+CONSTANT: key-a HEX: 0004
+CONSTANT: key-b HEX: 0005
+CONSTANT: key-c HEX: 0006
+CONSTANT: key-d HEX: 0007
+CONSTANT: key-e HEX: 0008
+CONSTANT: key-f HEX: 0009
+CONSTANT: key-g HEX: 000a
+CONSTANT: key-h HEX: 000b
+CONSTANT: key-i HEX: 000c
+CONSTANT: key-j HEX: 000d
+CONSTANT: key-k HEX: 000e
+CONSTANT: key-l HEX: 000f
+CONSTANT: key-m HEX: 0010
+CONSTANT: key-n HEX: 0011
+CONSTANT: key-o HEX: 0012
+CONSTANT: key-p HEX: 0013
+CONSTANT: key-q HEX: 0014
+CONSTANT: key-r HEX: 0015
+CONSTANT: key-s HEX: 0016
+CONSTANT: key-t HEX: 0017
+CONSTANT: key-u HEX: 0018
+CONSTANT: key-v HEX: 0019
+CONSTANT: key-w HEX: 001a
+CONSTANT: key-x HEX: 001b
+CONSTANT: key-y HEX: 001c
+CONSTANT: key-z HEX: 001d
+CONSTANT: key-1 HEX: 001e
+CONSTANT: key-2 HEX: 001f
+CONSTANT: key-3 HEX: 0020
+CONSTANT: key-4 HEX: 0021
+CONSTANT: key-5 HEX: 0022
+CONSTANT: key-6 HEX: 0023
+CONSTANT: key-7 HEX: 0024
+CONSTANT: key-8 HEX: 0025
+CONSTANT: key-9 HEX: 0026
+CONSTANT: key-0 HEX: 0027
+CONSTANT: key-return HEX: 0028
+CONSTANT: key-escape HEX: 0029
+CONSTANT: key-backspace HEX: 002a
+CONSTANT: key-tab HEX: 002b
+CONSTANT: key-space HEX: 002c
+CONSTANT: key-- HEX: 002d
+CONSTANT: key-= HEX: 002e
+CONSTANT: key-[ HEX: 002f
+CONSTANT: key-] HEX: 0030
+CONSTANT: key-\ HEX: 0031
+CONSTANT: key-#-non-us HEX: 0032
+CONSTANT: key-; HEX: 0033
+CONSTANT: key-' HEX: 0034
+CONSTANT: key-` HEX: 0035
+CONSTANT: key-, HEX: 0036
+CONSTANT: key-. HEX: 0037
+CONSTANT: key-/ HEX: 0038
+CONSTANT: key-caps-lock HEX: 0039
+CONSTANT: key-f1 HEX: 003a
+CONSTANT: key-f2 HEX: 003b
+CONSTANT: key-f3 HEX: 003c
+CONSTANT: key-f4 HEX: 003d
+CONSTANT: key-f5 HEX: 003e
+CONSTANT: key-f6 HEX: 003f
+CONSTANT: key-f7 HEX: 0040
+CONSTANT: key-f8 HEX: 0041
+CONSTANT: key-f9 HEX: 0042
+CONSTANT: key-f10 HEX: 0043
+CONSTANT: key-f11 HEX: 0044
+CONSTANT: key-f12 HEX: 0045
+CONSTANT: key-print-screen HEX: 0046
+CONSTANT: key-scroll-lock HEX: 0047
+CONSTANT: key-pause HEX: 0048
+CONSTANT: key-insert HEX: 0049
+CONSTANT: key-home HEX: 004a
+CONSTANT: key-page-up HEX: 004b
+CONSTANT: key-delete HEX: 004c
+CONSTANT: key-end HEX: 004d
+CONSTANT: key-page-down HEX: 004e
+CONSTANT: key-right-arrow HEX: 004f
+CONSTANT: key-left-arrow HEX: 0050
+CONSTANT: key-down-arrow HEX: 0051
+CONSTANT: key-up-arrow HEX: 0052
+CONSTANT: key-keypad-numlock HEX: 0053
+CONSTANT: key-keypad-/ HEX: 0054
+CONSTANT: key-keypad-* HEX: 0055
+CONSTANT: key-keypad-- HEX: 0056
+CONSTANT: key-keypad-+ HEX: 0057
+CONSTANT: key-keypad-enter HEX: 0058
+CONSTANT: key-keypad-1 HEX: 0059
+CONSTANT: key-keypad-2 HEX: 005a
+CONSTANT: key-keypad-3 HEX: 005b
+CONSTANT: key-keypad-4 HEX: 005c
+CONSTANT: key-keypad-5 HEX: 005d
+CONSTANT: key-keypad-6 HEX: 005e
+CONSTANT: key-keypad-7 HEX: 005f
+CONSTANT: key-keypad-8 HEX: 0060
+CONSTANT: key-keypad-9 HEX: 0061
+CONSTANT: key-keypad-0 HEX: 0062
+CONSTANT: key-keypad-. HEX: 0063
+CONSTANT: key-\-non-us HEX: 0064
+CONSTANT: key-application HEX: 0065
+CONSTANT: key-power HEX: 0066
+CONSTANT: key-keypad-= HEX: 0067
+CONSTANT: key-f13 HEX: 0068
+CONSTANT: key-f14 HEX: 0069
+CONSTANT: key-f15 HEX: 006a
+CONSTANT: key-f16 HEX: 006b
+CONSTANT: key-f17 HEX: 006c
+CONSTANT: key-f18 HEX: 006d
+CONSTANT: key-f19 HEX: 006e
+CONSTANT: key-f20 HEX: 006f
+CONSTANT: key-f21 HEX: 0070
+CONSTANT: key-f22 HEX: 0071
+CONSTANT: key-f23 HEX: 0072
+CONSTANT: key-f24 HEX: 0073
+CONSTANT: key-execute HEX: 0074
+CONSTANT: key-help HEX: 0075
+CONSTANT: key-menu HEX: 0076
+CONSTANT: key-select HEX: 0077
+CONSTANT: key-stop HEX: 0078
+CONSTANT: key-again HEX: 0079
+CONSTANT: key-undo HEX: 007a
+CONSTANT: key-cut HEX: 007b
+CONSTANT: key-copy HEX: 007c
+CONSTANT: key-paste HEX: 007d
+CONSTANT: key-find HEX: 007e
+CONSTANT: key-mute HEX: 007f
+CONSTANT: key-volume-up HEX: 0080
+CONSTANT: key-volume-down HEX: 0081
+CONSTANT: key-locking-caps-lock HEX: 0082
+CONSTANT: key-locking-num-lock HEX: 0083
+CONSTANT: key-locking-scroll-lock HEX: 0084
+CONSTANT: key-keypad-, HEX: 0085
+CONSTANT: key-keypad-=-as-400 HEX: 0086
+CONSTANT: key-international-1 HEX: 0087
+CONSTANT: key-international-2 HEX: 0088
+CONSTANT: key-international-3 HEX: 0089
+CONSTANT: key-international-4 HEX: 008a
+CONSTANT: key-international-5 HEX: 008b
+CONSTANT: key-international-6 HEX: 008c
+CONSTANT: key-international-7 HEX: 008d
+CONSTANT: key-international-8 HEX: 008e
+CONSTANT: key-international-9 HEX: 008f
+CONSTANT: key-lang-1 HEX: 0090
+CONSTANT: key-lang-2 HEX: 0091
+CONSTANT: key-lang-3 HEX: 0092
+CONSTANT: key-lang-4 HEX: 0093
+CONSTANT: key-lang-5 HEX: 0094
+CONSTANT: key-lang-6 HEX: 0095
+CONSTANT: key-lang-7 HEX: 0096
+CONSTANT: key-lang-8 HEX: 0097
+CONSTANT: key-lang-9 HEX: 0098
+CONSTANT: key-alternate-erase HEX: 0099
+CONSTANT: key-sysreq HEX: 009a
+CONSTANT: key-cancel HEX: 009b
+CONSTANT: key-clear HEX: 009c
+CONSTANT: key-prior HEX: 009d
+CONSTANT: key-enter HEX: 009e
+CONSTANT: key-separator HEX: 009f
+CONSTANT: key-out HEX: 00a0
+CONSTANT: key-oper HEX: 00a1
+CONSTANT: key-clear-again HEX: 00a2
+CONSTANT: key-crsel-props HEX: 00a3
+CONSTANT: key-exsel HEX: 00a4
+CONSTANT: key-left-control HEX: 00e0
+CONSTANT: key-left-shift HEX: 00e1
+CONSTANT: key-left-alt HEX: 00e2
+CONSTANT: key-left-gui HEX: 00e3
+CONSTANT: key-right-control HEX: 00e4
+CONSTANT: key-right-shift HEX: 00e5
+CONSTANT: key-right-alt HEX: 00e6
+CONSTANT: key-right-gui HEX: 00e7
--- /dev/null
+Scan code constants for HID keyboards
--- /dev/null
+Cross-platform joystick, gamepad, and raw keyboard input
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays byte-arrays combinators\r
+constructors grouping compression.huffman images\r
+images.processing io io.binary io.encodings.binary io.files\r
+io.streams.byte-array kernel locals math math.bitwise\r
+math.constants math.functions math.matrices math.order\r
+math.ranges math.vectors memoize multiline namespaces\r
+sequences sequences.deep ;\r
+IN: images.jpeg\r
+\r
+QUALIFIED-WITH: bitstreams bs\r
+\r
+TUPLE: jpeg-image < image\r
+ { headers }\r
+ { bitstream }\r
+ { color-info initial: { f f f f } }\r
+ { quant-tables initial: { f f } }\r
+ { huff-tables initial: { f f f f } }\r
+ { components } ;\r
+\r
+<PRIVATE\r
+\r
+CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;\r
+\r
+SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP\r
+APP JPG COM TEM RES ;\r
+\r
+! ISO/IEC 10918-1 Table B.1\r
+:: >marker ( byte -- marker )\r
+ byte\r
+ {\r
+ { [ dup HEX: CC = ] [ { DAC } ] }\r
+ { [ dup HEX: C4 = ] [ { DHT } ] }\r
+ { [ dup HEX: C9 = ] [ { JPG } ] }\r
+ { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] }\r
+\r
+ { [ dup HEX: D8 = ] [ { SOI } ] }\r
+ { [ dup HEX: D9 = ] [ { EOI } ] }\r
+ { [ dup HEX: DA = ] [ { SOS } ] }\r
+ { [ dup HEX: DB = ] [ { DQT } ] }\r
+ { [ dup HEX: DC = ] [ { DNL } ] }\r
+ { [ dup HEX: DD = ] [ { DRI } ] }\r
+ { [ dup HEX: DE = ] [ { DHP } ] }\r
+ { [ dup HEX: DF = ] [ { EXP } ] }\r
+ { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] }\r
+\r
+ { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] }\r
+ { [ dup HEX: FE = ] [ { COM } ] }\r
+ { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] }\r
+\r
+ { [ dup HEX: 01 = ] [ { TEM } ] }\r
+ [ { RES } ]\r
+ }\r
+ cond nip ;\r
+\r
+TUPLE: jpeg-chunk length type data ;\r
+\r
+CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ;\r
+\r
+TUPLE: jpeg-color-info\r
+ h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ;\r
+\r
+CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;\r
+\r
+: jpeg> ( -- jpeg-image ) jpeg-image get ;\r
+\r
+: apply-diff ( dc color -- dc' )\r
+ [ diff>> + dup ] [ (>>diff) ] bi ;\r
+\r
+: fetch-tables ( component -- )\r
+ [ [ jpeg> quant-tables>> nth ] change-quant-table drop ]\r
+ [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ]\r
+ [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ;\r
+\r
+: read4/4 ( -- a b ) read1 16 /mod ;\r
+\r
+\r
+! headers\r
+\r
+: decode-frame ( header -- )\r
+ data>>\r
+ binary\r
+ [\r
+ read1 8 assert=\r
+ 2 read be>\r
+ 2 read be>\r
+ swap 2array jpeg> (>>dim)\r
+ read1\r
+ [\r
+ read1 read4/4 read1 <jpeg-color-info>\r
+ swap [ >>id ] keep jpeg> color-info>> set-nth\r
+ ] times\r
+ ] with-byte-reader ;\r
+\r
+: decode-quant-table ( chunk -- )\r
+ dup data>>\r
+ binary\r
+ [\r
+ length>>\r
+ 2 - 65 /\r
+ [\r
+ read4/4 [ 0 assert= ] dip\r
+ 64 read\r
+ swap jpeg> quant-tables>> set-nth\r
+ ] times\r
+ ] with-byte-reader ;\r
+\r
+: decode-huff-table ( chunk -- )\r
+ data>>\r
+ binary\r
+ [\r
+ 1 ! %fixme: Should handle multiple tables at once\r
+ [\r
+ read4/4 swap 2 * +\r
+ 16 read\r
+ dup [ ] [ + ] map-reduce read\r
+ binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader\r
+ swap jpeg> huff-tables>> set-nth\r
+ ] times\r
+ ] with-byte-reader ;\r
+\r
+: decode-scan ( chunk -- )\r
+ data>>\r
+ binary\r
+ [\r
+ read1 [0,b)\r
+ [ drop\r
+ read1 jpeg> color-info>> nth clone\r
+ read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi*\r
+ ] map jpeg> (>>components)\r
+ read1 0 assert=\r
+ read1 63 assert=\r
+ read1 16 /mod [ 0 assert= ] bi@\r
+ ] with-byte-reader ;\r
+\r
+: singleton-first ( seq -- elt )\r
+ [ length 1 assert= ] [ first ] bi ;\r
+\r
+: baseline-parse ( -- )\r
+ jpeg> headers>>\r
+ {\r
+ [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ]\r
+ [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ]\r
+ [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ]\r
+ [ [ type>> { SOS } = ] filter singleton-first decode-scan ]\r
+ } cleave ;\r
+\r
+: parse-marker ( -- marker )\r
+ read1 HEX: FF assert=\r
+ read1 >marker ;\r
+\r
+: parse-headers ( -- chunks )\r
+ [ parse-marker dup { SOS } = not ]\r
+ [\r
+ 2 read be>\r
+ dup 2 - read <jpeg-chunk>\r
+ ] [ produce ] keep dip swap suffix ;\r
+\r
+MEMO: zig-zag ( -- zz )\r
+ {\r
+ { 0 1 5 6 14 15 27 28 }\r
+ { 2 4 7 13 16 26 29 42 }\r
+ { 3 8 12 17 25 30 41 43 }\r
+ { 9 11 18 24 31 40 44 53 }\r
+ { 10 19 23 32 39 45 52 54 }\r
+ { 20 22 33 38 46 51 55 60 }\r
+ { 21 34 37 47 50 56 59 61 }\r
+ { 35 36 48 49 57 58 62 63 }\r
+ } flatten ;\r
+\r
+MEMO: yuv>bgr-matrix ( -- m )\r
+ {\r
+ { 1 2.03211 0 }\r
+ { 1 -0.39465 -0.58060 }\r
+ { 1 0 1.13983 }\r
+ } ;\r
+\r
+: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ;\r
+\r
+:: dct-vect ( u v -- basis )\r
+ { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2\r
+ 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ;\r
+\r
+MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ;\r
+\r
+: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ;\r
+\r
+: all-macroblocks ( quot: ( mb -- ) -- )\r
+ [\r
+ jpeg>\r
+ [ dim>> 8 v/n ]\r
+ [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi\r
+ [ ceiling ] map\r
+ coord-matrix flip concat\r
+ ]\r
+ [ each ] bi* ; inline\r
+\r
+: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ;\r
+\r
+: idct-factor ( b -- b' ) dct-matrix v.m ;\r
+\r
+USE: math.blas.vectors\r
+USE: math.blas.matrices\r
+\r
+MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ;\r
+: V.M ( x A -- x.A ) Mtranspose swap M.V ;\r
+: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ;\r
+\r
+: idct ( b -- b' ) idct-blas ;\r
+\r
+:: draw-block ( block x,y color jpeg-image -- )\r
+ block dup length>> sqrt >fixnum group flip\r
+ dup matrix-dim coord-matrix flip\r
+ [\r
+ [ first2 spin nth nth ]\r
+ [ x,y v+ color id>> 1- jpeg-image draw-color ] bi\r
+ ] with each^2 ;\r
+\r
+: sign-extend ( bits v -- v' )\r
+ swap [ ] [ 1- 2^ < ] 2bi\r
+ [ -1 swap shift 1+ + ] [ drop ] if ;\r
+\r
+: read1-jpeg-dc ( decoder -- dc )\r
+ [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ;\r
+\r
+: read1-jpeg-ac ( decoder -- run/ac )\r
+ [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ;\r
+\r
+:: decode-block ( pos color -- )\r
+ color dc-huff-table>> read1-jpeg-dc color apply-diff\r
+ 64 0 <array> :> coefs\r
+ 0 coefs set-nth\r
+ 0 :> k!\r
+ [\r
+ color ac-huff-table>> read1-jpeg-ac\r
+ [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri\r
+ { 0 0 } = not\r
+ k 63 < and\r
+ ] loop\r
+ coefs color quant-table>> v*\r
+ reverse-zigzag idct\r
+ ! %fixme: color hack\r
+ ! this eat 50% cpu time\r
+ color h>> 2 =\r
+ [ 8 group 2 matrix-zoom concat ] unless\r
+ pos { 8 8 } v* color jpeg> draw-block ;\r
+\r
+: decode-macroblock ( mb -- )\r
+ jpeg> components>>\r
+ [\r
+ [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ]\r
+ [ [ decode-block ] curry each ] bi\r
+ ] with each ;\r
+\r
+: cleanup-bitstream ( bytes -- bytes' )\r
+ binary [\r
+ [\r
+ { HEX: FF } read-until\r
+ read1 tuck HEX: 00 = and\r
+ ]\r
+ [ drop ] produce\r
+ swap >marker { EOI } assert=\r
+ swap suffix\r
+ { HEX: FF } join\r
+ ] with-byte-reader ;\r
+\r
+: setup-bitmap ( image -- )\r
+ dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim\r
+ BGR >>component-order\r
+ f >>upside-down?\r
+ dup dim>> first2 * 3 * 0 <array> >>bitmap\r
+ drop ;\r
+\r
+: baseline-decompress ( -- )\r
+ jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append\r
+ >byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)\r
+ jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] with map ] change-huff-tables drop ] bi\r
+ jpeg> components>> [ fetch-tables ] each\r
+ jpeg> setup-bitmap\r
+ [ decode-macroblock ] all-macroblocks ;\r
+\r
+! this eats ~25% cpu time\r
+: color-transform ( yuv -- rgb )\r
+ { 128 0 0 } v+ yuv>bgr-matrix swap m.v\r
+ [ 0 max 255 min >fixnum ] map ;\r
+\r
+PRIVATE>\r
+\r
+: load-jpeg ( path -- image )\r
+ binary [\r
+ parse-marker { SOI } assert=\r
+ parse-headers\r
+ contents <jpeg-image>\r
+ ] with-file-reader\r
+ dup jpeg-image [\r
+ baseline-parse\r
+ baseline-decompress\r
+ jpeg> bitmap>> 3 <groups> [ color-transform ] change-each\r
+ jpeg> [ >byte-array ] change-bitmap drop\r
+ ] with-variable ;\r
+\r
+M: jpeg-image load-image* ( path jpeg-image -- bitmap )\r
+ drop load-jpeg ;\r
! 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 ;
{ "bmp" [ bitmap-image ] }
{ "tif" [ tiff-image ] }
{ "tiff" [ tiff-image ] }
+ { "jpg" [ jpeg-image ] }
+ { "jpeg" [ jpeg-image ] }
+ { "png" [ png-image ] }
[ unknown-image-extension ]
} case ;
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
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 ;
: fill-image-data ( image -- image )
dup [ width>> ] [ height>> ] bi 2array >>dim ;
+: zlib-data ( png-image -- bytes )
+ chunks>> [ type>> "IDAT" = ] find nip data>> ;
+
+ERROR: unknown-color-type n ;
+ERROR: unimplemented-color-type image ;
+
+: inflate-data ( image -- bytes )
+ zlib-data zlib-inflate ;
+
+: decode-greyscale ( image -- image )
+ unimplemented-color-type ;
+
+: decode-truecolor ( image -- image )
+ {
+ [ inflate-data ]
+ [ dim>> first 3 * 1 + group reverse-png-filter ]
+ [ swap >byte-array >>bitmap drop ]
+ [ RGB >>component-order drop ]
+ [ ]
+ } cleave ;
+
+: decode-indexed-color ( image -- image )
+ unimplemented-color-type ;
+
+: decode-greyscale-alpha ( image -- image )
+ unimplemented-color-type ;
+
+: decode-truecolor-alpha ( image -- image )
+ unimplemented-color-type ;
+
+: decode-png ( image -- image )
+ dup color-type>> {
+ { 0 [ decode-greyscale ] }
+ { 2 [ decode-truecolor ] }
+ { 3 [ decode-indexed-color ] }
+ { 4 [ decode-greyscale-alpha ] }
+ { 6 [ decode-truecolor-alpha ] }
+ [ unknown-color-type ]
+ } case ;
+
: load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi
stream-throws <limited-stream> [
read-png-chunks
parse-ihdr-chunk
fill-image-data
+ decode-png
] with-input-stream ;
+
+M: png-image load-image*
+ drop load-png ;
--- /dev/null
+! Copyright (C) 2009 Marc Fauconneau.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors arrays byte-arrays combinators grouping images\r
+kernel locals math math.order\r
+math.ranges math.vectors sequences sequences.deep fry ;\r
+IN: images.processing\r
+\r
+: coord-matrix ( dim -- m )\r
+ [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ;\r
+\r
+: map^2 ( m quot -- m' ) '[ _ map ] map ; inline\r
+: each^2 ( m quot -- m' ) '[ _ each ] each ; inline\r
+\r
+: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ;\r
+ \r
+: matrix>image ( m -- image )\r
+ <image> over matrix-dim >>dim\r
+ swap flip flatten\r
+ [ 128 * 128 + 0 max 255 min >fixnum ] map\r
+ >byte-array >>bitmap L >>component-order ;\r
+\r
+:: matrix-zoom ( m f -- m' )\r
+ m matrix-dim f v*n coord-matrix\r
+ [ [ f /i ] map first2 swap m nth nth ] map^2 ;\r
+\r
+:: image-offset ( x,y image -- xy )\r
+ image dim>> first\r
+ x,y second * x,y first + ;\r
+ \r
+:: draw-grey ( value x,y image -- )\r
+ x,y image image-offset 3 * { 0 1 2 }\r
+ [\r
+ + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth\r
+ ] with each ;\r
+\r
+:: draw-color ( value x,y color-id image -- )\r
+ x,y image image-offset 3 * color-id + value >fixnum\r
+ swap image bitmap>> set-nth ;\r
+\r
+! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ;\r
size-read-fd <fd> init-fd <input-port> >>size
data-read-fd <fd> >>data ;
-M: unix (init-stdio)
+M: unix init-stdio
<stdin> <input-port>
1 <fd> <output-port>
- 2 <fd> <output-port> t ;
+ 2 <fd> <output-port>
+ set-stdio ;
! mx io-task for embedding an fd-based mx inside another mx
TUPLE: mx-port < port mx ;
-USING: alien alien.c-types arrays assocs combinators
-continuations destructors io io.backend io.ports io.timeouts
-io.backend.windows io.files.windows io.files.windows.nt io.files
-io.pathnames io.buffers io.streams.c libc kernel math namespaces
-sequences threads windows windows.errors windows.kernel32
-strings splitting ascii system accessors locals ;
+USING: alien alien.c-types arrays assocs combinators continuations
+destructors io io.backend io.ports io.timeouts io.backend.windows
+io.files.windows io.files.windows.nt io.files io.pathnames io.buffers
+io.streams.c io.streams.null libc kernel math namespaces sequences
+threads windows windows.errors windows.kernel32 strings splitting
+ascii system accessors locals ;
QUALIFIED: windows.winsock
IN: io.backend.windows.nt
: console-app? ( -- ? ) GetConsoleWindow >boolean ;
-M: winnt (init-stdio)
- console-app? [ init-c-stdio t ] [ f f f f ] if ;
+M: winnt init-stdio
+ console-app?
+ [ init-c-stdio ]
+ [ null-reader null-writer null-writer set-stdio ] if ;
winnt set-io-backend
{
{ +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 -- )
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types io.directories.unix kernel system unix ;
+IN: io.directories.unix.linux
+
+M: unix find-next-file ( DIR* -- byte-array )
+ "dirent" <c-object>
+ f <void*>
+ [ readdir64_r 0 = [ (io-error) ] unless ] 2keep
+ *void* [ drop f ] unless ;
--- /dev/null
+unportable
continuations destructors fry io io.backend io.backend.unix
io.directories io.encodings.binary io.encodings.utf8 io.files
io.pathnames io.files.types kernel math.bitwise sequences system
-unix unix.stat ;
+unix unix.stat vocabs.loader ;
IN: io.directories.unix
: touch-mode ( -- n )
[ opendir dup [ (io-error) ] unless ] dip
dupd curry swap '[ _ closedir io-error ] [ ] cleanup ; inline
-: find-next-file ( DIR* -- byte-array )
+HOOK: find-next-file os ( DIR* -- byte-array )
+
+M: unix find-next-file ( DIR* -- byte-array )
"dirent" <c-object>
f <void*>
[ readdir_r 0 = [ (io-error) ] unless ] 2keep
} case ;
M: unix >directory-entry ( byte-array -- directory-entry )
- [ dirent-d_name utf8 alien>string ]
- [ dirent-d_type dirent-type>file-type ] bi directory-entry boa ;
+ {
+ [ dirent-d_name utf8 alien>string ]
+ [ dirent-d_type dirent-type>file-type ]
+ } cleave directory-entry boa ;
M: unix (directory-entries) ( path -- seq )
[
[ >directory-entry ]
produce nip
] with-unix-directory ;
+
+os linux? [ "io.directories.unix.linux" require ] when
! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel system sequences combinators
-vocabs.loader io.files.types ;
+vocabs.loader io.files.types io.directories math ;
IN: io.files.info
! File info
: directory? ( file-info -- ? ) type>> +directory+ = ;
+: sparse-file? ( file-info -- ? )
+ [ size-on-disk>> ] [ size>> ] bi < ;
+
! File systems
HOOK: file-systems os ( -- array )
{ [ 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 ;
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
: 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 )
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: system kernel namespaces strings hashtables sequences
-assocs combinators vocabs.loader init threads continuations
-math accessors concurrency.flags destructors environment
-io io.encodings.ascii io.backend io.timeouts io.pipes
-io.pipes.private io.encodings io.streams.duplex io.ports
-debugger prettyprint summary calendar ;
+USING: system kernel namespaces strings hashtables sequences assocs
+combinators vocabs.loader init threads continuations math accessors
+concurrency.flags destructors environment io io.encodings.ascii
+io.backend io.timeouts io.pipes io.pipes.private io.encodings
+io.encodings.utf8 io.streams.duplex io.ports debugger prettyprint
+summary calendar ;
IN: io.launcher
TUPLE: process < identity-tuple
swap [ with-stream ] dip
wait-for-success ; inline
+ERROR: output-process-error { output string } { process process } ;
+
+M: output-process-error error.
+ [ "Process:" print process>> . nl ]
+ [ "Output:" print output>> print ]
+ bi ;
+
+: try-output-process ( command -- )
+ >process
+ +stdout+ >>stderr
+ +closed+ >>stdin
+ utf8 <process-reader*>
+ [ stream-contents ] [ dup wait-for-process ] bi*
+ 0 = [ 2drop ] [ output-process-error ] if ;
+
: notify-exit ( process status -- )
>>status
[ processes get delete-at* drop [ resume ] each ] keep
--- /dev/null
+Slava Pestov
--- /dev/null
+USING: io help.markup help.syntax quotations ;
+IN: io.streams.null
+
+HELP: null-reader
+{ $class-description "Singleton class of null reader streams." } ;
+
+HELP: null-writer
+{ $class-description "Singleton class of null writer streams." } ;
+
+HELP: with-null-reader
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
+
+HELP: with-null-writer
+{ $values { "quot" quotation } }
+{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
+
+ARTICLE: "io.streams.null" "Null streams"
+"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
+$nl
+"Null readers:"
+{ $subsection null-reader }
+{ $subsection with-null-writer }
+"Null writers:"
+{ $subsection null-writer }
+{ $subsection with-null-reader } ;
+
+ABOUT: "io.streams.null"
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2007, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel io destructors io.streams.plain ;
+IN: io.streams.null
+
+SINGLETONS: null-reader null-writer ;
+UNION: null-stream null-reader null-writer ;
+INSTANCE: null-writer plain-writer
+
+M: null-stream dispose drop ;
+
+M: null-reader stream-element-type drop +byte+ ;
+M: null-reader stream-readln drop f ;
+M: null-reader stream-read1 drop f ;
+M: null-reader stream-read-until 2drop f f ;
+M: null-reader stream-read 2drop f ;
+
+M: null-writer stream-element-type drop +byte+ ;
+M: null-writer stream-write1 2drop ;
+M: null-writer stream-write 2drop ;
+M: null-writer stream-flush drop ;
+
+: with-null-reader ( quot -- )
+ null-reader swap with-input-stream* ; inline
+
+: with-null-writer ( quot -- )
+ null-writer swap with-output-stream* ; inline
--- /dev/null
+Dummy implementation of stream protocol
--- /dev/null
+USING: iokit alien alien.syntax alien.c-types kernel
+system core-foundation core-foundation.data
+core-foundation.dictionaries ;
+IN: iokit.hid
+
+CONSTANT: kIOHIDDeviceKey "IOHIDDevice"
+
+CONSTANT: kIOHIDTransportKey "Transport"
+CONSTANT: kIOHIDVendorIDKey "VendorID"
+CONSTANT: kIOHIDVendorIDSourceKey "VendorIDSource"
+CONSTANT: kIOHIDProductIDKey "ProductID"
+CONSTANT: kIOHIDVersionNumberKey "VersionNumber"
+CONSTANT: kIOHIDManufacturerKey "Manufacturer"
+CONSTANT: kIOHIDProductKey "Product"
+CONSTANT: kIOHIDSerialNumberKey "SerialNumber"
+CONSTANT: kIOHIDCountryCodeKey "CountryCode"
+CONSTANT: kIOHIDLocationIDKey "LocationID"
+CONSTANT: kIOHIDDeviceUsageKey "DeviceUsage"
+CONSTANT: kIOHIDDeviceUsagePageKey "DeviceUsagePage"
+CONSTANT: kIOHIDDeviceUsagePairsKey "DeviceUsagePairs"
+CONSTANT: kIOHIDPrimaryUsageKey "PrimaryUsage"
+CONSTANT: kIOHIDPrimaryUsagePageKey "PrimaryUsagePage"
+CONSTANT: kIOHIDMaxInputReportSizeKey "MaxInputReportSize"
+CONSTANT: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize"
+CONSTANT: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize"
+CONSTANT: kIOHIDReportIntervalKey "ReportInterval"
+
+CONSTANT: kIOHIDElementKey "Elements"
+
+CONSTANT: kIOHIDElementCookieKey "ElementCookie"
+CONSTANT: kIOHIDElementTypeKey "Type"
+CONSTANT: kIOHIDElementCollectionTypeKey "CollectionType"
+CONSTANT: kIOHIDElementUsageKey "Usage"
+CONSTANT: kIOHIDElementUsagePageKey "UsagePage"
+CONSTANT: kIOHIDElementMinKey "Min"
+CONSTANT: kIOHIDElementMaxKey "Max"
+CONSTANT: kIOHIDElementScaledMinKey "ScaledMin"
+CONSTANT: kIOHIDElementScaledMaxKey "ScaledMax"
+CONSTANT: kIOHIDElementSizeKey "Size"
+CONSTANT: kIOHIDElementReportSizeKey "ReportSize"
+CONSTANT: kIOHIDElementReportCountKey "ReportCount"
+CONSTANT: kIOHIDElementReportIDKey "ReportID"
+CONSTANT: kIOHIDElementIsArrayKey "IsArray"
+CONSTANT: kIOHIDElementIsRelativeKey "IsRelative"
+CONSTANT: kIOHIDElementIsWrappingKey "IsWrapping"
+CONSTANT: kIOHIDElementIsNonLinearKey "IsNonLinear"
+CONSTANT: kIOHIDElementHasPreferredStateKey "HasPreferredState"
+CONSTANT: kIOHIDElementHasNullStateKey "HasNullState"
+CONSTANT: kIOHIDElementFlagsKey "Flags"
+CONSTANT: kIOHIDElementUnitKey "Unit"
+CONSTANT: kIOHIDElementUnitExponentKey "UnitExponent"
+CONSTANT: kIOHIDElementNameKey "Name"
+CONSTANT: kIOHIDElementValueLocationKey "ValueLocation"
+CONSTANT: kIOHIDElementDuplicateIndexKey "DuplicateIndex"
+CONSTANT: kIOHIDElementParentCollectionKey "ParentCollection"
+
+: kIOHIDElementVendorSpecificKey ( -- str )
+ cpu ppc? "VendorSpecifc" "VendorSpecific" ? ; inline
+
+CONSTANT: kIOHIDElementCookieMinKey "ElementCookieMin"
+CONSTANT: kIOHIDElementCookieMaxKey "ElementCookieMax"
+CONSTANT: kIOHIDElementUsageMinKey "UsageMin"
+CONSTANT: kIOHIDElementUsageMaxKey "UsageMax"
+
+CONSTANT: kIOHIDElementCalibrationMinKey "CalibrationMin"
+CONSTANT: kIOHIDElementCalibrationMaxKey "CalibrationMax"
+CONSTANT: kIOHIDElementCalibrationSaturationMinKey "CalibrationSaturationMin"
+CONSTANT: kIOHIDElementCalibrationSaturationMaxKey "CalibrationSaturationMax"
+CONSTANT: kIOHIDElementCalibrationDeadZoneMinKey "CalibrationDeadZoneMin"
+CONSTANT: kIOHIDElementCalibrationDeadZoneMaxKey "CalibrationDeadZoneMax"
+CONSTANT: kIOHIDElementCalibrationGranularityKey "CalibrationGranularity"
+
+CONSTANT: kIOHIDElementTypeInput_Misc 1
+CONSTANT: kIOHIDElementTypeInput_Button 2
+CONSTANT: kIOHIDElementTypeInput_Axis 3
+CONSTANT: kIOHIDElementTypeInput_ScanCodes 4
+CONSTANT: kIOHIDElementTypeOutput 129
+CONSTANT: kIOHIDElementTypeFeature 257
+CONSTANT: kIOHIDElementTypeCollection 513
+
+CONSTANT: kIOHIDElementCollectionTypePhysical HEX: 00
+CONSTANT: kIOHIDElementCollectionTypeApplication HEX: 01
+CONSTANT: kIOHIDElementCollectionTypeLogical HEX: 02
+CONSTANT: kIOHIDElementCollectionTypeReport HEX: 03
+CONSTANT: kIOHIDElementCollectionTypeNamedArray HEX: 04
+CONSTANT: kIOHIDElementCollectionTypeUsageSwitch HEX: 05
+CONSTANT: kIOHIDElementCollectionTypeUsageModifier HEX: 06
+
+CONSTANT: kIOHIDReportTypeInput 0
+CONSTANT: kIOHIDReportTypeOutput 1
+CONSTANT: kIOHIDReportTypeFeature 2
+CONSTANT: kIOHIDReportTypeCount 3
+
+CONSTANT: kIOHIDOptionsTypeNone HEX: 00
+CONSTANT: kIOHIDOptionsTypeSeizeDevice HEX: 01
+
+CONSTANT: kIOHIDQueueOptionsTypeNone HEX: 00
+CONSTANT: kIOHIDQueueOptionsTypeEnqueueAll HEX: 01
+
+CONSTANT: kIOHIDElementFlagsConstantMask HEX: 0001
+CONSTANT: kIOHIDElementFlagsVariableMask HEX: 0002
+CONSTANT: kIOHIDElementFlagsRelativeMask HEX: 0004
+CONSTANT: kIOHIDElementFlagsWrapMask HEX: 0008
+CONSTANT: kIOHIDElementFlagsNonLinearMask HEX: 0010
+CONSTANT: kIOHIDElementFlagsNoPreferredMask HEX: 0020
+CONSTANT: kIOHIDElementFlagsNullStateMask HEX: 0040
+CONSTANT: kIOHIDElementFlagsVolativeMask HEX: 0080
+CONSTANT: kIOHIDElementFlagsBufferedByteMask HEX: 0100
+
+CONSTANT: kIOHIDValueScaleTypeCalibrated 0
+CONSTANT: kIOHIDValueScaleTypePhysical 1
+
+CONSTANT: kIOHIDTransactionDirectionTypeInput 0
+CONSTANT: kIOHIDTransactionDirectionTypeOutput 1
+
+CONSTANT: kIOHIDTransactionOptionDefaultOutputValue 1
+
+TYPEDEF: ptrdiff_t IOHIDElementCookie
+TYPEDEF: int IOHIDElementType
+TYPEDEF: int IOHIDElementCollectionType
+TYPEDEF: int IOHIDReportType
+TYPEDEF: uint IOHIDOptionsType
+TYPEDEF: uint IOHIDQueueOptionsType
+TYPEDEF: uint IOHIDElementFlags
+TYPEDEF: void* IOHIDDeviceRef
+TYPEDEF: void* IOHIDElementRef
+TYPEDEF: void* IOHIDValueRef
+TYPEDEF: void* IOHIDManagerRef
+TYPEDEF: void* IOHIDTransactionRef
+TYPEDEF: UInt32 IOHIDValueScaleType
+TYPEDEF: UInt32 IOHIDTransactionDirectionType
+
+TYPEDEF: void* IOHIDCallback
+: IOHIDCallback ( quot -- alien )
+ [ "void" { "void*" "IOReturn" "void*" } "cdecl" ]
+ dip alien-callback ; inline
+
+TYPEDEF: void* IOHIDReportCallback
+: IOHIDReportCallback ( quot -- alien )
+ [ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ]
+ dip alien-callback ; inline
+
+TYPEDEF: void* IOHIDValueCallback
+: IOHIDValueCallback ( quot -- alien )
+ [ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ]
+ dip alien-callback ; inline
+
+TYPEDEF: void* IOHIDValueMultipleCallback
+: IOHIDValueMultipleCallback ( quot -- alien )
+ [ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ]
+ dip alien-callback ; inline
+
+TYPEDEF: void* IOHIDDeviceCallback
+: IOHIDDeviceCallback ( quot -- alien )
+ [ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ]
+ dip alien-callback ; inline
+
+! IOHIDDevice
+
+FUNCTION: CFTypeID IOHIDDeviceGetTypeID ( ) ;
+FUNCTION: IOHIDDeviceRef IOHIDDeviceCreate ( CFAllocatorRef allocator, io_service_t service ) ;
+FUNCTION: IOReturn IOHIDDeviceOpen ( IOHIDDeviceRef device, IOOptionBits options ) ;
+FUNCTION: IOReturn IOHIDDeviceClose ( IOHIDDeviceRef device, IOOptionBits options ) ;
+FUNCTION: Boolean IOHIDDeviceConformsTo ( IOHIDDeviceRef device, UInt32 usagePage, UInt32 usage ) ;
+FUNCTION: CFTypeRef IOHIDDeviceGetProperty ( IOHIDDeviceRef device, CFStringRef key ) ;
+FUNCTION: Boolean IOHIDDeviceSetProperty ( IOHIDDeviceRef device, CFStringRef key, CFTypeRef property ) ;
+FUNCTION: CFArrayRef IOHIDDeviceCopyMatchingElements ( IOHIDDeviceRef device, CFDictionaryRef matching, IOOptionBits options ) ;
+FUNCTION: void IOHIDDeviceScheduleWithRunLoop ( IOHIDDeviceRef device, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
+FUNCTION: void IOHIDDeviceUnscheduleFromRunLoop ( IOHIDDeviceRef device, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
+FUNCTION: void IOHIDDeviceRegisterRemovalCallback ( IOHIDDeviceRef device, IOHIDCallback callback, void* context ) ;
+FUNCTION: void IOHIDDeviceRegisterInputValueCallback ( IOHIDDeviceRef device, IOHIDValueCallback callback, void* context ) ;
+FUNCTION: void IOHIDDeviceRegisterInputReportCallback ( IOHIDDeviceRef device, uchar* report, CFIndex reportLength, IOHIDReportCallback callback, void* context ) ;
+FUNCTION: void IOHIDDeviceSetInputValueMatching ( IOHIDDeviceRef device, CFDictionaryRef matching ) ;
+FUNCTION: void IOHIDDeviceSetInputValueMatchingMultiple ( IOHIDDeviceRef device, CFArrayRef multiple ) ;
+FUNCTION: IOReturn IOHIDDeviceSetValue ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef value ) ;
+FUNCTION: IOReturn IOHIDDeviceSetValueMultiple ( IOHIDDeviceRef device, CFDictionaryRef multiple ) ;
+FUNCTION: IOReturn IOHIDDeviceSetValueWithCallback ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef value, CFTimeInterval timeout, IOHIDValueCallback callback, void* context ) ;
+FUNCTION: IOReturn IOHIDDeviceSetValueMultipleWithCallback ( IOHIDDeviceRef device, CFDictionaryRef multiple, CFTimeInterval timeout, IOHIDValueMultipleCallback callback, void* context ) ;
+FUNCTION: IOReturn IOHIDDeviceGetValue ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef* pValue ) ;
+FUNCTION: IOReturn IOHIDDeviceCopyValueMultiple ( IOHIDDeviceRef device, CFArrayRef elements, CFDictionaryRef* pMultiple ) ;
+FUNCTION: IOReturn IOHIDDeviceGetValueWithCallback ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef* pValue, CFTimeInterval timeout, IOHIDValueCallback callback, void* context ) ;
+FUNCTION: IOReturn IOHIDDeviceCopyValueMultipleWithCallback ( IOHIDDeviceRef device, CFArrayRef elements, CFDictionaryRef* pMultiple, CFTimeInterval timeout, IOHIDValueMultipleCallback callback, void* context ) ;
+FUNCTION: IOReturn IOHIDDeviceSetReport ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex reportLength ) ;
+FUNCTION: IOReturn IOHIDDeviceSetReportWithCallback ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex reportLength, CFTimeInterval timeout, IOHIDReportCallback callback, void* context ) ;
+FUNCTION: IOReturn IOHIDDeviceGetReport ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex* pReportLength ) ;
+FUNCTION: IOReturn IOHIDDeviceGetReportWithCallback ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex* pReportLength, CFTimeInterval timeout, IOHIDReportCallback callback, void* context ) ;
+
+! IOHIDManager
+
+FUNCTION: CFTypeID IOHIDManagerGetTypeID ( ) ;
+FUNCTION: IOHIDManagerRef IOHIDManagerCreate ( CFAllocatorRef allocator, IOOptionBits options ) ;
+FUNCTION: IOReturn IOHIDManagerOpen ( IOHIDManagerRef manager, IOOptionBits options ) ;
+FUNCTION: IOReturn IOHIDManagerClose ( IOHIDManagerRef manager, IOOptionBits options ) ;
+FUNCTION: CFTypeRef IOHIDManagerGetProperty ( IOHIDManagerRef manager, CFStringRef key ) ;
+FUNCTION: Boolean IOHIDManagerSetProperty ( IOHIDManagerRef manager, CFStringRef key, CFTypeRef value ) ;
+FUNCTION: void IOHIDManagerScheduleWithRunLoop ( IOHIDManagerRef manager, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
+FUNCTION: void IOHIDManagerUnscheduleFromRunLoop ( IOHIDManagerRef manager, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
+FUNCTION: void IOHIDManagerSetDeviceMatching ( IOHIDManagerRef manager, CFDictionaryRef matching ) ;
+FUNCTION: void IOHIDManagerSetDeviceMatchingMultiple ( IOHIDManagerRef manager, CFArrayRef multiple ) ;
+FUNCTION: CFSetRef IOHIDManagerCopyDevices ( IOHIDManagerRef manager ) ;
+FUNCTION: void IOHIDManagerRegisterDeviceMatchingCallback ( IOHIDManagerRef manager, IOHIDDeviceCallback callback, void* context ) ;
+FUNCTION: void IOHIDManagerRegisterDeviceRemovalCallback ( IOHIDManagerRef manager, IOHIDDeviceCallback callback, void* context ) ;
+FUNCTION: void IOHIDManagerRegisterInputReportCallback ( IOHIDManagerRef manager, IOHIDReportCallback callback, void* context ) ;
+FUNCTION: void IOHIDManagerRegisterInputValueCallback ( IOHIDManagerRef manager, IOHIDValueCallback callback, void* context ) ;
+FUNCTION: void IOHIDManagerSetInputValueMatching ( IOHIDManagerRef manager, CFDictionaryRef matching ) ;
+FUNCTION: void IOHIDManagerSetInputValueMatchingMultiple ( IOHIDManagerRef manager, CFArrayRef multiple ) ;
+
+! IOHIDElement
+
+FUNCTION: CFTypeID IOHIDElementGetTypeID ( ) ;
+FUNCTION: IOHIDElementRef IOHIDElementCreateWithDictionary ( CFAllocatorRef allocator, CFDictionaryRef dictionary ) ;
+FUNCTION: IOHIDDeviceRef IOHIDElementGetDevice ( IOHIDElementRef element ) ;
+FUNCTION: IOHIDElementRef IOHIDElementGetParent ( IOHIDElementRef element ) ;
+FUNCTION: CFArrayRef IOHIDElementGetChildren ( IOHIDElementRef element ) ;
+FUNCTION: void IOHIDElementAttach ( IOHIDElementRef element, IOHIDElementRef toAttach ) ;
+FUNCTION: void IOHIDElementDetach ( IOHIDElementRef element, IOHIDElementRef toDetach ) ;
+FUNCTION: CFArrayRef IOHIDElementCopyAttached ( IOHIDElementRef element ) ;
+FUNCTION: IOHIDElementCookie IOHIDElementGetCookie ( IOHIDElementRef element ) ;
+FUNCTION: IOHIDElementType IOHIDElementGetType ( IOHIDElementRef element ) ;
+FUNCTION: IOHIDElementCollectionType IOHIDElementGetCollectionType ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetUsagePage ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetUsage ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementIsVirtual ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementIsRelative ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementIsWrapping ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementIsArray ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementIsNonLinear ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementHasPreferredState ( IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDElementHasNullState ( IOHIDElementRef element ) ;
+FUNCTION: CFStringRef IOHIDElementGetName ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetReportID ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetReportSize ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetReportCount ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetUnit ( IOHIDElementRef element ) ;
+FUNCTION: UInt32 IOHIDElementGetUnitExponent ( IOHIDElementRef element ) ;
+FUNCTION: CFIndex IOHIDElementGetLogicalMin ( IOHIDElementRef element ) ;
+FUNCTION: CFIndex IOHIDElementGetLogicalMax ( IOHIDElementRef element ) ;
+FUNCTION: CFIndex IOHIDElementGetPhysicalMin ( IOHIDElementRef element ) ;
+FUNCTION: CFIndex IOHIDElementGetPhysicalMax ( IOHIDElementRef element ) ;
+FUNCTION: CFTypeRef IOHIDElementGetProperty ( IOHIDElementRef element, CFStringRef key ) ;
+FUNCTION: Boolean IOHIDElementSetProperty ( IOHIDElementRef element, CFStringRef key, CFTypeRef property ) ;
+
+! IOHIDValue
+
+FUNCTION: CFTypeID IOHIDValueGetTypeID ( ) ;
+FUNCTION: IOHIDValueRef IOHIDValueCreateWithIntegerValue ( CFAllocatorRef allocator, IOHIDElementRef element, ulonglong timeStamp, CFIndex value ) ;
+FUNCTION: IOHIDValueRef IOHIDValueCreateWithBytes ( CFAllocatorRef allocator, IOHIDElementRef element, ulonglong timeStamp, uchar* bytes, CFIndex length ) ;
+FUNCTION: IOHIDValueRef IOHIDValueCreateWithBytesNoCopy ( CFAllocatorRef allocator, IOHIDElementRef element, ulonglong timeStamp, uchar* bytes, CFIndex length ) ;
+FUNCTION: IOHIDElementRef IOHIDValueGetElement ( IOHIDValueRef value ) ;
+FUNCTION: ulonglong IOHIDValueGetTimeStamp ( IOHIDValueRef value ) ;
+FUNCTION: CFIndex IOHIDValueGetLength ( IOHIDValueRef value ) ;
+FUNCTION: uchar* IOHIDValueGetBytePtr ( IOHIDValueRef value ) ;
+FUNCTION: CFIndex IOHIDValueGetIntegerValue ( IOHIDValueRef value ) ;
+FUNCTION: double IOHIDValueGetScaledValue ( IOHIDValueRef value, IOHIDValueScaleType type ) ;
+
+! IOHIDTransaction
+
+FUNCTION: CFTypeID IOHIDTransactionGetTypeID ( ) ;
+FUNCTION: IOHIDTransactionRef IOHIDTransactionCreate ( CFAllocatorRef allocator, IOHIDDeviceRef device, IOHIDTransactionDirectionType direction, IOOptionBits options ) ;
+FUNCTION: IOHIDDeviceRef IOHIDTransactionGetDevice ( IOHIDTransactionRef transaction ) ;
+FUNCTION: IOHIDTransactionDirectionType IOHIDTransactionGetDirection ( IOHIDTransactionRef transaction ) ;
+FUNCTION: void IOHIDTransactionSetDirection ( IOHIDTransactionRef transaction, IOHIDTransactionDirectionType direction ) ;
+FUNCTION: void IOHIDTransactionAddElement ( IOHIDTransactionRef transaction, IOHIDElementRef element ) ;
+FUNCTION: void IOHIDTransactionRemoveElement ( IOHIDTransactionRef transaction, IOHIDElementRef element ) ;
+FUNCTION: Boolean IOHIDTransactionContainsElement ( IOHIDTransactionRef transaction, IOHIDElementRef element ) ;
+FUNCTION: void IOHIDTransactionScheduleWithRunLoop ( IOHIDTransactionRef transaction, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
+FUNCTION: void IOHIDTransactionUnscheduleFromRunLoop ( IOHIDTransactionRef transaction, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
+FUNCTION: void IOHIDTransactionSetValue ( IOHIDTransactionRef transaction, IOHIDElementRef element, IOHIDValueRef value, IOOptionBits options ) ;
+FUNCTION: IOHIDValueRef IOHIDTransactionGetValue ( IOHIDTransactionRef transaction, IOHIDElementRef element, IOOptionBits options ) ;
+FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
+FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
+FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;
+
--- /dev/null
+HID Manager bindings
--- /dev/null
+bindings
+unportable
--- /dev/null
+USING: alien.syntax alien.c-types core-foundation
+core-foundation.bundles core-foundation.dictionaries system
+combinators kernel sequences debugger io accessors ;
+IN: iokit
+
+<<
+ os macosx?
+ [ "/System/Library/Frameworks/IOKit.framework" load-framework ]
+ when
+>>
+
+CONSTANT: kIOKitBuildVersionKey "IOKitBuildVersion"
+CONSTANT: kIOKitDiagnosticsKey "IOKitDiagnostics"
+
+CONSTANT: kIORegistryPlanesKey "IORegistryPlanes"
+CONSTANT: kIOCatalogueKey "IOCatalogue"
+
+CONSTANT: kIOServicePlane "IOService"
+CONSTANT: kIOPowerPlane "IOPower"
+CONSTANT: kIODeviceTreePlane "IODeviceTree"
+CONSTANT: kIOAudioPlane "IOAudio"
+CONSTANT: kIOFireWirePlane "IOFireWire"
+CONSTANT: kIOUSBPlane "IOUSB"
+
+CONSTANT: kIOServiceClass "IOService"
+
+CONSTANT: kIOResourcesClass "IOResources"
+
+CONSTANT: kIOClassKey "IOClass"
+CONSTANT: kIOProbeScoreKey "IOProbeScore"
+CONSTANT: kIOKitDebugKey "IOKitDebug"
+
+CONSTANT: kIOProviderClassKey "IOProviderClass"
+CONSTANT: kIONameMatchKey "IONameMatch"
+CONSTANT: kIOPropertyMatchKey "IOPropertyMatch"
+CONSTANT: kIOPathMatchKey "IOPathMatch"
+CONSTANT: kIOLocationMatchKey "IOLocationMatch"
+CONSTANT: kIOParentMatchKey "IOParentMatch"
+CONSTANT: kIOResourceMatchKey "IOResourceMatch"
+CONSTANT: kIOMatchedServiceCountKey "IOMatchedServiceCountMatch"
+
+CONSTANT: kIONameMatchedKey "IONameMatched"
+
+CONSTANT: kIOMatchCategoryKey "IOMatchCategory"
+CONSTANT: kIODefaultMatchCategoryKey "IODefaultMatchCategory"
+
+CONSTANT: kIOUserClientClassKey "IOUserClientClass"
+
+CONSTANT: kIOUserClientCrossEndianKey "IOUserClientCrossEndian"
+CONSTANT: kIOUserClientCrossEndianCompatibleKey "IOUserClientCrossEndianCompatible"
+CONSTANT: kIOUserClientSharedInstanceKey "IOUserClientSharedInstance"
+
+CONSTANT: kIOPublishNotification "IOServicePublish"
+CONSTANT: kIOFirstPublishNotification "IOServiceFirstPublish"
+CONSTANT: kIOMatchedNotification "IOServiceMatched"
+CONSTANT: kIOFirstMatchNotification "IOServiceFirstMatch"
+CONSTANT: kIOTerminatedNotification "IOServiceTerminate"
+
+CONSTANT: kIOGeneralInterest "IOGeneralInterest"
+CONSTANT: kIOBusyInterest "IOBusyInterest"
+CONSTANT: kIOAppPowerStateInterest "IOAppPowerStateInterest"
+CONSTANT: kIOPriorityPowerStateInterest "IOPriorityPowerStateInterest"
+
+CONSTANT: kIOPlatformDeviceMessageKey "IOPlatformDeviceMessage"
+
+CONSTANT: kIOCFPlugInTypesKey "IOCFPlugInTypes"
+
+CONSTANT: kIOCommandPoolSizeKey "IOCommandPoolSize"
+
+CONSTANT: kIOMaximumBlockCountReadKey "IOMaximumBlockCountRead"
+CONSTANT: kIOMaximumBlockCountWriteKey "IOMaximumBlockCountWrite"
+CONSTANT: kIOMaximumByteCountReadKey "IOMaximumByteCountRead"
+CONSTANT: kIOMaximumByteCountWriteKey "IOMaximumByteCountWrite"
+CONSTANT: kIOMaximumSegmentCountReadKey "IOMaximumSegmentCountRead"
+CONSTANT: kIOMaximumSegmentCountWriteKey "IOMaximumSegmentCountWrite"
+CONSTANT: kIOMaximumSegmentByteCountReadKey "IOMaximumSegmentByteCountRead"
+CONSTANT: kIOMaximumSegmentByteCountWriteKey "IOMaximumSegmentByteCountWrite"
+CONSTANT: kIOMinimumSegmentAlignmentByteCountKey "IOMinimumSegmentAlignmentByteCount"
+CONSTANT: kIOMaximumSegmentAddressableBitCountKey "IOMaximumSegmentAddressableBitCount"
+
+CONSTANT: kIOIconKey "IOIcon"
+CONSTANT: kIOBundleResourceFileKey "IOBundleResourceFile"
+
+CONSTANT: kIOBusBadgeKey "IOBusBadge"
+CONSTANT: kIODeviceIconKey "IODeviceIcon"
+
+CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber"
+
+CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID"
+
+CONSTANT: kIONVRAMDeletePropertyKey "IONVRAM-DELETE-PROPERTY"
+CONSTANT: kIODTNVRAMPanicInfoKey "aapl,panic-info"
+
+CONSTANT: kIOBootDeviceKey "IOBootDevice"
+CONSTANT: kIOBootDevicePathKey "IOBootDevicePath"
+CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize"
+
+CONSTANT: kOSBuildVersionKey "OS Build Version"
+
+CONSTANT: kNilOptions 0
+
+TYPEDEF: uint mach_port_t
+TYPEDEF: int kern_return_t
+TYPEDEF: int boolean_t
+TYPEDEF: mach_port_t io_object_t
+TYPEDEF: io_object_t io_iterator_t
+TYPEDEF: io_object_t io_registry_entry_t
+TYPEDEF: io_object_t io_service_t
+TYPEDEF: char[128] io_name_t
+TYPEDEF: char[512] io_string_t
+TYPEDEF: kern_return_t IOReturn
+
+TYPEDEF: uint IOOptionBits
+
+CONSTANT: MACH_PORT_NULL 0
+CONSTANT: KERN_SUCCESS 0
+
+FUNCTION: IOReturn IOMasterPort ( mach_port_t bootstrap, mach_port_t* master ) ;
+
+FUNCTION: CFDictionaryRef IOServiceMatching ( char* name ) ;
+FUNCTION: CFDictionaryRef IOServiceNameMatching ( char* name ) ;
+FUNCTION: CFDictionaryRef IOBSDNameMatching ( char* name ) ;
+
+FUNCTION: IOReturn IOObjectRetain ( io_object_t o ) ;
+FUNCTION: IOReturn IOObjectRelease ( io_object_t o ) ;
+
+FUNCTION: IOReturn IOServiceGetMatchingServices ( mach_port_t master, CFDictionaryRef matchingDict, io_iterator_t* iterator ) ;
+
+FUNCTION: io_object_t IOIteratorNext ( io_iterator_t i ) ;
+FUNCTION: void IOIteratorReset ( io_iterator_t i ) ;
+FUNCTION: boolean_t IOIteratorIsValid ( io_iterator_t i ) ;
+
+FUNCTION: IOReturn IORegistryEntryGetPath ( io_registry_entry_t entry, io_name_t plane, io_string_t path ) ;
+
+FUNCTION: IOReturn IORegistryEntryCreateCFProperties ( io_registry_entry_t entry, CFMutableDictionaryRef properties, CFAllocatorRef allocator, IOOptionBits options ) ;
+
+FUNCTION: char* mach_error_string ( IOReturn error ) ;
+
+TUPLE: mach-error error-code ;
+C: <mach-error> mach-error
+
+M: mach-error error.
+ "IOKit call failed: " print error-code>> mach_error_string print ;
+
+: mach-error ( return -- )
+ dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
+
+: master-port ( -- port )
+ MACH_PORT_NULL 0 <uint> [ IOMasterPort mach-error ] keep *uint ;
+
+: io-services-matching-dictionary ( nsdictionary -- iterator )
+ master-port swap 0 <uint>
+ [ IOServiceGetMatchingServices mach-error ] keep
+ *uint ;
+
+: io-services-matching-service ( service -- iterator )
+ IOServiceMatching io-services-matching-dictionary ;
+: io-services-matching-service-name ( service-name -- iterator )
+ IOServiceNameMatching io-services-matching-dictionary ;
+: io-services-matching-bsd-name ( bsd-name -- iterator )
+ IOBSDNameMatching io-services-matching-dictionary ;
+
+: retain-io-object ( o -- o )
+ [ IOObjectRetain mach-error ] keep ;
+: release-io-object ( o -- )
+ IOObjectRelease mach-error ;
+
+: io-objects-from-iterator* ( i -- i array )
+ [ dup IOIteratorNext dup MACH_PORT_NULL = not ] [ ] produce nip ;
+
+: io-objects-from-iterator ( i -- array )
+ io-objects-from-iterator* [ release-io-object ] dip ;
+
+: properties-from-io-object ( o -- o nsdictionary )
+ dup f <void*> [
+ kCFAllocatorDefault kNilOptions
+ IORegistryEntryCreateCFProperties mach-error
+ ]
+ keep *void* ;
+
--- /dev/null
+Bindings to Apple IOKit device interface
--- /dev/null
+bindings
+unportable
{ deploy-name "none" }
{ "stop-after-last-window?" t }
{ deploy-c-types? f }
- { deploy-compiler? f }
{ deploy-io 1 }
{ deploy-ui? f }
{ deploy-reflection 1 }
{ 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 ;
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 ;
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
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
+
<<
{
{ [ 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 ] }
<< {
{ [ 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 ] }
heap-size struct-array boa ; inline
: malloc-struct-array ( length c-type -- struct-array )
- [ heap-size calloc ] 2keep <direct-struct-array> ;
+ [ heap-size calloc ] 2keep <direct-struct-array> ; inline
INSTANCE: struct-array sequence
<PRIVATE
-: word-inputs ( word -- seq )
- stack-effect [
- [ datastack ] dip in>> length tail*
- ] [
- datastack
- ] if* ;
-
-: entering ( str -- )
- "/-- Entering: " write dup .
- word-inputs stack.
- "\\--" print flush ;
-
-: word-outputs ( word -- seq )
- stack-effect [
- [ datastack ] dip out>> length tail*
- ] [
- datastack
- ] if* ;
-
-: leaving ( str -- )
- "/-- Leaving: " write dup .
- word-outputs stack.
- "\\--" print flush ;
+: stack-values ( names -- alist )
+ [ datastack ] dip [ nip ] [ length tail* ] 2bi zip ;
+
+: trace-message ( word quot str -- )
+ "--- " write write bl over .
+ [ stack-effect ] dip '[ @ stack-values ] [ f ] if*
+ [ simple-table. ] unless-empty flush ; inline
+
+: entering ( str -- ) [ in>> ] "Entering" trace-message ;
+
+: leaving ( str -- ) [ out>> ] "Leaving" trace-message ;
: (watch) ( word def -- def )
over '[ _ entering @ _ leaving ] ;
[ my-arch make-image ] unless ;
: bootstrap-profile ( -- profile )
- {
- { "math" deploy-math? }
- { "compiler" deploy-compiler? }
- { "threads" deploy-threads? }
- { "ui" deploy-ui? }
- { "unicode" deploy-unicode? }
- } [ nip get ] assoc-filter keys
- native-io? [ "io" suffix ] when ;
+ [
+ deploy-math? get [ "math" , ] when
+ deploy-threads? get [ "threads" , ] when
+ "compiler" ,
+ deploy-ui? get [ "ui" , ] when
+ deploy-unicode? get [ "unicode" , ] when
+ native-io? [ "io" , ] when
+ ] { } make ;
: staging-image-name ( profile -- name )
"staging."
ARTICLE: "deploy-flags" "Deployment flags"
"There are two sets of deployment flags. The first set controls the major subsystems which are to be included in the deployment image:"
{ $subsection deploy-math? }
-{ $subsection deploy-compiler? }
{ $subsection deploy-unicode? }
{ $subsection deploy-threads? }
{ $subsection deploy-ui? }
$nl
"On by default. Often the programmer will use rationals without realizing it. A small amount of space can be saved by stripping these features out, but some code may require changes to work properly." } ;
-HELP: deploy-compiler?
-{ $description "Deploy flag. If set, words in the deployed image will be compiled with the optimizing compiler when possible."
-$nl
-"On by default. Most programs should be compiled, not only for performance but because features which depend on the C library interface only function after compilation." } ;
-
HELP: deploy-unicode?
{ $description "Deploy flag. If set, full Unicode " { $link POSTPONE: CHAR: } " syntax is included."
$nl
SYMBOL: deploy-name
SYMBOL: deploy-ui?
-SYMBOL: deploy-compiler?
SYMBOL: deploy-math?
SYMBOL: deploy-unicode?
SYMBOL: deploy-threads?
{ deploy-ui? f }
{ deploy-io 2 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ deploy-math? t }
"In deployed applications, the " { $link boa } " word does not verify that the parameters on the stack satisfy the tuple's slot declarations, if any. This reduces deploy image size but can make bugs harder to track down. Make sure your program is fully debugged before deployment."
{ $heading "Behavior of " { $link POSTPONE: execute( } }
"Similarly, the " { $link POSTPONE: execute( } " word does not check word stack effects in deployed applications, since stack effects are stripped out, and so it behaves exactly like " { $link POSTPONE: execute-effect-unsafe } "."
+{ $heading "Behavior of " { $link POSTPONE: call-next-method } }
+"The " { $link POSTPONE: call-next-method } " word does not check if the input is of the right type in deployed applications."
{ $heading "Error reporting" }
"If the " { $link deploy-reflection } " level in the configuration is low enough, the debugger is stripped out, and error messages can be rather cryptic. Increase the reflection level to get readable error messages."
{ $heading "Choosing the right deploy flags" }
\r
[ t ] [ "hello-ui" shake-and-bake 1300000 small-enough? ] unit-test\r
\r
-[ "staging.math-compiler-threads-ui-strip.image" ] [\r
+[ "staging.math-threads-compiler-ui-strip.image" ] [\r
"hello-ui" deploy-config\r
[ bootstrap-profile staging-image-name file-name ] bind\r
] unit-test\r
\r
[ t ] [ "tetris" shake-and-bake 1500000 small-enough? ] unit-test\r
\r
+[ t ] [ "spheres" shake-and-bake 1500000 small-enough? ] unit-test\r
+\r
+[ t ] [ "terrain" shake-and-bake 1600000 small-enough? ] unit-test\r
+\r
[ t ] [ "bunny" shake-and-bake 2500000 small-enough? ] unit-test\r
\r
os macosx? [\r
{\r
"tools.deploy.test.6"\r
"tools.deploy.test.7"\r
- "tools.deploy.test.8"\r
"tools.deploy.test.9"\r
"tools.deploy.test.10"\r
"tools.deploy.test.11"\r
shake-and-bake\r
run-temp-image\r
] curry unit-test\r
-] each
\ No newline at end of file
+] each\r
+\r
+os windows? os macosx? or [\r
+ [ ] [ "tools.deploy.test.8" shake-and-bake run-temp-image ] unit-test\r
+] when
\ No newline at end of file
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.backend io.streams.c init fry
-namespaces make assocs kernel parser lexer strings.parser vocabs
-sequences words memory kernel.private
-continuations io vocabs.loader system strings sets
-vectors quotations byte-arrays sorting compiler.units
-definitions generic generic.standard tools.deploy.config ;
+USING: arrays accessors io.backend io.streams.c init fry namespaces
+math make assocs kernel parser lexer strings.parser vocabs sequences
+sequences.private words memory kernel.private continuations io
+vocabs.loader system strings sets vectors quotations byte-arrays
+sorting compiler.units definitions generic generic.standard
+generic.single tools.deploy.config combinators classes
+slots.private ;
QUALIFIED: bootstrap.stage2
-QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors
QUALIFIED: continuations
strip-io? [
"io.files" init-hooks get delete-at
"io.backend" init-hooks get delete-at
+ "io.thread" init-hooks get delete-at
] when
strip-dictionary? [
{
- "compiler.units"
+ ! "compiler.units"
"vocabs"
"vocabs.cache"
"source-files.errors"
strip-word-names? [ dup strip-word-names ] when
2drop ;
+: strip-compiler-classes ( -- )
+ strip-dictionary? [
+ "Stripping compiler classes" show
+ { "compiler" "stack-checker" }
+ [ child-vocabs [ words ] map concat [ class? ] filter ] map concat
+ [ dup implementors [ "methods" word-prop delete-at ] with each ] each
+ ] when ;
+
: strip-default-methods ( -- )
strip-debugger? [
"Stripping default methods" show
{
gensym
name>char-hook
- classes:next-method-quot-cache
- classes:class-and-cache
- classes:class-not-cache
- classes:class-or-cache
- classes:class<=-cache
- classes:classes-intersect-cache
- classes:implementors-map
- classes:update-map
+ next-method-quot-cache
+ class-and-cache
+ class-not-cache
+ class-or-cache
+ class<=-cache
+ classes-intersect-cache
+ implementors-map
+ update-map
command-line:main-vocab-hook
compiled-crossref
compiled-generic-crossref
compiler-impl
compiler.errors:compiler-errors
- definition-observers
+ ! definition-observers
interactive-vocabs
lexer-factory
print-use-hook
compiler.errors:compiler-errors
continuations:thread-error-hook
} %
+
+ deploy-ui? get [
+ "ui-error-hook" "ui.gadgets.worlds" lookup ,
+ ] when
] when
deploy-c-types? get [
"c-types" "alien.c-types" lookup ,
] unless
- deploy-ui? get [
- "ui-error-hook" "ui.gadgets.worlds" lookup ,
- ] when
-
"windows-messages" "windows.messages" lookup [ , ] when*
] { } make ;
] [ drop ] if ;
: strip-c-io ( -- )
- deploy-io get 2 = os windows? or [
+ strip-io?
+ deploy-io get 3 = os windows? not and
+ or [
[
c-io-backend forget
"io.streams.c" forget-vocab
+ "io-thread-running?" "io.thread" lookup [
+ global delete-at
+ ] when*
] with-compilation-unit
- ] unless ;
+ ] when ;
: compress ( pred post-process string -- )
"Compressing " prepend show
[ instances dup H{ } clone [ [ ] cache ] curry map ] dip call
become ; inline
-: compress-byte-arrays ( -- )
- [ byte-array? ] [ ] "byte arrays" compress ;
+: compress-object? ( obj -- ? )
+ {
+ { [ dup array? ] [ empty? ] }
+ { [ dup byte-array? ] [ drop t ] }
+ { [ dup string? ] [ drop t ] }
+ { [ dup wrapper? ] [ drop t ] }
+ [ drop f ]
+ } cond ;
+
+: compress-objects ( -- )
+ [ compress-object? ] [ ] "objects" compress ;
: remain-compiled ( old new -- old new )
#! Quotations which were formerly compiled must remain
#! compiled.
2dup [
- 2dup [ compiled>> ] [ compiled>> not ] bi* and
+ 2dup [ quot-compiled? ] [ quot-compiled? not ] bi* and
[ nip jit-compile ] [ 2drop ] if
] 2each ;
[ quotation? ] [ remain-compiled ] "quotations" compress
[ quotation? ] instances [ f >>cached-effect f >>cache-counter drop ] each ;
-: compress-strings ( -- )
- [ string? ] [ ] "strings" compress ;
-
-: compress-wrappers ( -- )
- [ wrapper? ] [ ] "wrappers" compress ;
-
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
t "quiet" set-global
f output-stream set-global ;
+: unsafe-next-method-quot ( method -- quot )
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ next-method 1quotation ;
+
: compute-next-methods ( -- )
[ standard-generic? ] instances [
"methods" word-prop [
- nip
- dup next-method-quot "next-method-quot" set-word-prop
+ nip dup
+ unsafe-next-method-quot
+ "next-method-quot" set-word-prop
] assoc-each
] each
"vocab:tools/deploy/shaker/next-methods.factor" run-file ;
+: (clear-megamorphic-cache) ( i array -- )
+ 2dup 1 slot < [
+ 2dup [ f ] 2dip set-array-nth
+ [ 1 + ] dip (clear-megamorphic-cache)
+ ] [ 2drop ] if ;
+
+: clear-megamorphic-cache ( array -- )
+ [ 0 ] dip (clear-megamorphic-cache) ;
+
+: find-megamorphic-caches ( -- seq )
+ "Finding megamorphic caches" show
+ [ standard-generic? ] instances [ def>> third ] map ;
+
+: clear-megamorphic-caches ( cache -- )
+ "Clearing megamorphic caches" show
+ [ clear-megamorphic-cache ] each ;
+
: strip ( -- )
init-stripper
- strip-default-methods
strip-libc
strip-call
strip-cocoa
compute-next-methods
strip-init-hooks
strip-c-io
+ strip-compiler-classes
+ strip-default-methods
f 5 setenv ! we can't use the Factor debugger or Factor I/O anymore
deploy-vocab get vocab-main deploy-boot-quot
+ find-megamorphic-caches
stripped-word-props
stripped-globals strip-globals
- compress-byte-arrays
+ compress-objects
compress-quotations
- compress-strings
- compress-wrappers
- strip-words ;
+ strip-words
+ clear-megamorphic-caches ;
: deploy-error-handler ( quot -- )
[
strip-debugger? [
"debugger" require
"inspector" require
+ deploy-ui? get [
+ "ui.debugger" require
+ ] when
] unless
deploy-vocab set
deploy-vocab get require
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: cocoa cocoa.messages cocoa.application cocoa.nibs assocs
namespaces kernel kernel.private words compiler.units sequences
-init vocabs ;
+init vocabs memoize accessors ;
IN: tools.deploy.shaker.cocoa
: pool ( obj -- obj' ) \ pool get [ ] cache ;
[ get values compile ] each
] bind
] with-variable
+
+\ make-prepare-send reset-memoized
+\ <selector> reset-memoized
+
+\ (send) def>> second clear-assoc
\ No newline at end of file
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.1" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-unicode? f }
{ deploy-io 2 }
{ deploy-word-props? f }
- { deploy-compiler? f }
{ deploy-threads? f }
{ deploy-word-defs? f }
{ "stop-after-last-window?" t }
{ deploy-math? f }
{ deploy-unicode? f }
{ deploy-threads? f }
- { deploy-compiler? f }
{ deploy-io 2 }
{ deploy-ui? f }
}
{ deploy-io 2 }
{ deploy-ui? f }
{ deploy-name "tools.deploy.test.12" }
- { deploy-compiler? f }
{ deploy-word-defs? f }
{ deploy-threads? f }
}
USING: tools.deploy.config ;
H{
{ deploy-threads? t }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-io 2 }
{ "stop-after-last-window?" t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.2" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-io 3 }
{ deploy-math? t }
{ deploy-math? t }
{ deploy-io 2 }
{ deploy-name "tools.deploy.test.4" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-math? t }
{ deploy-io 3 }
{ deploy-name "tools.deploy.test.5" }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
}
{ deploy-io 1 }
{ deploy-name "tools.deploy.test.6" }
{ deploy-math? t }
- { deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }
{ deploy-io 2 }
{ deploy-math? t }
{ "stop-after-last-window?" t }
- { deploy-compiler? t }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-reflection 1 }
-USING: kernel ;
+USING: calendar game-input threads ui ui.gadgets.worlds kernel
+method-chains system ;
IN: tools.deploy.test.8
-: literal-merge-test-1 ( -- x ) H{ { "lil" "wayne" } } ;
-: literal-merge-test-2 ( -- x ) H{ { "lil" "wayne" } } ;
+TUPLE: my-world < world ;
-: literal-merge-test ( -- )
- literal-merge-test-1
- literal-merge-test-2 eq? t assert= ;
+BEFORE: my-world begin-world drop open-game-input ;
-MAIN: literal-merge-test
+AFTER: my-world end-world drop close-game-input ;
+
+: test-game-input ( -- )
+ [
+ f T{ world-attributes
+ { world-class my-world }
+ { title "Test" }
+ } open-window
+ 1 seconds sleep
+ 0 exit
+ ] with-ui ;
+
+MAIN: test-game-input
\ No newline at end of file
USING: tools.deploy.config ;
H{
- { deploy-name "tools.deploy.test.8" }
{ deploy-c-types? f }
- { deploy-word-props? f }
- { deploy-ui? f }
- { deploy-reflection 1 }
- { deploy-compiler? f }
{ deploy-unicode? f }
- { deploy-io 1 }
{ deploy-word-defs? f }
- { deploy-threads? f }
+ { deploy-name "tools.deploy.test.8" }
{ "stop-after-last-window?" t }
- { deploy-math? f }
+ { deploy-reflection 1 }
+ { deploy-ui? t }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-word-props? f }
+ { deploy-threads? t }
}
{ "stop-after-last-window?" t }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-threads? f }
{ deploy-io 1 }
{ deploy-math? t }
USING: accessors arrays continuations io.directories io.files.info
-io.files.temp io.launcher kernel layouts math sequences system
+io.files.temp io.launcher io.backend kernel layouts math sequences system
tools.deploy.backend tools.deploy.config.editor ;
IN: tools.deploy.test
[ "test.image" temp-file file-info size>> ] [ cell 4 / * ] bi* <= ;
: run-temp-image ( -- )
- vm
- "-i=" "test.image" temp-file append
- 2array
- <process> swap >>command +closed+ >>stdin try-process ;
\ No newline at end of file
+ os macosx?
+ "resource:Factor.app/Contents/MacOS/factor" normalize-path vm ?
+ "-i=" "test.image" temp-file append 2array try-output-process ;
\ No newline at end of file
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
- [ dup name>> file-info file-listing boa ] map
- _ [ sort-by ] when*
- [ _ [ file-spec>string ] with map ] map
+ [ dup name>> link-info file-listing boa ] map
+ _ [ sort-by ] when*
+ [ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
: list-files ( listing-tool -- array )
[ file-systems-info ]
[ [ unparse ] map ] bi prefix simple-table. ;
-: file-systems. ( -- )
+CONSTANT: default-file-systems-spec
{
+device-name+ +available-space+ +free-space+ +used-space+
+total-space+ +percent-used+ +mount-point+
- } print-file-systems ;
+ }
+
+: file-systems. ( -- )
+ default-file-systems-spec print-file-systems ;
{
{ [ os unix? ] [ "tools.files.unix" ] }
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 -- )
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 -- )
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
{ "windowDidResignKey:" "void" { "id" "SEL" "id" }
[
forget-rollover
- 2nip -> object -> contentView window unfocus-world
+ 2nip -> object -> contentView
+ dup -> isInFullScreenMode zero?
+ [ window unfocus-world ]
+ [ drop ] if
]
}
[ 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
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 ;
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
: 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 ( -- )
- class-name-ptr [
- [ [ f UnregisterClass drop ] [ free ] bi ] when* f
- ] change-global
- msg-obj change-global [ [ free ] when* f ] ;
+ class-name-ptr [ [ [ f UnregisterClass drop ] [ free ] bi ] when* f ] change-global
+ msg-obj [ [ free ] when* f ] change-global ;
: get-dc ( world -- )
handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
[ 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
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
--- /dev/null
+! Copyright (C) 2006, 2009 Slava Pestov.\r
+! See http://factorcode.org/license.txt for BSD license.\r
+USING: accessors debugger io kernel namespaces prettyprint\r
+ui.gadgets.panes ui.gadgets.worlds ui ;\r
+IN: ui.debugger\r
+\r
+: <error-pane> ( error -- pane )\r
+ <pane> [ [ print-error ] with-pane ] keep ; inline\r
+\r
+: error-window ( error -- )\r
+ <error-pane> "Error" open-window ;\r
+\r
+[ error-window ] ui-error-hook set-global\r
+\r
+M: world-error error.\r
+ "An error occurred while drawing the world " write\r
+ dup world>> pprint-short "." print\r
+ "This world has been deactivated to prevent cascading errors." print\r
+ error>> error. ;\r
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors definitions hashtables io kernel sequences
-strings words help math models namespaces quotations ui.gadgets
+strings words math models namespaces quotations ui.gadgets
ui.gadgets.borders ui.gadgets.buttons ui.gadgets.buttons.private
ui.gadgets.labels ui.gadgets.menus ui.gadgets.worlds
ui.gadgets.status-bar ui.commands ui.operations ui.gestures ;
HELP: hand-world
{ $var-description "Global variable. The " { $link world } " containing the gadget at the mouse location." } ;
+HELP: grab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " to grab mouse and keyboard input while focused." }
+{ $notes "Normal mouse gestures may not be available while input is grabbed." } ;
+
+HELP: ungrab-input
+{ $values { "gadget" gadget } }
+{ $description "Sets the " { $link world } " containing " { $snippet "gadget" } " not to grab mouse and keyboard input while focused." } ;
+
+{ grab-input ungrab-input } related-words
+
HELP: set-title
{ $values { "string" string } { "world" world } }
{ $description "Sets the title bar of the native window containing the world." }
{ { $snippet "focus" } " - the current owner of the keyboard focus in the world." }
{ { $snippet "focused?" } " - a boolean indicating if the native window containing the world has keyboard focus." }
{ { $snippet "fonts" } " - a hashtable used by the " { $link font-renderer } "." }
+ { { $snippet "grab-input?" } " - if set to " { $link t } ", the world will hide the mouse cursor and disable normal mouse input while focused. Use " { $link grab-input } " and " { $link ungrab-input } " to change this setting." }
{ { $snippet "handle" } " - a backend-specific native handle representing the native window containing the world, or " { $link f } " if the world is not grafted." }
{ { $snippet "window-loc" } " - the on-screen location of the native window containing the world. The co-ordinate system here is backend-specific." }
}
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
-ui.commands ui.pixel-formats destructors literals ;
+ui.pixel-formats destructors literals strings ;
IN: ui.gadgets.worlds
CONSTANT: default-world-pixel-format-attributes
TUPLE: world-attributes
{ world-class initial: world }
grab-input?
- title
+ { title string initial: "Factor Window" }
status
gadgets
{ pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
+: grab-input ( gadget -- )
+ find-world dup grab-input?>>
+ [ drop ] [
+ t >>grab-input?
+ dup focused?>> [ handle>> (grab-input) ] [ drop ] if
+ ] if ;
+
+: ungrab-input ( gadget -- )
+ find-world dup grab-input?>>
+ [
+ f >>grab-input?
+ dup focused?>> [ handle>> (ungrab-input) ] [ drop ] if
+ ] [ drop ] if ;
+
: show-status ( string/f gadget -- )
dup find-world dup [
dup status>> [
: new-world ( class -- world )
vertical swap new-track
t >>root?
- t >>active?
+ f >>active?
{ 0 0 } >>window-loc
f >>grab-input? ;
[ call-next-method ]
[ dup layers>> [ as-big-as-possible ] with each ] bi ;
-M: world focusable-child* gadget-child ;
+M: world focusable-child* children>> [ t ] [ first ] if-empty ;
M: world children-on nip children>> ;
USING: accessors arrays assocs kernel math math.order models
namespaces make sequences words strings system hashtables math.parser
math.vectors classes.tuple classes boxes calendar alarms combinators
-sets columns fry deques ui.gadgets ui.gadgets.private unicode.case
-unicode.categories combinators.short-circuit ;
+sets columns fry deques ui.gadgets ui.gadgets.private ascii
+combinators.short-circuit ;
IN: ui.gestures
GENERIC: handle-gesture ( gesture gadget -- ? )
M: macosx modifiers>string
[
{
- { A+ [ "\u{place-of-interest-sign}" ] }
- { M+ [ "\u{option-key}" ] }
- { S+ [ "\u{upwards-white-arrow}" ] }
- { C+ [ "\u{up-arrowhead}" ] }
+ { A+ [ "\u002318" ] }
+ { M+ [ "\u002325" ] }
+ { S+ [ "\u0021e7" ] }
+ { C+ [ "\u002303" ] }
} case
] map "" join ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions kernel ui.commands
ui.gestures sequences strings math words generic namespaces
-hashtables help.markup quotations assocs fry linked-assocs ;
+hashtables quotations assocs fry linked-assocs ;
IN: ui.operations
SYMBOL: +keyboard+
USING: accessors assocs classes destructors functors kernel
lexer math parser sequences specialized-arrays.int ui.backend
-words.symbol ;
+words ;
IN: ui.pixel-formats
SYMBOLS:
M: object >PFA
drop { } ;
-M: symbol >PFA
+M: word >PFA
TABLE at [ { } ] unless* ;
M: pixel-format-attribute >PFA
dup class TABLE at
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.tables
ui.gadgets.tracks ui.gadgets.scrollers ui.gadgets.panes
ui.gadgets.borders ui.gadgets.status-bar ui.tools.traceback
-ui.tools.inspector ui.tools.browser ;
+ui.tools.inspector ui.tools.browser ui.debugger ;
IN: ui.tools.debugger
TUPLE: debugger < track error restarts restart-hook restart-list continuation ;
t >>selection-required?
t >>single-click? ; inline
-: <error-pane> ( error -- pane )
- <pane> [ [ print-error ] with-pane ] keep ; inline
-
: <error-display> ( debugger -- gadget )
[ <filled-pile> ] dip
[ error>> <error-pane> add-gadget ]
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 ;
[ rethrow ] [ error-continuation get debugger-window ] if
] ui-error-hook set-global
-M: world-error error.
- "An error occurred while drawing the world " write
- dup world>> pprint-short "." print
- "This world has been deactivated to prevent cascading errors." print
- error>> error. ;
-
debugger "gestures" f {
{ T{ button-down } request-focus }
} define-command-map
: advanced-settings ( parent -- parent )
"Advanced:" <label> add-gadget
- deploy-compiler? get "Use optimizing compiler" <checkbox> add-gadget
deploy-math? get "Rational and complex number support" <checkbox> add-gadget
deploy-threads? get "Threading support" <checkbox> add-gadget
deploy-unicode? get "Unicode character literal support" <checkbox> add-gadget
{ { $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 } } }
{ $description "Finds a native window such that the gadget passed to " { $link open-window } " satisfies the quotation, outputting " { $link f } " if no such gadget could be found. The front-most native window is checked first." } ;
HELP: register-window
-{ $values { "world" world } { "handle" "a baackend-specific handle" } }
+{ $values { "world" world } { "handle" "a backend-specific handle" } }
{ $description "Adds a window to the global " { $link windows } " variable." }
{ $notes "This word should only be called by the UI backend. User code can open new windows with " { $link open-window } "." } ;
HELP: unregister-window
-{ $values { "handle" "a baackend-specific handle" } }
+{ $values { "handle" "a backend-specific handle" } }
{ $description "Removes a window from the global " { $link windows } " variable." }
{ $notes "This word should only be called only by the UI backend, and not user code." } ;
[ ?ungrab-input ]
[ focus-path f swap focus-gestures ] bi ;
-: try-to-open-window ( world -- )
+: set-up-window ( world -- )
{
- [ (open-window) ]
[ handle>> select-gl-context ]
- [
- [ begin-world ]
- [ [ handle>> (close-window) ] [ ui-error ] bi* ]
- recover
- ]
+ [ [ title>> ] keep set-title ]
+ [ begin-world ]
[ resize-world ]
+ [ t >>active? drop ]
+ [ request-focus ]
} cleave ;
+: clean-up-broken-window ( world -- )
+ [
+ dup { [ focused?>> ] [ grab-input?>> ] } 1&&
+ [ handle>> (ungrab-input) ] [ drop ] if
+ ] [ handle>> (close-window) ] bi ;
+
M: world graft*
- [ try-to-open-window ]
- [ [ title>> ] keep set-title ]
- [ request-focus ] tri ;
+ [ (open-window) ]
+ [
+ [ set-up-window ]
+ [ [ clean-up-broken-window ] [ ui-error ] bi* ] recover
+ ] bi ;
: reset-world ( world -- )
#! This is used when a window is being closed, but also
: 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* ;
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax alien system ;
IN: unix
! Linux.
{ "char*" "pw_dir" }
{ "char*" "pw_shell" } ;
+! dirent64
C-STRUCT: dirent
- { "__ino_t" "d_ino" }
- { "__off_t" "d_off" }
+ { "ulonglong" "d_ino" }
+ { "longlong" "d_off" }
{ "ushort" "d_reclen" }
{ "uchar" "d_type" }
{ { "char" 256 } "d_name" } ;
+FUNCTION: int open64 ( char* path, int flags, int prot ) ;
+FUNCTION: dirent64* readdir64 ( DIR* dirp ) ;
+FUNCTION: int readdir64_r ( void* dirp, dirent* entry, dirent** result ) ;
+
+M: linux open-file [ open64 ] unix-system-call ;
+
CONSTANT: EPERM 1
CONSTANT: ENOENT 2
CONSTANT: ESRCH 3
-USING: kernel alien.syntax math ;
+USING: kernel alien.syntax math sequences unix
+alien.c-types arrays accessors combinators ;
IN: unix.stat
-! Ubuntu 8.04 32-bit
-
+! stat64
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" "__pad2" }
- { "off_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "ulong" "unused4" }
- { "ulong" "unused5" } ;
+ { "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" } ;
-FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
-FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-: stat ( pathname buf -- int ) [ 3 ] 2dip __xstat ;
-: lstat ( pathname buf -- int ) [ 3 ] 2dip __lxstat ;
+: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ;
+: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ;
{ "gid_t" "st_gid" }
{ "int" "pad0" }
{ "dev_t" "st_rdev" }
- { "off_t" "st_size" }
+ { "off64_t" "st_size" }
{ "blksize_t" "st_blksize" }
- { "blkcnt_t" "st_blocks" }
+ { "blkcnt64_t" "st_blocks" }
{ "timespec" "st_atimespec" }
{ "timespec" "st_mtimespec" }
{ "timespec" "st_ctimespec" }
{ "long" "__unused1" }
{ "long" "__unused2" } ;
-FUNCTION: int __xstat ( int ver, char* pathname, stat* buf ) ;
-FUNCTION: int __lxstat ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
+FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat ;
-: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat ;
+: stat ( pathname buf -- int ) [ 1 ] 2dip __xstat64 ;
+: lstat ( pathname buf -- int ) [ 1 ] 2dip __lxstat64 ;
TYPEDEF: __sword_type ssize_t
TYPEDEF: __s32_type pid_t
TYPEDEF: __slongword_type time_t
+TYPEDEF: __slongword_type __time_t
TYPEDEF: ssize_t __SWORD_TYPE
+TYPEDEF: ulonglong blkcnt64_t
TYPEDEF: ulonglong __fsblkcnt64_t
TYPEDEF: ulonglong __fsfilcnt64_t
+TYPEDEF: ulonglong ino64_t
+TYPEDEF: ulonglong off64_t
FUNCTION: int open ( char* path, int flags, int prot ) ;
-FUNCTION: DIR* opendir ( char* path ) ;
+HOOK: open-file os ( path flags mode -- fd )
+
+M: unix open-file [ open ] unix-system-call ;
-: open-file ( path flags mode -- fd ) [ open ] unix-system-call ;
+FUNCTION: DIR* opendir ( char* path ) ;
C-STRUCT: utimbuf
{ "time_t" "actime" }
FUNCTION: dirent* readdir ( DIR* dirp ) ;
FUNCTION: int readdir_r ( void* dirp, dirent* entry, dirent** result ) ;
-
FUNCTION: ssize_t readlink ( char* path, char* buf, size_t bufsize ) ;
CONSTANT: PATH_MAX 1024
windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces
combinators sequences fry math accessors macros words quotations
libc continuations generalizations splitting locals assocs init
-struct-arrays ;
+struct-arrays memoize ;
IN: windows.dinput.constants
! Some global variables aren't provided by the DirectInput DLL (they're in the
<PRIVATE
+MEMO: c-type* ( name -- c-type ) c-type ;
+MEMO: heap-size* ( c-type -- n ) heap-size ;
+
: (field-spec-of) ( field struct -- field-spec )
- c-type fields>> [ name>> = ] with find nip ;
+ c-type* fields>> [ name>> = ] with find nip ;
: (offsetof) ( field struct -- offset )
[ (field-spec-of) offset>> ] [ drop 0 ] if* ;
: (sizeof) ( field struct -- size )
- [ (field-spec-of) type>> "[" split1 drop heap-size ] [ drop 1 ] if* ;
+ [ (field-spec-of) type>> "[" split1 drop heap-size* ] [ drop 1 ] if* ;
: (flag) ( thing -- integer )
{
[ nip length ] [ malloc-DIOBJECTDATAFORMAT-array ] 2bi
"DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
+: initialize ( symbol quot -- )
+ call swap set-global ; inline
+
: (malloc-guid-symbol) ( symbol guid -- )
'[
_ execute( -- value )
! Copyright (C) 2005, 2006 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax namespaces kernel words
-sequences math math.bitwise math.vectors colors ;
+sequences math math.bitwise math.vectors colors
+io.encodings.utf16n ;
IN: windows.types
TYPEDEF: char CHAR
TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER
TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER
+<< { "char*" utf16n } "wchar_t*" typedef >>
+
TYPEDEF: wchar_t* LPCSTR
TYPEDEF: wchar_t* LPWSTR
TYPEDEF: WCHAR TCHAR
"quotation" "quotations" create {
{ "array" { "array" "arrays" } read-only }
- { "compiled" read-only }
"cached-effect"
"cache-counter"
} define-builtin
{ "reset-inline-cache-stats" "generic.single" (( -- )) }
{ "inline-cache-stats" "generic.single" (( -- stats )) }
{ "optimized?" "words" (( word -- ? )) }
+ { "quot-compiled?" "quotations" (( quot -- ? )) }
} [ [ first3 ] dip swap make-primitive ] each-index
! Bump build number
-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 > ;
[ 10 ] [ -10 abs ] unit-test
[ 10 ] [ 10 abs ] unit-test
-[ 0 ] [ 0 abs ] unit-test
\ No newline at end of file
+[ 0 ] [ 0 abs ] unit-test
+
+! Bug report from Bruno Deferrari
+TUPLE: tuple-a slot ;
+TUPLE: tuple-b < tuple-a ;
+
+PREDICATE: tuple-c < tuple-b slot>> ;
+
+GENERIC: ptest ( tuple -- )
+M: tuple-a ptest drop ;
+IN: classes.predicate.tests USING: kernel ; M: tuple-c ptest drop ;
+
+[ ] [ tuple-b new ptest ] unit-test
[ ] [ "IN: generic.single.tests MATH: xyz ( a b -- c )" eval( -- ) ] unit-test
[ f ] [ "xyz" "generic.single.tests" lookup pic-def>> ] unit-test
-[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
\ No newline at end of file
+[ f ] [ "xyz" "generic.single.tests" lookup "decision-tree" word-prop ] unit-test
+
+! Corner case
+[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
+[ error>> bad-dispatch-position? ]
+must-fail-with
\ No newline at end of file
] 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 ;
[ <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<= ;
: 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 ;
[ <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
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 ;
M: single-combination perform-combination
[
+ H{ } clone predicate-engines set
dup generic-word set
dup build-decision-tree
[ "decision-tree" set-word-prop ]
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? ;
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs splitting alien io.streams.null ;
+io.encodings.utf8 init assocs splitting alien ;
IN: io.backend
SYMBOL: io-backend
HOOK: init-io io-backend ( -- )
-HOOK: (init-stdio) io-backend ( -- stdin stdout stderr ? )
-
-: set-stdio ( input-handle output-handle error-handle -- )
- [ input-stream set-global ]
- [ output-stream set-global ]
- [ error-stream set-global ] tri* ;
-
-: init-stdio ( -- )
- (init-stdio) [
- [ utf8 <decoder> ]
- [ utf8 <encoder> ]
- [ utf8 <encoder> ] tri*
- ] [
- 3drop
- null-reader null-writer null-writer
- ] if set-stdio ;
+HOOK: init-stdio io-backend ( -- )
+
+: set-stdio ( input output error -- )
+ [ utf8 <decoder> input-stream set-global ]
+ [ utf8 <encoder> output-stream set-global ]
+ [ utf8 <encoder> error-stream set-global ] tri* ;
HOOK: io-multiplex io-backend ( us -- )
: stdout-handle ( -- alien ) 12 getenv ;
: stderr-handle ( -- alien ) 61 getenv ;
-: init-c-stdio ( -- stdin stdout stderr )
+: init-c-stdio ( -- )
stdin-handle <c-reader>
stdout-handle <c-writer>
- stderr-handle <c-writer> ;
+ stderr-handle <c-writer>
+ set-stdio ;
-M: c-io-backend (init-stdio) init-c-stdio t ;
+M: c-io-backend init-stdio init-c-stdio ;
M: c-io-backend io-multiplex 60 60 * 1000 * 1000 * or (sleep) ;
+++ /dev/null
-Slava Pestov
+++ /dev/null
-USING: io help.markup help.syntax quotations ;
-IN: io.streams.null
-
-HELP: null-reader
-{ $class-description "Singleton class of null reader streams." } ;
-
-HELP: null-writer
-{ $class-description "Singleton class of null writer streams." } ;
-
-HELP: with-null-reader
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation with " { $link input-stream } " rebound to a " { $link null-reader } " which always produces EOF." } ;
-
-HELP: with-null-writer
-{ $values { "quot" quotation } }
-{ $description "Calls the quotation with " { $link output-stream } " rebound to a " { $link null-writer } " which ignores all output." } ;
-
-ARTICLE: "io.streams.null" "Null streams"
-"The " { $vocab-link "io.streams.null" } " vocabulary implements a pair of streams which are useful for testing. The null reader always yields EOF and the null writer ignores all output. Conceptually, they are similar to " { $snippet "/dev/null" } " on a Unix system."
-$nl
-"Null readers:"
-{ $subsection null-reader }
-{ $subsection with-null-writer }
-"Null writers:"
-{ $subsection null-writer }
-{ $subsection with-null-reader } ;
-
-ABOUT: "io.streams.null"
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2007, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel io destructors io.streams.plain ;
-IN: io.streams.null
-
-SINGLETONS: null-reader null-writer ;
-UNION: null-stream null-reader null-writer ;
-INSTANCE: null-writer plain-writer
-
-M: null-stream dispose drop ;
-
-M: null-reader stream-element-type drop +byte+ ;
-M: null-reader stream-readln drop f ;
-M: null-reader stream-read1 drop f ;
-M: null-reader stream-read-until 2drop f f ;
-M: null-reader stream-read 2drop f ;
-
-M: null-writer stream-element-type drop +byte+ ;
-M: null-writer stream-write1 2drop ;
-M: null-writer stream-write 2drop ;
-M: null-writer stream-flush drop ;
-
-: with-null-reader ( quot -- )
- null-reader swap with-input-stream* ; inline
-
-: with-null-writer ( quot -- )
- null-writer swap with-output-stream* ; inline
+++ /dev/null
-Dummy implementation of stream protocol
[ 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
{ deploy-math? t }
{ deploy-threads? t }
{ deploy-reflection 3 }
- { deploy-compiler? t }
{ deploy-unicode? t }
{ deploy-io 3 }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-ui? f }
{ deploy-io 1 }
- { deploy-compiler? t }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
{ deploy-word-defs? f }
{ deploy-word-props? f }
{ deploy-math? f }
- { deploy-compiler? t }
{ deploy-ui? f }
{ deploy-c-types? f }
{ "stop-after-last-window?" t }
--- /dev/null
+Alec Berryman
--- /dev/null
+USING: help.markup help.syntax kernel math ;
+IN: bloom-filters
+
+HELP: <bloom-filter>
+{ $values { "error-rate" "The desired false positive rate. A " { $link float } " between 0 and 1." }
+ { "number-objects" "The expected number of object in the set. A positive " { $link integer } "." }
+ { "bloom-filter" bloom-filter } }
+{ $description "Creates an empty Bloom filter." }
+{ $errors "Throws a " { $link capacity-error } " when unable to produce a filter meeting the given constraints. Throws a " { $link invalid-error-rate } " or a " { $link invalid-n-objects } " when input is invalid." } ;
+
+
+HELP: bloom-filter-insert
+{ $values { "object" object }
+ { "bloom-filter" bloom-filter } }
+{ $description "Records the item as a member of the filter." }
+{ $side-effects "bloom-filter" } ;
+
+HELP: bloom-filter-member?
+{ $values { "object" object }
+ { "bloom-filter" bloom-filter }
+ { "?" boolean } }
+{ $description "Returns " { $link t } " if the object may be a member of Bloom filter, " { $link f } " otherwise. The false positive rate is configurable; there are no false negatives." } ;
+
+HELP: bloom-filter
+{ $class-description "This is the class for Bloom filters. These provide constant-time insertion and probabilistic membership-testing operations, but do not actually store any elements." } ;
+
+ARTICLE: "bloom-filters" "Bloom filters"
+"This is a library for Bloom filters, sets that provide a constant-time insertion operation and probabilistic membership tests, but do not actually store any elements."
+$nl
+"The accuracy of the membership test is configurable; a Bloom filter will never incorrectly report an item is not a member of the set, but may incorrectly report than an item is a member of the set."
+$nl
+"Bloom filters cannot be resized and do not support removal."
+$nl
+{ $subsection <bloom-filter> }
+{ $subsection bloom-filter-insert }
+{ $subsection bloom-filter-member? } ;
+
+ABOUT: "bloom-filters"
--- /dev/null
+USING: accessors bit-arrays bloom-filters bloom-filters.private kernel layouts
+math random sequences tools.test ;
+IN: bloom-filters.tests
+
+
+[ { 200 5 } ] [ { 100 7 } { 200 5 } smaller-second ] unit-test
+[ { 200 5 } ] [ { 200 5 } { 100 7 } smaller-second ] unit-test
+
+! The sizing information was generated using the subroutine
+! calculate_shortest_filter_length from
+! http://www.perl.com/pub/a/2004/04/08/bloom_filters.html.
+
+! Test bloom-filter creation
+[ 47965 ] [ 7 0.01 5000 bits-to-satisfy-error-rate ] unit-test
+[ 7 47965 ] [ 0.01 5000 size-bloom-filter ] unit-test
+[ 7 ] [ 0.01 5000 <bloom-filter> n-hashes>> ] unit-test
+[ 47965 ] [ 0.01 5000 <bloom-filter> bits>> length ] unit-test
+[ 5000 ] [ 0.01 5000 <bloom-filter> maximum-n-objects>> ] unit-test
+[ 0 ] [ 0.01 5000 <bloom-filter> current-n-objects>> ] unit-test
+
+! Should return the fewest hashes to satisfy the bits requested, not the most.
+[ 32 ] [ 4 0.05 5 bits-to-satisfy-error-rate ] unit-test
+[ 32 ] [ 5 0.05 5 bits-to-satisfy-error-rate ] unit-test
+[ 4 32 ] [ 0.05 5 size-bloom-filter ] unit-test
+
+! This is a lot of bits.
+: oversized-filter-params ( -- error-rate n-objects )
+ 0.00000001 400000000000000 ;
+! [ oversized-filter-params size-bloom-filter ] [ capacity-error? ] must-fail-with
+! [ oversized-filter-params <bloom-filter> ] [ capacity-error? ] must-fail-with
+
+! Other error conditions.
+[ 1.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 20 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 0.0 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ -2 2000 <bloom-filter> ] [ invalid-error-rate? ] must-fail-with
+[ 0.5 0 <bloom-filter> ] [ invalid-n-objects? ] must-fail-with
+[ 0.5 -5 <bloom-filter> ] [ invalid-n-objects? ] must-fail-with
+
+! Should not generate bignum hash codes. Enhanced double hashing may generate a
+! lot of hash codes, and it's better to do this earlier than later.
+[ t ] [ 10000 iota [ hashcodes-from-object [ fixnum? ] both? ] map [ ] all? ] unit-test
+
+[ ?{ t f t f t f } ] [ { 0 2 4 } 6 <bit-array> [ set-indices ] keep ] unit-test
+
+: empty-bloom-filter ( -- bloom-filter )
+ 0.01 2000 <bloom-filter> ;
+
+[ 1 ] [ empty-bloom-filter dup increment-n-objects current-n-objects>> ] unit-test
+
+: basic-insert-test-setup ( -- bloom-filter )
+ 1 empty-bloom-filter [ bloom-filter-insert ] keep ;
+
+! Basic tests that insert does something
+[ t ] [ basic-insert-test-setup bits>> [ ] any? ] unit-test
+[ 1 ] [ basic-insert-test-setup current-n-objects>> ] unit-test
+
+: non-empty-bloom-filter ( -- bloom-filter )
+ 1000 iota
+ empty-bloom-filter
+ [ [ bloom-filter-insert ] curry each ] keep ;
+
+: full-bloom-filter ( -- bloom-filter )
+ 2000 iota
+ empty-bloom-filter
+ [ [ bloom-filter-insert ] curry each ] keep ;
+
+! Should find what we put in there.
+[ t ] [ 2000 iota
+ full-bloom-filter
+ [ bloom-filter-member? ] curry map
+ [ ] all? ] unit-test
+
+! We shouldn't have more than 0.01 false-positive rate.
+[ t ] [ 1000 iota [ drop most-positive-fixnum random 1000 + ] map
+ full-bloom-filter
+ [ bloom-filter-member? ] curry map
+ [ ] filter
+ ! TODO: This should be 10, but the false positive rate is currently very
+ ! high. It shouldn't be much more than this.
+ length 150 <= ] unit-test
--- /dev/null
+! Copyright (C) 2009 Alec Berryman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays bit-arrays fry infix kernel layouts locals math
+math.functions multiline sequences ;
+IN: bloom-filters
+
+FROM: math.ranges => [1,b] [0,b) ;
+FROM: math.intervals => (a,b) interval-contains? ;
+
+/*
+
+TODO:
+
+- The false positive rate is 10x what it should be, based on informal testing.
+ Better object hashes or a better method of generating extra hash codes would
+ help. Another way is to increase the number of bits used.
+
+ - Try something smarter than the bitwise complement for a second hash code.
+
+ - http://spyced.blogspot.com/2009/01/all-you-ever-wanted-to-know-about.html
+ makes a case for http://murmurhash.googlepages.com/ instead of enhanced
+ double-hashing.
+
+ - Be sure to adjust the test that asserts the number of false positives isn't
+ unreasonable.
+
+- Could round bits up to next power of two and use wrap instead of mod. This
+ would cost a lot of bits on 32-bit platforms, though, and limit the bit-array
+ to 8MB.
+
+- Should allow user to specify the hash codes, either as inputs to enhanced
+ double hashing or for direct use.
+
+- Support for serialization.
+
+- Wrappers for combining filters.
+
+- Should we signal an error when inserting past the number of objects the filter
+ is sized for? The filter will continue to work, just not very well.
+
+*/
+
+TUPLE: bloom-filter
+{ n-hashes fixnum read-only }
+{ bits bit-array read-only }
+{ maximum-n-objects fixnum read-only }
+{ current-n-objects fixnum } ;
+
+ERROR: capacity-error ;
+ERROR: invalid-error-rate ;
+ERROR: invalid-n-objects ;
+
+<PRIVATE
+
+! infix doesn't like ^
+: pow ( x y -- z )
+ ^ ; inline
+
+:: bits-to-satisfy-error-rate ( hashes error objects -- size )
+ [infix -(objects * hashes) / log(1 - pow(error, (1/hashes))) infix]
+ ceiling >integer ;
+
+! 100 hashes ought to be enough for anybody.
+: n-hashes-range ( -- range )
+ 100 [1,b] ;
+
+! { n-hashes n-bits }
+: identity-configuration ( -- 2seq )
+ 0 max-array-capacity 2array ;
+
+: smaller-second ( 2seq 2seq -- 2seq )
+ [ [ second ] bi@ <= ] most ;
+
+! If the number of hashes isn't positive, we haven't found anything smaller than the
+! identity configuration.
+: validate-sizes ( 2seq -- )
+ first 0 <= [ capacity-error ] when ;
+
+! The consensus on the tradeoff between increasing the number of bits and
+! increasing the number of hash functions seems to be "go for the smallest
+! number of bits", probably because most implementations just generate one hash
+! value and cheaply mangle it into the number of hashes they need. I have not
+! seen any usage studies from the implementations that made this tradeoff to
+! support it, and I haven't done my own, but we'll go with it anyway.
+!
+: size-bloom-filter ( error-rate number-objects -- number-hashes number-bits )
+ [ n-hashes-range identity-configuration ] 2dip
+ '[ dup [ _ _ bits-to-satisfy-error-rate ]
+ call 2array smaller-second ]
+ reduce
+ dup validate-sizes
+ first2 ;
+
+: validate-n-objects ( n-objects -- )
+ 0 <= [ invalid-n-objects ] when ;
+
+: valid-error-rate-interval ( -- interval )
+ 0 1 (a,b) ;
+
+: validate-error-rate ( error-rate -- )
+ valid-error-rate-interval interval-contains?
+ [ invalid-error-rate ] unless ;
+
+: validate-constraints ( error-rate n-objects -- )
+ validate-n-objects validate-error-rate ;
+
+PRIVATE>
+
+: <bloom-filter> ( error-rate number-objects -- bloom-filter )
+ [ validate-constraints ] 2keep
+ [ size-bloom-filter <bit-array> ] keep
+ 0 ! initially empty
+ bloom-filter boa ;
+
+<PRIVATE
+
+! See "Bloom Filters in Probabilistic Verification" by Peter C. Dillinger and
+! Panagiotis Manolios, section 5.2, "Enhanced Double Hashing":
+! http://www.cc.gatech.edu/~manolios/research/bloom-filters-verification.html
+:: enhanced-double-hash ( index hash0 hash1 -- hash )
+ [infix hash0 + (index * hash1) + ((pow(index, 3) - index) / 6) infix] ;
+
+: enhanced-double-hashes ( hash0 hash1 n -- seq )
+ [0,b)
+ [ '[ _ _ enhanced-double-hash ] ] dip
+ swap map ;
+
+! Make sure it's a fixnum here to speed up double-hashing.
+: hashcodes-from-hashcode ( n -- n n )
+ dup most-positive-fixnum >fixnum bitxor ;
+
+: hashcodes-from-object ( obj -- n n )
+ hashcode abs hashcodes-from-hashcode ;
+
+: set-indices ( indices bit-array -- )
+ [ [ drop t ] change-nth ] curry each ;
+
+: increment-n-objects ( bloom-filter -- )
+ [ 1 + ] change-current-n-objects drop ;
+
+: n-hashes-and-length ( bloom-filter -- n-hashes length )
+ [ n-hashes>> ] [ bits>> length ] bi ;
+
+: relevant-indices ( value bloom-filter -- indices )
+ [ hashcodes-from-object ] [ n-hashes-and-length ] bi*
+ [ enhanced-double-hashes ] dip '[ _ mod ] map ;
+
+PRIVATE>
+
+: bloom-filter-insert ( object bloom-filter -- )
+ [ increment-n-objects ]
+ [ relevant-indices ]
+ [ bits>> set-indices ]
+ tri ;
+
+: bloom-filter-member? ( object bloom-filter -- ? )
+ [ relevant-indices ] keep
+ bits>> nths [ ] all? ;
read-longlong
read-int32 oid boa ;
-M: bson-binary-custom element-binary-read ( size type -- dbref )
- 2drop
- read-cstring
- read-cstring objref boa ;
-
M: bson-binary-bytes element-binary-read ( size type -- bytes )
drop read ;
-M: bson-binary-function element-binary-read ( size type -- quot )
+M: bson-binary-custom element-binary-read ( size type -- quot )
drop read bytes>object ;
PRIVATE>
+USE: tools.continuations
+
: stream>assoc ( exemplar -- assoc bytes-read )
<state> dup state
[ read-int32 >>size read-elements ] with-variable
M: f bson-type? ( boolean -- type ) drop T_Boolean ;
M: real bson-type? ( real -- type ) drop T_Double ;
-M: word bson-type? ( word -- type ) drop T_String ;
M: tuple bson-type? ( tuple -- type ) drop T_Object ;
M: sequence bson-type? ( seq -- type ) drop T_Array ;
M: string bson-type? ( string -- type ) drop T_String ;
M: oid bson-type? ( word -- type ) drop T_OID ;
M: objref bson-type? ( objref -- type ) drop T_Binary ;
+M: word bson-type? ( word -- type ) drop T_Binary ;
M: quotation bson-type? ( quotation -- type ) drop T_Binary ;
M: byte-array bson-type? ( byte-array -- type ) drop T_Binary ;
T_Binary_Bytes write-byte
write ;
-M: quotation bson-write ( quotation -- )
- object>bytes [ length write-int32 ] keep
- T_Binary_Function write-byte
- write ;
-
M: oid bson-write ( oid -- )
[ a>> write-longlong ] [ b>> write-int32 ] bi ;
-
-M: objref bson-write ( objref -- )
- [ binary ] dip
- '[ _
- [ ns>> write-cstring ]
- [ objid>> write-cstring ] bi ] with-byte-writer
- [ length write-int32 ] keep
- T_Binary_Custom write-byte write ;
M: mdbregexp bson-write ( regexp -- )
[ regexp>> write-cstring ]
[ over skip-field? [ 2drop ] [ write-pair ] if ] assoc-each
write-eoo ] with-length-prefix ;
-M: word bson-write name>> bson-write ;
+: (serialize-code) ( code -- )
+ object>bytes [ length write-int32 ] keep
+ T_Binary_Custom write-byte
+ write ;
+
+M: quotation bson-write ( quotation -- )
+ (serialize-code) ;
+
+M: word bson-write ( word -- )
+ (serialize-code) ;
PRIVATE>
{ deploy-io 3 }
{ deploy-word-defs? f }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-c-types? f }
{ deploy-name "Bunny" }
{ deploy-word-props? f }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
{ deploy-unicode? f }
{ deploy-c-types? f }
{ deploy-word-defs? f }
- { deploy-compiler? t }
{ deploy-io 2 }
{ deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-math? t }
{ deploy-name "drills" }
{ deploy-ui? t }
- { deploy-compiler? t }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-c-types? f }
+++ /dev/null
-USING: windows.dinput windows.dinput.constants parser
-alien.c-types windows.ole32 namespaces assocs kernel arrays
-vectors windows.kernel32 windows.com windows.dinput shuffle
-windows.user32 windows.messages sequences combinators locals
-math.rectangles accessors math alien alien.strings
-io.encodings.utf16 io.encodings.utf16n continuations
-byte-arrays game-input.dinput.keys-array game-input
-ui.backend.windows windows.errors struct-arrays
-math.bitwise ;
-IN: game-input.dinput
-
-CONSTANT: MOUSE-BUFFER-SIZE 16
-
-SINGLETON: dinput-game-input-backend
-
-dinput-game-input-backend game-input-backend set-global
-
-SYMBOLS: +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+
- +mouse-device+ +mouse-state+ +mouse-buffer+ ;
-
-: create-dinput ( -- )
- f GetModuleHandle DIRECTINPUT_VERSION IDirectInput8W-iid
- f <void*> [ f DirectInput8Create ole32-error ] keep *void*
- +dinput+ set-global ;
-
-: delete-dinput ( -- )
- +dinput+ [ com-release f ] change-global ;
-
-: device-for-guid ( guid -- device )
- +dinput+ get swap f <void*>
- [ f IDirectInput8W::CreateDevice ole32-error ] keep *void* ;
-
-: set-coop-level ( device -- )
- +device-change-window+ get DISCL_BACKGROUND DISCL_NONEXCLUSIVE bitor
- IDirectInputDevice8W::SetCooperativeLevel ole32-error ;
-
-: set-data-format ( device format-symbol -- )
- get IDirectInputDevice8W::SetDataFormat ole32-error ;
-
-: <buffer-size-diprop> ( size -- DIPROPDWORD )
- "DIPROPDWORD" <c-object>
- "DIPROPDWORD" heap-size over set-DIPROPHEADER-dwSize
- "DIPROPHEADER" heap-size over set-DIPROPHEADER-dwHeaderSize
- 0 over set-DIPROPHEADER-dwObj
- DIPH_DEVICE over set-DIPROPHEADER-dwHow
- swap over set-DIPROPDWORD-dwData ;
-
-: set-buffer-size ( device size -- )
- DIPROP_BUFFERSIZE swap <buffer-size-diprop>
- IDirectInputDevice8W::SetProperty ole32-error ;
-
-: configure-keyboard ( keyboard -- )
- [ c_dfDIKeyboard_HID set-data-format ] [ set-coop-level ] bi ;
-: configure-mouse ( mouse -- )
- [ c_dfDIMouse2 set-data-format ]
- [ MOUSE-BUFFER-SIZE set-buffer-size ]
- [ set-coop-level ] tri ;
-: configure-controller ( controller -- )
- [ c_dfDIJoystick2 set-data-format ] [ set-coop-level ] bi ;
-
-: find-keyboard ( -- )
- GUID_SysKeyboard device-for-guid
- [ configure-keyboard ]
- [ +keyboard-device+ set-global ] bi
- 256 <byte-array> <keys-array> keyboard-state boa
- +keyboard-state+ set-global ;
-
-: find-mouse ( -- )
- GUID_SysMouse device-for-guid
- [ configure-mouse ]
- [ +mouse-device+ set-global ] bi
- 0 0 0 0 8 f <array> mouse-state boa
- +mouse-state+ set-global
- MOUSE-BUFFER-SIZE "DIDEVICEOBJECTDATA" <c-array>
- +mouse-buffer+ set-global ;
-
-: device-info ( device -- DIDEVICEIMAGEINFOW )
- "DIDEVICEINSTANCEW" <c-object>
- "DIDEVICEINSTANCEW" heap-size over set-DIDEVICEINSTANCEW-dwSize
- [ IDirectInputDevice8W::GetDeviceInfo ole32-error ] keep ;
-: device-caps ( device -- DIDEVCAPS )
- "DIDEVCAPS" <c-object>
- "DIDEVCAPS" heap-size over set-DIDEVCAPS-dwSize
- [ IDirectInputDevice8W::GetCapabilities ole32-error ] keep ;
-
-: <guid> ( memory -- byte-array )
- "GUID" heap-size memory>byte-array ;
-
-: device-guid ( device -- guid )
- device-info DIDEVICEINSTANCEW-guidInstance <guid> ;
-
-: device-attached? ( device -- ? )
- +dinput+ get swap device-guid
- IDirectInput8W::GetDeviceStatus S_OK = ;
-
-: find-device-axes-callback ( -- alien )
- [ ! ( lpddoi pvRef -- BOOL )
- +controller-devices+ get at
- swap DIDEVICEOBJECTINSTANCEW-guidType <guid> {
- { [ dup GUID_XAxis = ] [ drop 0.0 >>x ] }
- { [ dup GUID_YAxis = ] [ drop 0.0 >>y ] }
- { [ dup GUID_ZAxis = ] [ drop 0.0 >>z ] }
- { [ dup GUID_RxAxis = ] [ drop 0.0 >>rx ] }
- { [ dup GUID_RyAxis = ] [ drop 0.0 >>ry ] }
- { [ dup GUID_RzAxis = ] [ drop 0.0 >>rz ] }
- { [ dup GUID_Slider = ] [ drop 0.0 >>slider ] }
- [ drop ]
- } cond drop
- DIENUM_CONTINUE
- ] LPDIENUMDEVICEOBJECTSCALLBACKW ;
-
-: find-device-axes ( device controller-state -- controller-state )
- swap [ +controller-devices+ get set-at ] 2keep
- find-device-axes-callback over DIDFT_AXIS
- IDirectInputDevice8W::EnumObjects ole32-error ;
-
-: controller-state-template ( device -- controller-state )
- controller-state new
- over device-caps
- [ DIDEVCAPS-dwButtons f <array> >>buttons ]
- [ DIDEVCAPS-dwPOVs zero? f pov-neutral ? >>pov ] bi
- find-device-axes ;
-
-: device-known? ( guid -- ? )
- +controller-guids+ get key? ; inline
-
-: (add-controller) ( guid -- )
- device-for-guid {
- [ configure-controller ]
- [ controller-state-template ]
- [ dup device-guid +controller-guids+ get set-at ]
- [ +controller-devices+ get set-at ]
- } cleave ;
-
-: add-controller ( guid -- )
- dup <guid> device-known? [ drop ] [ (add-controller) ] if ;
-
-: remove-controller ( device -- )
- [ +controller-devices+ get delete-at ]
- [ device-guid +controller-guids+ get delete-at ]
- [ com-release ] tri ;
-
-: find-controller-callback ( -- alien )
- [ ! ( lpddi pvRef -- BOOL )
- drop DIDEVICEINSTANCEW-guidInstance add-controller
- DIENUM_CONTINUE
- ] LPDIENUMDEVICESCALLBACKW ;
-
-: find-controllers ( -- )
- +dinput+ get DI8DEVCLASS_GAMECTRL find-controller-callback
- f DIEDFL_ATTACHEDONLY IDirectInput8W::EnumDevices ole32-error ;
-
-: set-up-controllers ( -- )
- 4 <vector> +controller-devices+ set-global
- 4 <vector> +controller-guids+ set-global
- find-controllers ;
-
-: find-and-remove-detached-devices ( -- )
- +controller-devices+ get keys
- [ device-attached? not ] filter
- [ remove-controller ] each ;
-
-: device-interface? ( dbt-broadcast-hdr -- ? )
- DEV_BROADCAST_HDR-dbch_devicetype DBT_DEVTYP_DEVICEINTERFACE = ;
-
-: device-arrived ( dbt-broadcast-hdr -- )
- device-interface? [ find-controllers ] when ;
-
-: device-removed ( dbt-broadcast-hdr -- )
- device-interface? [ find-and-remove-detached-devices ] when ;
-
-: handle-wm-devicechange ( hWnd uMsg wParam lParam -- )
- [ 2drop ] 2dip swap {
- { [ dup DBT_DEVICEARRIVAL = ] [ drop <alien> device-arrived ] }
- { [ dup DBT_DEVICEREMOVECOMPLETE = ] [ drop <alien> device-removed ] }
- [ 2drop ]
- } cond ;
-
-TUPLE: window-rect < rect window-loc ;
-: <zero-window-rect> ( -- window-rect )
- window-rect new
- { 0 0 } >>window-loc
- { 0 0 } >>loc
- { 0 0 } >>dim ;
-
-: (device-notification-filter) ( -- DEV_BROADCAST_DEVICEW )
- "DEV_BROADCAST_DEVICEW" <c-object>
- "DEV_BROADCAST_DEVICEW" heap-size over set-DEV_BROADCAST_DEVICEW-dbcc_size
- DBT_DEVTYP_DEVICEINTERFACE over set-DEV_BROADCAST_DEVICEW-dbcc_devicetype ;
-
-: create-device-change-window ( -- )
- <zero-window-rect> create-window
- [
- (device-notification-filter)
- DEVICE_NOTIFY_WINDOW_HANDLE DEVICE_NOTIFY_ALL_INTERFACE_CLASSES bitor
- RegisterDeviceNotification
- +device-change-handle+ set-global
- ]
- [ +device-change-window+ set-global ] bi ;
-
-: close-device-change-window ( -- )
- +device-change-handle+ [ UnregisterDeviceNotification drop f ] change-global
- +device-change-window+ [ DestroyWindow win32-error=0/f f ] change-global ;
-
-: add-wm-devicechange ( -- )
- [ 4dup handle-wm-devicechange DefWindowProc ]
- WM_DEVICECHANGE add-wm-handler ;
-
-: remove-wm-devicechange ( -- )
- WM_DEVICECHANGE wm-handlers get-global delete-at ;
-
-: release-controllers ( -- )
- +controller-devices+ [ [ drop com-release ] assoc-each f ] change-global
- f +controller-guids+ set-global ;
-
-: release-keyboard ( -- )
- +keyboard-device+ [ com-release f ] change-global
- f +keyboard-state+ set-global ;
-
-: release-mouse ( -- )
- +mouse-device+ [ com-release f ] change-global
- f +mouse-state+ set-global ;
-
-M: dinput-game-input-backend (open-game-input)
- create-dinput
- create-device-change-window
- find-keyboard
- find-mouse
- set-up-controllers
- add-wm-devicechange ;
-
-M: dinput-game-input-backend (close-game-input)
- remove-wm-devicechange
- release-controllers
- release-mouse
- release-keyboard
- close-device-change-window
- delete-dinput ;
-
-M: dinput-game-input-backend (reset-game-input)
- {
- +dinput+ +keyboard-device+ +keyboard-state+
- +controller-devices+ +controller-guids+
- +device-change-window+ +device-change-handle+
- } [ f swap set-global ] each ;
-
-M: dinput-game-input-backend get-controllers
- +controller-devices+ get
- [ drop controller boa ] { } assoc>map ;
-
-M: dinput-game-input-backend product-string
- handle>> device-info DIDEVICEINSTANCEW-tszProductName
- utf16n alien>string ;
-
-M: dinput-game-input-backend product-id
- handle>> device-info DIDEVICEINSTANCEW-guidProduct <guid> ;
-M: dinput-game-input-backend instance-id
- handle>> device-guid ;
-
-:: with-acquisition ( device acquired-quot succeeded-quot failed-quot -- result/f )
- device IDirectInputDevice8W::Acquire succeeded? [
- device acquired-quot call
- succeeded-quot call
- ] failed-quot if ; inline
-
-CONSTANT: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- }
-
-: >axis ( long -- float )
- 32767 - 32767.0 /f ;
-: >slider ( long -- float )
- 65535.0 /f ;
-: >pov ( long -- symbol )
- dup HEX: FFFF bitand HEX: FFFF =
- [ drop pov-neutral ]
- [ 2750 + 4500 /i pov-values nth ] if ;
-: >buttons ( alien length -- array )
- memory>byte-array <keys-array> ;
-
-: (fill-if) ( controller-state DIJOYSTATE2 ? quot -- )
- [ drop ] compose [ 2drop ] if ; inline
-
-: fill-controller-state ( controller-state DIJOYSTATE2 -- controller-state )
- {
- [ over x>> [ DIJOYSTATE2-lX >axis >>x ] (fill-if) ]
- [ over y>> [ DIJOYSTATE2-lY >axis >>y ] (fill-if) ]
- [ over z>> [ DIJOYSTATE2-lZ >axis >>z ] (fill-if) ]
- [ over rx>> [ DIJOYSTATE2-lRx >axis >>rx ] (fill-if) ]
- [ over ry>> [ DIJOYSTATE2-lRy >axis >>ry ] (fill-if) ]
- [ over rz>> [ DIJOYSTATE2-lRz >axis >>rz ] (fill-if) ]
- [ over slider>> [ DIJOYSTATE2-rglSlider *long >slider >>slider ] (fill-if) ]
- [ over pov>> [ DIJOYSTATE2-rgdwPOV *uint >pov >>pov ] (fill-if) ]
- [ DIJOYSTATE2-rgbButtons over buttons>> length >buttons >>buttons ]
- } 2cleave ;
-
-: read-device-buffer ( device buffer count -- buffer count' )
- [ "DIDEVICEOBJECTDATA" heap-size ] 2dip <uint>
- [ 0 IDirectInputDevice8W::GetDeviceData ole32-error ] 2keep *uint ;
-
-: (fill-mouse-state) ( state DIDEVICEOBJECTDATA -- state )
- [ DIDEVICEOBJECTDATA-dwData 32 >signed ] [ DIDEVICEOBJECTDATA-dwOfs ] bi {
- { DIMOFS_X [ [ + ] curry change-dx ] }
- { DIMOFS_Y [ [ + ] curry change-dy ] }
- { DIMOFS_Z [ [ + ] curry change-scroll-dy ] }
- [ [ c-bool> ] [ DIMOFS_BUTTON0 - ] bi* rot [ buttons>> set-nth ] keep ]
- } case ;
-
-: fill-mouse-state ( buffer count -- state )
- [ +mouse-state+ get ] 2dip swap
- [ "DIDEVICEOBJECTDATA" byte-array>struct-array nth (fill-mouse-state) ] curry each ;
-
-: get-device-state ( device byte-array -- )
- [ dup IDirectInputDevice8W::Poll ole32-error ] dip
- [ length ] keep
- IDirectInputDevice8W::GetDeviceState ole32-error ;
-
-: (read-controller) ( handle template -- state )
- swap [ "DIJOYSTATE2" heap-size <byte-array> [ get-device-state ] keep ]
- [ fill-controller-state ] [ drop f ] with-acquisition ;
-
-M: dinput-game-input-backend read-controller
- handle>> dup +controller-devices+ get at
- [ (read-controller) ] [ drop f ] if* ;
-
-M: dinput-game-input-backend calibrate-controller
- handle>> f 0 IDirectInputDevice8W::RunControlPanel ole32-error ;
-
-M: dinput-game-input-backend read-keyboard
- +keyboard-device+ get
- [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
- [ ] [ f ] with-acquisition ;
-
-M: dinput-game-input-backend read-mouse
- +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
- [ fill-mouse-state ] [ f ] with-acquisition ;
-
-M: dinput-game-input-backend reset-mouse
- +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
- [ 2drop ] [ ] with-acquisition
- +mouse-state+ get
- 0 >>dx
- 0 >>dy
- 0 >>scroll-dx
- 0 >>scroll-dy
- drop ;
+++ /dev/null
-USING: sequences sequences.private math alien.c-types
-accessors ;
-IN: game-input.dinput.keys-array
-
-TUPLE: keys-array underlying ;
-C: <keys-array> keys-array
-
-: >key ( byte -- ? )
- HEX: 80 bitand c-bool> ;
-
-M: keys-array length underlying>> length ;
-M: keys-array nth-unsafe underlying>> nth-unsafe >key ;
-
-INSTANCE: keys-array sequence
-
+++ /dev/null
-DirectInput backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-USING: help.markup help.syntax kernel ui.gestures quotations
-sequences strings math ;
-IN: game-input
-
-ARTICLE: "game-input" "Game controller input"
-"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
-"The game input interface must be initialized before being used:"
-{ $subsection open-game-input }
-{ $subsection close-game-input }
-{ $subsection with-game-input }
-"Once the game input interface is open, connected controller devices can be enumerated:"
-{ $subsection get-controllers }
-{ $subsection find-controller-products }
-{ $subsection find-controller-instance }
-"These " { $link controller } " objects can be queried of their identity:"
-{ $subsection product-string }
-{ $subsection product-id }
-{ $subsection instance-id }
-"A hook is provided for invoking the system calibration tool:"
-{ $subsection calibrate-controller }
-"The current state of a controller, the keyboard, and the mouse can be read:"
-{ $subsection read-controller }
-{ $subsection read-keyboard }
-{ $subsection read-mouse }
-{ $subsection controller-state }
-{ $subsection keyboard-state }
-{ $subsection mouse-state } ;
-
-HELP: open-game-input
-{ $description "Initializes the game input interface. An exception will be thrown if the initialization fails. Calls to open-game-input are reference counted; each call to open-game-input needs a corresponding call to close-game-input to close the game input interface." } ;
-
-HELP: close-game-input
-{ $description "Closes the game input interface, releasing any allocated resources. Once this word is called, any remaining " { $link controller } " objects are invalid." } ;
-
-HELP: game-input-opened?
-{ $values { "?" "a boolean" } }
-{ $description "Returns true if the game input interface is open, false otherwise." } ;
-
-HELP: with-game-input
-{ $values { "quot" quotation } }
-{ $description "Initializes the game input interface for the dynamic extent of " { $snippet "quotation" } "." } ;
-
-{ open-game-input close-game-input with-game-input game-input-opened? } related-words
-
-HELP: get-controllers
-{ $values { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
-{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers. The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "get-controllers" } "." } ;
-
-HELP: find-controller-products
-{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "sequence" "A " { $link sequence } " of " { $link controller } "s" } }
-{ $description "Returns a " { $link sequence } " of " { $link controller } " objects representing the currently connected game controllers with the given " { $link product-id } ". The order of the controller objects in the sequence is not significant or guaranteed to be stable between calls to " { $snippet "find-controller-products" } "." } ;
-
-HELP: find-controller-instance
-{ $values { "product-id" "A product ID as returned by " { $link product-id } } { "instance-id" "An instance ID as returned by " { $link instance-id } "." } { "controller/f" "A " { $link controller } " object, or " { $link f } } }
-{ $description "Returns the " { $link controller } " instance identified by " { $snippet "product-id" } " and " { $snippet "instance-id" } ". If the identified device is not currently attached, " { $link f } " is returned." } ;
-
-HELP: controller
-{ $class-description "Objects of this class represent game controller devices such as joysticks and gamepads. They should be treated as opaque by client code." } ;
-
-HELP: product-string
-{ $values { "controller" controller } { "string" string } }
-{ $description "Returns a human-readable string describing the game controller device represented by " { $snippet "controller" } ". This string is not necessarily unique to the product or instance; to uniquely identify the device, see " { $link product-id } " and " { $link instance-id } "." } ;
-
-HELP: product-id
-{ $values { "controller" controller } { "id" "A unique identifier" } }
-{ $description "Returns an identifier uniquely representing the kind of game controller device represented by " { $snippet "controller" } ". This identifier will be the same for devices of the same make and manufacturer. The type of the identifier value is platform-specific, but equivalent " { $snippet "product-id" } "s are guaranteed to be testable with the " { $link = } " word. The identifier can be used to find devices of the same kind with the " { $link find-controller-products } " word." } ;
-
-HELP: instance-id
-{ $values { "controller" controller } { "id" "A unique identifier" } }
-{ $description "Returns an identifier uniquely representing the game controller device represented by " { $snippet "controller" } ". This identifier paired with the device's " { $link product-id } " provides a unique identifier for a particular device that persists between reboots (but not necessarily between computers). This unique identifier can be used to find the same device again with the " { $snippet "find-controller-instance" } " word. Depending on the platform, the instance-id may change if the device is plugged into a different port. The type of the identifier value is platform-specific, but equivalent " { $snippet "instance-id" } "s are guaranteed to be testable with the " { $link = } " word." } ;
-
-{ product-string product-id instance-id find-controller-products find-controller-instance } related-words
-
-HELP: calibrate-controller
-{ $values { "controller" controller } }
-{ $description "Invokes the operating system's calibration tool for " { $snippet "controller" } ". If the operating system does not have a calibration tool, this word does nothing." } ;
-
-HELP: read-controller
-{ $values { "controller" controller } { "controller-state" controller-state } }
-{ $description "Reads the current state of " { $snippet "controller" } ". See the documentation for the " { $link controller-state } " class for details of the returned value's format. If the device is no longer available, " { $link f } " is returned." }
-{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "controller-state" } " object next time " { $snippet "read-controller" } " is called on the same controller. You should " { $link clone } " any values from the returned tuple you need to preserve." } ;
-
-{ controller-state controller read-controller } related-words
-
-HELP: read-keyboard
-{ $values { "keyboard-state" keyboard-state } }
-{ $description "Reads the current raw state of the keyboard. See the documentation for the " { $link keyboard-state } " class for details on the returned value's format." }
-{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "keyboard-state" } " object next time " { $snippet "read-keyboard" } " is called. You should " { $link clone } " any values from the returned tuple you need to preserve."
-$nl "The keyboard state returned by this word is unprocessed by any keymaps, modifier keys, key repeat settings, or other operating environment postprocessing. Because of this, " { $snippet "read-keyboard" } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
-
-HELP: read-mouse
-{ $values { "mouse-state" mouse-state } }
-{ $description "Reads the current mouse state relative to either when the game input interface was opened with " { $link open-game-input } " or when the mouse state was reset with " { $link reset-mouse } "." }
-{ $warning "For efficiency, the implementation may reuse the returned " { $snippet "mouse-state" } " object for future " { $snippet "read-mouse" } " or " { $snippet "reset-mouse" } " calls. You should " { $link clone } " the " { $snippet "mouse-state" } " object if you need to preserve it." } ;
-
-HELP: reset-mouse
-{ $description "Resets the mouse state. Future " { $link read-mouse } " values will be relative to the time this word is called." } ;
-
-HELP: controller-state
-{ $class-description "The " { $link read-controller } " word returns objects of this class. " { $snippet "controller-state" } " objects have the following slots:"
-{ $list
- { { $snippet "x" } " contains the position of the device's X axis." }
- { { $snippet "y" } " contains the position of the device's Y axis." }
- { { $snippet "z" } " contains the position of the device's Z axis, if any." }
- { { $snippet "rx" } " contains the rotational position of the device's X axis, if available." }
- { { $snippet "ry" } " contains the rotational position of the device's Y axis, if available." }
- { { $snippet "rz" } " contains the rotational position of the device's Z axis, if available." }
- { { $snippet "slider" } " contains the position of the device's throttle slider, if any." }
- { { $snippet "pov" } " contains the state of the device's POV hat, if any." }
- { { $snippet "buttons" } " contains a sequence of values indicating the state of every button on the device." }
-}
-"The values are formatted as follows:"
-{ $list
- { "For the axis slots (" { $snippet "x" } ", " { $snippet "y" } ", " { $snippet "z" } ", " { $snippet "rx" } ", " { $snippet "ry" } ", " { $snippet "rz" } "), a " { $link float } " value between -1.0 and 1.0 is returned." }
- { "For the " { $snippet "slider" } " slot, a value between 0.0 and 1.0 is returned." }
- { "For the " { $snippet "pov" } " slot, one of the following symbols is returned:" { $list
- { { $link pov-neutral } }
- { { $link pov-up } }
- { { $link pov-up-right } }
- { { $link pov-right } }
- { { $link pov-down-right } }
- { { $link pov-down } }
- { { $link pov-down-left } }
- { { $link pov-left } }
- { { $link pov-up-left } }
- } }
- { "For each element of the " { $snippet "buttons" } " array, " { $link f } " indicates that the corresponding button is released. If the button is pressed, a value between 0.0 and 1.0 is returned indicating the pressure on the button (or simply 1.0 if the device's buttons are on/off only)." }
- { "A value of " { $link f } " in any slot (besides the elements of " { $snippet "buttons" } ") indicates that the corresponding element is not present on the device." } } } ;
-
-HELP: keyboard-state
-{ $class-description "The " { $link read-keyboard } " word returns objects of this class. The " { $snippet "keys" } " slot of a " { $snippet "keyboard-state" } " object contains a " { $link sequence } " of 256 members representing the state of the keys on the keyboard. Each element is a boolean value indicating whether the corresponding key is pressed. The sequence is indexed by scancode as defined under usage page 7 of the USB HID standard. Named scancode constants are provided in the " { $vocab-link "game-input.scancodes" } " vocabulary." }
-{ $warning "The scancodes used to index " { $snippet "keyboard-state" } " objects correspond to physical key positions on the keyboard--they are unaffected by keymaps, modifier keys, or other operating environment postprocessing. The face value of the constants in " { $vocab-link "game-input.scancodes" } " do not necessarily correspond to what the user expects the key to type. Because of this, " { $link read-keyboard } " should not be used for text entry purposes. The Factor UI's standard gesture mechanism should be used in cases where the logical meaning of keypresses is needed; see " { $link "keyboard-gestures" } "." } ;
-
-HELP: mouse-state
-{ $class-description "The " { $link read-mouse } " word returns objects of this class. " { $snippet "mouse-state" } " objects have the following slots:"
-{ $list
- { { $snippet "dx" } " contains the mouse's X axis movement." }
- { { $snippet "dy" } " contains the mouse's Y axis movement." }
- { { $snippet "scroll-dx" } " contains the scroller's X axis movement." }
- { { $snippet "scroll-dy" } " contains the scroller's Y axis movement." }
- { { $snippet "buttons" } " contains a sequence of boolean values indicate the state of the mouse's buttons." }
-}
-"Mouse movement is recorded relative to when the game input interface was opened with " { $link open-game-input } " or the mouse state is reset with " { $link reset-mouse } "."
-} ;
-
-
-{ keyboard-state read-keyboard } related-words
-
-ABOUT: "game-input"
+++ /dev/null
-IN: game-input.tests
-USING: ui game-input tools.test kernel system threads
-combinators.short-circuit calendar ;
-
-{
- [ os windows? ui-running? and ]
- [ os macosx? ]
-} 0|| [
- [ ] [ open-game-input ] unit-test
- [ ] [ 1 seconds sleep ] unit-test
- [ ] [ close-game-input ] unit-test
-] when
\ No newline at end of file
+++ /dev/null
-USING: arrays accessors continuations kernel math system
-sequences namespaces init vocabs vocabs.loader combinators ;
-IN: game-input
-
-SYMBOLS: game-input-backend game-input-opened ;
-
-game-input-opened [ 0 ] initialize
-
-HOOK: (open-game-input) game-input-backend ( -- )
-HOOK: (close-game-input) game-input-backend ( -- )
-HOOK: (reset-game-input) game-input-backend ( -- )
-
-HOOK: get-controllers game-input-backend ( -- sequence )
-
-HOOK: product-string game-input-backend ( controller -- string )
-HOOK: product-id game-input-backend ( controller -- id )
-HOOK: instance-id game-input-backend ( controller -- id )
-
-HOOK: read-controller game-input-backend ( controller -- controller-state )
-HOOK: calibrate-controller game-input-backend ( controller -- )
-
-HOOK: read-keyboard game-input-backend ( -- keyboard-state )
-
-HOOK: read-mouse game-input-backend ( -- mouse-state )
-
-HOOK: reset-mouse game-input-backend ( -- )
-
-: game-input-opened? ( -- ? )
- game-input-opened get zero? not ;
-
-<PRIVATE
-
-M: f (reset-game-input) ;
-
-: reset-game-input ( -- )
- (reset-game-input) ;
-
-[ reset-game-input ] "game-input" add-init-hook
-
-PRIVATE>
-
-ERROR: game-input-not-open ;
-
-: open-game-input ( -- )
- game-input-opened? [
- (open-game-input)
- ] unless
- game-input-opened [ 1+ ] change-global
- reset-mouse ;
-: close-game-input ( -- )
- game-input-opened [
- dup zero? [ game-input-not-open ] when
- 1-
- ] change-global
- game-input-opened? [
- (close-game-input)
- reset-game-input
- ] unless ;
-
-: with-game-input ( quot -- )
- open-game-input [ close-game-input ] [ ] cleanup ; inline
-
-TUPLE: controller handle ;
-TUPLE: controller-state x y z rx ry rz slider pov buttons ;
-
-M: controller-state clone
- call-next-method dup buttons>> clone >>buttons ;
-
-SYMBOLS:
- pov-neutral
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left ;
-
-: find-controller-products ( product-id -- sequence )
- get-controllers [ product-id = ] with filter ;
-: find-controller-instance ( product-id instance-id -- controller/f )
- get-controllers [
- tuck
- [ product-id = ]
- [ instance-id = ] 2bi* and
- ] with with find nip ;
-
-TUPLE: keyboard-state keys ;
-
-M: keyboard-state clone
- call-next-method dup keys>> clone >>keys ;
-
-TUPLE: mouse-state dx dy scroll-dx scroll-dy buttons ;
-
-M: mouse-state clone
- call-next-method dup buttons>> clone >>buttons ;
-
-{
- { [ os windows? ] [ "game-input.dinput" require ] }
- { [ os macosx? ] [ "game-input.iokit" require ] }
- { [ t ] [ ] }
-} cond
+++ /dev/null
-USING: cocoa cocoa.plists core-foundation iokit iokit.hid
-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 ;
-IN: game-input.iokit
-
-SINGLETON: iokit-game-input-backend
-
-SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ;
-
-iokit-game-input-backend game-input-backend set-global
-
-: hid-manager-matching ( matching-seq -- alien )
- f 0 IOHIDManagerCreate
- [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
- keep ;
-
-: devices-from-hid-manager ( manager -- vector )
- [
- IOHIDManagerCopyDevices
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-CONSTANT: game-devices-matching-seq
- {
- H{ { "DeviceUsage" 2 } { "DeviceUsagePage" 1 } } ! mouses
- H{ { "DeviceUsage" 4 } { "DeviceUsagePage" 1 } } ! joysticks
- H{ { "DeviceUsage" 5 } { "DeviceUsagePage" 1 } } ! gamepads
- H{ { "DeviceUsage" 6 } { "DeviceUsagePage" 1 } } ! keyboards
- H{ { "DeviceUsage" 7 } { "DeviceUsagePage" 1 } } ! keypads
- H{ { "DeviceUsage" 8 } { "DeviceUsagePage" 1 } } ! multiaxis controllers
- }
-
-CONSTANT: buttons-matching-hash
- H{ { "UsagePage" 9 } { "Type" 2 } }
-CONSTANT: keys-matching-hash
- H{ { "UsagePage" 7 } { "Type" 2 } }
-CONSTANT: x-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 30 } { "Type" 1 } }
-CONSTANT: y-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 31 } { "Type" 1 } }
-CONSTANT: z-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 32 } { "Type" 1 } }
-CONSTANT: rx-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 33 } { "Type" 1 } }
-CONSTANT: ry-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 34 } { "Type" 1 } }
-CONSTANT: rz-axis-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 35 } { "Type" 1 } }
-CONSTANT: slider-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 36 } { "Type" 1 } }
-CONSTANT: wheel-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 38 } { "Type" 1 } }
-CONSTANT: hat-switch-matching-hash
- H{ { "UsagePage" 1 } { "Usage" HEX: 39 } { "Type" 1 } }
-
-: device-elements-matching ( device matching-hash -- vector )
- [
- >plist 0 IOHIDDeviceCopyMatchingElements
- [ &CFRelease NSFastEnumeration>vector ] [ f ] if*
- ] with-destructors ;
-
-: button-count ( device -- button-count )
- buttons-matching-hash device-elements-matching length ;
-
-: ?axis ( device hash -- axis/f )
- device-elements-matching [ f ] [ first ] if-empty ;
-
-: ?x-axis ( device -- ? )
- x-axis-matching-hash ?axis ;
-: ?y-axis ( device -- ? )
- y-axis-matching-hash ?axis ;
-: ?z-axis ( device -- ? )
- z-axis-matching-hash ?axis ;
-: ?rx-axis ( device -- ? )
- rx-axis-matching-hash ?axis ;
-: ?ry-axis ( device -- ? )
- ry-axis-matching-hash ?axis ;
-: ?rz-axis ( device -- ? )
- rz-axis-matching-hash ?axis ;
-: ?slider ( device -- ? )
- slider-matching-hash ?axis ;
-: ?hat-switch ( device -- ? )
- hat-switch-matching-hash ?axis ;
-
-: hid-manager-matching-game-devices ( -- alien )
- game-devices-matching-seq hid-manager-matching ;
-
-: device-property ( device key -- value )
- <NSString> IOHIDDeviceGetProperty [ plist> ] [ f ] if* ;
-: element-property ( element key -- value )
- <NSString> IOHIDElementGetProperty [ plist> ] [ f ] if* ;
-: set-element-property ( element key value -- )
- [ <NSString> ] [ >plist ] bi* IOHIDElementSetProperty drop ;
-: transfer-element-property ( element from-key to-key -- )
- [ dupd element-property ] dip swap
- [ set-element-property ] [ 2drop ] if* ;
-
-: mouse-device? ( device -- ? )
- 1 2 IOHIDDeviceConformsTo ;
-
-: controller-device? ( device -- ? )
- {
- [ 1 4 IOHIDDeviceConformsTo ]
- [ 1 5 IOHIDDeviceConformsTo ]
- [ 1 8 IOHIDDeviceConformsTo ]
- } 1|| ;
-
-: element-usage ( element -- {usage-page,usage} )
- [ IOHIDElementGetUsagePage ] [ IOHIDElementGetUsage ] bi
- 2array ;
-
-: button? ( element -- ? )
- IOHIDElementGetUsagePage 9 = ; inline
-: keyboard-key? ( element -- ? )
- IOHIDElementGetUsagePage 7 = ; inline
-: axis? ( element -- ? )
- IOHIDElementGetUsagePage 1 = ; inline
-
-: x-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 30 = ; inline
-: y-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 31 = ; inline
-: z-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 32 = ; inline
-: rx-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 33 = ; inline
-: ry-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 34 = ; inline
-: rz-axis? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 35 = ; inline
-: slider? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 36 = ; inline
-: wheel? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 38 = ; inline
-: hat-switch? ( {usage-page,usage} -- ? )
- IOHIDElementGetUsage HEX: 39 = ; inline
-
-CONSTANT: pov-values
- {
- pov-up pov-up-right pov-right pov-down-right
- pov-down pov-down-left pov-left pov-up-left
- pov-neutral
- }
-
-: button-value ( value -- f/(0,1] )
- IOHIDValueGetIntegerValue dup zero? [ drop f ] when ;
-: axis-value ( value -- [-1,1] )
- kIOHIDValueScaleTypeCalibrated IOHIDValueGetScaledValue ;
-: mouse-axis-value ( value -- n )
- IOHIDValueGetIntegerValue ;
-: pov-value ( value -- pov-direction )
- IOHIDValueGetIntegerValue pov-values ?nth [ pov-neutral ] unless* ;
-
-: record-button ( state hid-value element -- )
- [ buttons>> ] [ button-value ] [ IOHIDElementGetUsage 1- ] tri* rot set-nth ;
-
-: record-controller ( controller-state value -- )
- dup IOHIDValueGetElement {
- { [ dup button? ] [ record-button ] }
- { [ dup axis? ] [ {
- { [ dup x-axis? ] [ drop axis-value >>x drop ] }
- { [ dup y-axis? ] [ drop axis-value >>y drop ] }
- { [ dup z-axis? ] [ drop axis-value >>z drop ] }
- { [ dup rx-axis? ] [ drop axis-value >>rx drop ] }
- { [ dup ry-axis? ] [ drop axis-value >>ry drop ] }
- { [ dup rz-axis? ] [ drop axis-value >>rz drop ] }
- { [ dup slider? ] [ drop axis-value >>slider drop ] }
- { [ dup hat-switch? ] [ drop pov-value >>pov drop ] }
- [ 3drop ]
- } cond ] }
- [ 3drop ]
- } cond ;
-
-HINTS: record-controller { controller-state alien } ;
-
-: ?set-nth ( value nth seq -- )
- 2dup bounds-check? [ set-nth-unsafe ] [ 3drop ] if ;
-
-: record-keyboard ( keyboard-state value -- )
- dup IOHIDValueGetElement dup keyboard-key? [
- [ IOHIDValueGetIntegerValue c-bool> ]
- [ IOHIDElementGetUsage ] bi*
- rot ?set-nth
- ] [ 3drop ] if ;
-
-HINTS: record-keyboard { array alien } ;
-
-: record-mouse ( mouse-state value -- )
- dup IOHIDValueGetElement {
- { [ dup button? ] [ record-button ] }
- { [ dup axis? ] [ {
- { [ dup x-axis? ] [ drop mouse-axis-value [ + ] curry change-dx drop ] }
- { [ dup y-axis? ] [ drop mouse-axis-value [ + ] curry change-dy drop ] }
- { [ dup wheel? ] [ drop mouse-axis-value [ + ] curry change-scroll-dx drop ] }
- { [ dup z-axis? ] [ drop mouse-axis-value [ + ] curry change-scroll-dy drop ] }
- [ 3drop ]
- } cond ] }
- [ 3drop ]
- } cond ;
-
-HINTS: record-mouse { mouse-state alien } ;
-
-M: iokit-game-input-backend read-mouse
- +mouse-state+ get ;
-
-M: iokit-game-input-backend reset-mouse
- +mouse-state+ get
- 0 >>dx
- 0 >>dy
- 0 >>scroll-dx
- 0 >>scroll-dy
- drop ;
-
-: default-calibrate-saturation ( element -- )
- [ kIOHIDElementMinKey kIOHIDElementCalibrationSaturationMinKey transfer-element-property ]
- [ kIOHIDElementMaxKey kIOHIDElementCalibrationSaturationMaxKey transfer-element-property ]
- bi ;
-
-: default-calibrate-axis ( element -- )
- [ kIOHIDElementCalibrationMinKey -1.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: default-calibrate-slider ( element -- )
- [ kIOHIDElementCalibrationMinKey 0.0 set-element-property ]
- [ kIOHIDElementCalibrationMaxKey 1.0 set-element-property ]
- [ default-calibrate-saturation ]
- tri ;
-
-: (default) ( ? quot -- )
- [ f ] if* ; inline
-
-: <device-controller-state> ( device -- controller-state )
- {
- [ ?x-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?y-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?z-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rx-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?ry-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?rz-axis [ default-calibrate-axis 0.0 ] (default) ]
- [ ?slider [ default-calibrate-slider 0.0 ] (default) ]
- [ ?hat-switch pov-neutral and ]
- [ button-count f <array> ]
- } cleave controller-state boa ;
-
-: ?add-mouse-buttons ( device -- )
- button-count +mouse-state+ get buttons>>
- 2dup length >
- [ set-length ] [ 2drop ] if ;
-
-: device-matched-callback ( -- alien )
- [| context result sender device |
- {
- { [ device controller-device? ] [
- device <device-controller-state>
- device +controller-states+ get set-at
- ] }
- { [ device mouse-device? ] [ device ?add-mouse-buttons ] }
- [ ]
- } cond
- ] IOHIDDeviceCallback ;
-
-: device-removed-callback ( -- alien )
- [| context result sender device |
- device +controller-states+ get delete-at
- ] IOHIDDeviceCallback ;
-
-: device-input-callback ( -- alien )
- [| context result sender value |
- {
- { [ sender controller-device? ] [
- sender +controller-states+ get at value record-controller
- ] }
- { [ sender mouse-device? ] [ +mouse-state+ get value record-mouse ] }
- [ +keyboard-state+ get value record-keyboard ]
- } cond
- ] IOHIDValueCallback ;
-
-: initialize-variables ( manager -- )
- +hid-manager+ set-global
- 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 ;
-
-M: iokit-game-input-backend (open-game-input)
- hid-manager-matching-game-devices {
- [ initialize-variables ]
- [ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
- [ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
- [ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
- [ 0 IOHIDManagerOpen mach-error ]
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerScheduleWithRunLoop
- ]
- } cleave ;
-
-M: iokit-game-input-backend (reset-game-input)
- { +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ }
- [ f swap set-global ] each ;
-
-M: iokit-game-input-backend (close-game-input)
- +hid-manager+ get-global [
- +hid-manager+ [
- [
- CFRunLoopGetMain CFRunLoopDefaultMode
- IOHIDManagerUnscheduleFromRunLoop
- ]
- [ 0 IOHIDManagerClose drop ]
- [ CFRelease ] tri
- f
- ] change-global
- f +keyboard-state+ set-global
- f +mouse-state+ set-global
- f +controller-states+ set-global
- ] when ;
-
-M: iokit-game-input-backend get-controllers ( -- sequence )
- +controller-states+ get keys [ controller boa ] map ;
-
-: ?join ( pre post sep -- string )
- 2over start [ swap 2nip ] [ [ 2array ] dip join ] if ;
-
-M: iokit-game-input-backend product-string ( controller -- string )
- handle>>
- [ kIOHIDManufacturerKey device-property ]
- [ kIOHIDProductKey device-property ] bi " " ?join ;
-M: iokit-game-input-backend product-id ( controller -- integer )
- handle>>
- [ kIOHIDVendorIDKey device-property ]
- [ kIOHIDProductIDKey device-property ] bi 2array ;
-M: iokit-game-input-backend instance-id ( controller -- integer )
- handle>> kIOHIDLocationIDKey device-property ;
-
-M: iokit-game-input-backend read-controller ( controller -- controller-state )
- handle>> +controller-states+ get at clone ;
-
-M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
- +keyboard-state+ get clone keyboard-state boa ;
-
-M: iokit-game-input-backend calibrate-controller ( controller -- )
- drop ;
+++ /dev/null
-IOKit HID Manager backend for game-input
+++ /dev/null
-unportable
-games
+++ /dev/null
-IN: game-input.scancodes
-
-CONSTANT: key-undefined HEX: 0000
-CONSTANT: key-error-roll-over HEX: 0001
-CONSTANT: key-error-post-fail HEX: 0002
-CONSTANT: key-error-undefined HEX: 0003
-CONSTANT: key-a HEX: 0004
-CONSTANT: key-b HEX: 0005
-CONSTANT: key-c HEX: 0006
-CONSTANT: key-d HEX: 0007
-CONSTANT: key-e HEX: 0008
-CONSTANT: key-f HEX: 0009
-CONSTANT: key-g HEX: 000a
-CONSTANT: key-h HEX: 000b
-CONSTANT: key-i HEX: 000c
-CONSTANT: key-j HEX: 000d
-CONSTANT: key-k HEX: 000e
-CONSTANT: key-l HEX: 000f
-CONSTANT: key-m HEX: 0010
-CONSTANT: key-n HEX: 0011
-CONSTANT: key-o HEX: 0012
-CONSTANT: key-p HEX: 0013
-CONSTANT: key-q HEX: 0014
-CONSTANT: key-r HEX: 0015
-CONSTANT: key-s HEX: 0016
-CONSTANT: key-t HEX: 0017
-CONSTANT: key-u HEX: 0018
-CONSTANT: key-v HEX: 0019
-CONSTANT: key-w HEX: 001a
-CONSTANT: key-x HEX: 001b
-CONSTANT: key-y HEX: 001c
-CONSTANT: key-z HEX: 001d
-CONSTANT: key-1 HEX: 001e
-CONSTANT: key-2 HEX: 001f
-CONSTANT: key-3 HEX: 0020
-CONSTANT: key-4 HEX: 0021
-CONSTANT: key-5 HEX: 0022
-CONSTANT: key-6 HEX: 0023
-CONSTANT: key-7 HEX: 0024
-CONSTANT: key-8 HEX: 0025
-CONSTANT: key-9 HEX: 0026
-CONSTANT: key-0 HEX: 0027
-CONSTANT: key-return HEX: 0028
-CONSTANT: key-escape HEX: 0029
-CONSTANT: key-backspace HEX: 002a
-CONSTANT: key-tab HEX: 002b
-CONSTANT: key-space HEX: 002c
-CONSTANT: key-- HEX: 002d
-CONSTANT: key-= HEX: 002e
-CONSTANT: key-[ HEX: 002f
-CONSTANT: key-] HEX: 0030
-CONSTANT: key-\ HEX: 0031
-CONSTANT: key-#-non-us HEX: 0032
-CONSTANT: key-; HEX: 0033
-CONSTANT: key-' HEX: 0034
-CONSTANT: key-` HEX: 0035
-CONSTANT: key-, HEX: 0036
-CONSTANT: key-. HEX: 0037
-CONSTANT: key-/ HEX: 0038
-CONSTANT: key-caps-lock HEX: 0039
-CONSTANT: key-f1 HEX: 003a
-CONSTANT: key-f2 HEX: 003b
-CONSTANT: key-f3 HEX: 003c
-CONSTANT: key-f4 HEX: 003d
-CONSTANT: key-f5 HEX: 003e
-CONSTANT: key-f6 HEX: 003f
-CONSTANT: key-f7 HEX: 0040
-CONSTANT: key-f8 HEX: 0041
-CONSTANT: key-f9 HEX: 0042
-CONSTANT: key-f10 HEX: 0043
-CONSTANT: key-f11 HEX: 0044
-CONSTANT: key-f12 HEX: 0045
-CONSTANT: key-print-screen HEX: 0046
-CONSTANT: key-scroll-lock HEX: 0047
-CONSTANT: key-pause HEX: 0048
-CONSTANT: key-insert HEX: 0049
-CONSTANT: key-home HEX: 004a
-CONSTANT: key-page-up HEX: 004b
-CONSTANT: key-delete HEX: 004c
-CONSTANT: key-end HEX: 004d
-CONSTANT: key-page-down HEX: 004e
-CONSTANT: key-right-arrow HEX: 004f
-CONSTANT: key-left-arrow HEX: 0050
-CONSTANT: key-down-arrow HEX: 0051
-CONSTANT: key-up-arrow HEX: 0052
-CONSTANT: key-keypad-numlock HEX: 0053
-CONSTANT: key-keypad-/ HEX: 0054
-CONSTANT: key-keypad-* HEX: 0055
-CONSTANT: key-keypad-- HEX: 0056
-CONSTANT: key-keypad-+ HEX: 0057
-CONSTANT: key-keypad-enter HEX: 0058
-CONSTANT: key-keypad-1 HEX: 0059
-CONSTANT: key-keypad-2 HEX: 005a
-CONSTANT: key-keypad-3 HEX: 005b
-CONSTANT: key-keypad-4 HEX: 005c
-CONSTANT: key-keypad-5 HEX: 005d
-CONSTANT: key-keypad-6 HEX: 005e
-CONSTANT: key-keypad-7 HEX: 005f
-CONSTANT: key-keypad-8 HEX: 0060
-CONSTANT: key-keypad-9 HEX: 0061
-CONSTANT: key-keypad-0 HEX: 0062
-CONSTANT: key-keypad-. HEX: 0063
-CONSTANT: key-\-non-us HEX: 0064
-CONSTANT: key-application HEX: 0065
-CONSTANT: key-power HEX: 0066
-CONSTANT: key-keypad-= HEX: 0067
-CONSTANT: key-f13 HEX: 0068
-CONSTANT: key-f14 HEX: 0069
-CONSTANT: key-f15 HEX: 006a
-CONSTANT: key-f16 HEX: 006b
-CONSTANT: key-f17 HEX: 006c
-CONSTANT: key-f18 HEX: 006d
-CONSTANT: key-f19 HEX: 006e
-CONSTANT: key-f20 HEX: 006f
-CONSTANT: key-f21 HEX: 0070
-CONSTANT: key-f22 HEX: 0071
-CONSTANT: key-f23 HEX: 0072
-CONSTANT: key-f24 HEX: 0073
-CONSTANT: key-execute HEX: 0074
-CONSTANT: key-help HEX: 0075
-CONSTANT: key-menu HEX: 0076
-CONSTANT: key-select HEX: 0077
-CONSTANT: key-stop HEX: 0078
-CONSTANT: key-again HEX: 0079
-CONSTANT: key-undo HEX: 007a
-CONSTANT: key-cut HEX: 007b
-CONSTANT: key-copy HEX: 007c
-CONSTANT: key-paste HEX: 007d
-CONSTANT: key-find HEX: 007e
-CONSTANT: key-mute HEX: 007f
-CONSTANT: key-volume-up HEX: 0080
-CONSTANT: key-volume-down HEX: 0081
-CONSTANT: key-locking-caps-lock HEX: 0082
-CONSTANT: key-locking-num-lock HEX: 0083
-CONSTANT: key-locking-scroll-lock HEX: 0084
-CONSTANT: key-keypad-, HEX: 0085
-CONSTANT: key-keypad-=-as-400 HEX: 0086
-CONSTANT: key-international-1 HEX: 0087
-CONSTANT: key-international-2 HEX: 0088
-CONSTANT: key-international-3 HEX: 0089
-CONSTANT: key-international-4 HEX: 008a
-CONSTANT: key-international-5 HEX: 008b
-CONSTANT: key-international-6 HEX: 008c
-CONSTANT: key-international-7 HEX: 008d
-CONSTANT: key-international-8 HEX: 008e
-CONSTANT: key-international-9 HEX: 008f
-CONSTANT: key-lang-1 HEX: 0090
-CONSTANT: key-lang-2 HEX: 0091
-CONSTANT: key-lang-3 HEX: 0092
-CONSTANT: key-lang-4 HEX: 0093
-CONSTANT: key-lang-5 HEX: 0094
-CONSTANT: key-lang-6 HEX: 0095
-CONSTANT: key-lang-7 HEX: 0096
-CONSTANT: key-lang-8 HEX: 0097
-CONSTANT: key-lang-9 HEX: 0098
-CONSTANT: key-alternate-erase HEX: 0099
-CONSTANT: key-sysreq HEX: 009a
-CONSTANT: key-cancel HEX: 009b
-CONSTANT: key-clear HEX: 009c
-CONSTANT: key-prior HEX: 009d
-CONSTANT: key-enter HEX: 009e
-CONSTANT: key-separator HEX: 009f
-CONSTANT: key-out HEX: 00a0
-CONSTANT: key-oper HEX: 00a1
-CONSTANT: key-clear-again HEX: 00a2
-CONSTANT: key-crsel-props HEX: 00a3
-CONSTANT: key-exsel HEX: 00a4
-CONSTANT: key-left-control HEX: 00e0
-CONSTANT: key-left-shift HEX: 00e1
-CONSTANT: key-left-alt HEX: 00e2
-CONSTANT: key-left-gui HEX: 00e3
-CONSTANT: key-right-control HEX: 00e4
-CONSTANT: key-right-shift HEX: 00e5
-CONSTANT: key-right-alt HEX: 00e6
-CONSTANT: key-right-gui HEX: 00e7
+++ /dev/null
-Scan code constants for HID keyboards
+++ /dev/null
-Cross-platform joystick, gamepad, and raw keyboard input
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 ;
+ drop ;
M: game-world end-world
- close-game-input
[ [ stop-loop ] when* f ] change-game-loop
+ close-game-input
drop ;
-M: game-world focusable-child* drop t ;
-
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 3 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
: gesture-logger ( -- )
[
<pane> t >>scrolls? dup <scroller>
+ { 450 500 } >>pref-dim
"Gesture log" open-window
<pane-stream> <gesture-logger>
"Gesture input" open-window
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
- { deploy-math? t }
- { deploy-name "Hello world" }
{ deploy-c-types? f }
- { deploy-word-props? f }
- { deploy-io 2 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
+ { deploy-unicode? f }
{ deploy-word-defs? f }
- { deploy-compiler? t }
+ { deploy-name "Hello world" }
+ { "stop-after-last-window?" t }
{ deploy-reflection 1 }
+ { deploy-ui? t }
+ { deploy-math? t }
+ { deploy-io 1 }
+ { deploy-word-props? f }
+ { deploy-threads? t }
}
{ deploy-word-defs? f }
{ deploy-reflection 1 }
{ deploy-word-props? f }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-unicode? f }
{ "stop-after-last-window?" t }
H{
{ deploy-unicode? f }
{ deploy-ui? f }
- { deploy-compiler? t }
{ deploy-name "Hello world (console)" }
{ deploy-io 2 }
{ deploy-threads? f }
+++ /dev/null
-USING: iokit alien alien.syntax alien.c-types kernel
-system core-foundation core-foundation.data
-core-foundation.dictionaries ;
-IN: iokit.hid
-
-CONSTANT: kIOHIDDeviceKey "IOHIDDevice"
-
-CONSTANT: kIOHIDTransportKey "Transport"
-CONSTANT: kIOHIDVendorIDKey "VendorID"
-CONSTANT: kIOHIDVendorIDSourceKey "VendorIDSource"
-CONSTANT: kIOHIDProductIDKey "ProductID"
-CONSTANT: kIOHIDVersionNumberKey "VersionNumber"
-CONSTANT: kIOHIDManufacturerKey "Manufacturer"
-CONSTANT: kIOHIDProductKey "Product"
-CONSTANT: kIOHIDSerialNumberKey "SerialNumber"
-CONSTANT: kIOHIDCountryCodeKey "CountryCode"
-CONSTANT: kIOHIDLocationIDKey "LocationID"
-CONSTANT: kIOHIDDeviceUsageKey "DeviceUsage"
-CONSTANT: kIOHIDDeviceUsagePageKey "DeviceUsagePage"
-CONSTANT: kIOHIDDeviceUsagePairsKey "DeviceUsagePairs"
-CONSTANT: kIOHIDPrimaryUsageKey "PrimaryUsage"
-CONSTANT: kIOHIDPrimaryUsagePageKey "PrimaryUsagePage"
-CONSTANT: kIOHIDMaxInputReportSizeKey "MaxInputReportSize"
-CONSTANT: kIOHIDMaxOutputReportSizeKey "MaxOutputReportSize"
-CONSTANT: kIOHIDMaxFeatureReportSizeKey "MaxFeatureReportSize"
-CONSTANT: kIOHIDReportIntervalKey "ReportInterval"
-
-CONSTANT: kIOHIDElementKey "Elements"
-
-CONSTANT: kIOHIDElementCookieKey "ElementCookie"
-CONSTANT: kIOHIDElementTypeKey "Type"
-CONSTANT: kIOHIDElementCollectionTypeKey "CollectionType"
-CONSTANT: kIOHIDElementUsageKey "Usage"
-CONSTANT: kIOHIDElementUsagePageKey "UsagePage"
-CONSTANT: kIOHIDElementMinKey "Min"
-CONSTANT: kIOHIDElementMaxKey "Max"
-CONSTANT: kIOHIDElementScaledMinKey "ScaledMin"
-CONSTANT: kIOHIDElementScaledMaxKey "ScaledMax"
-CONSTANT: kIOHIDElementSizeKey "Size"
-CONSTANT: kIOHIDElementReportSizeKey "ReportSize"
-CONSTANT: kIOHIDElementReportCountKey "ReportCount"
-CONSTANT: kIOHIDElementReportIDKey "ReportID"
-CONSTANT: kIOHIDElementIsArrayKey "IsArray"
-CONSTANT: kIOHIDElementIsRelativeKey "IsRelative"
-CONSTANT: kIOHIDElementIsWrappingKey "IsWrapping"
-CONSTANT: kIOHIDElementIsNonLinearKey "IsNonLinear"
-CONSTANT: kIOHIDElementHasPreferredStateKey "HasPreferredState"
-CONSTANT: kIOHIDElementHasNullStateKey "HasNullState"
-CONSTANT: kIOHIDElementFlagsKey "Flags"
-CONSTANT: kIOHIDElementUnitKey "Unit"
-CONSTANT: kIOHIDElementUnitExponentKey "UnitExponent"
-CONSTANT: kIOHIDElementNameKey "Name"
-CONSTANT: kIOHIDElementValueLocationKey "ValueLocation"
-CONSTANT: kIOHIDElementDuplicateIndexKey "DuplicateIndex"
-CONSTANT: kIOHIDElementParentCollectionKey "ParentCollection"
-
-: kIOHIDElementVendorSpecificKey ( -- str )
- cpu ppc? "VendorSpecifc" "VendorSpecific" ? ; inline
-
-CONSTANT: kIOHIDElementCookieMinKey "ElementCookieMin"
-CONSTANT: kIOHIDElementCookieMaxKey "ElementCookieMax"
-CONSTANT: kIOHIDElementUsageMinKey "UsageMin"
-CONSTANT: kIOHIDElementUsageMaxKey "UsageMax"
-
-CONSTANT: kIOHIDElementCalibrationMinKey "CalibrationMin"
-CONSTANT: kIOHIDElementCalibrationMaxKey "CalibrationMax"
-CONSTANT: kIOHIDElementCalibrationSaturationMinKey "CalibrationSaturationMin"
-CONSTANT: kIOHIDElementCalibrationSaturationMaxKey "CalibrationSaturationMax"
-CONSTANT: kIOHIDElementCalibrationDeadZoneMinKey "CalibrationDeadZoneMin"
-CONSTANT: kIOHIDElementCalibrationDeadZoneMaxKey "CalibrationDeadZoneMax"
-CONSTANT: kIOHIDElementCalibrationGranularityKey "CalibrationGranularity"
-
-CONSTANT: kIOHIDElementTypeInput_Misc 1
-CONSTANT: kIOHIDElementTypeInput_Button 2
-CONSTANT: kIOHIDElementTypeInput_Axis 3
-CONSTANT: kIOHIDElementTypeInput_ScanCodes 4
-CONSTANT: kIOHIDElementTypeOutput 129
-CONSTANT: kIOHIDElementTypeFeature 257
-CONSTANT: kIOHIDElementTypeCollection 513
-
-CONSTANT: kIOHIDElementCollectionTypePhysical HEX: 00
-CONSTANT: kIOHIDElementCollectionTypeApplication HEX: 01
-CONSTANT: kIOHIDElementCollectionTypeLogical HEX: 02
-CONSTANT: kIOHIDElementCollectionTypeReport HEX: 03
-CONSTANT: kIOHIDElementCollectionTypeNamedArray HEX: 04
-CONSTANT: kIOHIDElementCollectionTypeUsageSwitch HEX: 05
-CONSTANT: kIOHIDElementCollectionTypeUsageModifier HEX: 06
-
-CONSTANT: kIOHIDReportTypeInput 0
-CONSTANT: kIOHIDReportTypeOutput 1
-CONSTANT: kIOHIDReportTypeFeature 2
-CONSTANT: kIOHIDReportTypeCount 3
-
-CONSTANT: kIOHIDOptionsTypeNone HEX: 00
-CONSTANT: kIOHIDOptionsTypeSeizeDevice HEX: 01
-
-CONSTANT: kIOHIDQueueOptionsTypeNone HEX: 00
-CONSTANT: kIOHIDQueueOptionsTypeEnqueueAll HEX: 01
-
-CONSTANT: kIOHIDElementFlagsConstantMask HEX: 0001
-CONSTANT: kIOHIDElementFlagsVariableMask HEX: 0002
-CONSTANT: kIOHIDElementFlagsRelativeMask HEX: 0004
-CONSTANT: kIOHIDElementFlagsWrapMask HEX: 0008
-CONSTANT: kIOHIDElementFlagsNonLinearMask HEX: 0010
-CONSTANT: kIOHIDElementFlagsNoPreferredMask HEX: 0020
-CONSTANT: kIOHIDElementFlagsNullStateMask HEX: 0040
-CONSTANT: kIOHIDElementFlagsVolativeMask HEX: 0080
-CONSTANT: kIOHIDElementFlagsBufferedByteMask HEX: 0100
-
-CONSTANT: kIOHIDValueScaleTypeCalibrated 0
-CONSTANT: kIOHIDValueScaleTypePhysical 1
-
-CONSTANT: kIOHIDTransactionDirectionTypeInput 0
-CONSTANT: kIOHIDTransactionDirectionTypeOutput 1
-
-CONSTANT: kIOHIDTransactionOptionDefaultOutputValue 1
-
-TYPEDEF: ptrdiff_t IOHIDElementCookie
-TYPEDEF: int IOHIDElementType
-TYPEDEF: int IOHIDElementCollectionType
-TYPEDEF: int IOHIDReportType
-TYPEDEF: uint IOHIDOptionsType
-TYPEDEF: uint IOHIDQueueOptionsType
-TYPEDEF: uint IOHIDElementFlags
-TYPEDEF: void* IOHIDDeviceRef
-TYPEDEF: void* IOHIDElementRef
-TYPEDEF: void* IOHIDValueRef
-TYPEDEF: void* IOHIDManagerRef
-TYPEDEF: void* IOHIDTransactionRef
-TYPEDEF: UInt32 IOHIDValueScaleType
-TYPEDEF: UInt32 IOHIDTransactionDirectionType
-
-TYPEDEF: void* IOHIDCallback
-: IOHIDCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDReportCallback
-: IOHIDReportCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "IOHIDReportType" "UInt32" "uchar*" "CFIndex" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDValueCallback
-: IOHIDValueCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "IOHIDValueRef" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDValueMultipleCallback
-: IOHIDValueMultipleCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "CFDictionaryRef" } "cdecl" ]
- dip alien-callback ; inline
-
-TYPEDEF: void* IOHIDDeviceCallback
-: IOHIDDeviceCallback ( quot -- alien )
- [ "void" { "void*" "IOReturn" "void*" "IOHIDDeviceRef" } "cdecl" ]
- dip alien-callback ; inline
-
-! IOHIDDevice
-
-FUNCTION: CFTypeID IOHIDDeviceGetTypeID ( ) ;
-FUNCTION: IOHIDDeviceRef IOHIDDeviceCreate ( CFAllocatorRef allocator, io_service_t service ) ;
-FUNCTION: IOReturn IOHIDDeviceOpen ( IOHIDDeviceRef device, IOOptionBits options ) ;
-FUNCTION: IOReturn IOHIDDeviceClose ( IOHIDDeviceRef device, IOOptionBits options ) ;
-FUNCTION: Boolean IOHIDDeviceConformsTo ( IOHIDDeviceRef device, UInt32 usagePage, UInt32 usage ) ;
-FUNCTION: CFTypeRef IOHIDDeviceGetProperty ( IOHIDDeviceRef device, CFStringRef key ) ;
-FUNCTION: Boolean IOHIDDeviceSetProperty ( IOHIDDeviceRef device, CFStringRef key, CFTypeRef property ) ;
-FUNCTION: CFArrayRef IOHIDDeviceCopyMatchingElements ( IOHIDDeviceRef device, CFDictionaryRef matching, IOOptionBits options ) ;
-FUNCTION: void IOHIDDeviceScheduleWithRunLoop ( IOHIDDeviceRef device, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
-FUNCTION: void IOHIDDeviceUnscheduleFromRunLoop ( IOHIDDeviceRef device, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
-FUNCTION: void IOHIDDeviceRegisterRemovalCallback ( IOHIDDeviceRef device, IOHIDCallback callback, void* context ) ;
-FUNCTION: void IOHIDDeviceRegisterInputValueCallback ( IOHIDDeviceRef device, IOHIDValueCallback callback, void* context ) ;
-FUNCTION: void IOHIDDeviceRegisterInputReportCallback ( IOHIDDeviceRef device, uchar* report, CFIndex reportLength, IOHIDReportCallback callback, void* context ) ;
-FUNCTION: void IOHIDDeviceSetInputValueMatching ( IOHIDDeviceRef device, CFDictionaryRef matching ) ;
-FUNCTION: void IOHIDDeviceSetInputValueMatchingMultiple ( IOHIDDeviceRef device, CFArrayRef multiple ) ;
-FUNCTION: IOReturn IOHIDDeviceSetValue ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef value ) ;
-FUNCTION: IOReturn IOHIDDeviceSetValueMultiple ( IOHIDDeviceRef device, CFDictionaryRef multiple ) ;
-FUNCTION: IOReturn IOHIDDeviceSetValueWithCallback ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef value, CFTimeInterval timeout, IOHIDValueCallback callback, void* context ) ;
-FUNCTION: IOReturn IOHIDDeviceSetValueMultipleWithCallback ( IOHIDDeviceRef device, CFDictionaryRef multiple, CFTimeInterval timeout, IOHIDValueMultipleCallback callback, void* context ) ;
-FUNCTION: IOReturn IOHIDDeviceGetValue ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef* pValue ) ;
-FUNCTION: IOReturn IOHIDDeviceCopyValueMultiple ( IOHIDDeviceRef device, CFArrayRef elements, CFDictionaryRef* pMultiple ) ;
-FUNCTION: IOReturn IOHIDDeviceGetValueWithCallback ( IOHIDDeviceRef device, IOHIDElementRef element, IOHIDValueRef* pValue, CFTimeInterval timeout, IOHIDValueCallback callback, void* context ) ;
-FUNCTION: IOReturn IOHIDDeviceCopyValueMultipleWithCallback ( IOHIDDeviceRef device, CFArrayRef elements, CFDictionaryRef* pMultiple, CFTimeInterval timeout, IOHIDValueMultipleCallback callback, void* context ) ;
-FUNCTION: IOReturn IOHIDDeviceSetReport ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex reportLength ) ;
-FUNCTION: IOReturn IOHIDDeviceSetReportWithCallback ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex reportLength, CFTimeInterval timeout, IOHIDReportCallback callback, void* context ) ;
-FUNCTION: IOReturn IOHIDDeviceGetReport ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex* pReportLength ) ;
-FUNCTION: IOReturn IOHIDDeviceGetReportWithCallback ( IOHIDDeviceRef device, IOHIDReportType reportType, CFIndex reportID, uchar* report, CFIndex* pReportLength, CFTimeInterval timeout, IOHIDReportCallback callback, void* context ) ;
-
-! IOHIDManager
-
-FUNCTION: CFTypeID IOHIDManagerGetTypeID ( ) ;
-FUNCTION: IOHIDManagerRef IOHIDManagerCreate ( CFAllocatorRef allocator, IOOptionBits options ) ;
-FUNCTION: IOReturn IOHIDManagerOpen ( IOHIDManagerRef manager, IOOptionBits options ) ;
-FUNCTION: IOReturn IOHIDManagerClose ( IOHIDManagerRef manager, IOOptionBits options ) ;
-FUNCTION: CFTypeRef IOHIDManagerGetProperty ( IOHIDManagerRef manager, CFStringRef key ) ;
-FUNCTION: Boolean IOHIDManagerSetProperty ( IOHIDManagerRef manager, CFStringRef key, CFTypeRef value ) ;
-FUNCTION: void IOHIDManagerScheduleWithRunLoop ( IOHIDManagerRef manager, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
-FUNCTION: void IOHIDManagerUnscheduleFromRunLoop ( IOHIDManagerRef manager, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
-FUNCTION: void IOHIDManagerSetDeviceMatching ( IOHIDManagerRef manager, CFDictionaryRef matching ) ;
-FUNCTION: void IOHIDManagerSetDeviceMatchingMultiple ( IOHIDManagerRef manager, CFArrayRef multiple ) ;
-FUNCTION: CFSetRef IOHIDManagerCopyDevices ( IOHIDManagerRef manager ) ;
-FUNCTION: void IOHIDManagerRegisterDeviceMatchingCallback ( IOHIDManagerRef manager, IOHIDDeviceCallback callback, void* context ) ;
-FUNCTION: void IOHIDManagerRegisterDeviceRemovalCallback ( IOHIDManagerRef manager, IOHIDDeviceCallback callback, void* context ) ;
-FUNCTION: void IOHIDManagerRegisterInputReportCallback ( IOHIDManagerRef manager, IOHIDReportCallback callback, void* context ) ;
-FUNCTION: void IOHIDManagerRegisterInputValueCallback ( IOHIDManagerRef manager, IOHIDValueCallback callback, void* context ) ;
-FUNCTION: void IOHIDManagerSetInputValueMatching ( IOHIDManagerRef manager, CFDictionaryRef matching ) ;
-FUNCTION: void IOHIDManagerSetInputValueMatchingMultiple ( IOHIDManagerRef manager, CFArrayRef multiple ) ;
-
-! IOHIDElement
-
-FUNCTION: CFTypeID IOHIDElementGetTypeID ( ) ;
-FUNCTION: IOHIDElementRef IOHIDElementCreateWithDictionary ( CFAllocatorRef allocator, CFDictionaryRef dictionary ) ;
-FUNCTION: IOHIDDeviceRef IOHIDElementGetDevice ( IOHIDElementRef element ) ;
-FUNCTION: IOHIDElementRef IOHIDElementGetParent ( IOHIDElementRef element ) ;
-FUNCTION: CFArrayRef IOHIDElementGetChildren ( IOHIDElementRef element ) ;
-FUNCTION: void IOHIDElementAttach ( IOHIDElementRef element, IOHIDElementRef toAttach ) ;
-FUNCTION: void IOHIDElementDetach ( IOHIDElementRef element, IOHIDElementRef toDetach ) ;
-FUNCTION: CFArrayRef IOHIDElementCopyAttached ( IOHIDElementRef element ) ;
-FUNCTION: IOHIDElementCookie IOHIDElementGetCookie ( IOHIDElementRef element ) ;
-FUNCTION: IOHIDElementType IOHIDElementGetType ( IOHIDElementRef element ) ;
-FUNCTION: IOHIDElementCollectionType IOHIDElementGetCollectionType ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetUsagePage ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetUsage ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementIsVirtual ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementIsRelative ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementIsWrapping ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementIsArray ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementIsNonLinear ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementHasPreferredState ( IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDElementHasNullState ( IOHIDElementRef element ) ;
-FUNCTION: CFStringRef IOHIDElementGetName ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetReportID ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetReportSize ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetReportCount ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetUnit ( IOHIDElementRef element ) ;
-FUNCTION: UInt32 IOHIDElementGetUnitExponent ( IOHIDElementRef element ) ;
-FUNCTION: CFIndex IOHIDElementGetLogicalMin ( IOHIDElementRef element ) ;
-FUNCTION: CFIndex IOHIDElementGetLogicalMax ( IOHIDElementRef element ) ;
-FUNCTION: CFIndex IOHIDElementGetPhysicalMin ( IOHIDElementRef element ) ;
-FUNCTION: CFIndex IOHIDElementGetPhysicalMax ( IOHIDElementRef element ) ;
-FUNCTION: CFTypeRef IOHIDElementGetProperty ( IOHIDElementRef element, CFStringRef key ) ;
-FUNCTION: Boolean IOHIDElementSetProperty ( IOHIDElementRef element, CFStringRef key, CFTypeRef property ) ;
-
-! IOHIDValue
-
-FUNCTION: CFTypeID IOHIDValueGetTypeID ( ) ;
-FUNCTION: IOHIDValueRef IOHIDValueCreateWithIntegerValue ( CFAllocatorRef allocator, IOHIDElementRef element, ulonglong timeStamp, CFIndex value ) ;
-FUNCTION: IOHIDValueRef IOHIDValueCreateWithBytes ( CFAllocatorRef allocator, IOHIDElementRef element, ulonglong timeStamp, uchar* bytes, CFIndex length ) ;
-FUNCTION: IOHIDValueRef IOHIDValueCreateWithBytesNoCopy ( CFAllocatorRef allocator, IOHIDElementRef element, ulonglong timeStamp, uchar* bytes, CFIndex length ) ;
-FUNCTION: IOHIDElementRef IOHIDValueGetElement ( IOHIDValueRef value ) ;
-FUNCTION: ulonglong IOHIDValueGetTimeStamp ( IOHIDValueRef value ) ;
-FUNCTION: CFIndex IOHIDValueGetLength ( IOHIDValueRef value ) ;
-FUNCTION: uchar* IOHIDValueGetBytePtr ( IOHIDValueRef value ) ;
-FUNCTION: CFIndex IOHIDValueGetIntegerValue ( IOHIDValueRef value ) ;
-FUNCTION: double IOHIDValueGetScaledValue ( IOHIDValueRef value, IOHIDValueScaleType type ) ;
-
-! IOHIDTransaction
-
-FUNCTION: CFTypeID IOHIDTransactionGetTypeID ( ) ;
-FUNCTION: IOHIDTransactionRef IOHIDTransactionCreate ( CFAllocatorRef allocator, IOHIDDeviceRef device, IOHIDTransactionDirectionType direction, IOOptionBits options ) ;
-FUNCTION: IOHIDDeviceRef IOHIDTransactionGetDevice ( IOHIDTransactionRef transaction ) ;
-FUNCTION: IOHIDTransactionDirectionType IOHIDTransactionGetDirection ( IOHIDTransactionRef transaction ) ;
-FUNCTION: void IOHIDTransactionSetDirection ( IOHIDTransactionRef transaction, IOHIDTransactionDirectionType direction ) ;
-FUNCTION: void IOHIDTransactionAddElement ( IOHIDTransactionRef transaction, IOHIDElementRef element ) ;
-FUNCTION: void IOHIDTransactionRemoveElement ( IOHIDTransactionRef transaction, IOHIDElementRef element ) ;
-FUNCTION: Boolean IOHIDTransactionContainsElement ( IOHIDTransactionRef transaction, IOHIDElementRef element ) ;
-FUNCTION: void IOHIDTransactionScheduleWithRunLoop ( IOHIDTransactionRef transaction, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
-FUNCTION: void IOHIDTransactionUnscheduleFromRunLoop ( IOHIDTransactionRef transaction, CFRunLoopRef runLoop, CFStringRef runLoopMode ) ;
-FUNCTION: void IOHIDTransactionSetValue ( IOHIDTransactionRef transaction, IOHIDElementRef element, IOHIDValueRef value, IOOptionBits options ) ;
-FUNCTION: IOHIDValueRef IOHIDTransactionGetValue ( IOHIDTransactionRef transaction, IOHIDElementRef element, IOOptionBits options ) ;
-FUNCTION: IOReturn IOHIDTransactionCommit ( IOHIDTransactionRef transaction ) ;
-FUNCTION: IOReturn IOHIDTransactionCommitWithCallback ( IOHIDTransactionRef transaction, CFTimeInterval timeout, IOHIDCallback callback, void* context ) ;
-FUNCTION: void IOHIDTransactionClear ( IOHIDTransactionRef transaction ) ;
-
+++ /dev/null
-HID Manager bindings
+++ /dev/null
-bindings
-unportable
+++ /dev/null
-USING: alien.syntax alien.c-types core-foundation
-core-foundation.bundles core-foundation.dictionaries system
-combinators kernel sequences debugger io accessors ;
-IN: iokit
-
-<<
- os macosx?
- [ "/System/Library/Frameworks/IOKit.framework" load-framework ]
- when
->>
-
-CONSTANT: kIOKitBuildVersionKey "IOKitBuildVersion"
-CONSTANT: kIOKitDiagnosticsKey "IOKitDiagnostics"
-
-CONSTANT: kIORegistryPlanesKey "IORegistryPlanes"
-CONSTANT: kIOCatalogueKey "IOCatalogue"
-
-CONSTANT: kIOServicePlane "IOService"
-CONSTANT: kIOPowerPlane "IOPower"
-CONSTANT: kIODeviceTreePlane "IODeviceTree"
-CONSTANT: kIOAudioPlane "IOAudio"
-CONSTANT: kIOFireWirePlane "IOFireWire"
-CONSTANT: kIOUSBPlane "IOUSB"
-
-CONSTANT: kIOServiceClass "IOService"
-
-CONSTANT: kIOResourcesClass "IOResources"
-
-CONSTANT: kIOClassKey "IOClass"
-CONSTANT: kIOProbeScoreKey "IOProbeScore"
-CONSTANT: kIOKitDebugKey "IOKitDebug"
-
-CONSTANT: kIOProviderClassKey "IOProviderClass"
-CONSTANT: kIONameMatchKey "IONameMatch"
-CONSTANT: kIOPropertyMatchKey "IOPropertyMatch"
-CONSTANT: kIOPathMatchKey "IOPathMatch"
-CONSTANT: kIOLocationMatchKey "IOLocationMatch"
-CONSTANT: kIOParentMatchKey "IOParentMatch"
-CONSTANT: kIOResourceMatchKey "IOResourceMatch"
-CONSTANT: kIOMatchedServiceCountKey "IOMatchedServiceCountMatch"
-
-CONSTANT: kIONameMatchedKey "IONameMatched"
-
-CONSTANT: kIOMatchCategoryKey "IOMatchCategory"
-CONSTANT: kIODefaultMatchCategoryKey "IODefaultMatchCategory"
-
-CONSTANT: kIOUserClientClassKey "IOUserClientClass"
-
-CONSTANT: kIOUserClientCrossEndianKey "IOUserClientCrossEndian"
-CONSTANT: kIOUserClientCrossEndianCompatibleKey "IOUserClientCrossEndianCompatible"
-CONSTANT: kIOUserClientSharedInstanceKey "IOUserClientSharedInstance"
-
-CONSTANT: kIOPublishNotification "IOServicePublish"
-CONSTANT: kIOFirstPublishNotification "IOServiceFirstPublish"
-CONSTANT: kIOMatchedNotification "IOServiceMatched"
-CONSTANT: kIOFirstMatchNotification "IOServiceFirstMatch"
-CONSTANT: kIOTerminatedNotification "IOServiceTerminate"
-
-CONSTANT: kIOGeneralInterest "IOGeneralInterest"
-CONSTANT: kIOBusyInterest "IOBusyInterest"
-CONSTANT: kIOAppPowerStateInterest "IOAppPowerStateInterest"
-CONSTANT: kIOPriorityPowerStateInterest "IOPriorityPowerStateInterest"
-
-CONSTANT: kIOPlatformDeviceMessageKey "IOPlatformDeviceMessage"
-
-CONSTANT: kIOCFPlugInTypesKey "IOCFPlugInTypes"
-
-CONSTANT: kIOCommandPoolSizeKey "IOCommandPoolSize"
-
-CONSTANT: kIOMaximumBlockCountReadKey "IOMaximumBlockCountRead"
-CONSTANT: kIOMaximumBlockCountWriteKey "IOMaximumBlockCountWrite"
-CONSTANT: kIOMaximumByteCountReadKey "IOMaximumByteCountRead"
-CONSTANT: kIOMaximumByteCountWriteKey "IOMaximumByteCountWrite"
-CONSTANT: kIOMaximumSegmentCountReadKey "IOMaximumSegmentCountRead"
-CONSTANT: kIOMaximumSegmentCountWriteKey "IOMaximumSegmentCountWrite"
-CONSTANT: kIOMaximumSegmentByteCountReadKey "IOMaximumSegmentByteCountRead"
-CONSTANT: kIOMaximumSegmentByteCountWriteKey "IOMaximumSegmentByteCountWrite"
-CONSTANT: kIOMinimumSegmentAlignmentByteCountKey "IOMinimumSegmentAlignmentByteCount"
-CONSTANT: kIOMaximumSegmentAddressableBitCountKey "IOMaximumSegmentAddressableBitCount"
-
-CONSTANT: kIOIconKey "IOIcon"
-CONSTANT: kIOBundleResourceFileKey "IOBundleResourceFile"
-
-CONSTANT: kIOBusBadgeKey "IOBusBadge"
-CONSTANT: kIODeviceIconKey "IODeviceIcon"
-
-CONSTANT: kIOPlatformSerialNumberKey "IOPlatformSerialNumber"
-
-CONSTANT: kIOPlatformUUIDKey "IOPlatformUUID"
-
-CONSTANT: kIONVRAMDeletePropertyKey "IONVRAM-DELETE-PROPERTY"
-CONSTANT: kIODTNVRAMPanicInfoKey "aapl,panic-info"
-
-CONSTANT: kIOBootDeviceKey "IOBootDevice"
-CONSTANT: kIOBootDevicePathKey "IOBootDevicePath"
-CONSTANT: kIOBootDeviceSizeKey "IOBootDeviceSize"
-
-CONSTANT: kOSBuildVersionKey "OS Build Version"
-
-CONSTANT: kNilOptions 0
-
-TYPEDEF: uint mach_port_t
-TYPEDEF: int kern_return_t
-TYPEDEF: int boolean_t
-TYPEDEF: mach_port_t io_object_t
-TYPEDEF: io_object_t io_iterator_t
-TYPEDEF: io_object_t io_registry_entry_t
-TYPEDEF: io_object_t io_service_t
-TYPEDEF: char[128] io_name_t
-TYPEDEF: char[512] io_string_t
-TYPEDEF: kern_return_t IOReturn
-
-TYPEDEF: uint IOOptionBits
-
-CONSTANT: MACH_PORT_NULL 0
-CONSTANT: KERN_SUCCESS 0
-
-FUNCTION: IOReturn IOMasterPort ( mach_port_t bootstrap, mach_port_t* master ) ;
-
-FUNCTION: CFDictionaryRef IOServiceMatching ( char* name ) ;
-FUNCTION: CFDictionaryRef IOServiceNameMatching ( char* name ) ;
-FUNCTION: CFDictionaryRef IOBSDNameMatching ( char* name ) ;
-
-FUNCTION: IOReturn IOObjectRetain ( io_object_t o ) ;
-FUNCTION: IOReturn IOObjectRelease ( io_object_t o ) ;
-
-FUNCTION: IOReturn IOServiceGetMatchingServices ( mach_port_t master, CFDictionaryRef matchingDict, io_iterator_t* iterator ) ;
-
-FUNCTION: io_object_t IOIteratorNext ( io_iterator_t i ) ;
-FUNCTION: void IOIteratorReset ( io_iterator_t i ) ;
-FUNCTION: boolean_t IOIteratorIsValid ( io_iterator_t i ) ;
-
-FUNCTION: IOReturn IORegistryEntryGetPath ( io_registry_entry_t entry, io_name_t plane, io_string_t path ) ;
-
-FUNCTION: IOReturn IORegistryEntryCreateCFProperties ( io_registry_entry_t entry, CFMutableDictionaryRef properties, CFAllocatorRef allocator, IOOptionBits options ) ;
-
-FUNCTION: char* mach_error_string ( IOReturn error ) ;
-
-TUPLE: mach-error error-code ;
-C: <mach-error> mach-error
-
-M: mach-error error.
- "IOKit call failed: " print error-code>> mach_error_string print ;
-
-: mach-error ( return -- )
- dup KERN_SUCCESS = [ drop ] [ <mach-error> throw ] if ;
-
-: master-port ( -- port )
- MACH_PORT_NULL 0 <uint> [ IOMasterPort mach-error ] keep *uint ;
-
-: io-services-matching-dictionary ( nsdictionary -- iterator )
- master-port swap 0 <uint>
- [ IOServiceGetMatchingServices mach-error ] keep
- *uint ;
-
-: io-services-matching-service ( service -- iterator )
- IOServiceMatching io-services-matching-dictionary ;
-: io-services-matching-service-name ( service-name -- iterator )
- IOServiceNameMatching io-services-matching-dictionary ;
-: io-services-matching-bsd-name ( bsd-name -- iterator )
- IOBSDNameMatching io-services-matching-dictionary ;
-
-: retain-io-object ( o -- o )
- [ IOObjectRetain mach-error ] keep ;
-: release-io-object ( o -- )
- IOObjectRelease mach-error ;
-
-: io-objects-from-iterator* ( i -- i array )
- [ dup IOIteratorNext dup MACH_PORT_NULL = not ] [ ] produce nip ;
-
-: io-objects-from-iterator ( i -- array )
- io-objects-from-iterator* [ release-io-object ] dip ;
-
-: properties-from-io-object ( o -- o nsdictionary )
- dup f <void*> [
- kCFAllocatorDefault kNilOptions
- IORegistryEntryCreateCFProperties mach-error
- ]
- keep *void* ;
-
+++ /dev/null
-Bindings to Apple IOKit device interface
+++ /dev/null
-bindings
-unportable
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 ;
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 )
<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 ;
! 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)
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 ;
"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 ;
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 ;
: (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*
[ part new annotate-message irc-send ]
[ name>> unregister-chat ] bi ;
-: (terminate-irc) ( -- )
- irc> dup is-running>> [
- f >>is-running
- [ stream>> dispose ] keep
- [ in-messages>> ] [ out-messages>> ] bi 2array
- [ irc-end swap mailbox-put ] each
- ] [ drop ] if ;
-
-: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
\ No newline at end of file
+: (speak) ( message irc-chat -- ) swap annotate-message irc-send ;
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 ;
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 ;
"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 ;
] [
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 ;
! 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
GENERIC: fill-irc-message-slots ( irc-message -- )
M: irc-message fill-irc-message-slots
+ gmt >>timestamp
{
[ process-irc-trailing ]
[ process-irc-prefix ]
{ name "nickname" }
{ trailing "Nickname is already in use" } } }
[ ":ircserver.net 433 * nickname :Nickname is already in use"
- string>irc-message f >>timestamp ] unit-test
\ No newline at end of file
+ string>irc-message f >>timestamp ] unit-test
+
+{ t } [ ":someuser!n=user@some.where PRIVMSG #factortest :\ 1ACTION jumps!\ 1"
+ string>irc-message action? ] unit-test
! 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
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 ;
! 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
[ >>trailing ]
tri*
[ (>>prefix) ] [ fill-irc-message-slots ] [ swap >>line ] tri
- now >>timestamp dup sender >>sender ;
+ dup sender >>sender ;
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
[ 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 ;
[ 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 ] }
{ deploy-math? t }
{ "stop-after-last-window?" t }
{ deploy-ui? t }
- { deploy-compiler? t }
}
: 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
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 ;
SYMBOL: current-git-id
-ERROR: output-process-error { output string } { process process } ;
-
-M: output-process-error error.
- [ "Process:" print process>> . nl ]
- [ "Output:" print output>> print ]
- bi ;
-
-: try-output-process ( command -- )
- >process +stdout+ >>stderr utf8 <process-reader*>
- [ stream-contents ] [ dup wait-for-process ] bi*
- 0 = [ 2drop ] [ output-process-error ] if ;
+: 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
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 ;
: 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 ( -- )
] { } make prepend
[ 5 ] 2dip '[
<process>
- _ >>command
_ [ +closed+ ] unless* >>stdin
- try-output-process
+ _ >>command
+ short-running-process
] retry
] [ 2drop ] if ;
: 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 -- )
- "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
\ No newline at end of file
+ "Uploaded " prepend [ print flush ] [ mason-tweet ] bi ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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
! 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" ? ;
! 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 ;
: 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 {
:: 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>
USING: tools.deploy.config ;
H{
- { deploy-threads? t }
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
{ deploy-math? t }
- { deploy-name "Maze" }
+ { deploy-io 2 }
{ deploy-c-types? f }
+ { deploy-name "Maze" }
{ deploy-word-props? f }
- { deploy-io 2 }
- { deploy-ui? t }
- { "stop-after-last-window?" t }
{ deploy-word-defs? f }
- { deploy-compiler? t }
- { deploy-reflection 1 }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
}
{ "stop-after-last-window?" t }
{ deploy-ui? t }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-name "Merger" }
{ deploy-word-props? f }
{ deploy-threads? t }
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
[ ] [ name>> ] bi H{ } clone [ set-at ] keep
] [ 2drop H{ } clone ] if ;
+
+
PRIVATE>
: MDB_ADDON_SLOTS ( -- slots )
[ drop MDB_USER_KEY set-word-prop ] [ 3drop ] if ; inline
: set-index-map ( class index-list -- )
- [ [ dup user-defined-key-index ] dip index-list>map ] output>sequence
+ [ dup user-defined-key-index ] dip index-list>map 2array
assoc-combine MDB_INDEX_MAP set-word-prop ; inline
M: tuple-class tuple-collection ( tuple -- mdb-collection )
<update> >upsert update ] assoc-each ; inline
PRIVATE>
-: save-tuple ( tuple -- )
- tuple>storable [ (save-tuples) ] assoc-each ;
+: save-tuple-deep ( tuple -- )
+ tuple>storable [ (save-tuples) ] assoc-each ;
: update-tuple ( tuple -- )
- save-tuple ;
+ [ tuple-collection name>> ]
+ [ id-selector ]
+ [ tuple>assoc ] tri
+ <update> update ;
+
+: save-tuple ( tuple -- )
+ update-tuple ;
: insert-tuple ( tuple -- )
- save-tuple ;
+ [ tuple-collection name>> ]
+ [ tuple>assoc ] bi
+ save ;
: delete-tuple ( tuple -- )
[ tuple-collection name>> ] keep
id-selector delete ;
+: delete-tuples ( seq -- )
+ [ delete-tuple ] each ;
+
: tuple>query ( tuple -- query )
[ tuple-collection name>> ] keep
tuple>selector <query> ;
{ deploy-ui? t }
{ deploy-io 1 }
{ deploy-reflection 1 }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-word-props? f }
{ deploy-c-types? f }
: zoom-demo-world ( distance gadget -- )
[ + ] with change-distance relayout-1 ;
-M: demo-world focusable-child* ( world -- gadget )
- drop t ;
-
M: demo-world pref-dim* ( gadget -- dim )
drop { 640 480 } ;
--- /dev/null
+! 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 ;
--- /dev/null
+Bruno Deferrari
--- /dev/null
+Assoc protocol implementation for Redis
! 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
: 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 ;
#! 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
USING: tools.deploy.config ;
H{
- { deploy-reflection 1 }
+ { deploy-c-types? f }
+ { deploy-unicode? f }
{ deploy-word-defs? f }
- { deploy-word-props? f }
{ deploy-name "Spheres" }
- { deploy-compiler? t }
+ { "stop-after-last-window?" t }
+ { deploy-reflection 1 }
+ { deploy-ui? t }
{ deploy-math? t }
{ deploy-io 1 }
+ { deploy-word-props? f }
{ deploy-threads? t }
- { "stop-after-last-window?" t }
- { deploy-ui? t }
- { deploy-c-types? f }
}
{ deploy-word-defs? f }
{ deploy-name "Sudoku" }
{ deploy-threads? f }
- { deploy-compiler? t }
{ deploy-math? t }
{ deploy-c-types? f }
{ deploy-io 2 }
--- /dev/null
+USING: tools.deploy.config ;
+H{
+ { deploy-ui? t }
+ { deploy-reflection 1 }
+ { deploy-unicode? f }
+ { deploy-math? t }
+ { deploy-io 2 }
+ { deploy-c-types? f }
+ { deploy-name "Terrain" }
+ { deploy-word-props? f }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-threads? t }
+}
void main()
{
- vec4 v = vec4(gl_Vertex.xy, -1.0, 1.0);
+ vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0);
gl_Position = v;
+
+ 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)
- * (gl_ModelViewMatrixInverse * vec4(v.xyz, 0.0)).xyz;
+ * (gl_ModelViewMatrixInverse * vec4(p.xyz, 0.0)).xyz;
}
;
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 combinators.short-circuit ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: VELOCITY-MODIFIER-NORMAL { 1.0 1.0 1.0 }
+CONSTANT: VELOCITY-MODIFIER-FAST { 2.0 1.0 2.0 }
CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
CONSTANT: JUMP $[ 1.0 1024.0 / ]
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
CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
TUPLE: player
- location yaw pitch velocity ;
+ location yaw pitch velocity velocity-modifier
+ reverse-time ;
TUPLE: terrain-world < game-world
player
sky-image sky-texture sky-program
terrain terrain-segment terrain-texture terrain-program
- terrain-vertex-buffer ;
+ terrain-vertex-buffer
+ history ;
+
+: <player> ( -- player )
+ player new
+ PLAYER-START-LOCATION >>location
+ 0.0 >>yaw
+ 0.0 >>pitch
+ { 0.0 0.0 0.0 } >>velocity
+ VELOCITY-MODIFIER-NORMAL >>velocity-modifier ;
M: terrain-world tick-length
drop 1000 30 /i ;
: 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 ;
: 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
+ VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier)
+
+ {
+ [ key-1 keys nth 1 f ? ]
+ [ key-2 keys nth 2 f ? ]
+ [ key-3 keys nth 3 f ? ]
+ [ key-4 keys nth 4 f ? ]
+ [ key-5 keys nth 10000 f ? ]
+ } 0|| player (>>reverse-time)
+
key-w keys nth [ player walk-forward ] when
key-s keys nth [ player walk-backward ] when
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 ;
[ [ 1 ] 2dip [ max ] with change-nth ]
[ ] tri ;
-: tick-player ( world player -- )
+: scaled-velocity ( player -- velocity )
+ [ velocity>> ] [ velocity-modifier>> ] bi v* ;
+
+: save-history ( world player -- )
+ clone swap history>> push ;
+
+:: tick-player-reverse ( world player -- )
+ player reverse-time>> :> reverse-time
+ world history>> :> history
+ history length 0 > [
+ history length reverse-time 1 - - 1 max history set-length
+ history pop world (>>player)
+ ] when ;
+
+: tick-player-forward ( world player -- )
+ 2dup save-history
[ apply-friction apply-gravity ] change-velocity
- dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
+ dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
drop ;
+: tick-player ( world player -- )
+ dup reverse-time>> [
+ tick-player-reverse
+ ] [
+ tick-player-forward
+ ] if ;
+
M: terrain-world tick*
[ dup focused?>> [ handle-input ] [ drop ] if ]
[ dup player>> tick-player ] bi ;
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> >>player
+ V{ } clone >>history
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
USING: tools.deploy.config ;
H{
{ deploy-ui? t }
- { deploy-compiler? t }
{ deploy-threads? t }
{ deploy-word-props? f }
{ deploy-reflection 1 }
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! 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 ;
\ No newline at end of file
{ deploy-threads? f }
{ deploy-word-defs? f }
{ deploy-ui? f }
- { deploy-compiler? t }
{ deploy-word-props? f }
{ "stop-after-last-window?" t }
{ deploy-unicode? f }
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)
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();
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);
#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));
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);
-
- frames = allot_array_internal<array>(frame_count);
+ stack_frame_counter counter;
+ iterate_callstack_object(callstack.untagged(),counter);
- frame_index = 0;
- iterate_callstack_object(callstack.untagged(),stack_frame_to_array);
+ stack_frame_accumulator accum(counter.count);
+ iterate_callstack_object(callstack.untagged(),accum);
- dpush(tag<array>(frames));
+ dpush(tag<array>(accum.frames));
}
stack_frame *innermost_stack_frame(callstack *stack)
return sizeof(callstack) + size;
}
-typedef void (*CALLSTACK_ITER)(stack_frame *frame);
-
stack_frame *fix_callstack_top(stack_frame *top, stack_frame *bottom);
-void iterate_callstack(cell top, cell bottom, CALLSTACK_ITER iterator);
-void iterate_callstack_object(callstack *stack, CALLSTACK_ITER iterator);
stack_frame *frame_successor(stack_frame *frame);
code_block *frame_code(stack_frame *frame);
cell frame_executing(stack_frame *frame);
VM_ASM_API void save_callstack_bottom(stack_frame *callstack_bottom);
+template<typename T> void iterate_callstack(cell top, cell bottom, T &iterator)
+{
+ stack_frame *frame = (stack_frame *)bottom - 1;
+
+ while((cell)frame >= top)
+ {
+ iterator(frame);
+ frame = frame_successor(frame);
+ }
+}
+
+template<typename T> void iterate_callstack_object(callstack *stack, T &iterator)
+{
+ iterate_callstack((cell)stack->top(),(cell)stack->bottom(),iterator);
+}
+
}
else
{
quotation *quot = untag<quotation>(tagged_quot);
- if(quot->compiledp == F)
- return w->xt;
- else
+ if(quot->code)
return quot->xt;
+ else
+ return w->xt;
}
}
case QUOTATION_TYPE:
{
quotation *q = (quotation *)object;
- if(q->compiledp != F)
+ if(q->code)
mark_code_block(q->code);
break;
}
{
quotation *quot = untag<quotation>(obj);
- if(quot->compiledp != F)
+ if(quot->code)
quot->code = forward_xt(quot->code);
}
break;
}
}
- /* End the heap scan */
- gc_off = false;
+ end_scan();
}
/* Set the XT fields now that the heap has been compacted */
case QUOTATION_TYPE:
{
quotation *quot = untag<quotation>(obj);
- if(quot->compiledp != F)
+ if(quot->code)
set_quot_xt(quot,quot->code);
break;
}
}
}
- /* End the heap scan */
- gc_off = false;
+ end_scan();
}
/* Move all free space to the end of the code heap. This is not very efficient,
/* Note that the XT is passed to the quotation in r11 */
#define CALL_OR_JUMP_QUOT \
- lwz r11,16(r3) /* load quotation-xt slot */ XX \
+ lwz r11,12(r3) /* load quotation-xt slot */ XX \
#define CALL_QUOT \
CALL_OR_JUMP_QUOT XX \
pop %ebp ; \
pop %ebx
-#define QUOT_XT_OFFSET 16
+#define QUOT_XT_OFFSET 12
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
#endif
-#define QUOT_XT_OFFSET 36
+#define QUOT_XT_OFFSET 28
/* We pass a function pointer to memcpy to work around a Mac OS X
ABI limitation which would otherwise require us to do a bizzaro PC-relative
gc_off = true;
}
+void end_scan()
+{
+ gc_off = false;
+}
+
PRIMITIVE(begin_scan)
{
begin_scan();
gc_off = false;
}
-cell find_all_words()
+template<typename T> void each_object(T &functor)
{
- growable_array words;
-
begin_scan();
-
cell obj;
while((obj = next_object()) != F)
- {
- if(tagged<object>(obj).type_p(WORD_TYPE))
- words.add(obj);
- }
+ functor(tagged<object>(obj));
+ end_scan();
+}
- /* End heap scan */
- gc_off = false;
+namespace
+{
+
+struct word_counter {
+ cell count;
+ word_counter() : count(0) {}
+ void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) count++; }
+};
+
+struct word_accumulator {
+ growable_array words;
+ word_accumulator(int count) : words(count) {}
+ void operator()(tagged<object> obj) { if(obj.type_p(WORD_TYPE)) words.add(obj.value()); }
+};
+
+}
- words.trim();
- return words.elements.value();
+cell find_all_words()
+{
+ word_counter counter;
+ each_object(counter);
+ word_accumulator accum(counter.count);
+ each_object(accum);
+ accum.words.trim();
+ return accum.words.elements.value();
}
}
cell object_size(cell tagged);
void begin_scan();
+void end_scan();
cell next_object();
PRIMITIVE(data_room);
}
}
- /* end scan */
- gc_off = false;
+ end_scan();
}
cell look_for;
while((obj = next_object()) != F)
do_slots(UNTAG(obj),find_data_references_step);
- /* end scan */
- gc_off = false;
+ end_scan();
}
/* Dump all code blocks for debugging */
static void fixup_quotation(quotation *quot)
{
- if(quot->compiledp == F)
- quot->xt = (void *)lazy_jit_compile;
- else
+ if(quot->code)
{
code_fixup("->xt);
code_fixup("->code);
}
+ else
+ quot->xt = (void *)lazy_jit_compile;
}
static void fixup_alien(alien *d)
return type < HEADER_TYPE ? type : OBJECT_TYPE;
}
-class object;
+struct object;
struct header {
cell value;
/* tagged */
cell array;
/* tagged */
- cell compiledp;
- /* tagged */
cell cached_effect;
/* tagged */
cell cache_counter;
#include <stdlib.h>
#include <string.h>
#include <time.h>
-#include <unistd.h>
-#include <sys/param.h>
/* C++ headers */
#if __GNUC__ == 4
#ifdef SYS_inotify_init
-int inotify_init()
+VM_C_API int inotify_init()
{
return syscall(SYS_inotify_init);
}
-int inotify_add_watch(int fd, const char *name, u32 mask)
+VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
return syscall(SYS_inotify_add_watch, fd, name, mask);
}
-int inotify_rm_watch(int fd, u32 wd)
+VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
return syscall(SYS_inotify_rm_watch, fd, wd);
}
#else
-int inotify_init()
+VM_C_API int inotify_init()
{
not_implemented_error();
return -1;
}
-int inotify_add_watch(int fd, const char *name, u32 mask)
+VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask)
{
not_implemented_error();
return -1;
}
-int inotify_rm_watch(int fd, u32 wd)
+VM_C_API int inotify_rm_watch(int fd, u32 wd)
{
not_implemented_error();
return -1;
namespace factor
{
-int inotify_init();
-int inotify_add_watch(int fd, const char *name, u32 mask);
-int inotify_rm_watch(int fd, u32 wd);
+VM_C_API int inotify_init();
+VM_C_API int inotify_add_watch(int fd, const char *name, u32 mask);
+VM_C_API int inotify_rm_watch(int fd, u32 wd);
}
+#include <unistd.h>
+#include <sys/param.h>
#include <dirent.h>
#include <sys/mman.h>
#include <sys/types.h>
#define FSEEK fseeko
#define FIXNUM_FORMAT "%ld"
-#define cell_FORMAT "%lu"
-#define cell_HEX_FORMAT "%lx"
+#define CELL_FORMAT "%lu"
+#define CELL_HEX_FORMAT "%lx"
#ifdef FACTOR_64
- #define cell_HEX_PAD_FORMAT "%016lx"
+ #define CELL_HEX_PAD_FORMAT "%016lx"
#else
- #define cell_HEX_PAD_FORMAT "%08lx"
+ #define CELL_HEX_PAD_FORMAT "%08lx"
#endif
#define FIXNUM_FORMAT "%ld"
#define FSEEK fseek
#ifdef WIN64
- #define cell_FORMAT "%Iu"
- #define cell_HEX_FORMAT "%Ix"
- #define cell_HEX_PAD_FORMAT "%016Ix"
+ #define CELL_FORMAT "%Iu"
+ #define CELL_HEX_FORMAT "%Ix"
+ #define CELL_HEX_PAD_FORMAT "%016Ix"
#define FIXNUM_FORMAT "%Id"
#else
- #define cell_FORMAT "%lu"
- #define cell_HEX_FORMAT "%lx"
- #define cell_HEX_PAD_FORMAT "%08lx"
+ #define CELL_FORMAT "%lu"
+ #define CELL_HEX_FORMAT "%lx"
+ #define CELL_HEX_PAD_FORMAT "%08lx"
#define FIXNUM_FORMAT "%ld"
#endif
primitive_reset_inline_cache_stats,
primitive_inline_cache_stats,
primitive_optimized_p,
+ primitive_quot_compiled_p,
};
}
quot->code = code;
quot->xt = code->xt();
- quot->compiledp = T;
}
/* Allocates memory */
void jit_compile(cell quot_, bool relocating)
{
gc_root<quotation> quot(quot_);
- if(quot->compiledp != F) return;
+ if(quot->code) return;
quotation_jit compiler(quot.value(),true,relocating);
compiler.iterate_quotation();
{
quotation *quot = allot<quotation>(sizeof(quotation));
quot->array = dpeek();
- quot->xt = (void *)lazy_jit_compile;
- quot->compiledp = F;
quot->cached_effect = F;
quot->cache_counter = F;
+ quot->xt = (void *)lazy_jit_compile;
+ quot->code = NULL;
drepl(tag<quotation>(quot));
}
return quot.value();
}
+PRIMITIVE(quot_compiled_p)
+{
+ tagged<quotation> quot(dpop());
+ quot.untag_check();
+ dpush(tag_boolean(quot->code != NULL));
+}
+
}
VM_ASM_API cell lazy_jit_compile_impl(cell quot, stack_frame *stack);
+PRIMITIVE(quot_compiled_p);
+
}
void print_cell(cell x)
{
- printf(cell_FORMAT,x);
+ printf(CELL_FORMAT,x);
}
void print_cell_hex(cell x)
{
- printf(cell_HEX_FORMAT,x);
+ printf(CELL_HEX_FORMAT,x);
}
void print_cell_hex_pad(cell x)
{
- printf(cell_HEX_PAD_FORMAT,x);
+ printf(CELL_HEX_PAD_FORMAT,x);
}
void print_fixnum(fixnum x)
cell read_cell_hex()
{
cell cell;
- if(scanf(cell_HEX_FORMAT,&cell) < 0) exit(1);
+ if(scanf(CELL_HEX_FORMAT,&cell) < 0) exit(1);
return cell;
};
projects / factor.git / commitdiff