From ba9ba118a6d4abf054c3ce098f357bb5f396a8c0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 10:08:57 -0500 Subject: [PATCH 01/22] don't assume world has children in debugger --- basis/ui/tools/debugger/debugger.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor index f3f533e681..4d6960306c 100755 --- a/basis/ui/tools/debugger/debugger.factor +++ b/basis/ui/tools/debugger/debugger.factor @@ -60,7 +60,7 @@ M: debugger focusable-child* GENERIC: error-in-debugger? ( error -- ? ) -M: world-error error-in-debugger? world>> gadget-child debugger? ; +M: world-error error-in-debugger? world>> children>> [ f ] [ first debugger? ] if-empty ; M: object error-in-debugger? drop f ; From b4ca3d2af570d0b54489febbaa9338f8b657d03d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 14:08:51 -0500 Subject: [PATCH 02/22] handle resize on key-down instead of key-up --- extra/terrain/terrain.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d6905144bb..fb326ef534 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -134,7 +134,7 @@ M: terrain-world tick-length 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 -- ) From 92e508356e3910417e1633bf4b3bfd7448f4bcd5 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 15:01:21 -0500 Subject: [PATCH 03/22] flip cursor warp point for cocoa mouse grab into y-goes-down space --- basis/core-graphics/core-graphics.factor | 2 ++ basis/ui/backend/cocoa/cocoa.factor | 4 +++- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index 924f7130f0..e9158be47d 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -110,6 +110,8 @@ FUNCTION: CGDirectDisplayID CGMainDisplayID ( ) ; FUNCTION: CGError CGDisplayHideCursor ( CGDirectDisplayID display ) ; FUNCTION: CGError CGDisplayShowCursor ( CGDirectDisplayID display ) ; +FUNCTION: CGError CGDisplayMoveCursorToPoint ( CGDirectDisplayID display, CGPoint point ) ; + FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) ; FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index c6f4c6def0..e952de659e 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -126,7 +126,9 @@ M: cocoa-ui-backend (grab-input) ( handle -- ) 0 CGAssociateMouseAndMouseCursorPosition drop CGMainDisplayID CGDisplayHideCursor drop window>> -> frame CGRect>rect rect-center - first2 CGWarpMouseCursorPosition drop ; + NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h + [ drop first ] [ swap second - ] 2bi + CGWarpMouseCursorPosition drop ; M: cocoa-ui-backend (ungrab-input) ( handle -- ) drop From 606ed8aaa14c2c643ab859f024394863e902032c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 15:36:18 -0500 Subject: [PATCH 04/22] spin on GetCurrentButtonState before warping cursor when grabbing cocoa input. this keeps the window from jumping if you click on its titlebar to focus --- basis/core-graphics/core-graphics.factor | 2 ++ basis/ui/backend/cocoa/cocoa.factor | 1 + 2 files changed, 3 insertions(+) diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index e9158be47d..6612a43dca 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -116,6 +116,8 @@ FUNCTION: CGError CGAssociateMouseAndMouseCursorPosition ( boolean_t connected ) FUNCTION: CGError CGWarpMouseCursorPosition ( CGPoint newCursorPosition ) ; +FUNCTION: uint GetCurrentButtonState ( ) ; + > -> frame CGRect>rect rect-center NSScreen -> screens 0 -> objectAtIndex: -> frame CGRect-h [ drop first ] [ swap second - ] 2bi + [ GetCurrentButtonState zero? not ] [ yield ] while CGWarpMouseCursorPosition drop ; M: cocoa-ui-backend (ungrab-input) ( handle -- ) From dc107aa26c1bca423279d50f8231f77a3d478d08 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:43:51 -0500 Subject: [PATCH 05/22] larger default window size for gesture-logger --- extra/gesture-logger/gesture-logger.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/extra/gesture-logger/gesture-logger.factor b/extra/gesture-logger/gesture-logger.factor index e03204dc35..0dc0f05205 100644 --- a/extra/gesture-logger/gesture-logger.factor +++ b/extra/gesture-logger/gesture-logger.factor @@ -25,6 +25,7 @@ M: gesture-logger user-input* : gesture-logger ( -- ) [ t >>scrolls? dup + { 450 500 } >>pref-dim "Gesture log" open-window "Gesture input" open-window From ac32822b116a1e9451401a4ffe26fb26ef3fe938 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:44:57 -0500 Subject: [PATCH 06/22] replace my bitstream-reader with marc's bitstreams. implement a minimal bit-writer --- basis/bitstreams/bitstreams.factor | 217 ++++++++++++++++++----------- basis/compression/lzw/lzw.factor | 26 ++-- 2 files changed, 149 insertions(+), 94 deletions(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 7113b650fd..d7d13cf17c 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -1,96 +1,147 @@ ! 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 ) - new - swap >>stream - reset-bitstream ; inline +: 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 ; -M: bitstream-reader dispose ( stream -- ) - stream>> dispose ; +: ( bits #bits -- widthed ) + check-widthed + widthed boa ; -: ( stream -- bitstream ) - bitstream-reader new-bitstream ; inline +: zero-widthed ( -- widthed ) 0 0 ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; -: read-next-byte ( bitstream -- bitstream ) - dup stream>> stream-read1 [ - >>current-bits 8 >>#bits +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 ; +CONSTRUCTOR: msb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; +CONSTRUCTOR: lsb0-bit-writer ( -- bs ) + BV{ } clone >>bytes + 0 0 >>widthed ; + +! interface + +GENERIC: peek ( n bitstream -- value ) +GENERIC: poke ( value n bitstream -- ) + +: seek ( n bitstream -- ) + { + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] + [ (>>byte-pos) ] + } cleave ; inline + +: read ( n bitstream -- value ) + [ peek ] [ seek ] 2bi ; inline + + +! reading + +quot ; + +GENERIC: fetch3-le-unsafe ( n byte-array -- value ) +GENERIC: fetch3-be-unsafe ( n byte-array -- value ) + +: fetch3-unsafe ( byte-array n offsets -- value ) + multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline + +M: byte-array fetch3-le-unsafe ( n byte-array -- value ) + swap { 0 1 2 } fetch3-unsafe ; inline +M: byte-array fetch3-be-unsafe ( n byte-array -- value ) + swap { 2 1 0 } fetch3-unsafe ; inline + +: fetch3 ( n byte-array -- value ) + [ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ; + +: fetch3-le ( n byte-array -- value ) fetch3 le> ; +: fetch3-be ( n byte-array -- value ) fetch3 be> ; + +GENERIC: peek16 ( n bitstream -- value ) + +M:: lsb0-bit-reader peek16 ( n bs -- v ) + bs byte-pos>> bs bytes>> fetch3-le + bs bit-pos>> 2^ /i + n 2^ mod ; + +M:: msb0-bit-reader peek16 ( n bs -- v ) + bs byte-pos>> bs bytes>> fetch3-be + 24 n bs bit-pos>> + - 2^ /i + n 2^ mod ; + +PRIVATE> + +M: lsb0-bit-reader peek ( n bs -- v ) peek16 ; +M: msb0-bit-reader peek ( n bs -- v ) peek16 ; + +! writing + +> ] dip < [ not-enough-bits ] when + [ [ bits>> ] [ #bits>> ] bi ] dip + [ - neg shift ] keep ; + +: split-widthed ( widthed n -- widthed1 widthed2 ) + 2dup [ #bits>> ] dip < [ + drop zero-widthed ] [ - 0 >>#bits - t >>end-of-stream? - ] if* ; - -: maybe-read-next-byte ( bitstream -- bitstream ) - dup #bits>> 0 = [ read-next-byte ] when ; inline - -: shift-one-bit ( bitstream -- n ) - [ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline - -: next-bit ( bitstream -- n/f ? ) - maybe-read-next-byte - dup end-of-stream?>> [ - drop f - ] [ - [ shift-one-bit ] - [ [ 1- ] change-#bits maybe-read-next-byte drop ] bi - ] if dup >boolean ; - -: read-bit ( bitstream -- n ? ) - dup #bits>> 1 = [ - [ current-bits>> 1 bitand ] - [ read-next-byte drop ] bi t - ] [ - next-bit - ] if ; inline - -: bits>integer ( seq -- n ) - 0 [ [ 1 shift ] dip bitor ] reduce ; inline - -: read-bits ( width bitstream -- n width ? ) - [ - '[ _ read-bit drop ] replicate - [ f = ] trim-tail - [ bits>integer ] [ length ] bi - ] 2keep drop over = ; - -TUPLE: bitstream-writer < bitstream ; - -: ( stream -- bitstream ) - bitstream-writer new-bitstream ; inline - -: write-bit ( n bitstream -- ) - [ 1 shift bitor ] change-current-bits - [ 1+ ] change-#bits - dup #bits>> 8 = [ - [ [ current-bits>> ] [ stream>> stream-write1 ] bi ] - [ reset-bitstream drop ] bi - ] [ - drop - ] if ; inline - -ERROR: invalid-bit-width n ; - -:: write-bits ( n width bitstream -- ) - n 0 < [ n invalid-bit-width ] when - n 0 = [ - width [ 0 bitstream write-bit ] times - ] [ - width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times - n-length [ - n-length swap - 1- neg n swap shift 1 bitand - bitstream write-bit - ] each + [ widthed-bits ] + [ [ [ bits>> ] [ #bits>> ] bi ] dip - [ bits ] keep ] 2bi ] if ; -: flush-bits ( bitstream -- ) stream>> stream-flush ; +: widthed>bytes ( widthed -- bytes widthed ) + [ 8 split-widthed dup zero-widthed? not ] + [ swap bits>> ] B{ } produce-as nip swap ; -: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ; +PRIVATE> + +M:: lsb0-bit-writer poke ( value n bs -- ) + value n :> widthed + widthed + bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte + + byte #bits>> 8 = [ + byte bits>> bs bytes>> push + zero-widthed bs (>>widthed) + remainder widthed>bytes + [ bs bytes>> push-all ] [ B bs (>>widthed) ] bi* + ] [ + byte bs (>>widthed) + ] if ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 29cbe96d69..592a0efb6c 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,9 +1,11 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs bitstreams byte-vectors combinators io -io.encodings.binary io.streams.byte-array kernel math sequences -vectors ; -IN: compression.lzw +USING: accessors alien.accessors byte-arrays combinators +constructors destructors fry io io.binary kernel locals macros +math math.ranges multiline sequences sequences.private ; +IN: bitstreams + +QUALIFIED-WITH: bitstreams bs CONSTANT: clear-code 256 CONSTANT: end-of-information 257 @@ -52,7 +54,8 @@ ERROR: index-too-big n ; : ( input -- obj ) lzw new swap >>input - binary >>output + ! binary >>output + V{ } clone >>output ! TODO reset-lzw-compress ; : ( input -- obj ) @@ -76,7 +79,7 @@ ERROR: not-in-table value ; [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless ] [ [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] bi ; : omega-k>omega ( lzw -- lzw ) @@ -114,18 +117,18 @@ ERROR: not-in-table value ; [ [ clear-code ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ (lzw-compress-chars) ] [ [ k>> ] [ lzw-bit-width-compress ] - [ output>> write-bits ] tri + [ output>> bs:poke ] tri ] [ [ end-of-information ] dip [ lzw-bit-width-compress ] - [ output>> write-bits ] bi + [ output>> bs:poke ] bi ] [ ] } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; @@ -152,7 +155,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -200,5 +203,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - binary + + ! binary ! [ lzw-uncompress-char ] [ output>> ] bi ; From c443d6d8159bce11eef509d806d564d6ef32b41e Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 15:46:10 -0500 Subject: [PATCH 07/22] check in marc's jpeg loader, png decoder, huffman, inflate, and image-processing vocabularies --- basis/compression/huffman/huffman.factor | 88 +++++++ basis/compression/inflate/inflate.factor | 209 +++++++++++++++ basis/images/jpeg/jpeg.factor | 304 ++++++++++++++++++++++ basis/images/loader/loader.factor | 6 +- basis/images/png/png.factor | 21 +- basis/images/processing/processing.factor | 40 +++ 6 files changed, 665 insertions(+), 3 deletions(-) create mode 100755 basis/compression/huffman/huffman.factor create mode 100755 basis/compression/inflate/inflate.factor create mode 100755 basis/images/jpeg/jpeg.factor create mode 100755 basis/images/processing/processing.factor diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor new file mode 100755 index 0000000000..60b3a1d5a1 --- /dev/null +++ b/basis/compression/huffman/huffman.factor @@ -0,0 +1,88 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors alt.bitstreams arrays assocs constructors fry +hashtables io kernel locals math math.order math.parser +math.ranges multiline sequences ; +IN: compression.huffman + +QUALIFIED-WITH: alt.bitstreams bs + + ( -- code ) 0 0 0 huffman-code boa ; +: next-size ( code -- ) [ 1+ ] change-size [ 2 * ] change-code drop ; +: next-code ( code -- ) [ 1+ ] change-code drop ; + +:: all-patterns ( huff n -- seq ) + n log2 huff size>> - :> free-bits + free-bits 0 > + [ free-bits 2^ [0,b) [ huff code>> free-bits 2^ * + ] map ] + [ huff code>> free-bits neg 2^ /i 1array ] if ; + +:: huffman-each ( tdesc quot: ( huff -- ) -- ) + :> code + tdesc + [ + code next-size + [ code (>>value) code clone quot call code next-code ] each + ] each ; inline + +: update-reverse-table ( huff n table -- ) + [ drop all-patterns ] + [ nip '[ _ swap _ set-at ] each ] 3bi ; + +:: reverse-table ( tdesc n -- rtable ) + n f :> table + tdesc [ n table update-reverse-table ] huffman-each + table seq>> ; + +:: huffman-table ( tdesc max -- table ) + max f :> table + tdesc [ [ ] [ value>> ] bi table set-nth ] huffman-each + table ; + +PRIVATE> + +! decoder + +TUPLE: huffman-decoder + { bs } + { tdesc } + { rtable } + { bits/level } ; + +CONSTRUCTOR: huffman-decoder ( bs tdesc -- decoder ) + 16 >>bits/level + [ ] [ tdesc>> ] [ bits/level>> 2^ ] tri reverse-table >>rtable ; + +: read1-huff ( decoder -- elt ) + 16 over [ bs>> bs:peek ] [ rtable>> nth ] bi ! first/last + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; + +! %remove +: reverse-bits ( value bits -- value' ) + [ >bin ] [ CHAR: 0 pad-head bin> ] bi* ; + +: read1-huff2 ( decoder -- elt ) + 16 over [ bs>> bs:peek 16 reverse-bits ] [ rtable>> nth ] bi ! first/last + [ size>> swap bs>> bs:seek ] [ value>> ] bi ; + +/* +: huff>string ( code -- str ) + [ value>> number>string ] + [ [ code>> ] [ size>> bits>string ] bi ] bi + " = " glue ; + +: huff. ( code -- ) huff>string print ; + +:: rtable. ( rtable -- ) + rtable length>> log2 :> n + rtable [ swap n bits. [ huff. ] each ] assoc-each ; +*/ diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor new file mode 100755 index 0000000000..a828718f75 --- /dev/null +++ b/basis/compression/inflate/inflate.factor @@ -0,0 +1,209 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs byte-arrays +byte-vectors combinators constructors fry grouping hashtables +compression.huffman images io.binary kernel locals +math math.bitwise math.order math.ranges multiline sequences +sorting ; +IN: compression.inflate + +QUALIFIED-WITH: alt.bitstreams bs + +seq ( assoc -- seq ) + dup keys [ ] [ max ] map-reduce 1 + f + [ '[ swap _ set-nth ] assoc-each ] keep ; + +ERROR: zlib-unimplemented ; +ERROR: bad-zlib-data ; +ERROR: bad-zlib-header ; + +:: check-zlib-header ( data -- ) + 16 data bs:peek 2 >le be> 31 mod ! checksum + 0 assert= + 4 data bs:read 8 assert= ! compression method: deflate + 4 data bs:read ! log2(max length)-8, 32K max + 7 <= [ bad-zlib-header ] unless + 5 data bs:seek ! drop check bits + 1 data bs:read 0 assert= ! dictionnary - not allowed in png + 2 data bs:seek ! compression level; ignore + ; + +:: default-table ( -- table ) + 0 :> table + 0 143 [a,b] 280 287 [a,b] append 8 table set-at + 144 255 [a,b] >array 9 table set-at + 256 279 [a,b] >array 7 table set-at + table enum>seq 1 tail ; + +CONSTANT: clen-shuffle { 16 17 18 0 8 7 9 6 10 5 11 4 12 3 13 2 14 1 15 } + +: get-table ( values size -- table ) + 16 f clone + [ '[ _ push-at ] 2each ] keep seq>> 1 tail [ natural-sort ] map ; + +:: decode-huffman-tables ( bitstream -- tables ) + 5 bitstream bs:read 257 + + 5 bitstream bs:read 1 + + 4 bitstream bs:read 4 + + clen-shuffle swap head + dup [ drop 3 bitstream bs:read ] map + get-table + bitstream swap + [ 2dup + ] dip swap :> k! + '[ + _ read1-huff2 + { + { [ dup 16 = ] [ 2 bitstream bs:read 3 + 2array ] } + { [ dup 17 = ] [ 3 bitstream bs:read 3 + 2array ] } + { [ dup 18 = ] [ 7 bitstream bs:read 11 + 2array ] } + [ ] + } cond + dup array? [ dup second ] [ 1 ] if + k swap - dup k! 0 > + ] + [ ] produce swap suffix + { } [ dup array? [ dup first 16 = ] [ f ] if [ [ unclip-last ] [ second 1+ swap append ] bi* ] [ suffix ] if ] reduce + [ dup array? [ second 0 ] [ 1array ] if ] map concat + nip swap cut 2array [ [ length>> [0,b) ] [ ] bi get-table ] map ; + +CONSTANT: length-table + { + 3 4 5 6 7 8 9 10 + 11 13 15 17 + 19 23 27 31 + 35 43 51 59 + 67 83 99 115 + 131 163 195 227 + } + +CONSTANT: dist-table + { 1 2 3 4 + 5 7 9 13 + 17 25 33 49 + 65 97 129 193 + 257 385 513 769 + 1025 1537 2049 3073 + 4097 6145 8193 12289 + 16385 24577 } + +: nth* ( n seq -- elt ) + [ length 1- swap - ] [ nth ] bi ; + +:: inflate-lz77 ( seq -- bytes ) + 1000 :> bytes + seq + [ + dup array? + [ first2 '[ _ 1- bytes nth* bytes push ] times ] + [ bytes push ] if + ] each + bytes ; + +:: inflate-dynamic ( bitstream -- bytes ) + bitstream decode-huffman-tables + bitstream '[ _ swap ] map :> tables + [ + tables first read1-huff2 + dup 256 > + [ + dup 285 = + [ ] + [ + dup 264 > + [ + dup 261 - 4 /i dup 5 > + [ bad-zlib-data ] when + bitstream bs:read 2array + ] + when + ] if + ! 5 bitstream read-bits ! distance + tables second read1-huff2 + dup 3 > + [ + dup 2 - 2 /i dup 13 > + [ bad-zlib-data ] when + bitstream bs:read 2array + ] + when + 2array + ] + when + dup 256 = not + ] + [ ] produce nip + [ + dup array? [ + first2 + [ + dup array? [ first2 ] [ 0 ] if + [ 257 - length-table nth ] [ + ] bi* + ] + [ + dup array? [ first2 ] [ 0 ] if + [ dist-table nth ] [ + ] bi* + ] bi* + 2array + ] when + ] map ; + +: inflate-raw ( bitstream -- bytes ) zlib-unimplemented ; +: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; + +:: inflate-loop ( bitstream -- bytes ) + [ 1 bitstream bs:read 0 = ] + [ + bitstream + 2 bitstream bs:read ! B + { + { 0 [ inflate-raw ] } + { 1 [ inflate-static ] } + { 2 [ inflate-dynamic ] } + { 3 [ bad-zlib-data f ] } + } + case + ] + [ produce ] keep call suffix concat ; + + ! [ produce ] keep dip swap suffix + +:: paeth ( a b c -- p ) + a b + c - { a b c } [ [ - abs ] keep 2array ] with map + sort-keys first second ; + +:: png-unfilter-line ( prev curr filter -- curr' ) + prev :> c + prev 3 tail-slice :> b + curr :> a + curr 3 tail-slice :> x + x length [0,b) + filter + { + { 0 [ drop ] } + { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } + { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } + { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } + { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } + + } case + curr 3 tail ; + +PRIVATE> + +! for debug -- shows residual values +: reverse-png-filter' ( lines -- filtered ) + [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip + concat [ 128 + 256 wrap ] map ; + +: reverse-png-filter ( lines -- filtered ) + dup first [ 0 ] replicate prefix + [ { 0 0 } prepend ] map + 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; + +: zlib-inflate ( bytes -- bytes ) + bs: + [ check-zlib-header ] + [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor new file mode 100755 index 0000000000..0588e5c365 --- /dev/null +++ b/basis/images/jpeg/jpeg.factor @@ -0,0 +1,304 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators +constructors grouping compression.huffman images +images.processing io io.binary io.encodings.binary io.files +io.streams.byte-array kernel locals math math.bitwise +math.constants math.functions math.matrices math.order +math.ranges math.vectors memoize multiline namespaces +sequences sequences.deep ; +IN: images.jpeg + +QUALIFIED-WITH: alt.bitstreams bs + +TUPLE: jpeg-image < image + { headers } + { bitstream } + { color-info initial: { f f f f } } + { quant-tables initial: { f f } } + { huff-tables initial: { f f f f } } + { components } ; + +marker ( byte -- marker ) + byte + { + { [ dup HEX: CC = ] [ { DAC } ] } + { [ dup HEX: C4 = ] [ { DHT } ] } + { [ dup HEX: C9 = ] [ { JPG } ] } + { [ dup -4 shift HEX: C = ] [ SOF byte 4 bits 2array ] } + + { [ dup HEX: D8 = ] [ { SOI } ] } + { [ dup HEX: D9 = ] [ { EOI } ] } + { [ dup HEX: DA = ] [ { SOS } ] } + { [ dup HEX: DB = ] [ { DQT } ] } + { [ dup HEX: DC = ] [ { DNL } ] } + { [ dup HEX: DD = ] [ { DRI } ] } + { [ dup HEX: DE = ] [ { DHP } ] } + { [ dup HEX: DF = ] [ { EXP } ] } + { [ dup -4 shift HEX: D = ] [ RST byte 4 bits 2array ] } + + { [ dup -4 shift HEX: E = ] [ APP byte 4 bits 2array ] } + { [ dup HEX: FE = ] [ { COM } ] } + { [ dup -4 shift HEX: F = ] [ JPG byte 4 bits 2array ] } + + { [ dup HEX: 01 = ] [ { TEM } ] } + [ { RES } ] + } + cond nip ; + +TUPLE: jpeg-chunk length type data ; + +CONSTRUCTOR: jpeg-chunk ( type length data -- jpeg-chunk ) ; + +TUPLE: jpeg-color-info + h v quant-table dc-huff-table ac-huff-table { diff initial: 0 } id ; + +CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ; + +: jpeg> ( -- jpeg-image ) jpeg-image get ; + +: apply-diff ( dc color -- dc' ) + [ diff>> + dup ] [ (>>diff) ] bi ; + +: fetch-tables ( component -- ) + [ [ jpeg> quant-tables>> nth ] change-quant-table drop ] + [ [ jpeg> huff-tables>> nth ] change-dc-huff-table drop ] + [ [ 2 + jpeg> huff-tables>> nth ] change-ac-huff-table drop ] tri ; + +: read4/4 ( -- a b ) read1 16 /mod ; + + +! headers + +: decode-frame ( header -- ) + data>> + binary + [ + read1 8 assert= + 2 read be> + 2 read be> + swap 2array jpeg> (>>dim) + read1 + [ + read1 read4/4 read1 + swap [ >>id ] keep jpeg> color-info>> set-nth + ] times + ] with-byte-reader ; + +: decode-quant-table ( chunk -- ) + dup data>> + binary + [ + length>> + 2 - 65 / + [ + read4/4 [ 0 assert= ] dip + 64 read + swap jpeg> quant-tables>> set-nth + ] times + ] with-byte-reader ; + +: decode-huff-table ( chunk -- ) + data>> + binary + [ + 1 ! %fixme: Should handle multiple tables at once + [ + read4/4 swap 2 * + + 16 read + dup [ ] [ + ] map-reduce read + binary [ [ read [ B{ } ] unless* ] { } map-as ] with-byte-reader + swap jpeg> huff-tables>> set-nth + ] times + ] with-byte-reader ; + +: decode-scan ( chunk -- ) + data>> + binary + [ + read1 [0,b) + [ drop + read1 jpeg> color-info>> nth clone + read1 16 /mod [ >>dc-huff-table ] [ >>ac-huff-table ] bi* + ] map jpeg> (>>components) + read1 0 assert= + read1 63 assert= + read1 16 /mod [ 0 assert= ] bi@ + ] with-byte-reader ; + +: singleton-first ( seq -- elt ) + [ length 1 assert= ] [ first ] bi ; + +: baseline-parse ( -- ) + jpeg> headers>> + { + [ [ type>> { SOF 0 } = ] filter singleton-first decode-frame ] + [ [ type>> { DQT } = ] filter [ decode-quant-table ] each ] + [ [ type>> { DHT } = ] filter [ decode-huff-table ] each ] + [ [ type>> { SOS } = ] filter singleton-first decode-scan ] + } cleave ; + +: parse-marker ( -- marker ) + read1 HEX: FF assert= + read1 >marker ; + +: parse-headers ( -- chunks ) + [ parse-marker dup { SOS } = not ] + [ + 2 read be> + dup 2 - read + ] [ produce ] keep dip swap suffix ; + +MEMO: zig-zag ( -- zz ) + { + { 0 1 5 6 14 15 27 28 } + { 2 4 7 13 16 26 29 42 } + { 3 8 12 17 25 30 41 43 } + { 9 11 18 24 31 40 44 53 } + { 10 19 23 32 39 45 52 54 } + { 20 22 33 38 46 51 55 60 } + { 21 34 37 47 50 56 59 61 } + { 35 36 48 49 57 58 62 63 } + } flatten ; + +MEMO: yuv>bgr-matrix ( -- m ) + { + { 1 2.03211 0 } + { 1 -0.39465 -0.58060 } + { 1 0 1.13983 } + } ; + +: wave ( x u -- n ) swap 2 * 1 + * pi * 16 / cos ; + +:: dct-vect ( u v -- basis ) + { 8 8 } coord-matrix [ { u v } [ wave ] 2map product ] map^2 + 1 u v [ 0 = [ 2 sqrt / ] when ] bi@ 4 / m*n ; + +MEMO: dct-matrix ( -- m ) 64 [0,b) [ 8 /mod dct-vect flatten ] map ; + +: mb-dim ( component -- dim ) [ h>> ] [ v>> ] bi 2array ; + +: all-macroblocks ( quot: ( mb -- ) -- ) + [ + jpeg> + [ dim>> 8 v/n ] + [ color-info>> sift { 0 0 } [ mb-dim vmax ] reduce v/ ] bi + [ ceiling ] map + coord-matrix flip concat + ] + [ each ] bi* ; inline + +: reverse-zigzag ( b -- b' ) zig-zag swap [ nth ] curry map ; + +: idct-factor ( b -- b' ) dct-matrix v.m ; + +USE: math.blas.vectors +USE: math.blas.matrices + +MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; +: V.M ( x A -- x.A ) Mtranspose swap M.V ; +: idct-blas ( b -- b' ) >float-blas-vector dct-matrix-blas V.M ; + +: idct ( b -- b' ) idct-blas ; + +:: draw-block ( block x,y color jpeg-image -- ) + block dup length>> sqrt >fixnum group flip + dup matrix-dim coord-matrix flip + [ + [ first2 spin nth nth ] + [ x,y v+ color id>> 1- jpeg-image draw-color ] bi + ] with each^2 ; + +: sign-extend ( bits v -- v' ) + swap [ ] [ 1- 2^ < ] 2bi + [ -1 swap shift 1+ + ] [ drop ] if ; + +: read1-jpeg-dc ( decoder -- dc ) + [ read1-huff dup ] [ bs>> bs:read ] bi sign-extend ; + +: read1-jpeg-ac ( decoder -- run/ac ) + [ read1-huff 16 /mod dup ] [ bs>> bs:read ] bi sign-extend 2array ; + +:: decode-block ( pos color -- ) + color dc-huff-table>> read1-jpeg-dc color apply-diff + 64 0 :> coefs + 0 coefs set-nth + 0 :> k! + [ + color ac-huff-table>> read1-jpeg-ac + [ first 1+ k + k! ] [ second k coefs set-nth ] [ ] tri + { 0 0 } = not + k 63 < and + ] loop + coefs color quant-table>> v* + reverse-zigzag idct + ! %fixme: color hack + ! this eat 50% cpu time + color h>> 2 = + [ 8 group 2 matrix-zoom concat ] unless + pos { 8 8 } v* color jpeg> draw-block ; + +: decode-macroblock ( mb -- ) + jpeg> components>> + [ + [ mb-dim coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ] + [ [ decode-block ] curry each ] bi + ] with each ; + +: cleanup-bitstream ( bytes -- bytes' ) + binary [ + [ + { HEX: FF } read-until + read1 tuck HEX: 00 = and + ] + [ drop ] produce + swap >marker { EOI } assert= + swap suffix + { HEX: FF } join + ] with-byte-reader ; + +: setup-bitmap ( image -- ) + dup dim>> 16 v/n [ ceiling ] map 16 v*n >>dim + BGR >>component-order + f >>upside-down? + dup dim>> first2 * 3 * 0 >>bitmap + drop ; + +: baseline-decompress ( -- ) + jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append + >byte-array bs: jpeg> (>>bitstream) + jpeg> [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi + jpeg> components>> [ fetch-tables ] each + jpeg> setup-bitmap + [ decode-macroblock ] all-macroblocks ; + +! this eats ~25% cpu time +: color-transform ( yuv -- rgb ) + { 128 0 0 } v+ yuv>bgr-matrix swap m.v + [ 0 max 255 min >fixnum ] map ; + +PRIVATE> + +: load-jpeg ( path -- image ) + binary [ + parse-marker { SOI } assert= + parse-headers + contents + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + jpeg> bitmap>> 3 [ color-transform ] change-each + jpeg> [ >byte-array ] change-bitmap drop + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor index fe33cc8f00..27b726f3c0 100644 --- a/basis/images/loader/loader.factor +++ b/basis/images/loader/loader.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: constructors kernel splitting unicode.case combinators -accessors images.bitmap images.tiff images io.pathnames ; +accessors images.bitmap images.tiff images io.pathnames +images.jpeg images.png ; IN: images.loader ERROR: unknown-image-extension extension ; @@ -11,6 +12,9 @@ ERROR: unknown-image-extension extension ; { "bmp" [ bitmap-image ] } { "tif" [ tiff-image ] } { "tiff" [ tiff-image ] } + { "jpg" [ jpeg-image ] } + { "jpeg" [ jpeg-image ] } + { "png" [ png-image ] } [ unknown-image-extension ] } case ; diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index b027362977..bf13c43546 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -3,7 +3,7 @@ USING: accessors constructors images io io.binary io.encodings.ascii io.encodings.binary io.encodings.string io.files io.files.info kernel sequences io.streams.limited fry combinators arrays math -checksums checksums.crc32 ; +checksums checksums.crc32 compression.inflate grouping byte-arrays ; IN: images.png TUPLE: png-image < image chunks @@ -17,7 +17,8 @@ TUPLE: png-chunk length type data ; CONSTRUCTOR: png-chunk ( -- png-chunk ) ; -CONSTANT: png-header B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } +CONSTANT: png-header + B{ HEX: 89 HEX: 50 HEX: 4e HEX: 47 HEX: 0d HEX: 0a HEX: 1a HEX: 0a } ERROR: bad-png-header header ; @@ -61,6 +62,18 @@ ERROR: bad-checksum ; : fill-image-data ( image -- image ) dup [ width>> ] [ height>> ] bi 2array >>dim ; +: zlib-data ( png-image -- bytes ) + chunks>> [ type>> "IDAT" = ] find nip data>> ; + +: decode-png ( image -- image ) + { + [ zlib-data zlib-inflate ] + [ dim>> first 3 * 1 + group reverse-png-filter ] + [ swap >byte-array >>bitmap drop ] + [ RGB >>component-order drop ] + [ ] + } cleave ; + : load-png ( path -- image ) [ binary ] [ file-info size>> ] bi stream-throws [ @@ -69,4 +82,8 @@ ERROR: bad-checksum ; read-png-chunks parse-ihdr-chunk fill-image-data + decode-png ] with-input-stream ; + +M: png-image load-image* + drop load-png ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor new file mode 100755 index 0000000000..2304c56171 --- /dev/null +++ b/basis/images/processing/processing.factor @@ -0,0 +1,40 @@ +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators grouping images +images.loader images.viewer kernel locals math math.order +math.ranges math.vectors sequences sequences.deep fry ; +IN: images.processing + +: coord-matrix ( dim -- m ) + [ [0,b) ] map first2 [ [ 2array ] with map ] curry map ; + +: map^2 ( m quot -- m' ) '[ _ map ] map ; inline +: each^2 ( m quot -- m' ) '[ _ each ] each ; inline + +: matrix-dim ( m -- dim ) [ length ] [ first length ] bi 2array ; + +: matrix>image ( m -- image ) + over matrix-dim >>dim + swap flip flatten + [ 128 * 128 + 0 max 255 min >fixnum ] map + >byte-array >>bitmap L >>component-order ; + +:: matrix-zoom ( m f -- m' ) + m matrix-dim f v*n coord-matrix + [ [ f /i ] map first2 swap m nth nth ] map^2 ; + +:: image-offset ( x,y image -- xy ) + image dim>> first + x,y second * x,y first + ; + +:: draw-grey ( value x,y image -- ) + x,y image image-offset 3 * { 0 1 2 } + [ + + value 128 + >fixnum 0 max 255 min swap image bitmap>> set-nth + ] with each ; + +:: draw-color ( value x,y color-id image -- ) + x,y image image-offset 3 * color-id + value >fixnum + swap image bitmap>> set-nth ; + +! : matrix. ( m -- ) 10 matrix-zoom matrix>image image. ; From 99c6c054c20459441a2b7618d8d7a10d510a398c Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 17:26:54 -0500 Subject: [PATCH 08/22] no reason not to use bit-array for game-input key state --- basis/game-input/iokit/iokit.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 5f09a054f9..32440e92b2 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -3,7 +3,7 @@ kernel cocoa.enumeration destructors math.parser cocoa.application sequences locals combinators.short-circuit threads namespaces assocs vectors arrays combinators hints alien core-foundation.run-loop accessors sequences.private -alien.c-types math parser game-input vectors ; +alien.c-types math parser game-input vectors bit-arrays ; IN: game-input.iokit SINGLETON: iokit-game-input-backend @@ -186,7 +186,7 @@ HINTS: record-controller { controller-state alien } ; rot ?set-nth ] [ 3drop ] if ; -HINTS: record-keyboard { array alien } ; +HINTS: record-keyboard { bit-array alien } ; : record-mouse ( mouse-state value -- ) dup IOHIDValueGetElement { @@ -285,7 +285,7 @@ M: iokit-game-input-backend reset-mouse 4 +controller-states+ set-global 0 0 0 0 2 mouse-state boa +mouse-state+ set-global - 256 f +keyboard-state+ set-global ; + 256 +keyboard-state+ set-global ; M: iokit-game-input-backend (open-game-input) hid-manager-matching-game-devices { From 7fdd018aec75a5f11a230fb59b0e8ba52c43f46e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 14 May 2009 17:29:25 -0500 Subject: [PATCH 09/22] set first responder on cocoa view back when returning from fullscreen mode. un-fullscreen the view if window is closed while view is fullscreen --- basis/ui/backend/cocoa/cocoa.factor | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor index 73eff25240..b6c9b43271 100755 --- a/basis/ui/backend/cocoa/cocoa.factor +++ b/basis/ui/backend/cocoa/cocoa.factor @@ -99,7 +99,9 @@ M: cocoa-ui-backend set-title ( string world -- ) drop ; : exit-fullscreen ( world -- ) - handle>> view>> f -> exitFullScreenModeWithOptions: ; + handle>> + [ view>> f -> exitFullScreenModeWithOptions: ] + [ [ window>> ] [ view>> ] bi -> makeFirstResponder: drop ] bi ; M: cocoa-ui-backend (set-fullscreen) ( world ? -- ) [ enter-fullscreen ] [ exit-fullscreen ] if ; @@ -120,7 +122,11 @@ 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 From 1214e22839e97b2b2e6c79fc538add3ecada437f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Thu, 14 May 2009 17:36:07 -0500 Subject: [PATCH 10/22] copy-tree now preserves file permissions on Unix --- basis/io/directories/hierarchy/hierarchy.factor | 2 +- basis/io/files/info/info.factor | 6 +++++- basis/io/files/info/unix/unix.factor | 5 ++++- 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/basis/io/directories/hierarchy/hierarchy.factor b/basis/io/directories/hierarchy/hierarchy.factor index 555f001bfc..4a2955ccaf 100644 --- a/basis/io/directories/hierarchy/hierarchy.factor +++ b/basis/io/directories/hierarchy/hierarchy.factor @@ -20,7 +20,7 @@ DEFER: copy-tree-into { { +symbolic-link+ [ copy-link ] } { +directory+ [ '[ [ _ copy-tree-into ] each ] with-directory-files ] } - [ drop copy-file ] + [ drop copy-file-and-info ] } case ; : copy-tree-into ( from to -- ) diff --git a/basis/io/files/info/info.factor b/basis/io/files/info/info.factor index f16db428a8..60a9308f38 100644 --- a/basis/io/files/info/info.factor +++ b/basis/io/files/info/info.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel system sequences combinators -vocabs.loader io.files.types math ; +vocabs.loader io.files.types io.directories math ; IN: io.files.info ! File info @@ -29,3 +29,7 @@ HOOK: file-system-info os ( path -- file-system-info ) { [ os unix? ] [ "io.files.info.unix." os name>> append ] } { [ os windows? ] [ "io.files.info.windows" ] } } cond require + +HOOK: copy-file-and-info os ( from to -- ) + +M: object copy-file-and-info copy-file ; diff --git a/basis/io/files/info/unix/unix.factor b/basis/io/files/info/unix/unix.factor index 80f4b74ac8..94cb60a2c6 100644 --- a/basis/io/files/info/unix/unix.factor +++ b/basis/io/files/info/unix/unix.factor @@ -3,7 +3,7 @@ USING: accessors kernel system math math.bitwise strings arrays sequences combinators combinators.short-circuit alien.c-types vocabs.loader calendar calendar.unix io.files.info -io.files.types io.backend unix unix.stat unix.time unix.users +io.files.types io.backend io.directories unix unix.stat unix.time unix.users unix.groups ; IN: io.files.info.unix @@ -174,6 +174,9 @@ CONSTANT: OTHER-EXECUTE OCT: 0000001 : file-permissions ( path -- n ) normalize-path file-info permissions>> ; +M: unix copy-file-and-info ( from to -- ) + [ copy-file ] [ swap file-permissions set-file-permissions ] 2bi ; + Date: Thu, 14 May 2009 17:37:14 -0500 Subject: [PATCH 11/22] don't unfocus the world if cocoa view has gone fullscreen; the original window isn't really associated with the view while fullscreen --- basis/ui/backend/cocoa/views/views.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor index aab851c783..a9568d4f75 100644 --- a/basis/ui/backend/cocoa/views/views.factor +++ b/basis/ui/backend/cocoa/views/views.factor @@ -391,7 +391,10 @@ CLASS: { { "windowDidResignKey:" "void" { "id" "SEL" "id" } [ forget-rollover - 2nip -> object -> contentView window unfocus-world + 2nip -> object -> contentView + dup -> isInFullScreenMode zero? + [ window unfocus-world ] + [ drop ] if ] } From af2f62ae62721481c66b63dcadb81d1fdf4b6a13 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 14 May 2009 23:33:00 -0500 Subject: [PATCH 12/22] remove all the compress code from lzw until it works, fix bitstreams --- basis/bitstreams/bitstreams-tests.factor | 58 +++++++--- basis/bitstreams/bitstreams.factor | 128 ++++++++++++---------- basis/compression/lzw/lzw.factor | 117 ++------------------ basis/images/processing/processing.factor | 2 +- 4 files changed, 123 insertions(+), 182 deletions(-) diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor index 769efcbb04..a5b1b43acd 100644 --- a/basis/bitstreams/bitstreams-tests.factor +++ b/basis/bitstreams/bitstreams-tests.factor @@ -5,23 +5,51 @@ grouping compression.lzw multiline byte-arrays io.encodings.binary io.streams.byte-array ; IN: bitstreams.tests -[ 1 t ] -[ B{ 254 } binary read-bit ] unit-test -[ 254 8 t ] -[ B{ 254 } binary 8 swap read-bits ] unit-test - -[ 4095 12 t ] -[ B{ 255 255 } binary 12 swap read-bits ] unit-test - -[ B{ 254 } ] +[ BIN: 1111111111 ] [ - binary 254 8 rot - [ write-bits ] keep stream>> >byte-array + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 10 swap peek ] unit-test -[ 255 8 t ] -[ B{ 255 } binary 8 swap read-bits ] unit-test +[ BIN: 111111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 9 swap peek +] unit-test -[ 255 8 f ] -[ B{ 255 } binary 9 swap read-bits ] unit-test +[ BIN: 11111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 8 swap peek +] unit-test + +[ BIN: 1111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 7 swap peek +] unit-test + +[ BIN: 111111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 6 swap peek +] unit-test + +[ BIN: 11111 ] +[ + B{ HEX: 0f HEX: ff HEX: ff HEX: ff } + 2 >>byte-pos 6 >>bit-pos + 5 swap peek +] unit-test + +[ B{ } 5 swap peek ] must-fail +[ B{ } 1 swap peek ] must-fail +[ B{ } 8 swap peek ] must-fail + +[ 0 ] [ B{ } 0 swap peek ] unit-test diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index d7d13cf17c..997daa2c5d 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -23,7 +23,7 @@ ERROR: invalid-widthed bits #bits ; widthed boa ; : zero-widthed ( -- widthed ) 0 0 ; -: zero-widthed? ( widthed -- ? ) zero-widthed = ; +: zero-widthed? ( widthed -- ? ) zero-widthed = ; TUPLE: bit-reader { bytes byte-array } @@ -41,73 +41,32 @@ CONSTRUCTOR: lsb0-bit-reader ( bytes -- bs ) ; TUPLE: msb0-bit-writer < bit-writer ; TUPLE: lsb0-bit-writer < bit-writer ; -CONSTRUCTOR: msb0-bit-writer ( -- bs ) - BV{ } clone >>bytes - 0 0 >>widthed ; -CONSTRUCTOR: lsb0-bit-writer ( -- bs ) - BV{ } clone >>bytes - 0 0 >>widthed ; -! interface +: new-bit-writer ( class -- bs ) + new + BV{ } clone >>bytes + 0 0 >>widthed ; inline + +: ( -- bs ) + msb0-bit-writer new-bit-writer ; + +: ( -- bs ) + lsb0-bit-writer new-bit-writer ; GENERIC: peek ( n bitstream -- value ) GENERIC: poke ( value n bitstream -- ) : seek ( n bitstream -- ) { - [ byte-pos>> 8 * ] - [ bit-pos>> + + 8 /mod ] - [ (>>bit-pos) ] + [ byte-pos>> 8 * ] + [ bit-pos>> + + 8 /mod ] + [ (>>bit-pos) ] [ (>>byte-pos) ] } cleave ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline - -! reading - -quot ; - -GENERIC: fetch3-le-unsafe ( n byte-array -- value ) -GENERIC: fetch3-be-unsafe ( n byte-array -- value ) - -: fetch3-unsafe ( byte-array n offsets -- value ) - multi-alien-unsigned-1 8 2^ * + 8 2^ * + ; inline - -M: byte-array fetch3-le-unsafe ( n byte-array -- value ) - swap { 0 1 2 } fetch3-unsafe ; inline -M: byte-array fetch3-be-unsafe ( n byte-array -- value ) - swap { 2 1 0 } fetch3-unsafe ; inline - -: fetch3 ( n byte-array -- value ) - [ 3 [0,b) [ + ] with map ] dip [ nth ] curry map ; - -: fetch3-le ( n byte-array -- value ) fetch3 le> ; -: fetch3-be ( n byte-array -- value ) fetch3 be> ; - -GENERIC: peek16 ( n bitstream -- value ) - -M:: lsb0-bit-reader peek16 ( n bs -- v ) - bs byte-pos>> bs bytes>> fetch3-le - bs bit-pos>> 2^ /i - n 2^ mod ; - -M:: msb0-bit-reader peek16 ( n bs -- v ) - bs byte-pos>> bs bytes>> fetch3-be - 24 n bs bit-pos>> + - 2^ /i - n 2^ mod ; - -PRIVATE> - -M: lsb0-bit-reader peek ( n bs -- v ) peek16 ; -M: msb0-bit-reader peek ( n bs -- v ) peek16 ; - -! writing - > ] 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 + ; + PRIVATE> M:: lsb0-bit-writer poke ( value n bs -- ) value n :> widthed widthed bs widthed>> #bits>> 8 swap - split-widthed :> remainder :> byte - - byte #bits>> 8 = [ - byte bits>> bs bytes>> push + 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 ] [ B bs (>>widthed) ] bi* + [ bs bytes>> push-all ] [ bs (>>widthed) ] bi* ] [ byte bs (>>widthed) ] if ; + +: enough-bits? ( n bs -- ? ) + [ bytes>> length ] + [ byte-pos>> - 8 * ] + [ bit-pos>> - ] tri <= ; + +ERROR: not-enough-bits n bit-reader ; + +: #bits>#bytes ( #bits -- #bytes ) + 8 /mod 0 = [ 1 + ] unless ; inline + +:: subseq>bits ( bignum n bs -- bits ) + bignum + 8 bs bit-pos>> - n - 8 mod dup 0 < [ 8 + ] when + neg shift n bits ; + +:: adjust-bits ( n bs -- ) + n 8 /mod :> #bits :> #bytes + bs [ #bytes + ] change-byte-pos + bit-pos>> #bits + dup 8 >= [ + 8 - bs (>>bit-pos) + bs [ 1 + ] change-byte-pos drop + ] [ + bs (>>bit-pos) + ] if ; + +:: (peek) ( n bs word -- bits ) + n bs enough-bits? [ n bs not-enough-bits ] unless + bs [ byte-pos>> ] [ bit-pos>> n + ] bi #bits>#bytes dupd + + bs bytes>> subseq word execute( seq -- x ) :> bignum + bignum n bs subseq>bits ; + +M: lsb0-bit-reader peek ( n bs -- bits ) \ le> (peek) ; + +M: msb0-bit-reader peek ( n bs -- 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>> ; diff --git a/basis/compression/lzw/lzw.factor b/basis/compression/lzw/lzw.factor index 592a0efb6c..46a319662e 100644 --- a/basis/compression/lzw/lzw.factor +++ b/basis/compression/lzw/lzw.factor @@ -1,22 +1,19 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.accessors byte-arrays combinators -constructors destructors fry io io.binary kernel locals macros -math math.ranges multiline sequences sequences.private ; -IN: bitstreams +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 ] } @@ -26,37 +23,14 @@ ERROR: index-too-big n ; [ drop table-full ] } cond ; -: lzw-bit-width-compress ( lzw -- n ) - count>> lzw-bit-width ; - : lzw-bit-width-uncompress ( lzw -- n ) table>> length lzw-bit-width ; -: initial-compress-table ( -- assoc ) - 258 iota [ [ 1vector ] keep ] H{ } map>assoc ; - : initial-uncompress-table ( -- seq ) 258 iota [ 1vector ] V{ } map-as ; -: reset-lzw ( lzw -- lzw ) - 257 >>count - V{ } clone >>omega - V{ } clone >>omega-k - 9 >>#bits ; - -: reset-lzw-compress ( lzw -- lzw ) - f >>k - initial-compress-table >>table reset-lzw ; - : reset-lzw-uncompress ( lzw -- lzw ) - initial-uncompress-table >>table reset-lzw ; - -: ( input -- obj ) - lzw new - swap >>input - ! binary >>output - V{ } clone >>output ! TODO - reset-lzw-compress ; + initial-uncompress-table >>table ; : ( input -- obj ) lzw new @@ -64,79 +38,8 @@ ERROR: index-too-big n ; BV{ } clone >>output reset-lzw-uncompress ; -: push-k ( lzw -- lzw ) - [ ] - [ k>> ] - [ omega>> clone [ push ] keep ] tri >>omega-k ; - -: omega-k-in-table? ( lzw -- ? ) - [ omega-k>> ] [ table>> ] bi key? ; - ERROR: not-in-table value ; -: write-output ( lzw -- ) - [ - [ omega>> ] [ table>> ] bi ?at [ not-in-table ] unless - ] [ - [ lzw-bit-width-compress ] - [ output>> bs:poke ] 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>> bs:poke ] bi - ] - [ (lzw-compress-chars) ] - [ - [ k>> ] - [ lzw-bit-width-compress ] - [ output>> bs:poke ] tri - ] - [ - [ end-of-information ] dip - [ lzw-bit-width-compress ] - [ output>> bs:poke ] bi - ] - [ ] - } cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ; - -: lzw-compress ( byte-array -- seq ) - binary - [ lzw-compress-chars ] [ output>> stream>> ] bi ; - : lookup-old-code ( lzw -- vector ) [ old-code>> ] [ table>> ] bi nth ; @@ -155,7 +58,7 @@ ERROR: not-in-table value ; : add-to-table ( seq lzw -- ) table>> push ; : lzw-read ( lzw -- lzw n ) - [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:peek ; + [ ] [ lzw-bit-width-uncompress ] [ input>> ] tri bs:read ; DEFER: lzw-uncompress-char : handle-clear-code ( lzw -- ) @@ -203,6 +106,6 @@ DEFER: lzw-uncompress-char ] if* ; : lzw-uncompress ( seq -- byte-array ) - - ! binary ! - [ lzw-uncompress-char ] [ output>> ] bi ; + bs: + + [ lzw-uncompress-char ] [ output>> ] bi ; diff --git a/basis/images/processing/processing.factor b/basis/images/processing/processing.factor index 2304c56171..fc463731b3 100755 --- a/basis/images/processing/processing.factor +++ b/basis/images/processing/processing.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays byte-arrays combinators grouping images -images.loader images.viewer kernel locals math math.order +kernel locals math math.order math.ranges math.vectors sequences sequences.deep fry ; IN: images.processing From 451a13c740d3cf82f881b78a8937c13563b783ed Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 01:27:00 -0500 Subject: [PATCH 13/22] oops, i was using alt.bitstreams in some places --- basis/compression/huffman/huffman.factor | 4 ++-- basis/compression/inflate/inflate.factor | 4 ++-- basis/images/jpeg/jpeg.factor | 4 ++-- 3 files changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/compression/huffman/huffman.factor b/basis/compression/huffman/huffman.factor index 60b3a1d5a1..6ef9c2fabc 100755 --- a/basis/compression/huffman/huffman.factor +++ b/basis/compression/huffman/huffman.factor @@ -1,11 +1,11 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alt.bitstreams arrays assocs constructors fry +USING: accessors arrays assocs constructors fry hashtables io kernel locals math math.order math.parser math.ranges multiline sequences ; IN: compression.huffman -QUALIFIED-WITH: alt.bitstreams bs +QUALIFIED-WITH: bitstreams bs 2 clump [ first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line ] map concat ; : zlib-inflate ( bytes -- bytes ) - bs: + bs: [ check-zlib-header ] [ inflate-loop ] bi inflate-lz77 ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 0588e5c365..648923704a 100755 --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -9,7 +9,7 @@ math.ranges math.vectors memoize multiline namespaces sequences sequences.deep ; IN: images.jpeg -QUALIFIED-WITH: alt.bitstreams bs +QUALIFIED-WITH: bitstreams bs TUPLE: jpeg-image < image { headers } @@ -274,7 +274,7 @@ MEMO: dct-matrix-blas ( -- m ) dct-matrix >float-blas-matrix ; : baseline-decompress ( -- ) jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append - >byte-array bs: jpeg> (>>bitstream) + >byte-array bs: jpeg> (>>bitstream) jpeg> [ bitstream>> ] [ [ [ ] with map ] change-huff-tables drop ] bi jpeg> components>> [ fetch-tables ] each jpeg> setup-bitmap From 480870e3676758ea368c1f14aa94a1b28d5600d7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 May 2009 11:00:39 -0500 Subject: [PATCH 14/22] add some more opengl extension bindings: GL_EXT_framebuffer_blit GL_EXT_framebuffer_multisample GL_EXT_gpu_shader4 GL_EXT_geometry_shader4 GL_EXT_transform_feedback --- basis/opengl/framebuffers/framebuffers.factor | 13 +- basis/opengl/gl/gl.factor | 242 ++++++++++++++++++ 2 files changed, 254 insertions(+), 1 deletion(-) diff --git a/basis/opengl/framebuffers/framebuffers.factor b/basis/opengl/framebuffers/framebuffers.factor index 346789e1c5..f3ed8d320d 100644 --- a/basis/opengl/framebuffers/framebuffers.factor +++ b/basis/opengl/framebuffers/framebuffers.factor @@ -28,6 +28,7 @@ IN: opengl.framebuffers { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT [ "framebuffer incomplete (multisample counts don't match)" ] } [ drop gl-error "unknown framebuffer error" ] } case throw ; @@ -35,9 +36,19 @@ IN: opengl.framebuffers framebuffer-incomplete? [ framebuffer-error ] when* ; : with-framebuffer ( id quot -- ) - GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT + [ GL_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] dip [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline +: with-draw-read-framebuffers ( draw-id read-id quot -- ) + [ + [ GL_DRAW_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] + [ GL_READ_FRAMEBUFFER_EXT swap glBindFramebufferEXT ] bi* + ] dip + [ + GL_DRAW_FRAMEBUFFER_EXT 0 glBindFramebufferEXT + GL_READ_FRAMEBUFFER_EXT 0 glBindFramebufferEXT + ] [ ] cleanup ; inline + : framebuffer-attachment ( attachment -- id ) GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 6181a72ffc..39a8a2c4fe 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -1774,6 +1774,33 @@ GL-FUNCTION: GLboolean glIsRenderbufferEXT { } ( GLuint renderbuffer ) ; GL-FUNCTION: void glRenderbufferStorageEXT { } ( GLenum target, GLenum internalformat, GLsizei width, GLsizei height ) ; +! GL_EXT_framebuffer_blit + + +GL-FUNCTION: void glBlitFramebufferEXT { } ( GLint srcX0, GLint srcY0, GLint srcX1, GLint srcY1, + GLint dstX0, GLint dstY0, GLint dstX1, GLint dstY1, + GLbitfield mask, GLenum filter ) ; + +CONSTANT: GL_READ_FRAMEBUFFER_EXT HEX: 8CA8 +CONSTANT: GL_DRAW_FRAMEBUFFER_EXT HEX: 8CA9 + +ALIAS: GL_DRAW_FRAMEBUFFER_BINDING_EXT GL_FRAMEBUFFER_BINDING_EXT +CONSTANT: GL_READ_FRAMEBUFFER_BINDING_EXT HEX: 8CAA + + +! GL_EXT_framebuffer_multisample + + +GL-FUNCTION: void glRenderbufferStorageMultisampleEXT { } ( + GLenum target, GLsizei samples, + GLenum internalformat, + GLsizei width, GLsizei height ) ; + +CONSTANT: GL_RENDERBUFFER_SAMPLES_EXT HEX: 8CAB +CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_MULTISAMPLE_EXT HEX: 8D56 +CONSTANT: GL_MAX_SAMPLES_EXT HEX: 8D57 + + ! GL_ARB_texture_float @@ -1798,3 +1825,218 @@ CONSTANT: GL_TEXTURE_INTENSITY_TYPE_ARB HEX: 8C15 CONSTANT: GL_TEXTURE_DEPTH_TYPE_ARB HEX: 8C16 CONSTANT: GL_UNSIGNED_NORMALIZED_ARB HEX: 8C17 + +! GL_EXT_gpu_shader4 + + +GL-FUNCTION: void glVertexAttribI1iEXT { } ( GLuint index, GLint x ) ; +GL-FUNCTION: void glVertexAttribI2iEXT { } ( GLuint index, GLint x, GLint y ) ; +GL-FUNCTION: void glVertexAttribI3iEXT { } ( GLuint index, GLint x, GLint y, GLint z ) ; +GL-FUNCTION: void glVertexAttribI4iEXT { } ( GLuint index, GLint x, GLint y, GLint z, GLint w ) ; + +GL-FUNCTION: void glVertexAttribI1uiEXT { } ( GLuint index, GLuint x ) ; +GL-FUNCTION: void glVertexAttribI2uiEXT { } ( GLuint index, GLuint x, GLuint y ) ; +GL-FUNCTION: void glVertexAttribI3uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z ) ; +GL-FUNCTION: void glVertexAttribI4uiEXT { } ( GLuint index, GLuint x, GLuint y, GLuint z, GLuint w ) ; + +GL-FUNCTION: void glVertexAttribI1ivEXT { } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttribI2ivEXT { } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttribI3ivEXT { } ( GLuint index, GLint* v ) ; +GL-FUNCTION: void glVertexAttribI4ivEXT { } ( GLuint index, GLint* v ) ; + +GL-FUNCTION: void glVertexAttribI1uivEXT { } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttribI2uivEXT { } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttribI3uivEXT { } ( GLuint index, GLuint* v ) ; +GL-FUNCTION: void glVertexAttribI4uivEXT { } ( GLuint index, GLuint* v ) ; + +GL-FUNCTION: void glVertexAttribI4bvEXT { } ( GLuint index, GLbyte* v ) ; +GL-FUNCTION: void glVertexAttribI4svEXT { } ( GLuint index, GLshort* v ) ; +GL-FUNCTION: void glVertexAttribI4ubvEXT { } ( GLuint index, GLubyte* v ) ; +GL-FUNCTION: void glVertexAttribI4usvEXT { } ( GLuint index, GLushort* v ) ; + +GL-FUNCTION: void glVertexAttribIPointerEXT { } ( GLuint index, GLint size, GLenum type, GLsizei stride, void* pointer ) ; + +GL-FUNCTION: void glGetVertexAttribIivEXT { } ( GLuint index, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetVertexAttribIuivEXT { } ( GLuint index, GLenum pname, GLuint* params ) ; + +GL-FUNCTION: void glUniform1uiEXT { } ( GLint location, GLuint v0 ) ; +GL-FUNCTION: void glUniform2uiEXT { } ( GLint location, GLuint v0, GLuint v1 ) ; +GL-FUNCTION: void glUniform3uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2 ) ; +GL-FUNCTION: void glUniform4uiEXT { } ( GLint location, GLuint v0, GLuint v1, GLuint v2, GLuint v3 ) ; + +GL-FUNCTION: void glUniform1uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; +GL-FUNCTION: void glUniform2uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; +GL-FUNCTION: void glUniform3uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; +GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint* value ) ; + +GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ; + +GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ; +GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ; + +CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD +CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0 +CONSTANT: GL_SAMPLER_2D_ARRAY_EXT HEX: 8DC1 +CONSTANT: GL_SAMPLER_BUFFER_EXT HEX: 8DC2 +CONSTANT: GL_SAMPLER_1D_ARRAY_SHADOW_EXT HEX: 8DC3 +CONSTANT: GL_SAMPLER_2D_ARRAY_SHADOW_EXT HEX: 8DC4 +CONSTANT: GL_SAMPLER_CUBE_SHADOW_EXT HEX: 8DC5 +CONSTANT: GL_UNSIGNED_INT_VEC2_EXT HEX: 8DC6 +CONSTANT: GL_UNSIGNED_INT_VEC3_EXT HEX: 8DC7 +CONSTANT: GL_UNSIGNED_INT_VEC4_EXT HEX: 8DC8 +CONSTANT: GL_INT_SAMPLER_1D_EXT HEX: 8DC9 +CONSTANT: GL_INT_SAMPLER_2D_EXT HEX: 8DCA +CONSTANT: GL_INT_SAMPLER_3D_EXT HEX: 8DCB +CONSTANT: GL_INT_SAMPLER_CUBE_EXT HEX: 8DCC +CONSTANT: GL_INT_SAMPLER_2D_RECT_EXT HEX: 8DCD +CONSTANT: GL_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DCE +CONSTANT: GL_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DCF +CONSTANT: GL_INT_SAMPLER_BUFFER_EXT HEX: 8DD0 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_EXT HEX: 8DD1 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_EXT HEX: 8DD2 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_3D_EXT HEX: 8DD3 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_CUBE_EXT HEX: 8DD4 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_RECT_EXT HEX: 8DD5 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_1D_ARRAY_EXT HEX: 8DD6 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_2D_ARRAY_EXT HEX: 8DD7 +CONSTANT: GL_UNSIGNED_INT_SAMPLER_BUFFER_EXT HEX: 8DD8 +CONSTANT: GL_MIN_PROGRAM_TEXEL_OFFSET_EXT HEX: 8904 +CONSTANT: GL_MAX_PROGRAM_TEXEL_OFFSET_EXT HEX: 8905 + + +! GL_EXT_geometry_shader4 + + +GL-FUNCTION: void glProgramParameteriEXT { } ( GLuint program, GLenum pname, GLint value ) ; +GL-FUNCTION: void glFramebufferTextureEXT { } ( GLenum target, GLenum attachment, + GLuint texture, GLint level ) ; +GL-FUNCTION: void glFramebufferTextureLayerEXT { } ( GLenum target, GLenum attachment, + GLuint texture, GLint level, GLint layer ) ; +GL-FUNCTION: void glFramebufferTextureFaceEXT { } ( GLenum target, GLenum attachment, + GLuint texture, GLint level, GLenum face ) ; + +CONSTANT: GL_GEOMETRY_SHADER_EXT HEX: 8DD9 +CONSTANT: GL_GEOMETRY_VERTICES_OUT_EXT HEX: 8DDA +CONSTANT: GL_GEOMETRY_INPUT_TYPE_EXT HEX: 8DDB +CONSTANT: GL_GEOMETRY_OUTPUT_TYPE_EXT HEX: 8DDC +CONSTANT: GL_MAX_GEOMETRY_TEXTURE_IMAGE_UNITS_EXT HEX: 8C29 +CONSTANT: GL_MAX_GEOMETRY_VARYING_COMPONENTS_EXT HEX: 8DDD +CONSTANT: GL_MAX_VERTEX_VARYING_COMPONENTS_EXT HEX: 8DDE +CONSTANT: GL_MAX_VARYING_COMPONENTS_EXT HEX: 8B4B +CONSTANT: GL_MAX_GEOMETRY_UNIFORM_COMPONENTS_EXT HEX: 8DDF +CONSTANT: GL_MAX_GEOMETRY_OUTPUT_VERTICES_EXT HEX: 8DE0 +CONSTANT: GL_MAX_GEOMETRY_TOTAL_OUTPUT_COMPONENTS_EXT HEX: 8DE1 +CONSTANT: GL_LINES_ADJACENCY_EXT HEX: A +CONSTANT: GL_LINE_STRIP_ADJACENCY_EXT HEX: B +CONSTANT: GL_TRIANGLES_ADJACENCY_EXT HEX: C +CONSTANT: GL_TRIANGLE_STRIP_ADJACENCY_EXT HEX: D +CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_TARGETS_EXT HEX: 8DA8 +CONSTANT: GL_FRAMEBUFFER_INCOMPLETE_LAYER_COUNT_EXT HEX: 8DA9 +CONSTANT: GL_FRAMEBUFFER_ATTACHMENT_LAYERED_EXT HEX: 8DA7 +ALIAS: GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_LAYER_EXT GL_FRAMEBUFFER_ATTACHMENT_TEXTURE_3D_ZOFFSET_EXT +CONSTANT: GL_PROGRAM_POINT_SIZE_EXT HEX: 8642 + + +! GL_EXT_texture_integer + + +GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ; +GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ; +GL-FUNCTION: void glTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ; +GL-FUNCTION: void glGetTexParameterIivEXT { } ( GLenum target, GLenum pname, GLint* params ) ; +GL-FUNCTION: void glGetTexParameterIuivEXT { } ( GLenum target, GLenum pname, GLuint* params ) ; + +CONSTANT: GL_RGBA_INTEGER_MODE_EXT HEX: 8D9E + +CONSTANT: GL_RGBA32UI_EXT HEX: 8D70 +CONSTANT: GL_RGB32UI_EXT HEX: 8D71 +CONSTANT: GL_ALPHA32UI_EXT HEX: 8D72 +CONSTANT: GL_INTENSITY32UI_EXT HEX: 8D73 +CONSTANT: GL_LUMINANCE32UI_EXT HEX: 8D74 +CONSTANT: GL_LUMINANCE_ALPHA32UI_EXT HEX: 8D75 + +CONSTANT: GL_RGBA16UI_EXT HEX: 8D76 +CONSTANT: GL_RGB16UI_EXT HEX: 8D77 +CONSTANT: GL_ALPHA16UI_EXT HEX: 8D78 +CONSTANT: GL_INTENSITY16UI_EXT HEX: 8D79 +CONSTANT: GL_LUMINANCE16UI_EXT HEX: 8D7A +CONSTANT: GL_LUMINANCE_ALPHA16UI_EXT HEX: 8D7B + +CONSTANT: GL_RGBA8UI_EXT HEX: 8D7C +CONSTANT: GL_RGB8UI_EXT HEX: 8D7D +CONSTANT: GL_ALPHA8UI_EXT HEX: 8D7E +CONSTANT: GL_INTENSITY8UI_EXT HEX: 8D7F +CONSTANT: GL_LUMINANCE8UI_EXT HEX: 8D80 +CONSTANT: GL_LUMINANCE_ALPHA8UI_EXT HEX: 8D81 + +CONSTANT: GL_RGBA32I_EXT HEX: 8D82 +CONSTANT: GL_RGB32I_EXT HEX: 8D83 +CONSTANT: GL_ALPHA32I_EXT HEX: 8D84 +CONSTANT: GL_INTENSITY32I_EXT HEX: 8D85 +CONSTANT: GL_LUMINANCE32I_EXT HEX: 8D86 +CONSTANT: GL_LUMINANCE_ALPHA32I_EXT HEX: 8D87 + +CONSTANT: GL_RGBA16I_EXT HEX: 8D88 +CONSTANT: GL_RGB16I_EXT HEX: 8D89 +CONSTANT: GL_ALPHA16I_EXT HEX: 8D8A +CONSTANT: GL_INTENSITY16I_EXT HEX: 8D8B +CONSTANT: GL_LUMINANCE16I_EXT HEX: 8D8C +CONSTANT: GL_LUMINANCE_ALPHA16I_EXT HEX: 8D8D + +CONSTANT: GL_RGBA8I_EXT HEX: 8D8E +CONSTANT: GL_RGB8I_EXT HEX: 8D8F +CONSTANT: GL_ALPHA8I_EXT HEX: 8D90 +CONSTANT: GL_INTENSITY8I_EXT HEX: 8D91 +CONSTANT: GL_LUMINANCE8I_EXT HEX: 8D92 +CONSTANT: GL_LUMINANCE_ALPHA8I_EXT HEX: 8D93 + +CONSTANT: GL_RED_INTEGER_EXT HEX: 8D94 +CONSTANT: GL_GREEN_INTEGER_EXT HEX: 8D95 +CONSTANT: GL_BLUE_INTEGER_EXT HEX: 8D96 +CONSTANT: GL_ALPHA_INTEGER_EXT HEX: 8D97 +CONSTANT: GL_RGB_INTEGER_EXT HEX: 8D98 +CONSTANT: GL_RGBA_INTEGER_EXT HEX: 8D99 +CONSTANT: GL_BGR_INTEGER_EXT HEX: 8D9A +CONSTANT: GL_BGRA_INTEGER_EXT HEX: 8D9B +CONSTANT: GL_LUMINANCE_INTEGER_EXT HEX: 8D9C +CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D + + +! GL_EXT_transform_feedback + + +GL-FUNCTION: void glBindBufferRangeEXT { } ( GLenum target, GLuint index, GLuint buffer, + GLintptr offset, GLsizeiptr size ) ; +GL-FUNCTION: void glBindBufferOffsetEXT { } ( GLenum target, GLuint index, GLuint buffer, + GLintptr offset ) ; +GL-FUNCTION: void glBindBufferBaseEXT { } ( GLenum target, GLuint index, GLuint buffer ) ; + +GL-FUNCTION: void glBeginTransformFeedbackEXT { } ( GLenum primitiveMode ) ; +GL-FUNCTION: void glEndTransformFeedbackEXT { } ( ) ; + +GL-FUNCTION: void glTransformFeedbackVaryingsEXT { } ( GLuint program, GLsizei count, + GLchar** varyings, GLenum bufferMode ) ; +GL-FUNCTION: void glGetTransformFeedbackVaryingEXT { } ( GLuint program, GLuint index, + GLsizei bufSize, GLsizei* length, + GLsizei* size, GLenum* type, GLchar* name ) ; + +GL-FUNCTION: void glGetIntegerIndexedvEXT { } ( GLenum param, GLuint index, GLint* values ) ; +GL-FUNCTION: void glGetBooleanIndexedvEXT { } ( GLenum param, GLuint index, GLboolean* values ) ; + +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_EXT HEX: 8C8E +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_START_EXT HEX: 8C84 +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_SIZE_EXT HEX: 8C85 +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_BINDING_EXT HEX: 8C8F +CONSTANT: GL_INTERLEAVED_ATTRIBS_EXT HEX: 8C8C +CONSTANT: GL_SEPARATE_ATTRIBS_EXT HEX: 8C8D +CONSTANT: GL_PRIMITIVES_GENERATED_EXT HEX: 8C87 +CONSTANT: GL_TRANSFORM_FEEDBACK_PRIMITIVES_WRITTEN_EXT HEX: 8C88 +CONSTANT: GL_RASTERIZER_DISCARD_EXT HEX: 8C89 +CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_INTERLEAVED_COMPONENTS_EXT HEX: 8C8A +CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_ATTRIBS_EXT HEX: 8C8B +CONSTANT: GL_MAX_TRANSFORM_FEEDBACK_SEPARATE_COMPONENTS_EXT HEX: 8C80 +CONSTANT: GL_TRANSFORM_FEEDBACK_VARYINGS_EXT HEX: 8C83 +CONSTANT: GL_TRANSFORM_FEEDBACK_BUFFER_MODE_EXT HEX: 8C7F +CONSTANT: GL_TRANSFORM_FEEDBACK_VARYING_MAX_LENGTH_EXT HEX: 8C76 + From 6d1f1e3b5e263456e1137ffb109fe2d4afe68711 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 May 2009 11:04:11 -0500 Subject: [PATCH 15/22] cocoa doesn't send key-up gestures for cmd+keys --- extra/terrain/terrain.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index d6905144bb..fb326ef534 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -134,7 +134,7 @@ M: terrain-world tick-length 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 -- ) From 9785cd4c40212d834e3ce966fddf0a574ddeb825 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 14:08:56 -0500 Subject: [PATCH 16/22] fix inflate --- basis/bitstreams/bitstreams.factor | 15 +++++++++------ 1 file changed, 9 insertions(+), 6 deletions(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 997daa2c5d..300ab5c1bf 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -123,7 +123,10 @@ ERROR: not-enough-bits n bit-reader ; : #bits>#bytes ( #bits -- #bytes ) 8 /mod 0 = [ 1 + ] unless ; inline -:: subseq>bits ( bignum n bs -- bits ) +:: 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 ; @@ -138,15 +141,15 @@ ERROR: not-enough-bits n bit-reader ; bs (>>bit-pos) ] if ; -:: (peek) ( n bs word -- bits ) +:: (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 word execute( seq -- x ) :> bignum - bignum n bs subseq>bits ; + 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> (peek) ; +M: lsb0-bit-reader peek ( n bs -- bits ) \ le> \ subseq>bits-le (peek) ; -M: msb0-bit-reader peek ( n bs -- bits ) \ be> (peek) ; +M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ; :: bit-writer-bytes ( writer -- bytes ) writer widthed>> #bits>> :> n From 74d1fe6defeffdb4435bd274be203bd1a5b3da82 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 14:59:26 -0500 Subject: [PATCH 17/22] remove debugging code from bitstreams --- basis/bitstreams/bitstreams.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 300ab5c1bf..cb6a753735 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -104,7 +104,7 @@ M:: lsb0-bit-writer poke ( value n bs -- ) 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>> 8 = [ new-byte bits>> bs bytes>> push zero-widthed bs (>>widthed) remainder widthed>bytes From ae5f5553e6329aca915b361b5ccfdf5dc0387f94 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 15 May 2009 15:26:41 -0500 Subject: [PATCH 18/22] move IOHIDManagerSetDeviceMatching call after IOHIDManagerOpen. this prevents IOHIDManagerOpen from failing if it would match an exclusive-opened device --- basis/game-input/iokit/iokit.factor | 15 +++++++-------- 1 file changed, 7 insertions(+), 8 deletions(-) diff --git a/basis/game-input/iokit/iokit.factor b/basis/game-input/iokit/iokit.factor index 32440e92b2..68ecaecc29 100755 --- a/basis/game-input/iokit/iokit.factor +++ b/basis/game-input/iokit/iokit.factor @@ -12,10 +12,11 @@ SYMBOLS: +hid-manager+ +keyboard-state+ +mouse-state+ +controller-states+ ; iokit-game-input-backend game-input-backend set-global -: hid-manager-matching ( matching-seq -- alien ) - f 0 IOHIDManagerCreate - [ swap >plist IOHIDManagerSetDeviceMatchingMultiple ] - keep ; +: make-hid-manager ( -- alien ) + f 0 IOHIDManagerCreate ; + +: set-hid-manager-matching ( alien matching-seq -- ) + >plist IOHIDManagerSetDeviceMatchingMultiple ; : devices-from-hid-manager ( manager -- vector ) [ @@ -85,9 +86,6 @@ CONSTANT: hat-switch-matching-hash : ?hat-switch ( device -- ? ) hat-switch-matching-hash ?axis ; -: hid-manager-matching-game-devices ( -- alien ) - game-devices-matching-seq hid-manager-matching ; - : device-property ( device key -- value ) IOHIDDeviceGetProperty [ plist> ] [ f ] if* ; : element-property ( element key -- value ) @@ -288,12 +286,13 @@ M: iokit-game-input-backend reset-mouse 256 +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 From 3c49944fc16322f1e610303661b8a13cf68b34fd Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 16:06:48 -0500 Subject: [PATCH 19/22] call vim with run-detached instead of try-process. clean up vim code. --- basis/editors/gvim/gvim.factor | 5 ++++- basis/editors/macvim/macvim.factor | 8 +++----- basis/editors/vim/vim-docs.factor | 2 +- basis/editors/vim/vim.factor | 12 ++++++------ 4 files changed, 14 insertions(+), 13 deletions(-) diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor index 15fd52f5ee..277cd734cc 100644 --- a/basis/editors/gvim/gvim.factor +++ b/basis/editors/gvim/gvim.factor @@ -11,7 +11,10 @@ SINGLETON: gvim HOOK: gvim-path io-backend ( -- path ) M: gvim vim-command ( file line -- string ) - [ gvim-path , "+" swap number>string append , , ] { } make ; + [ + gvim-path , + number>string "+" prepend , , + ] { } make ; gvim vim-editor set-global diff --git a/basis/editors/macvim/macvim.factor b/basis/editors/macvim/macvim.factor index b5f864dcd0..c178207e49 100644 --- a/basis/editors/macvim/macvim.factor +++ b/basis/editors/macvim/macvim.factor @@ -3,11 +3,9 @@ namespaces prettyprint editors make ; IN: editors.macvim -: macvim-location ( file line -- ) +: macvim ( file line -- ) drop [ "open" , "-a" , "MacVim", , ] { } make - try-process ; - -[ macvim-location ] edit-hook set-global - + run-detached drop ; +[ macvim ] edit-hook set-global diff --git a/basis/editors/vim/vim-docs.factor b/basis/editors/vim/vim-docs.factor index 7f527bf18f..1ec3a37061 100644 --- a/basis/editors/vim/vim-docs.factor +++ b/basis/editors/vim/vim-docs.factor @@ -3,7 +3,7 @@ USING: definitions editors help help.markup help.syntax io io.files IN: editors.vim ARTICLE: { "vim" "vim" } "Vim support" -"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim-location } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "." +"This module makes the " { $link edit } " word work with Vim by setting the " { $link edit-hook } " global variable to call " { $link vim } ". The " { $link vim-path } " variable contains the name of the vim executable. The default " { $link vim-path } " is " { $snippet "\"gvim\"" } "." $nl "If you intend to use this module regularly, it helps to have it load during stage 2 bootstrap. On Windows, place the following example " { $snippet ".factor-boot-rc" } " in the directory returned by " { $link home } ":" { $code diff --git a/basis/editors/vim/vim.factor b/basis/editors/vim/vim.factor index f07f257888..88c8b8051e 100644 --- a/basis/editors/vim/vim.factor +++ b/basis/editors/vim/vim.factor @@ -4,7 +4,6 @@ make ; IN: editors.vim SYMBOL: vim-path - SYMBOL: vim-editor HOOK: vim-command vim-editor ( file line -- array ) @@ -12,12 +11,13 @@ SINGLETON: vim M: vim vim-command [ - vim-path get , swap , "+" swap number>string append , + vim-path get , + [ , ] [ number>string "+" prepend , ] bi* ] { } make ; -: vim-location ( file line -- ) - vim-command try-process ; +: vim ( file line -- ) + vim-command run-detached drop ; "vim" vim-path set-global -[ vim-location ] edit-hook set-global -vim vim-editor set-global +[ vim ] edit-hook set-global +\ vim vim-editor set-global From a0b9cfd6024ecac5c3099e6c0fa3651b7eed304c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 16:12:13 -0500 Subject: [PATCH 20/22] launch editors with run-detached. the naming convention foo-location doesn't make sense with some text editors, so rename the edit words to the text editor name --- basis/editors/scite/scite.factor | 4 ++-- basis/editors/textedit/textedit.factor | 6 +++--- basis/editors/textmate/textmate.factor | 7 +++---- 3 files changed, 8 insertions(+), 9 deletions(-) diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor index 7e8a540b73..605b4d53aa 100644 --- a/basis/editors/scite/scite.factor +++ b/basis/editors/scite/scite.factor @@ -25,7 +25,7 @@ IN: editors.scite number>string "-goto:" prepend , ] { } make ; -: scite-location ( file line -- ) +: scite ( file line -- ) scite-command run-detached drop ; -[ scite-location ] edit-hook set-global +[ scite ] edit-hook set-global diff --git a/basis/editors/textedit/textedit.factor b/basis/editors/textedit/textedit.factor index cccc94b539..4b5f2c6886 100644 --- a/basis/editors/textedit/textedit.factor +++ b/basis/editors/textedit/textedit.factor @@ -2,9 +2,9 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; IN: editors.textedit -: textedit-location ( file line -- ) +: textedit ( file line -- ) drop [ "open" , "-a" , "TextEdit", , ] { } make - try-process ; + run-detached drop ; -[ textedit-location ] edit-hook set-global +[ textedit ] edit-hook set-global diff --git a/basis/editors/textmate/textmate.factor b/basis/editors/textmate/textmate.factor index 8bea085c7f..65395bd590 100644 --- a/basis/editors/textmate/textmate.factor +++ b/basis/editors/textmate/textmate.factor @@ -1,10 +1,9 @@ USING: definitions io.launcher kernel math math.parser parser namespaces prettyprint editors make ; - IN: editors.textmate -: textmate-location ( file line -- ) +: textmate ( file line -- ) [ "mate" , "-a" , "-l" , number>string , , ] { } make - try-process ; + run-detached drop ; -[ textmate-location ] edit-hook set-global +[ textmate ] edit-hook set-global From 8de7f016c89d00ff0ff39e23d0bff97a000d35fe Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 19:36:36 -0500 Subject: [PATCH 21/22] add reverse time to terrain demo and refactored it a bit --- extra/terrain/terrain.factor | 59 +++++++++++++++++++++++++++++------- 1 file changed, 48 insertions(+), 11 deletions(-) diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index fb326ef534..cfacfeb700 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -6,13 +6,15 @@ opengl.shaders opengl.textures opengl.textures.private sequences sequences.product specialized-arrays.float terrain.generation terrain.shaders ui ui.gadgets ui.gadgets.worlds ui.pixel-formats game-worlds method-chains -math.affine-transforms noise 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 / ] @@ -28,13 +30,23 @@ CONSTANT: terrain-vertex-distance { $[ 1.0 512.0 / ] $[ 1.0 512.0 / ] } CONSTANT: terrain-vertex-row-length $[ 512 1 + 2 * ] TUPLE: player - location yaw pitch velocity 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 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 ; @@ -140,12 +152,17 @@ terrain-world H{ :: 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 @@ -199,11 +216,30 @@ terrain-world H{ : 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 ; @@ -226,7 +262,8 @@ BEFORE: terrain-world begin-world GL_DEPTH_TEST glEnable GL_TEXTURE_2D glEnable GL_VERTEX_ARRAY glEnableClientState - PLAYER-START-LOCATION 0.0 0.0 { 0.0 0.0 0.0 } { 1.0 1.0 1.0 } player boa >>player + >>player + V{ } clone >>history 0.01 0.01 { 512 512 } perlin-noise-image [ >>sky-image ] keep make-texture [ set-texture-parameters ] keep >>sky-texture From 241e6a64bfe41e6247722e0e99a5d57bcc792315 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 15 May 2009 22:31:50 -0500 Subject: [PATCH 22/22] call link-info instead of file-info, fix wonky spacing, name a constant --- basis/tools/files/files.factor | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/basis/tools/files/files.factor b/basis/tools/files/files.factor index 146a119a63..29d3674b60 100755 --- a/basis/tools/files/files.factor +++ b/basis/tools/files/files.factor @@ -74,9 +74,9 @@ M: object file-spec>string ( file-listing spec -- string ) : list-files-slow ( listing-tool -- array ) [ path>> ] [ sort>> ] [ specs>> ] tri '[ - [ dup name>> file-info file-listing boa ] map - _ [ sort-by ] when* - [ _ [ file-spec>string ] with map ] map + [ dup name>> link-info file-listing boa ] map + _ [ sort-by ] when* + [ _ [ file-spec>string ] with map ] map ] with-directory-entries ; inline : list-files ( listing-tool -- array ) @@ -115,11 +115,14 @@ SYMBOLS: +device-name+ +mount-point+ +type+ [ file-systems-info ] [ [ unparse ] map ] bi prefix simple-table. ; -: file-systems. ( -- ) +CONSTANT: default-file-systems-spec { +device-name+ +available-space+ +free-space+ +used-space+ +total-space+ +percent-used+ +mount-point+ - } print-file-systems ; + } + +: file-systems. ( -- ) + default-file-systems-spec print-file-systems ; { { [ os unix? ] [ "tools.files.unix" ] }