io.streams.byte-array ;
IN: bitstreams.tests
-[ 1 t ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> read-bit ] unit-test
-[ 254 8 t ]
-[ B{ 254 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ BIN: 1111111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 10 swap peek
+] unit-test
-[ 4095 12 t ]
-[ B{ 255 255 } binary <byte-reader> <bitstream-reader> 12 swap read-bits ] unit-test
+[ BIN: 111111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 9 swap peek
+] unit-test
+
+[ BIN: 11111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 8 swap peek
+] unit-test
+
+[ BIN: 1111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 7 swap peek
+] unit-test
+
+[ BIN: 111111 ]
+[
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 6 swap peek
+] unit-test
-[ B{ 254 } ]
+[ BIN: 11111 ]
[
- binary <byte-writer> <bitstream-writer> 254 8 rot
- [ write-bits ] keep stream>> >byte-array
+ B{ HEX: 0f HEX: ff HEX: ff HEX: ff } <msb0-bit-reader>
+ 2 >>byte-pos 6 >>bit-pos
+ 5 swap peek
] unit-test
-[ 255 8 t ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
+[ B{ } <msb0-bit-reader> 5 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 1 swap peek ] must-fail
+[ B{ } <msb0-bit-reader> 8 swap peek ] must-fail
-[ 255 8 f ]
-[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
+[ 0 ] [ B{ } <msb0-bit-reader> 0 swap peek ] unit-test
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors byte-arrays destructors fry io kernel locals
-math sequences ;
+USING: accessors alien.accessors assocs byte-arrays combinators
+constructors destructors fry io io.binary io.encodings.binary
+io.streams.byte-array kernel locals macros math math.ranges
+multiline sequences sequences.private vectors byte-vectors
+combinators.short-circuit math.bitwise ;
IN: bitstreams
-TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
-TUPLE: bitstream-reader < bitstream ;
+TUPLE: widthed { bits integer read-only } { #bits integer read-only } ;
-: reset-bitstream ( stream -- stream )
- 0 >>#bits 0 >>current-bits ; inline
+ERROR: invalid-widthed bits #bits ;
-: new-bitstream ( stream class -- bitstream )
+: check-widthed ( bits #bits -- bits #bits )
+ dup 0 < [ invalid-widthed ] when
+ 2dup { [ nip 0 = ] [ drop 0 = not ] } 2&& [ invalid-widthed ] when
+ over 0 = [
+ 2dup [ dup 0 < [ neg ] when log2 1 + ] dip > [ invalid-widthed ] when
+ ] unless ;
+
+: <widthed> ( bits #bits -- widthed )
+ check-widthed
+ widthed boa ;
+
+: zero-widthed ( -- widthed ) 0 0 <widthed> ;
+: zero-widthed? ( widthed -- ? ) zero-widthed = ;
+
+TUPLE: bit-reader
+ { bytes byte-array }
+ { byte-pos array-capacity initial: 0 }
+ { bit-pos array-capacity initial: 0 } ;
+
+TUPLE: bit-writer
+ { bytes byte-vector }
+ { widthed widthed } ;
+
+TUPLE: msb0-bit-reader < bit-reader ;
+TUPLE: lsb0-bit-reader < bit-reader ;
+CONSTRUCTOR: msb0-bit-reader ( bytes -- bs ) ;
+CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ;
+
+TUPLE: msb0-bit-writer < bit-writer ;
+TUPLE: lsb0-bit-writer < bit-writer ;
+
+: new-bit-writer ( class -- bs )
new
- swap >>stream
- reset-bitstream ; inline
+ BV{ } clone >>bytes
+ 0 0 <widthed> >>widthed ; inline
-M: bitstream-reader dispose ( stream -- )
- stream>> dispose ;
+: <msb0-bit-writer> ( -- bs )
+ msb0-bit-writer new-bit-writer ;
-: <bitstream-reader> ( stream -- bitstream )
- bitstream-reader new-bitstream ; inline
+: <lsb0-bit-writer> ( -- bs )
+ lsb0-bit-writer new-bit-writer ;
-: read-next-byte ( bitstream -- bitstream )
- dup stream>> stream-read1 [
- >>current-bits 8 >>#bits
- ] [
- 0 >>#bits
- t >>end-of-stream?
- ] if* ;
+GENERIC: peek ( n bitstream -- value )
+GENERIC: poke ( value n bitstream -- )
-: maybe-read-next-byte ( bitstream -- bitstream )
- dup #bits>> 0 = [ read-next-byte ] when ; inline
+: seek ( n bitstream -- )
+ {
+ [ byte-pos>> 8 * ]
+ [ bit-pos>> + + 8 /mod ]
+ [ (>>bit-pos) ]
+ [ (>>byte-pos) ]
+ } cleave ; inline
-: shift-one-bit ( bitstream -- n )
- [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
+: read ( n bitstream -- value )
+ [ peek ] [ seek ] 2bi ; inline
-: next-bit ( bitstream -- n/f ? )
- maybe-read-next-byte
- dup end-of-stream?>> [
- drop f
- ] [
- [ shift-one-bit ]
- [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
- ] if dup >boolean ;
-
-: read-bit ( bitstream -- n ? )
- dup #bits>> 1 = [
- [ current-bits>> 1 bitand ]
- [ read-next-byte drop ] bi t
+<PRIVATE
+
+ERROR: not-enough-bits widthed n ;
+
+: widthed-bits ( widthed n -- bits )
+ dup 0 < [ not-enough-bits ] when
+ 2dup [ #bits>> ] dip < [ not-enough-bits ] when
+ [ [ bits>> ] [ #bits>> ] bi ] dip
+ [ - neg shift ] keep <widthed> ;
+
+: split-widthed ( widthed n -- widthed1 widthed2 )
+ 2dup [ #bits>> ] dip < [
+ drop zero-widthed
] [
- next-bit
- ] if ; inline
-
-: bits>integer ( seq -- n )
- 0 [ [ 1 shift ] dip bitor ] reduce ; inline
-
-: read-bits ( width bitstream -- n width ? )
- [
- '[ _ read-bit drop ] replicate
- [ f = ] trim-tail
- [ bits>integer ] [ length ] bi
- ] 2keep drop over = ;
-
-TUPLE: bitstream-writer < bitstream ;
-
-: <bitstream-writer> ( stream -- bitstream )
- bitstream-writer new-bitstream ; inline
-
-: write-bit ( n bitstream -- )
- [ 1 shift bitor ] change-current-bits
- [ 1+ ] change-#bits
- dup #bits>> 8 = [
- [ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
- [ reset-bitstream drop ] bi
+ [ widthed-bits ]
+ [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep <widthed> ] 2bi
+ ] if ;
+
+: widthed>bytes ( widthed -- bytes widthed )
+ [ 8 split-widthed dup zero-widthed? not ]
+ [ swap bits>> ] B{ } produce-as nip swap ;
+
+:: |widthed ( widthed1 widthed2 -- widthed3 )
+ widthed1 bits>> :> bits1
+ widthed1 #bits>> :> #bits1
+ widthed2 bits>> :> bits2
+ widthed2 #bits>> :> #bits2
+ bits1 #bits2 shift bits2 bitor
+ #bits1 #bits2 + <widthed> ;
+
+PRIVATE>
+
+M:: lsb0-bit-writer poke ( value n bs -- )
+ value n <widthed> :> widthed
+ widthed
+ bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte
+ byte bs widthed>> |widthed :> new-byte
+ new-byte #bits>> 8 = [
+ new-byte bits>> bs bytes>> push
+ zero-widthed bs (>>widthed)
+ remainder widthed>bytes
+ [ bs bytes>> push-all ] [ bs (>>widthed) ] bi*
] [
- drop
- ] if ; inline
+ byte bs (>>widthed)
+ ] if ;
-ERROR: invalid-bit-width n ;
+: enough-bits? ( n bs -- ? )
+ [ bytes>> length ]
+ [ byte-pos>> - 8 * ]
+ [ bit-pos>> - ] tri <= ;
-:: write-bits ( n width bitstream -- )
- n 0 < [ n invalid-bit-width ] when
- n 0 = [
- width [ 0 bitstream write-bit ] times
+ERROR: not-enough-bits n bit-reader ;
+
+: #bits>#bytes ( #bits -- #bytes )
+ 8 /mod 0 = [ 1 + ] unless ; inline
+
+:: subseq>bits-le ( bignum n bs -- bits )
+ bignum bs bit-pos>> neg shift n bits ;
+
+:: subseq>bits-be ( bignum n bs -- bits )
+ bignum
+ 8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when
+ neg shift n bits ;
+
+:: adjust-bits ( n bs -- )
+ n 8 /mod :> #bits :> #bytes
+ bs [ #bytes + ] change-byte-pos
+ bit-pos>> #bits + dup 8 >= [
+ 8 - bs (>>bit-pos)
+ bs [ 1 + ] change-byte-pos drop
] [
- width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
- n-length [
- n-length swap - 1- neg n swap shift 1 bitand
- bitstream write-bit
- ] each
+ bs (>>bit-pos)
] if ;
-: flush-bits ( bitstream -- ) stream>> stream-flush ;
+:: (peek) ( n bs endian> subseq-endian -- bits )
+ n bs enough-bits? [ n bs not-enough-bits ] unless
+ bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd +
+ bs bytes>> subseq endian> execute( seq -- x ) :> bignum
+ bignum n bs subseq-endian execute( bignum n bs -- bits ) ;
+
+M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ;
-: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
+M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
+
+:: bit-writer-bytes ( writer -- bytes )
+ writer widthed>> #bits>> :> n
+ n 0 = [
+ writer widthed>> bits>> 8 n - shift
+ writer bytes>> swap push
+ ] unless
+ writer bytes>> ;
--- /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 )
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
- [ gvim-path , "+" swap number>string append , , ] { } make ;
+ [
+ gvim-path ,
+ number>string "+" prepend , ,
+ ] { } make ;
gvim vim-editor set-global
IN: editors.macvim
-: macvim-location ( file line -- )
+: macvim ( file line -- )
drop
[ "open" , "-a" , "MacVim", , ] { } make
- try-process ;
-
-[ macvim-location ] edit-hook set-global
-
+ run-detached drop ;
+[ macvim ] edit-hook set-global
number>string "-goto:" prepend ,
] { } make ;
-: scite-location ( file line -- )
+: scite ( file line -- )
scite-command run-detached drop ;
-[ scite-location ] edit-hook set-global
+[ scite ] edit-hook set-global
namespaces prettyprint editors make ;
IN: editors.textedit
-: textedit-location ( file line -- )
+: textedit ( file line -- )
drop
[ "open" , "-a" , "TextEdit", , ] { } make
- try-process ;
+ run-detached drop ;
-[ textedit-location ] edit-hook set-global
+[ textedit ] edit-hook set-global
USING: definitions io.launcher kernel math math.parser parser
namespaces prettyprint editors make ;
-
IN: editors.textmate
-: textmate-location ( file line -- )
+: textmate ( file line -- )
[ "mate" , "-a" , "-l" , number>string , , ] { } make
- try-process ;
+ run-detached drop ;
-[ textmate-location ] edit-hook set-global
+[ textmate ] edit-hook set-global
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support"
-"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
+"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "."
$nl
"If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":"
{ $code
IN: editors.vim
SYMBOL: vim-path
-
SYMBOL: vim-editor
HOOK: vim-command vim-editor ( file line -- array )
M: vim vim-command
[
- vim-path get , swap , "+" swap number>string append ,
+ vim-path get ,
+ [ , ] [ number>string "+" prepend , ] bi*
] { } make ;
-: vim-location ( file line -- )
- vim-command try-process ;
+: vim ( file line -- )
+ vim-command run-detached drop ;
"vim" vim-path set-global
-[ vim-location ] edit-hook set-global
-vim vim-editor set-global
+[ vim ] edit-hook set-global
+\ vim vim-editor set-global
sequences locals combinators.short-circuit threads
namespaces assocs arrays combinators hints alien
core-foundation.run-loop accessors sequences.private
-alien.c-types math parser game-input vectors ;
+alien.c-types math parser game-input vectors bit-arrays ;
IN: game-input.iokit
SINGLETON: iokit-game-input-backend
iokit-game-input-backend game-input-backend set-global
-: hid-manager-matching ( matching-seq -- alien )
- f 0 IOHIDManagerCreate
- [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ]
- keep ;
+: make-hid-manager ( -- alien )
+ f 0 IOHIDManagerCreate ;
+
+: set-hid-manager-matching ( alien matching-seq -- )
+ >plist IOHIDManagerSetDeviceMatchingMultiple ;
: devices-from-hid-manager ( manager -- vector )
[
: ?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 )
rot ?set-nth
] [ 3drop ] if ;
-HINTS: record-keyboard { array alien } ;
+HINTS: record-keyboard { bit-array alien } ;
: record-mouse ( mouse-state value -- )
dup IOHIDValueGetElement {
4 <vector> +controller-states+ set-global
0 0 0 0 2 <vector> mouse-state boa
+mouse-state+ set-global
- 256 f <array> +keyboard-state+ set-global ;
+ 256 <bit-array> +keyboard-state+ set-global ;
M: iokit-game-input-backend (open-game-input)
- hid-manager-matching-game-devices {
+ make-hid-manager {
[ initialize-variables ]
[ device-matched-callback f IOHIDManagerRegisterDeviceMatchingCallback ]
[ device-removed-callback f IOHIDManagerRegisterDeviceRemovalCallback ]
[ device-input-callback f IOHIDManagerRegisterInputValueCallback ]
[ 0 IOHIDManagerOpen mach-error ]
+ [ game-devices-matching-seq set-hid-manager-matching ]
[
CFRunLoopGetMain CFRunLoopDefaultMode
IOHIDManagerScheduleWithRunLoop
--- /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 )
{ 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
+
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
- [ dup name>> file-info file-listing boa ] map
- _ [ sort-by ] when*
- [ _ [ file-spec>string ] with map ] map
+ [ dup name>> link-info file-listing boa ] map
+ _ [ sort-by ] when*
+ [ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline
: list-files ( listing-tool -- array )
[ file-systems-info ]
[ [ unparse ] map ] bi prefix simple-table. ;
-: file-systems. ( -- )
+CONSTANT: default-file-systems-spec
{
+device-name+ +available-space+ +free-space+ +used-space+
+total-space+ +percent-used+ +mount-point+
- } print-file-systems ;
+ }
+
+: file-systems. ( -- )
+ default-file-systems-spec print-file-systems ;
{
{ [ os unix? ] [ "tools.files.unix" ] }
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 ? -- )
[ enter-fullscreen ] [ exit-fullscreen ] if ;
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
]
}
: gesture-logger ( -- )
[
<pane> t >>scrolls? dup <scroller>
+ { 450 500 } >>pref-dim
"Gesture log" open-window
<pane-stream> <gesture-logger>
"Gesture input" open-window
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 ui.gestures ;
+math.affine-transforms noise ui.gestures combinators.short-circuit ;
IN: terrain
CONSTANT: FOV $[ 2.0 sqrt 1+ ]
CONSTANT: NEAR-PLANE $[ 1.0 1024.0 / ]
CONSTANT: FAR-PLANE 2.0
CONSTANT: PLAYER-START-LOCATION { 0.5 0.51 0.5 }
+CONSTANT: VELOCITY-MODIFIER-NORMAL { 1.0 1.0 1.0 }
+CONSTANT: VELOCITY-MODIFIER-FAST { 2.0 1.0 2.0 }
CONSTANT: PLAYER-HEIGHT $[ 1.0 256.0 / ]
CONSTANT: GRAVITY $[ 1.0 4096.0 / ]
CONSTANT: JUMP $[ 1.0 1024.0 / ]
CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ]
TUPLE: player
- location yaw pitch velocity velocity-modifier ;
+ location yaw pitch velocity velocity-modifier
+ reverse-time ;
TUPLE: terrain-world < game-world
player
sky-image sky-texture sky-program
terrain terrain-segment terrain-texture terrain-program
- terrain-vertex-buffer ;
+ terrain-vertex-buffer
+ history ;
+
+: <player> ( -- player )
+ player new
+ PLAYER-START-LOCATION >>location
+ 0.0 >>yaw
+ 0.0 >>pitch
+ { 0.0 0.0 0.0 } >>velocity
+ VELOCITY-MODIFIER-NORMAL >>velocity-modifier ;
M: terrain-world tick-length
drop 1000 30 /i ;
terrain-world H{
- { T{ key-up { mods { A+ } } { sym "RET" } } [ toggle-fullscreen ] }
+ { 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-left-shift keys nth
+ VELOCITY-MODIFIER-FAST VELOCITY-MODIFIER-NORMAL ? player (>>velocity-modifier)
+
+ {
+ [ key-1 keys nth 1 f ? ]
+ [ key-2 keys nth 2 f ? ]
+ [ key-3 keys nth 3 f ? ]
+ [ key-4 keys nth 4 f ? ]
+ [ key-5 keys nth 10000 f ? ]
+ } 0|| player (>>reverse-time)
key-w keys nth [ player walk-forward ] when
key-s keys nth [ player walk-backward ] when
: scaled-velocity ( player -- velocity )
[ velocity>> ] [ velocity-modifier>> ] bi v* ;
-: tick-player ( world player -- )
+: save-history ( world player -- )
+ clone swap history>> push ;
+
+:: tick-player-reverse ( world player -- )
+ player reverse-time>> :> reverse-time
+ world history>> :> history
+ history length 0 > [
+ history length reverse-time 1 - - 1 max history set-length
+ history pop world (>>player)
+ ] when ;
+
+: tick-player-forward ( world player -- )
+ 2dup save-history
[ apply-friction apply-gravity ] change-velocity
dup scaled-velocity [ v+ [ terrain-segment>> ] dip collide ] curry with change-location
drop ;
+: tick-player ( world player -- )
+ dup reverse-time>> [
+ tick-player-reverse
+ ] [
+ tick-player-forward
+ ] if ;
+
M: terrain-world tick*
[ dup focused?>> [ handle-input ] [ drop ] if ]
[ dup player>> tick-player ] bi ;
GL_DEPTH_TEST glEnable
GL_TEXTURE_2D glEnable
GL_VERTEX_ARRAY glEnableClientState
- PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player
+ <player> >>player
+ V{ } clone >>history
<perlin-noise-table> 0.01 0.01 <scale> { 512 512 } perlin-noise-image
[ >>sky-image ] keep
make-texture [ set-texture-parameters ] keep >>sky-texture
projects / factor.git / commitdiff