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>> dup 8 > [ "oops" throw ] when 8 = [
+ new-byte bits>> bs bytes>> push
+ zero-widthed bs (>>widthed)
+ remainder widthed>bytes
+ [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
] [
- 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>> ;
{ "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 ;
: 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 [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] 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 )
--- /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
+
+: 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 { 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)
+ 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
--- /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>> ;
+
+: decode-png ( image -- image )
+ {
+ [ zlib-data zlib-inflate ]
+ [ dim>> first 3 * 1 + group reverse-png-filter ]
+ [ swap >byte-array >>bitmap drop ]
+ [ RGB >>component-order drop ]
+ [ ]
+ } cleave ;
+
: load-png ( path -- image )
[ binary <file-reader> ] [ file-info size>> ] bi
stream-throws <limited-stream> [
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
{
{ +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 -- )
! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel system sequences combinators
-vocabs.loader io.files.types math ;
+vocabs.loader io.files.types io.directories math ;
IN: io.files.info
! File info
{ [ 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 )
--- /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
{ 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 ] }
<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 ] ;
2drop ;
: strip-compiler-classes ( -- )
- "Stripping compiler classes" show
- { "compiler" "stack-checker" }
- [ child-vocabs [ words ] map concat [ class? ] filter ] map concat
- [ dup implementors [ "methods" word-prop delete-at ] with each ] each ;
+ strip-dictionary? [
+ "Stripping compiler classes" show
+ { "compiler" "stack-checker" }
+ [ child-vocabs [ words ] map concat [ class? ] filter ] map concat
+ [ dup implementors [ "methods" word-prop delete-at ] with each ] each
+ ] when ;
: strip-default-methods ( -- )
strip-debugger? [
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 ( -- )
[ 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
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 ;
{ { $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 } } }
: 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* ;
alien.c-types arrays accessors combinators ;
IN: unix.stat
-! stat64
+! Ubuntu 7.10 64-bit
+
C-STRUCT: stat
- { "dev_t" "st_dev" }
- { "ushort" "__pad1" }
- { "__ino_t" "__st_ino" }
- { "mode_t" "st_mode" }
- { "nlink_t" "st_nlink" }
- { "uid_t" "st_uid" }
- { "gid_t" "st_gid" }
- { "dev_t" "st_rdev" }
- { { "ushort" 2 } "__pad2" }
- { "off64_t" "st_size" }
- { "blksize_t" "st_blksize" }
- { "blkcnt64_t" "st_blocks" }
- { "timespec" "st_atimespec" }
- { "timespec" "st_mtimespec" }
- { "timespec" "st_ctimespec" }
- { "ulonglong" "st_ino" } ;
+ { "dev_t" "st_dev" }
+ { "ino_t" "st_ino" }
+ { "nlink_t" "st_nlink" }
+ { "mode_t" "st_mode" }
+ { "uid_t" "st_uid" }
+ { "gid_t" "st_gid" }
+ { "int" "pad0" }
+ { "dev_t" "st_rdev" }
+ { "off64_t" "st_size" }
+ { "blksize_t" "st_blksize" }
+ { "blkcnt64_t" "st_blocks" }
+ { "timespec" "st_atimespec" }
+ { "timespec" "st_mtimespec" }
+ { "timespec" "st_ctimespec" }
+ { "long" "__unused0" }
+ { "long" "__unused1" }
+ { "long" "__unused2" } ;
FUNCTION: int __xstat64 ( int ver, char* pathname, stat* buf ) ;
FUNCTION: int __lxstat64 ( int ver, char* pathname, stat* buf ) ;
-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? ;
[ 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
+++ /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 ;
-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 ;
: gesture-logger ( -- )
[
<pane> t >>scrolls? dup <scroller>
+ { 450 500 } >>pref-dim
"Gesture log" open-window
<pane-stream> <gesture-logger>
"Gesture input" open-window
+++ /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 ;
[ 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 ] }
: 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
+: 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 ( -- )
<process>
_ [ +closed+ ] unless* >>stdin
_ >>command
- try-output-process
+ 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 -- )
--- /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>
--- /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
vec4 v = vec4(gl_Vertex.xy, 1.0, 1.0);
gl_Position = v;
- vec4 p = (gl_ProjectionMatrixInverse * v) * vec4(1,1,-1,1);
+ vec4 p = gl_ProjectionMatrixInverse * v;
+ p.z = -abs(p.z);
float s = sin(sky_theta), c = cos(sky_theta);
direction = mat3(1, 0, 0, 0, c, s, 0, -s, c)
sequences sequences.product specialized-arrays.float
terrain.generation terrain.shaders ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats game-worlds method-chains
-math.affine-transforms noise ;
+math.affine-transforms noise ui.gestures ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
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 ;
TUPLE: terrain-world < game-world
player
: 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 [
+ { 2.0 1.0 2.0 } player (>>velocity-modifier)
+ ] when
+ key-left-shift keys nth [
+ { 1.0 1.0 1.0 } player (>>velocity-modifier)
+ ] unless
+
key-w keys nth [ player walk-forward ] when
key-s keys nth [ player walk-backward ] when
key-a keys nth [ player walk-leftward ] when
key-d keys nth [ player walk-rightward ] when
+ key-q keys nth [ player -1 look-horizontally ] when
+ key-e keys nth [ player 1 look-horizontally ] when
+ key-left-arrow keys nth [ player -1 look-horizontally ] when
+ key-right-arrow keys nth [ player 1 look-horizontally ] when
+ key-down-arrow keys nth [ player 1 look-vertically ] when
+ key-up-arrow keys nth [ player -1 look-vertically ] when
key-space keys nth [ player jump ] when
key-escape keys nth [ world close-window ] when
player read-mouse rotate-with-mouse
reset-mouse ;
: apply-friction ( velocity -- velocity' )
- FRICTION v*n ;
+ FRICTION v* ;
: apply-gravity ( velocity -- velocity' )
1 over [ GRAVITY - ] change-nth ;
[ [ 1 ] 2dip [ max ] with change-nth ]
[ ] tri ;
+: scaled-velocity ( player -- velocity )
+ [ velocity>> ] [ velocity-modifier>> ] bi v* ;
+
: tick-player ( world player -- )
[ apply-friction apply-gravity ] change-velocity
- dup velocity>> [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
+ dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
drop ;
M: terrain-world tick*
GL_DEPTH_TEST glEnable
GL_TEXTURE_2D glEnable
GL_VERTEX_ARRAY glEnableClientState
- PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } player boa >>player
+ PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
--- /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
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);
+}
+
}
}
}
- /* End the heap scan */
- gc_off = false;
+ end_scan();
}
/* Set the XT fields now that the heap has been compacted */
}
}
- /* 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,
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 */
return type < HEADER_TYPE ? type : OBJECT_TYPE;
}
-class object;
+struct object;
struct header {
cell value;
#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
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