diff --git a/basis/bitstreams/bitstreams.factor b/basis/bitstreams/bitstreams.factor index 4718f137e4..032e851a79 100644 --- a/basis/bitstreams/bitstreams.factor +++ b/basis/bitstreams/bitstreams.factor @@ -56,13 +56,20 @@ TUPLE: lsb0-bit-writer < bit-writer ; GENERIC: peek ( n bitstream -- value ) GENERIC: poke ( value n bitstream -- ) +: get-abp ( bitstream -- abp ) + [ byte-pos>> 8 * ] [ bit-pos>> + ] bi ; inline + +: set-abp ( abp bitstream -- ) + [ 8 /mod ] dip [ (>>bit-pos) ] [ (>>byte-pos) ] bi ; inline + : seek ( n bitstream -- ) - { - [ byte-pos>> 8 * ] - [ bit-pos>> + + 8 /mod ] - [ (>>bit-pos) ] - [ (>>byte-pos) ] - } cleave ; inline + [ get-abp + ] [ set-abp ] bi ; inline + +: (align) ( n m -- n' ) + [ /mod 0 > [ 1+ ] when ] [ * ] bi ; inline + +: align ( n bitstream -- ) + [ get-abp swap (align) ] [ set-abp ] bi ; inline : read ( n bitstream -- value ) [ peek ] [ seek ] 2bi ; inline diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor old mode 100755 new mode 100644 index 7cb43ac68f..ab1caf3f6a --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -1,212 +1,220 @@ -! Copyright (C) 2009 Marc Fauconneau. -! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs byte-arrays -byte-vectors combinators constructors fry grouping hashtables -compression.huffman images io.binary kernel locals -math math.bitwise math.order math.ranges multiline sequences -sorting ; -IN: compression.inflate - -QUALIFIED-WITH: bitstreams bs - -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 258 - } - -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 - { - { 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 ; +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs byte-arrays +byte-vectors combinators constructors fry grouping hashtables +compression.huffman images io.binary kernel locals +math math.bitwise math.order math.ranges multiline sequences +sorting ; +IN: compression.inflate + +QUALIFIED-WITH: bitstreams bs + +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 258 + } + +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 ) + 8 bitstream bs:align + 16 bitstream bs:read :> len + 16 bitstream bs:read :> nlen + len nlen + 16 >signed -1 assert= ! len + ~len = -1 + bitstream byte-pos>> + bitstream byte-pos>> len + + bitstream bytes>> + len 8 * bitstream bs:seek ; + +: inflate-static ( bitstream -- bytes ) zlib-unimplemented ; + +:: inflate-loop ( bitstream -- bytes ) + [ 1 bitstream bs:read 0 = ] + [ + bitstream + 2 bitstream bs:read + { + { 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> + +: reverse-png-filter' ( lines -- byte-array ) + [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip + concat [ 128 + ] B{ } map-as ; + +: reverse-png-filter ( lines -- byte-array ) + dup first [ 0 ] replicate prefix + [ { 0 0 } prepend ] map + 2 clump [ + first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line + ] map B{ } concat-as ; + +: zlib-inflate ( bytes -- bytes ) + bs: + [ check-zlib-header ] [ inflate-loop ] bi + inflate-lz77 ; diff --git a/basis/compression/run-length/authors.txt b/basis/compression/run-length/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/compression/run-length/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index 6553860546..cde2a7e113 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -1,7 +1,75 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays grouping sequences ; +USING: accessors arrays combinators grouping kernel locals math +math.matrices math.order multiline sequence-parser sequences +tools.continuations ; IN: compression.run-length : run-length-uncompress ( byte-array -- byte-array' ) - 2 group [ first2 ] map concat ; + 2 group [ first2 ] map B{ } concat-as ; + +: 8hi-lo ( byte -- hi lo ) + [ HEX: f0 bitand -4 shift ] [ HEX: f bitand ] bi ; inline + +:: run-length-uncompress-bitmap4 ( byte-array m n -- byte-array' ) + byte-array :> sp + m 1 + n zero-matrix :> matrix + n 4 mod n + :> stride + 0 :> i! + 0 :> j! + f :> done?! + [ + ! i j [ number>string ] bi@ " " glue . + sp next dup 0 = [ + sp next dup HEX: 03 HEX: ff between? [ + nip [ sp ] dip dup odd? + [ 1 + take-n but-last ] [ take-n ] if + [ j matrix i swap nth copy ] [ length j + j! ] bi + ] [ + nip { + { 0 [ i 1 + i! 0 j! ] } + { 1 [ t done?! ] } + { 2 [ sp next j + j! sp next i + i! ] } + } case + ] if + ] [ + [ sp next 8hi-lo 2array concat ] [ head ] bi + [ j matrix i swap nth copy ] [ length j + j! ] bi + ] if + + ! j stride >= [ i 1 + i! 0 j! ] when + j stride >= [ 0 j! ] when + done? not + ] loop + matrix B{ } concat-as ; + +:: run-length-uncompress-bitmap8 ( byte-array m n -- byte-array' ) + byte-array :> sp + m 1 + n zero-matrix :> matrix + n 4 mod n + :> stride + 0 :> i! + 0 :> j! + f :> done?! + [ + ! i j [ number>string ] bi@ " " glue . + sp next dup 0 = [ + sp next dup HEX: 03 HEX: ff between? [ + nip [ sp ] dip dup odd? + [ 1 + take-n but-last ] [ take-n ] if + [ j matrix i swap nth copy ] [ length j + j! ] bi + ] [ + nip { + { 0 [ i 1 + i! 0 j! ] } + { 1 [ t done?! ] } + { 2 [ sp next j + j! sp next i + i! ] } + } case + ] if + ] [ + sp next [ j matrix i swap nth copy ] [ length j + j! ] bi + ] if + + ! j stride >= [ i 1 + i! 0 j! ] when + j stride >= [ 0 j! ] when + done? not + ] loop + matrix B{ } concat-as ; diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index 271e173718..59ecb8ff77 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -57,3 +57,30 @@ TUPLE: default { a integer initial: 0 } ; CONSTRUCTOR: default ( -- obj ) ; [ 0 ] [ a>> ] unit-test + + +TUPLE: inherit1 a ; +TUPLE: inherit2 < inherit1 a ; + +CONSTRUCTOR: inherit2 ( a -- obj ) ; + +[ T{ inherit2 f f 100 } ] [ 100 ] unit-test + + +TUPLE: inherit3 hp max-hp ; +TUPLE: inherit4 < inherit3 ; +TUPLE: inherit5 < inherit3 ; + +CONSTRUCTOR: inherit3 ( -- obj ) + dup max-hp>> >>hp ; + +BACKWARD-CONSTRUCTOR: inherit4 ( -- obj ) + 10 >>max-hp ; + +[ 10 ] [ hp>> ] unit-test + +FORWARD-CONSTRUCTOR: inherit5 ( -- obj ) + 5 >>hp + 10 >>max-hp ; + +[ 5 ] [ hp>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index e6982e3d98..b8fe598f84 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors assocs classes.tuple effects.parser fry -generalizations generic.standard kernel lexer locals macros -parser sequences slots vocabs words ; +USING: accessors assocs classes classes.tuple effects.parser +fry generalizations generic.standard kernel lexer locals macros +parser sequences slots vocabs words arrays ; IN: constructors ! An experiment @@ -25,30 +25,44 @@ IN: constructors [ drop define-initializer-generic ] [ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ; +: all-slots-assoc ( class -- slots ) + superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ; + MACRO:: slots>constructor ( class slots -- quot ) - class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params + class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc + class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params slots length - params length + default-params length '[ - _ narray slots swap zip - params swap assoc-union - values _ firstn class boa + _ narray slot-assoc swap zip + default-params swap assoc-union values _ firstn class boa ] ; -:: define-constructor ( constructor-word class effect def -- ) +:: (define-constructor) ( constructor-word class effect def -- word quot ) constructor-word class def define-initializer - class effect in>> '[ _ _ slots>constructor ] + class effect in>> '[ _ _ slots>constructor ] ; + +:: define-constructor ( constructor-word class effect def -- ) + constructor-word class effect def (define-constructor) class lookup-initializer '[ @ _ execute( obj -- obj ) ] effect define-declared ; +:: define-auto-constructor ( constructor-word class effect def reverse? -- ) + constructor-word class effect def (define-constructor) + class superclasses [ lookup-initializer ] map sift + reverse? [ reverse ] when + '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ; + : scan-constructor ( -- class word ) scan-word [ name>> "<" ">" surround create-in ] keep ; -SYNTAX: CONSTRUCTOR: - scan-constructor - complete-effect - parse-definition - define-constructor ; +: parse-constructor ( -- class word effect def ) + scan-constructor complete-effect parse-definition ; + +SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ; +SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ; +SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ; +SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ; "initializers" create-vocab drop diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index 7994c3ed96..b10ca775f4 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -104,8 +104,8 @@ HOOK: signal-error. os ( obj -- ) "Cannot do next-object outside begin/end-scan" print drop ; : undefined-symbol-error. ( obj -- ) - "The image refers to a library or symbol that was not found" - " at load time" append print drop ; + "The image refers to a library or symbol that was not found at load time" + print drop ; : stack-underflow. ( obj name -- ) write " stack underflow" print drop ; @@ -252,12 +252,15 @@ M: no-current-vocab summary drop "Not in a vocabulary; IN: form required" ; M: no-word-error summary - name>> "No word named ``" "'' found in current vocabulary search path" surround ; + name>> + "No word named ``" + "'' found in current vocabulary search path" surround ; M: no-word-error error. summary print ; M: ambiguous-use-error summary - words>> first name>> "More than one vocabulary defines a word named ``" "''" surround ; + words>> first name>> + "More than one vocabulary defines a word named ``" "''" surround ; M: ambiguous-use-error error. summary print ; @@ -317,4 +320,4 @@ M: wrong-values summary drop "Quotation called with wrong stack effect" ; { { [ os windows? ] [ "debugger.windows" require ] } { [ os unix? ] [ "debugger.unix" require ] } -} cond \ No newline at end of file +} cond diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 8540907db9..0ecf543baa 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -1,14 +1,13 @@ -USING: windows.dinput windows.dinput.constants parser -alien.c-types windows.ole32 namespaces assocs kernel arrays -vectors windows.kernel32 windows.com windows.dinput shuffle -windows.user32 windows.messages sequences combinators locals -math.rectangles accessors math alien alien.strings -io.encodings.utf16 io.encodings.utf16n continuations -byte-arrays game-input.dinput.keys-array game-input -ui.backend.windows windows.errors struct-arrays -math.bitwise ; +USING: accessors alien alien.c-types alien.strings arrays +assocs byte-arrays combinators continuations game-input +game-input.dinput.keys-array io.encodings.utf16 +io.encodings.utf16n kernel locals math math.bitwise +math.rectangles namespaces parser sequences shuffle +struct-arrays ui.backend.windows vectors windows.com +windows.dinput windows.dinput.constants windows.errors +windows.kernel32 windows.messages windows.ole32 +windows.user32 ; IN: game-input.dinput - CONSTANT: MOUSE-BUFFER-SIZE 16 SINGLETON: dinput-game-input-backend diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index d0f614f9cd..c877acf936 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -59,4 +59,11 @@ IN: generalizations.tests { 3 5 } [ 2 nweave ] must-infer-as [ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] -[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test \ No newline at end of file +[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test + +[ 1 2 3 4 1 2 3 ] [ 1 2 3 4 3 nover ] unit-test + +[ [ 1 2 3 ] [ 1 2 3 ] ] +[ 1 2 3 [ ] [ ] 3 nbi-curry ] unit-test + +[ 15 3 ] [ 1 2 3 4 5 [ + + + + ] [ - - - - ] 5 nbi ] unit-test diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 28a1f7dddb..0ea179b52c 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -39,6 +39,9 @@ MACRO: firstn ( n -- ) MACRO: npick ( n -- ) 1- [ dup ] [ '[ _ dip swap ] ] repeat ; +MACRO: nover ( n -- ) + dup '[ _ 1 + npick ] n*quot ; + MACRO: ndup ( n -- ) dup '[ _ npick ] n*quot ; @@ -69,6 +72,9 @@ MACRO: ncurry ( n -- ) MACRO: nwith ( n -- ) [ with ] n*quot ; +MACRO: nbi ( n -- ) + '[ [ _ nkeep ] dip call ] ; + MACRO: ncleave ( quots n -- ) [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi compose ; @@ -91,6 +97,9 @@ MACRO: nweave ( n -- ) [ dup [ '[ _ _ mnswap ] ] with map ] keep '[ _ _ ncleave ] ; +MACRO: nbi-curry ( n -- ) + [ bi-curry ] n*quot ; + : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline diff --git a/basis/images/bitmap/bitmap-tests.factor b/basis/images/bitmap/bitmap-tests.factor index ea8b0d4c0c..950fd0b3a6 100644 --- a/basis/images/bitmap/bitmap-tests.factor +++ b/basis/images/bitmap/bitmap-tests.factor @@ -1,7 +1,6 @@ USING: images.bitmap images.viewer io.encodings.binary io.files io.files.unique kernel tools.test images.loader -literals sequences checksums.md5 checksums -images.normalization ; +literals sequences checksums.md5 checksums ; IN: images.bitmap.tests CONSTANT: test-bitmap24 "vocab:images/test-images/thiswayup24.bmp" @@ -26,8 +25,8 @@ ${ : test-bitmap-save ( path -- ? ) [ md5 checksum-file ] - [ load-image normalize-image ] bi - "bitmap-save-test" unique-file + [ load-image ] bi + "bitmap-save-test" ".bmp" make-unique-file [ save-bitmap ] [ md5 checksum-file ] bi = ; diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 4f2ad720b6..cb73e4e274 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,288 +2,21 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien alien.c-types arrays byte-arrays columns combinators compression.run-length endian fry grouping images -images.loader io io.binary io.encodings.binary io.files +images.bitmap.loading images.loader io io.binary +io.encodings.binary io.encodings.string io.files io.streams.limited kernel locals macros math math.bitwise math.functions namespaces sequences specialized-arrays.uint -specialized-arrays.ushort strings summary io.encodings.8-bit -io.encodings.string ; -QUALIFIED-WITH: bitstreams b +specialized-arrays.ushort strings summary ; IN: images.bitmap -: read2 ( -- n ) 2 read le> ; -: read4 ( -- n ) 4 read le> ; : write2 ( n -- ) 2 >le write ; : write4 ( n -- ) 4 >le write ; -SINGLETON: bitmap-image -"bmp" bitmap-image register-image-class - -TUPLE: loading-bitmap -magic size reserved1 reserved2 offset header-length width -height planes bit-count compression size-image -x-pels y-pels color-used color-important -red-mask green-mask blue-mask alpha-mask -cs-type end-points -gamma-red gamma-green gamma-blue -intent profile-data profile-size reserved3 -color-palette color-index bitfields ; - -! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint - -> >array ] - [ color-palette>> 3 ] bi - '[ _ nth ] map concat ; - -: os2v2-color-lookup ( loading-bitmap -- seq ) - [ color-index>> >array ] - [ color-palette>> 3 ] bi - '[ _ nth ] map concat ; - -: v3-color-lookup ( loading-bitmap -- seq ) - [ color-index>> >array ] - [ color-palette>> 4 [ 3 head-slice ] map ] bi - '[ _ nth ] map concat ; - -: color-lookup ( loading-bitmap -- seq ) - dup header-length>> { - { 12 [ os2-color-lookup ] } - { 64 [ os2v2-color-lookup ] } - { 40 [ v3-color-lookup ] } - ! { 108 [ v4-color-lookup ] } - ! { 124 [ v5-color-lookup ] } - } case ; - -ERROR: bmp-not-supported n ; - -: uncompress-bitfield ( seq masks -- bytes' ) - '[ - _ [ - [ bitand ] [ bit-count ] [ log2 ] tri - shift - ] with map - ] { } map-as B{ } concat-as ; - -: bitmap>bytes ( loading-bitmap -- byte-array ) - dup bit-count>> - { - { 32 [ color-index>> ] } - { 24 [ color-index>> ] } - { 16 [ - [ - ! byte-array>ushort-array - 2 group [ le> ] map - ! 5 6 5 - ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield - ! 5 5 5 - { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield - ] change-color-index - color-index>> - ] } - { 8 [ color-lookup ] } - { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] } - { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] } - [ bmp-not-supported ] - } case >byte-array ; - -: set-bitfield-widths ( loading-bitmap -- loading-bitmap' ) - dup bit-count>> { - { 16 [ dup color-palette>> 4 group [ le> ] map ] } - { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] } - } case reverse >>bitfields ; - -ERROR: unsupported-bitfield-widths n ; - -M: unsupported-bitfield-widths summary - drop "Bitmaps only support bitfield compression in 16/32bit images" ; - -: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' ) - set-bitfield-widths - dup bit-count>> { - { 16 [ - dup bitfields>> '[ - byte-array>ushort-array _ uncompress-bitfield - ] change-color-index - ] } - { 32 [ - dup bitfields>> '[ - byte-array>uint-array _ uncompress-bitfield - ] change-color-index - ] } - [ unsupported-bitfield-widths ] - } case ; - -ERROR: unsupported-bitmap-compression compression ; - -: uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) - dup compression>> { - { f [ ] } - { 0 [ ] } - { 1 [ [ run-length-uncompress ] change-color-index ] } - { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] } - { 3 [ uncompress-bitfield-widths ] } - { 4 [ "jpeg" unsupported-bitmap-compression ] } - { 5 [ "png" unsupported-bitmap-compression ] } - } case ; - -: bitmap-padding ( width -- n ) - 3 * 4 mod 4 swap - 4 mod ; inline - -: loading-bitmap>bytes ( loading-bitmap -- byte-array ) - uncompress-bitmap - bitmap>bytes ; - -: parse-file-header ( loading-bitmap -- loading-bitmap ) - 2 read latin1 decode >>magic - read4 >>size - read2 >>reserved1 - read2 >>reserved2 - read4 >>offset ; - -: read-v3-header ( loading-bitmap -- loading-bitmap ) - read4 >>width - read4 32 >signed >>height - read2 >>planes - read2 >>bit-count - read4 >>compression - read4 >>size-image - read4 >>x-pels - read4 >>y-pels - read4 >>color-used - read4 >>color-important ; - -: read-v4-header ( loading-bitmap -- loading-bitmap ) - read-v3-header - read4 >>red-mask - read4 >>green-mask - read4 >>blue-mask - read4 >>alpha-mask - read4 >>cs-type - read4 read4 read4 3array >>end-points - read4 >>gamma-red - read4 >>gamma-green - read4 >>gamma-blue ; - -: read-v5-header ( loading-bitmap -- loading-bitmap ) - read-v4-header - read4 >>intent - read4 >>profile-data - read4 >>profile-size - read4 >>reserved3 ; - -: read-os2-header ( loading-bitmap -- loading-bitmap ) - read2 >>width - read2 16 >signed >>height - read2 >>planes - read2 >>bit-count ; - -: read-os2v2-header ( loading-bitmap -- loading-bitmap ) - read4 >>width - read4 32 >signed >>height - read2 >>planes - read2 >>bit-count ; - -ERROR: unknown-bitmap-header n ; - -: parse-bitmap-header ( loading-bitmap -- loading-bitmap ) - read4 [ >>header-length ] keep - { - { 12 [ read-os2-header ] } - { 64 [ read-os2v2-header ] } - { 40 [ read-v3-header ] } - { 108 [ read-v4-header ] } - { 124 [ read-v5-header ] } - [ unknown-bitmap-header ] - } case ; - -: color-palette-length ( loading-bitmap -- n ) - [ offset>> 14 - ] [ header-length>> ] bi - ; - -: color-index-length ( loading-bitmap -- n ) - { - [ width>> ] - [ planes>> * ] - [ bit-count>> * 31 + 32 /i 4 * ] - [ height>> abs * ] - } cleave ; - -: image-size ( loading-bitmap -- n ) - [ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ; - -: parse-bitmap ( loading-bitmap -- loading-bitmap ) - dup color-palette-length read >>color-palette - dup size-image>> dup 0 > [ - read >>color-index - ] [ - drop dup color-index-length read >>color-index - ] if ; - -ERROR: unsupported-bitmap-file magic ; - -: load-bitmap ( path -- loading-bitmap ) - binary stream-throws [ - loading-bitmap new - parse-file-header dup magic>> { - { "BM" [ parse-bitmap-header parse-bitmap ] } - ! { "BA" [ parse-os2-bitmap-array ] } - ! { "CI" [ parse-os2-color-icon ] } - ! { "CP" [ parse-os2-color-pointer ] } - ! { "IC" [ parse-os2-icon ] } - ! { "PT" [ parse-os2-pointer ] } - [ unsupported-bitmap-file ] - } case - ] with-input-stream ; - -ERROR: unknown-component-order bitmap ; - -: bitmap>component-order ( loading-bitmap -- object ) - bit-count>> { - { 32 [ BGR ] } - { 24 [ BGR ] } - { 16 [ BGR ] } - { 8 [ BGR ] } - { 4 [ BGR ] } - { 1 [ BGR ] } - [ unknown-component-order ] - } case ; - -M: bitmap-image load-image* ( path bitmap-image -- bitmap ) - drop load-bitmap - [ image new ] dip - { - [ loading-bitmap>bytes >>bitmap ] - [ [ width>> ] [ height>> abs ] bi 2array >>dim ] - [ height>> 0 < not >>upside-down? ] - [ compression>> 3 = [ t >>upside-down? ] when ] - [ bitmap>component-order >>component-order ] - } cleave ; - -PRIVATE> - -: bitmap>color-index ( bitmap -- byte-array ) - [ - bitmap>> - 4 - [ 3 head-slice ] map - B{ } join - ] [ - dim>> first dup bitmap-padding dup 0 > [ - [ 3 * group ] dip '[ _ append ] map - B{ } join - ] [ - 2drop - ] if - ] bi ; - -: reverse-lines ( byte-array width -- byte-array ) - concat ; inline - : save-bitmap ( image path -- ) binary [ B{ CHAR: B CHAR: M } write [ - bitmap>color-index length 14 + 40 + write4 + bitmap>> length 14 + 40 + write4 0 write4 54 write4 40 write4 @@ -301,8 +34,8 @@ PRIVATE> ! compression [ drop 0 write4 ] - ! size-image - [ bitmap>color-index length write4 ] + ! image-size + [ bitmap>> length write4 ] ! x-pels [ drop 0 write4 ] @@ -317,12 +50,7 @@ PRIVATE> [ drop 0 write4 ] ! color-palette - [ - [ bitmap>color-index ] - [ dim>> first 3 * ] - [ dim>> first bitmap-padding + ] tri - reverse-lines write - ] + [ bitmap>> write ] } cleave ] bi ] with-file-writer ; diff --git a/basis/images/bitmap/loading/authors.txt b/basis/images/bitmap/loading/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/images/bitmap/loading/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor new file mode 100644 index 0000000000..b0bd501f09 --- /dev/null +++ b/basis/images/bitmap/loading/loading.factor @@ -0,0 +1,374 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators +compression.run-length fry grouping images images.loader io +io.binary io.encodings.8-bit io.encodings.binary +io.encodings.string io.streams.limited kernel math math.bitwise +sequences specialized-arrays.ushort summary ; +QUALIFIED-WITH: bitstreams b +IN: images.bitmap.loading + +SINGLETON: bitmap-image +"bmp" bitmap-image register-image-class + +! http://www.fileformat.info/format/bmp/egff.htm +! http://www.digicamsoft.com/bmp/bmp.html + +ERROR: unknown-component-order bitmap ; +ERROR: unknown-bitmap-header n ; + +: read2 ( -- n ) 2 read le> ; +: read4 ( -- n ) 4 read le> ; + +TUPLE: loading-bitmap + file-header header + color-palette color-index bitfields ; + +TUPLE: file-header + { magic initial: "BM" } + { size } + { reserved1 initial: 0 } + { reserved2 initial: 0 } + { offset } + { header-length } ; + +TUPLE: v3-header + { width initial: 0 } + { height initial: 0 } + { planes initial: 0 } + { bit-count initial: 0 } + { compression initial: 0 } + { image-size initial: 0 } + { x-resolution initial: 0 } + { y-resolution initial: 0 } + { colors-used initial: 0 } + { colors-important initial: 0 } ; + +TUPLE: v4-header < v3-header + { red-mask initial: 0 } + { green-mask initial: 0 } + { blue-mask initial: 0 } + { alpha-mask initial: 0 } + { cs-type initial: 0 } + { end-points initial: 0 } + { gamma-red initial: 0 } + { gamma-green initial: 0 } + { gamma-blue initial: 0 } ; + +TUPLE: v5-header < v4-header + { intent initial: 0 } + { profile-data initial: 0 } + { profile-size initial: 0 } + { reserved3 initial: 0 } ; + +TUPLE: os2v1-header + { width initial: 0 } + { height initial: 0 } + { planes initial: 0 } + { bit-count initial: 0 } ; + +TUPLE: os2v2-header < os2v1-header + { compression initial: 0 } + { image-size initial: 0 } + { x-resolution initial: 0 } + { y-resolution initial: 0 } + { colors-used initial: 0 } + { colors-important initial: 0 } + { units initial: 0 } + { reserved initial: 0 } + { recording initial: 0 } + { rendering initial: 0 } + { size1 initial: 0 } + { size2 initial: 0 } + { color-encoding initial: 0 } + { identifier initial: 0 } ; + +UNION: v-header v3-header v4-header v5-header ; +UNION: os2-header os2v1-header os2v2-header ; + +: parse-file-header ( -- file-header ) + \ file-header new + 2 read latin1 decode >>magic + read4 >>size + read2 >>reserved1 + read2 >>reserved2 + read4 >>offset + read4 >>header-length ; + +: read-v3-header-data ( header -- header ) + read4 >>width + read4 32 >signed >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>image-size + read4 >>x-resolution + read4 >>y-resolution + read4 >>colors-used + read4 >>colors-important ; + +: read-v3-header ( -- header ) + \ v3-header new + read-v3-header-data ; + +: read-v4-header-data ( header -- header ) + read4 >>red-mask + read4 >>green-mask + read4 >>blue-mask + read4 >>alpha-mask + read4 >>cs-type + read4 read4 read4 3array >>end-points + read4 >>gamma-red + read4 >>gamma-green + read4 >>gamma-blue ; + +: read-v4-header ( -- v4-header ) + \ v4-header new + read-v3-header-data + read-v4-header-data ; + +: read-v5-header-data ( v5-header -- v5-header ) + read4 >>intent + read4 >>profile-data + read4 >>profile-size + read4 >>reserved3 ; + +: read-v5-header ( -- loading-bitmap ) + \ v5-header new + read-v3-header-data + read-v4-header-data + read-v5-header-data ; + +: read-os2v1-header ( -- os2v1-header ) + \ os2v1-header new + read2 >>width + read2 16 >signed >>height + read2 >>planes + read2 >>bit-count ; + +: read-os2v2-header-data ( os2v2-header -- os2v2-header ) + read4 >>width + read4 32 >signed >>height + read2 >>planes + read2 >>bit-count + read4 >>compression + read4 >>image-size + read4 >>x-resolution + read4 >>y-resolution + read4 >>colors-used + read4 >>colors-important + read2 >>units + read2 >>reserved + read2 >>recording + read2 >>rendering + read4 >>size1 + read4 >>size2 + read4 >>color-encoding + read4 >>identifier ; + +: read-os2v2-header ( -- os2v2-header ) + \ os2v2-header new + read-os2v2-header-data ; + +: parse-header ( n -- header ) + { + { 12 [ read-os2v1-header ] } + { 64 [ read-os2v2-header ] } + { 40 [ read-v3-header ] } + { 108 [ read-v4-header ] } + { 124 [ read-v5-header ] } + [ unknown-bitmap-header ] + } case ; + +: color-index-length ( header -- n ) + { + [ width>> ] + [ planes>> * ] + [ bit-count>> * 31 + 32 /i 4 * ] + [ height>> abs * ] + } cleave ; + +: color-palette-length ( loading-bitmap -- n ) + file-header>> + [ offset>> 14 - ] [ header-length>> ] bi - ; + +: parse-color-palette ( loading-bitmap -- loading-bitmap ) + dup color-palette-length read >>color-palette ; + +GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap ) + +: parse-color-data ( loading-bitmap -- loading-bitmap ) + dup header>> parse-color-data* ; + +M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap ) + color-index-length read >>color-index ; + +M: object parse-color-data* ( loading-bitmap header -- loading-bitmap ) + dup image-size>> [ 0 ] unless* dup 0 > + [ nip ] [ drop color-index-length ] if read >>color-index ; + +: alpha-used? ( loading-bitmap -- ? ) + color-index>> 4 [ fourth 0 = ] all? not ; + +GENERIC: bitmap>component-order* ( loading-bitmap header -- object ) + +: bitmap>component-order ( loading-bitmap -- object ) + dup header>> bitmap>component-order* ; + +: simple-bitmap>component-order ( loading-bitamp -- object ) + header>> bit-count>> { + { 32 [ BGRX ] } + { 24 [ BGR ] } + { 16 [ BGR ] } + { 8 [ BGR ] } + { 4 [ BGR ] } + { 1 [ BGR ] } + [ unknown-component-order ] + } case ; + +: advanced-bitmap>component-order ( loading-bitmap -- object ) + [ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array { + { { 32 t } [ drop BGRA ] } + { { 32 f } [ drop BGRX ] } + [ drop simple-bitmap>component-order ] + } case ; + +: color-lookup3 ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 3 ] bi + '[ _ nth ] map concat ; + +: color-lookup4 ( loading-bitmap -- seq ) + [ color-index>> >array ] + [ color-palette>> 4 [ 3 head-slice ] map ] bi + '[ _ nth ] map concat ; + +! os2v1 is 3bytes each, all others are 3 + 1 unused +: color-lookup ( loading-bitmap -- seq ) + dup file-header>> header-length>> { + { 12 [ color-lookup3 ] } + { 64 [ color-lookup4 ] } + { 40 [ color-lookup4 ] } + { 108 [ color-lookup4 ] } + { 124 [ color-lookup4 ] } + } case ; + +M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ; +M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ; +M: v3-header bitmap>component-order* drop simple-bitmap>component-order ; +M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ; +M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ; + +: uncompress-bitfield ( seq masks -- bytes' ) + '[ + _ [ + [ bitand ] [ bit-count ] [ log2 ] tri - shift + ] with map + ] { } map-as B{ } concat-as ; + +ERROR: bmp-not-supported n ; + +: bitmap>bytes ( loading-bitmap -- byte-array ) + dup header>> bit-count>> + { + { 32 [ color-index>> ] } + { 24 [ color-index>> ] } + { 16 [ + [ + ! byte-array>ushort-array + 2 group [ le> ] map + ! 5 6 5 + ! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield + ! 5 5 5 + { HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield + ] change-color-index + color-index>> + ] } + { 8 [ color-lookup ] } + { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] } + { 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] } + [ bmp-not-supported ] + } case >byte-array ; + +: set-bitfield-widths ( loading-bitmap -- loading-bitmap' ) + dup header>> bit-count>> { + { 16 [ dup color-palette>> 4 group [ le> ] map ] } + { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] } + } case reverse >>bitfields ; + +ERROR: unsupported-bitfield-widths n ; + +M: unsupported-bitfield-widths summary + drop "Bitmaps only support bitfield compression in 16/32bit images" ; + +: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' ) + set-bitfield-widths + dup header>> bit-count>> { + { 16 [ + dup bitfields>> '[ + byte-array>ushort-array _ uncompress-bitfield + ] change-color-index + ] } + { 32 [ ] } + [ unsupported-bitfield-widths ] + } case ; + +ERROR: unsupported-bitmap-compression compression ; + +GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap ) + +: uncompress-bitmap ( loading-bitmap -- loading-bitmap ) + dup header>> uncompress-bitmap* ; + +M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) + drop ; + +: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap ) + dupd '[ + _ header>> [ width>> ] [ height>> ] bi + _ execute + ] change-color-index ; inline + +M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) + compression>> { + { f [ ] } + { 0 [ ] } + { 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] } + { 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] } + { 3 [ uncompress-bitfield-widths ] } + { 4 [ "jpeg" unsupported-bitmap-compression ] } + { 5 [ "png" unsupported-bitmap-compression ] } + } case ; + +ERROR: unsupported-bitmap-file magic ; + +: load-bitmap ( path -- loading-bitmap ) + binary stream-throws [ + \ loading-bitmap new + parse-file-header [ >>file-header ] [ ] bi magic>> { + { "BM" [ + dup file-header>> header-length>> parse-header >>header + parse-color-palette + parse-color-data + ] } + ! { "BA" [ parse-os2-bitmap-array ] } + ! { "CI" [ parse-os2-color-icon ] } + ! { "CP" [ parse-os2-color-pointer ] } + ! { "IC" [ parse-os2-icon ] } + ! { "PT" [ parse-os2-pointer ] } + [ unsupported-bitmap-file ] + } case + ] with-input-stream ; + +: loading-bitmap>bytes ( loading-bitmap -- byte-array ) + uncompress-bitmap bitmap>bytes ; + +M: bitmap-image load-image* ( path bitmap-image -- bitmap ) + drop load-bitmap + [ image new ] dip + { + [ loading-bitmap>bytes >>bitmap ] + [ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ] + [ header>> height>> 0 < not >>upside-down? ] + [ bitmap>component-order >>component-order ] + } cleave ; diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor old mode 100755 new mode 100644 index 2cdc32e9df..b66aed043d --- a/basis/images/jpeg/jpeg.factor +++ b/basis/images/jpeg/jpeg.factor @@ -1,306 +1,359 @@ -! 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 images.loader ; -QUALIFIED-WITH: bitstreams bs -IN: images.jpeg - -SINGLETON: jpeg-image -{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each - -TUPLE: loading-jpeg < 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 ) loading-jpeg 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 loading-jpeg [ - 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 ; +! Copyright (C) 2009 Marc Fauconneau. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays byte-arrays combinators +constructors grouping compression.huffman images +images.processing io io.binary io.encodings.binary io.files +io.streams.byte-array kernel locals math math.bitwise +math.constants math.functions math.matrices math.order +math.ranges math.vectors memoize multiline namespaces +sequences sequences.deep ; +IN: images.jpeg + +QUALIFIED-WITH: bitstreams bs + +TUPLE: jpeg-image < image + { headers } + { bitstream } + { color-info initial: { f f f f } } + { quant-tables initial: { f f } } + { huff-tables initial: { f f f f } } + { components } ; + +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 ; + +! : blocks ( component -- seq ) +! mb-dim ! coord-matrix flip concat [ [ { 2 2 } v* ] [ v+ ] bi* ] with map ; + +: 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-id jpeg-image -- ) + block dup length>> sqrt >fixnum group flip + dup matrix-dim coord-matrix flip + [ + [ first2 spin nth nth ] + [ x,y v+ color-id 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 ( color -- pixels ) + 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 ; + +:: draw-macroblock-yuv420 ( mb blocks -- ) + mb { 16 16 } v* :> pos + 0 blocks nth pos { 0 0 } v+ 0 jpeg> draw-block + 1 blocks nth pos { 8 0 } v+ 0 jpeg> draw-block + 2 blocks nth pos { 0 8 } v+ 0 jpeg> draw-block + 3 blocks nth pos { 8 8 } v+ 0 jpeg> draw-block + 4 blocks nth 8 group 2 matrix-zoom concat pos 1 jpeg> draw-block + 5 blocks nth 8 group 2 matrix-zoom concat pos 2 jpeg> draw-block ; + +:: draw-macroblock-yuv444 ( mb blocks -- ) + mb { 8 8 } v* :> pos + 3 iota [ [ blocks nth pos ] [ jpeg> draw-block ] bi ] each ; + +:: draw-macroblock-y ( mb blocks -- ) + mb { 8 8 } v* :> pos + 0 blocks nth pos 0 jpeg> draw-block + 64 0 pos 1 jpeg> draw-block + 64 0 pos 2 jpeg> draw-block ; + + ! %fixme: color hack + ! color h>> 2 = + ! [ 8 group 2 matrix-zoom concat ] unless + ! pos { 8 8 } v* color jpeg> draw-block ; + +: decode-macroblock ( -- blocks ) + jpeg> components>> + [ + [ mb-dim first2 * iota ] + [ [ decode-block ] curry replicate ] bi + ] map concat ; + +: 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 ; + +ERROR: unsupported-colorspace ; +SINGLETONS: YUV420 YUV444 Y MAGIC! ; + +:: detect-colorspace ( jpeg-image -- csp ) + jpeg-image color-info>> sift :> colors + MAGIC! + colors length 1 = [ drop Y ] when + colors length 3 = + [ + colors [ mb-dim { 1 1 } = ] all? + [ drop YUV444 ] when + + colors unclip + [ [ mb-dim { 1 1 } = ] all? ] + [ mb-dim { 2 2 } = ] bi* and + [ drop YUV420 ] when + ] when ; + +! this eats ~50% cpu time +: draw-macroblocks ( mbs -- ) + jpeg> detect-colorspace + { + { YUV420 [ [ first2 draw-macroblock-yuv420 ] each ] } + { YUV444 [ [ first2 draw-macroblock-yuv444 ] each ] } + { Y [ [ first2 draw-macroblock-y ] each ] } + [ unsupported-colorspace ] + } case ; + +! 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 ; + +: 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 + [ decode-macroblock 2array ] accumulator + [ all-macroblocks ] dip + jpeg> setup-bitmap draw-macroblocks + jpeg> bitmap>> 3 [ color-transform ] change-each + jpeg> [ >byte-array ] change-bitmap drop ; + +ERROR: not-a-jpeg-image ; + +PRIVATE> + +: load-jpeg ( path -- image ) + binary [ + parse-marker { SOI } = [ not-a-jpeg-image ] unless + parse-headers + contents + ] with-file-reader + dup jpeg-image [ + baseline-parse + baseline-decompress + ] with-variable ; + +M: jpeg-image load-image* ( path jpeg-image -- bitmap ) + drop load-jpeg ; + diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index fd5e36e212..eb6b29713c 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -10,9 +10,10 @@ IN: images.png SINGLETON: png-image "png" png-image register-image-class -TUPLE: loading-png < image chunks -width height bit-depth color-type compression-method -filter-method interlace-method uncompressed ; +TUPLE: loading-png + chunks + width height bit-depth color-type compression-method + filter-method interlace-method uncompressed ; CONSTRUCTOR: loading-png ( -- image ) V{ } clone >>chunks ; @@ -33,22 +34,21 @@ ERROR: bad-png-header header ; ERROR: bad-checksum ; -: read-png-chunks ( image -- image ) +: read-png-chunks ( loading-png -- loading-png ) 4 read be> [ >>length ] [ 4 + ] bi read dup crc32 checksum-bytes 4 read = [ bad-checksum ] unless 4 cut-slice - [ ascii decode >>type ] - [ B{ } like >>data ] bi* + [ ascii decode >>type ] [ B{ } like >>data ] bi* [ over chunks>> push ] [ type>> ] bi "IEND" = [ read-png-chunks ] unless ; -: find-chunk ( image string -- chunk ) +: find-chunk ( loading-png string -- chunk ) [ chunks>> ] dip '[ type>> _ = ] find nip ; -: parse-ihdr-chunk ( image -- image ) +: parse-ihdr-chunk ( loading-png -- loading-png ) dup "IHDR" find-chunk data>> { [ [ 0 4 ] dip subseq be> >>width ] [ [ 4 8 ] dip subseq be> >>height ] @@ -59,44 +59,44 @@ ERROR: bad-checksum ; [ [ 12 ] dip nth >>interlace-method ] } cleave ; -: find-compressed-bytes ( image -- bytes ) +: find-compressed-bytes ( loading-png -- bytes ) chunks>> [ type>> "IDAT" = ] filter [ data>> ] map concat ; -: fill-image-data ( image -- image ) - dup [ width>> ] [ height>> ] bi 2array >>dim ; -: zlib-data ( png-image -- bytes ) +: zlib-data ( loading-png -- bytes ) chunks>> [ type>> "IDAT" = ] find nip data>> ; ERROR: unknown-color-type n ; ERROR: unimplemented-color-type image ; -: inflate-data ( image -- bytes ) +: inflate-data ( loading-png -- bytes ) zlib-data zlib-inflate ; -: decode-greyscale ( image -- image ) +: decode-greyscale ( loading-png -- loading-png ) unimplemented-color-type ; -: decode-truecolor ( image -- image ) - { - [ inflate-data ] - [ dim>> first 3 * 1 + group reverse-png-filter ] - [ swap >byte-array >>bitmap drop ] - [ RGB >>component-order drop ] - [ ] +: png-image-bytes ( loading-png -- byte-array ) + [ inflate-data ] [ width>> 3 * 1 + ] bi group + reverse-png-filter ; + +: decode-truecolor ( loading-png -- loading-png ) + [ ] dip { + [ png-image-bytes >>bitmap ] + [ [ width>> ] [ height>> ] bi 2array >>dim ] + [ drop RGB >>component-order ] } cleave ; -: decode-indexed-color ( image -- image ) +: decode-indexed-color ( loading-png -- loading-png ) unimplemented-color-type ; -: decode-greyscale-alpha ( image -- image ) +: decode-greyscale-alpha ( loading-png -- loading-png ) unimplemented-color-type ; -: decode-truecolor-alpha ( image -- image ) +: decode-truecolor-alpha ( loading-png -- loading-png ) unimplemented-color-type ; -: decode-png ( image -- image ) +: decode-png ( loading-png -- loading-png ) dup color-type>> { { 0 [ decode-greyscale ] } { 2 [ decode-truecolor ] } @@ -112,7 +112,6 @@ ERROR: unimplemented-color-type image ; read-png-header read-png-chunks parse-ihdr-chunk - fill-image-data decode-png ] with-input-stream ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 876076e9fe..e0de68b368 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -443,7 +443,7 @@ ERROR: unhandled-compression compression ; '[ _ group [ _ group unclip [ v+ ] accumulate swap suffix concat ] map - concat >byte-array + B{ } concat-as ] change-bitmap ; : strips-predictor ( ifd -- ifd ) @@ -492,11 +492,11 @@ ERROR: unknown-component-order ifd ; } case ; : ifd>image ( ifd -- image ) - { - [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] - [ ifd-component-order f ] - [ bitmap>> ] - } cleave image boa ; + [ ] dip { + [ [ image-width find-tag ] [ image-length find-tag ] bi 2array >>dim ] + [ ifd-component-order >>component-order ] + [ bitmap>> >>bitmap ] + } cleave ; : tiff>image ( image -- image ) ifds>> [ ifd>image ] map first ; diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index df6c21e7cc..de75165c7a 100644 --- a/basis/io/servers/connection/connection.factor +++ b/basis/io/servers/connection/connection.factor @@ -11,17 +11,17 @@ combinators.short-circuit ; IN: io.servers.connection TUPLE: threaded-server -name -log-level +{ name initial: "server" } +{ log-level initial: DEBUG } secure insecure -secure-config -sockets +{ secure-config initial-quot: [ ] } +{ sockets initial-quot: [ V{ } clone ] } max-connections semaphore -timeout +{ timeout initial-quot: [ 1 minutes ] } encoding -handler -ready ; +{ handler initial: [ "No handler quotation" throw ] } +{ ready initial-quot: [ ] } ; : local-server ( port -- addrspec ) "localhost" swap ; @@ -29,14 +29,7 @@ ready ; : new-threaded-server ( encoding class -- threaded-server ) new - swap >>encoding - "server" >>name - DEBUG >>log-level - 1 minutes >>timeout - V{ } clone >>sockets - >>secure-config - [ "No handler quotation" throw ] >>handler - >>ready ; inline + swap >>encoding ; : ( encoding -- threaded-server ) threaded-server new-threaded-server ; diff --git a/basis/io/sockets/sockets.factor b/basis/io/sockets/sockets.factor index 98b9a2ce23..6e41f083b7 100644 --- a/basis/io/sockets/sockets.factor +++ b/basis/io/sockets/sockets.factor @@ -117,7 +117,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ; glue ; : inet6-bytes ( seq -- bytes ) - [ 2 >be ] { } map-as concat >byte-array ; + [ 2 >be ] { } map-as B{ } concat-as ; PRIVATE> diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor index 0bdc6ce00b..e47de14dba 100644 --- a/basis/math/functions/functions-tests.factor +++ b/basis/math/functions/functions-tests.factor @@ -22,6 +22,7 @@ IN: math.functions.tests [ t ] [ e pi i* ^ imaginary-part -0.00001 0.00001 between? ] unit-test [ t ] [ 0 0 ^ fp-nan? ] unit-test +[ 0.0 ] [ 0.0 1.0 ^ ] unit-test [ 1/0. ] [ 0 -2 ^ ] unit-test [ t ] [ 0 0.0 ^ fp-nan? ] unit-test [ 1/0. ] [ 0 -2.0 ^ ] unit-test @@ -162,4 +163,4 @@ IN: math.functions.tests [ 2.5 ] [ 1.0 2.5 1.0 lerp ] unit-test [ 1.75 ] [ 1.0 2.5 0.5 lerp ] unit-test -[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test \ No newline at end of file +[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor index 5d88eba9fa..19a8f17a0c 100644 --- a/basis/math/functions/functions.factor +++ b/basis/math/functions/functions.factor @@ -89,7 +89,7 @@ PRIVATE> : ^ ( x y -- z ) { - { [ over zero? ] [ nip 0^ ] } + { [ over 0 = ] [ nip 0^ ] } { [ dup integer? ] [ integer^ ] } { [ 2dup real^? ] [ fpow ] } [ ^complex ] diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor old mode 100755 new mode 100644 index cfdbe17c06..d6bee78c14 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.order math.vectors -sequences sequences.private accessors columns ; +USING: accessors arrays columns kernel math math.bits +math.order math.vectors sequences sequences.private fry ; IN: math.matrices ! Matrices : zero-matrix ( m n -- matrix ) - [ nip 0 ] curry map ; + '[ _ 0 ] replicate ; : identity-matrix ( n -- matrix ) #! Make a nxn identity matrix. @@ -60,4 +60,8 @@ PRIVATE> gram-schmidt [ normalize ] map ; : cross-zip ( seq1 seq2 -- seq1xseq2 ) - [ [ 2array ] with map ] curry map ; \ No newline at end of file + [ [ 2array ] with map ] curry map ; + +: m^n ( m n -- n ) + make-bits over first length identity-matrix + [ [ dupd m. ] when [ dup m. ] dip ] reduce nip ; diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index f0edab23a3..d43e1736d1 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -50,7 +50,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed [ dup 1 = [ next-power-of-2 ] unless ] map ] unless ; -: (tex-image) ( image bitmap -- ) +: tex-image ( image bitmap -- ) [ [ GL_TEXTURE_2D 0 GL_RGBA ] dip [ dim>> adjust-texture-dim first2 0 ] @@ -58,9 +58,11 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed ] dip glTexImage2D ; -: (tex-sub-image) ( image -- ) +: tex-sub-image ( image -- ) [ GL_TEXTURE_2D 0 0 0 ] dip - [ dim>> first2 ] [ component-order>> component-order>format ] [ bitmap>> ] tri + [ dim>> first2 ] + [ component-order>> component-order>format ] + [ bitmap>> ] tri glTexSubImage2D ; : init-texture ( -- ) @@ -173,8 +175,8 @@ PRIVATE> GL_TEXTURE_BIT [ GL_TEXTURE_2D swap glBindTexture non-power-of-2-textures? get - [ dup bitmap>> (tex-image) ] - [ [ f (tex-image) ] [ (tex-sub-image) ] bi ] if + [ dup bitmap>> tex-image ] + [ [ f tex-image ] [ tex-sub-image ] bi ] if ] do-attribs ] keep ; diff --git a/basis/porter-stemmer/porter-stemmer.factor b/basis/porter-stemmer/porter-stemmer.factor index 35ed84aaf4..4765df10d7 100644 --- a/basis/porter-stemmer/porter-stemmer.factor +++ b/basis/porter-stemmer/porter-stemmer.factor @@ -1,5 +1,5 @@ +USING: combinators kernel math parser sequences splitting ; IN: porter-stemmer -USING: kernel math parser sequences combinators splitting ; : consonant? ( i str -- ? ) 2dup nth dup "aeiou" member? [ diff --git a/basis/tools/hexdump/hexdump.factor b/basis/tools/hexdump/hexdump.factor index 666e051088..f8a8bb96aa 100644 --- a/basis/tools/hexdump/hexdump.factor +++ b/basis/tools/hexdump/hexdump.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays io io.streams.string kernel math math.parser -namespaces sequences splitting grouping strings ascii -byte-arrays byte-vectors ; +USING: arrays ascii byte-arrays byte-vectors grouping io +io.encodings.binary io.files io.streams.string kernel math +math.parser namespaces sequences splitting strings ; IN: tools.hexdump >" "call-next-method" "initial:" + "initial-quot:" "read-only" "call(" "execute(" diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index b95507c78b..350b594274 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -1,7 +1,7 @@ IN: classes.tuple.parser.tests USING: accessors classes.tuple.parser lexer words classes sequences math kernel slots tools.test parser compiler.units -arrays classes.tuple eval ; +arrays classes.tuple eval multiline ; TUPLE: test-1 ; @@ -142,3 +142,11 @@ TUPLE: parsing-corner-case x ; " x 3 }" } "\n" join eval( -- tuple ) ] [ error>> unexpected-eof? ] must-fail-with + + +[ ] [ + <" USE: sequences + IN: classes.tuple.tests + TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;"> + eval( -- ) +] unit-test diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index e3452194c6..352d66f19e 100644 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -1,11 +1,12 @@ -USING: definitions generic kernel kernel.private math math.constants -parser sequences tools.test words assocs namespaces quotations -sequences.private classes continuations generic.single -generic.standard effects classes.tuple classes.tuple.private arrays -vectors strings compiler.units accessors classes.algebra calendar -prettyprint io.streams.string splitting summary columns math.order -classes.private slots slots.private eval see words.symbol -compiler.errors parser.notes ; +USING: accessors arrays assocs calendar classes classes.algebra +classes.private classes.tuple classes.tuple.private columns +compiler.errors compiler.units continuations definitions +effects eval generic generic.single generic.standard grouping +io.streams.string kernel kernel.private math math.constants +math.order namespaces parser parser.notes prettyprint +quotations random see sequences sequences.private slots +slots.private splitting strings summary threads tools.test +vectors vocabs words words.symbol ; IN: classes.tuple.tests TUPLE: rect x y w h ; @@ -421,7 +422,6 @@ TUPLE: redefinition-problem-2 ; [ t ] [ 3 redefinition-problem'? ] unit-test ! Hardcore unit tests -USE: threads \ thread "slots" word-prop "slots" set @@ -439,8 +439,6 @@ USE: threads ] with-compilation-unit ] unit-test -USE: vocabs - \ vocab "slots" word-prop "slots" set [ ] [ @@ -731,3 +729,18 @@ DEFER: redefine-tuple-twice [ ] [ "IN: classes.tuple.tests TUPLE: redefine-tuple-twice ;" eval( -- ) ] unit-test [ t ] [ \ redefine-tuple-twice symbol? ] unit-test + +TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } ; +SLOT: winner? + +[ f ] [ 100 [ lucky-number new ] replicate all-equal? ] unit-test + +! Reshaping initial-quot: +lucky-number new dup n>> 2array "luckiest-number" set + +[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test + +[ ] [ "USING: accessors random ; IN: classes.tuple.tests TUPLE: lucky-number { n initial-quot: [ 64 random-bits ] } { winner? initial-quot: [ t ] } ;" eval( -- ) ] unit-test + +[ t ] [ "luckiest-number" get first2 [ n>> ] dip = ] unit-test +[ t ] [ "luckiest-number" get first winner?>> ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 225176f4e5..e5ea80bc39 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,6 +50,9 @@ M: tuple class layout-of 2 slot { word } declare ; PRIVATE> +: initial-quots? ( class -- ? ) + all-slots [ initial-quot>> ] any? ; + : initial-values ( class -- slots ) all-slots [ initial>> ] map ; @@ -66,7 +69,7 @@ PRIVATE> GENERIC: slots>tuple ( seq class -- tuple ) -M: tuple-class slots>tuple +M: tuple-class slots>tuple ( seq class -- tuple ) check-slots pad-slots tuple-layout [ [ tuple-size ] @@ -146,12 +149,22 @@ ERROR: bad-superclass class ; : define-boa-check ( class -- ) dup boa-check-quot "boa-check" set-word-prop ; +: tuple-initial-quots-quot ( class -- quot ) + all-slots [ initial-quot>> ] filter + [ + [ + [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ] + [ offset>> , ] bi \ set-slot , + ] each + ] [ ] make f like ; + : tuple-prototype ( class -- prototype ) - [ initial-values ] keep - over [ ] any? [ slots>tuple ] [ 2drop f ] if ; + [ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri + [ slots>tuple ] [ 2drop f ] if ; : define-tuple-prototype ( class -- ) - dup tuple-prototype "prototype" set-word-prop ; + dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array + dup [ ] any? [ drop f ] unless "prototype" set-word-prop ; : prepare-slots ( slots superclass -- slots' ) [ make-slots ] [ class-size 2 + ] bi* finalize-slots ; @@ -173,10 +186,21 @@ ERROR: bad-superclass class ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; +: calculate-initial-value ( slot-spec -- value ) + dup initial>> [ + nip + ] [ + dup initial-quot>> [ + nip call( -- obj ) + ] [ + drop f + ] if* + ] if* ; + : compute-slot-permutation ( new-slots old-slots -- triples ) [ [ [ name>> ] map ] bi@ [ index ] curry map ] [ drop [ class>> ] map ] - [ drop [ initial>> ] map ] + [ drop [ calculate-initial-value ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) @@ -340,8 +364,11 @@ M: tuple tuple-hashcode M: tuple hashcode* tuple-hashcode ; M: tuple-class new - dup "prototype" word-prop - [ (clone) ] [ tuple-layout ] ?if ; + dup "prototype" word-prop [ + first2 [ (clone) ] dip [ call( obj -- obj ) ] when* + ] [ + tuple-layout + ] ?if ; M: tuple-class boa [ "boa-check" word-prop [ call ] when* ] diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 1966f0b69f..1abcba0720 100644 --- a/core/destructors/destructors-docs.factor +++ b/core/destructors/destructors-docs.factor @@ -8,16 +8,16 @@ HELP: dispose $nl "No further operations can be performed on a disposable object after this call." $nl -"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." } +"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." } { $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word." $nl -"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ; +"The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ; HELP: dispose* { $values { "disposable" "a disposable object" } } { $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." } { $notes - "This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once." + "This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once." } ; HELP: with-disposal diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..c8be08e79b 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors words sequences.private assocs alien quotations hashtables ; IN: slots -TUPLE: slot-spec name offset class initial read-only ; +TUPLE: slot-spec name offset class initial initial-quot read-only ; PREDICATE: reader < word "reader" word-prop ; @@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ; dup empty? [ unclip { { initial: [ [ first >>initial ] [ rest ] bi ] } + { initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] } { read-only [ [ t >>read-only ] dip ] } [ bad-slot-attribute ] } case @@ -197,7 +198,14 @@ ERROR: bad-slot-attribute key ; ERROR: bad-initial-value name ; +ERROR: duplicate-initial-values slot ; + +: check-duplicate-initial-values ( slot-spec -- slot-spec ) + dup [ initial>> ] [ initial-quot>> ] bi and + [ duplicate-initial-values ] when ; + : check-initial-value ( slot-spec -- slot-spec ) + check-duplicate-initial-values dup initial>> [ [ ] [ dup [ initial>> ] [ class>> ] bi instance? diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 56ac9fa36e..8093b6345b 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -245,7 +245,9 @@ IN: bootstrap.syntax ] define-core-syntax "initial:" "syntax" lookup define-symbol - + + "initial-quot:" "syntax" lookup define-symbol + "read-only" "syntax" lookup define-symbol "call(" [ \ call-effect parse-call( ] define-core-syntax diff --git a/extra/cursors/cursors-tests.factor b/extra/cursors/cursors-tests.factor index 3c98608b72..8294eb05e8 100644 --- a/extra/cursors/cursors-tests.factor +++ b/extra/cursors/cursors-tests.factor @@ -19,3 +19,21 @@ IN: cursors.tests [ f ] [ { 2 4 6 } [ odd? ] any? ] unit-test [ { 1 3 5 } ] [ { 1 2 3 4 5 6 } [ odd? ] filter ] unit-test + +[ { } ] +[ { 1 2 } { } [ + ] 2map ] unit-test + +[ { 11 } ] +[ { 1 2 } { 10 } [ + ] 2map ] unit-test + +[ { 11 22 } ] +[ { 1 2 } { 10 20 } [ + ] 2map ] unit-test + +[ { } ] +[ { 1 2 } { } { } [ + + ] 3map ] unit-test + +[ { 111 } ] +[ { 1 2 } { 10 } { 100 200 } [ + + ] 3map ] unit-test + +[ { 111 222 } ] +[ { 1 2 } { 10 20 } { 100 200 } [ + + ] 3map ] unit-test diff --git a/extra/cursors/cursors.factor b/extra/cursors/cursors.factor index 11b9bf4bf4..14cc1fdf7f 100644 --- a/extra/cursors/cursors.factor +++ b/extra/cursors/cursors.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Slava Pestov, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel math sequences sequences.private ; +USING: accessors arrays generalizations kernel math sequences +sequences.private ; IN: cursors GENERIC: cursor-done? ( cursor -- ? ) @@ -40,7 +41,7 @@ ERROR: cursor-ended cursor ; [ [ call ] dip cursor-write ] 2curry ; inline : cursor-map ( from to quot -- ) - swap cursor-map-quot cursor-each ; inline + swap cursor-map-quot cursor-each ; inline : cursor-write-if ( obj quot to -- ) [ over [ call ] dip ] dip @@ -99,3 +100,53 @@ M: to-sequence cursor-write : map ( seq quot -- ) [ cursor-map ] transform ; inline : filter ( seq quot -- newseq ) [ cursor-filter ] transform ; inline + +: find-done2? ( cursor cursor quot -- ? ) + 2over [ cursor-done? ] either? + [ 3drop t ] [ [ [ cursor-get-unsafe ] bi@ ] dip call ] if ; inline + +: cursor-until2 ( cursor cursor quot -- ) + [ find-done2? not ] + [ drop [ cursor-advance ] bi@ ] bi-curry bi-curry bi-curry while ; inline + +: cursor-each2 ( cursor cursor quot -- ) + [ f ] compose cursor-until2 ; inline + +: cursor-map2 ( from to quot -- ) + swap cursor-map-quot cursor-each2 ; inline + +: iterate2 ( seq1 seq2 quot iterator -- ) + [ [ >input ] bi@ ] 2dip call ; inline + +: transform2 ( seq1 seq2 quot transformer -- newseq ) + [ over >output [ [ >input ] [ >input ] bi* ] dip ] 2dip + [ call ] + [ 2drop nip freeze ] 4 nbi ; inline + +: 2each ( seq1 seq2 quot -- ) [ cursor-each2 ] iterate2 ; inline +: 2map ( seq1 seq2 quot -- ) [ cursor-map2 ] transform2 ; inline + +: find-done3? ( cursor1 cursor2 cursor3 quot -- ? ) + 3 nover 3array [ cursor-done? ] any? + [ 4 ndrop t ] [ [ [ cursor-get-unsafe ] tri@ ] dip call ] if ; inline + +: cursor-until3 ( cursor cursor quot -- ) + [ find-done3? not ] + [ drop [ cursor-advance ] tri@ ] bi-curry bi-curry bi-curry bi-curry while ; inline + +: cursor-each3 ( cursor cursor quot -- ) + [ f ] compose cursor-until3 ; inline + +: cursor-map3 ( from to quot -- ) + swap cursor-map-quot cursor-each3 ; inline + +: iterate3 ( seq1 seq2 seq3 quot iterator -- ) + [ [ >input ] tri@ ] 2dip call ; inline + +: transform3 ( seq1 seq2 seq3 quot transformer -- newseq ) + [ pick >output [ [ >input ] [ >input ] [ >input ] tri* ] dip ] 2dip + [ call ] + [ 2drop 2nip freeze ] 5 nbi ; inline + +: 3each ( seq1 seq2 seq3 quot -- ) [ cursor-each3 ] iterate3 ; inline +: 3map ( seq1 seq2 seq3 quot -- ) [ cursor-map3 ] transform3 ; inline diff --git a/extra/half-floats/authors.txt b/extra/half-floats/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/half-floats/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/half-floats/half-floats-tests.factor b/extra/half-floats/half-floats-tests.factor new file mode 100644 index 0000000000..d026ca2933 --- /dev/null +++ b/extra/half-floats/half-floats-tests.factor @@ -0,0 +1,46 @@ +USING: alien.c-types alien.syntax half-floats kernel math tools.test ; +IN: half-floats.tests + +[ HEX: 0000 ] [ 0.0 half>bits ] unit-test +[ HEX: 8000 ] [ -0.0 half>bits ] unit-test +[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test +[ HEX: be00 ] [ -1.5 half>bits ] unit-test +[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test +[ HEX: fc00 ] [ -1/0. half>bits ] unit-test +[ HEX: 7eaa ] [ HEX: aaaaaaaaaaaaa half>bits ] unit-test + +! too-big floats overflow to infinity +[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test +[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test +[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test +[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test + +! too-small floats flush to zero +[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test +[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test + +[ 0.0 ] [ HEX: 0000 bits>half ] unit-test +[ -0.0 ] [ HEX: 8000 bits>half ] unit-test +[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test +[ -1.5 ] [ HEX: be00 bits>half ] unit-test +[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test +[ -1/0. ] [ HEX: fc00 bits>half ] unit-test +[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test + +C-STRUCT: halves + { "half" "tom" } + { "half" "dick" } + { "half" "harry" } + { "half" "harry-jr" } ; + +[ 8 ] [ "halves" heap-size ] unit-test + +[ 3.0 ] [ + "halves" + 3.0 over set-halves-dick + halves-dick +] unit-test + +[ half-array{ 1.0 2.0 3.0 1/0. -1/0. } ] +[ { 1.0 2.0 3.0 1/0. -1/0. } >half-array ] unit-test + diff --git a/extra/half-floats/half-floats.factor b/extra/half-floats/half-floats.factor new file mode 100644 index 0000000000..53f6c6cfb1 --- /dev/null +++ b/extra/half-floats/half-floats.factor @@ -0,0 +1,42 @@ +! (c)2009 Joe Groff bsd license +USING: accessors alien.c-types alien.syntax kernel math math.order +specialized-arrays.direct.functor specialized-arrays.functor ; +IN: half-floats + +: half>bits ( float -- bits ) + float>bits + [ -31 shift 15 shift ] [ + HEX: 7fffffff bitand + dup zero? [ + dup HEX: 7f800000 >= [ -13 shift HEX: 7fff bitand ] [ + -13 shift + 112 10 shift - + 0 HEX: 7c00 clamp + ] if + ] unless + ] bi bitor ; + +: bits>half ( bits -- float ) + [ -15 shift 31 shift ] [ + HEX: 7fff bitand + dup zero? [ + dup HEX: 7c00 >= [ 13 shift HEX: 7f800000 bitor ] [ + 13 shift + 112 23 shift + + ] if + ] unless + ] bi bitor bits>float ; + +C-STRUCT: half { "ushort" "(bits)" } ; + +<< + +"half" c-type + [ half>bits ] >>unboxer-quot + [ *ushort bits>half ] >>boxer-quot + drop + +"half" define-array +"half" define-direct-array + +>> diff --git a/extra/half-floats/summary.txt b/extra/half-floats/summary.txt new file mode 100644 index 0000000000..b22448f69b --- /dev/null +++ b/extra/half-floats/summary.txt @@ -0,0 +1 @@ +Half-precision float support for FFI diff --git a/extra/nested-comments/nested-comments.factor b/extra/nested-comments/nested-comments.factor new file mode 100644 index 0000000000..94daffec2d --- /dev/null +++ b/extra/nested-comments/nested-comments.factor @@ -0,0 +1,20 @@ +! by blei on #concatenative +USING: kernel sequences math locals make multiline ; +IN: nested-comments + +:: (subsequences-at) ( sseq seq n -- ) + sseq seq n start* + [ dup , sseq length + [ sseq seq ] dip (subsequences-at) ] + when* ; + +: subsequences-at ( sseq seq -- indices ) + [ 0 (subsequences-at) ] { } make ; + +: count-subsequences ( sseq seq -- i ) + subsequences-at length ; + +: parse-all-(* ( parsed-vector left-to-parse -- parsed-vector ) + 1 - "*)" parse-multiline-string [ "(*" ] dip + count-subsequences + dup 0 > [ parse-all-(* ] [ drop ] if ; + +SYNTAX: (* 1 parse-all-(* ; \ No newline at end of file diff --git a/extra/noise/noise.factor b/extra/noise/noise.factor index 46704eed36..3de4147835 100644 --- a/extra/noise/noise.factor +++ b/extra/noise/noise.factor @@ -1,8 +1,9 @@ -USING: byte-arrays combinators fry images kernel locals math +USING: accessors arrays byte-arrays combinators +combinators.short-circuit fry hints images kernel locals math math.affine-transforms math.functions math.order -math.polynomials math.vectors random random.mersenne-twister -sequences sequences.product hints arrays sequences.private -combinators.short-circuit math.private ; +math.polynomials math.private math.vectors random +random.mersenne-twister sequences sequences.private +sequences.product ; IN: noise : ( -- table ) @@ -60,7 +61,10 @@ HINTS: hashes { byte-array fixnum fixnum fixnum } ; [ 255.0 * >fixnum ] B{ } map-as ; : >image ( bytes dim -- image ) - swap [ L f ] dip image boa ; + image new + swap >>dim + swap >>bitmap + L >>component-order ; :: perlin-noise-unsafe ( table point -- value ) point unit-cube :> cube diff --git a/extra/sequence-parser/sequence-parser-tests.factor b/extra/sequence-parser/sequence-parser-tests.factor index da097f4c00..259fb9f259 100644 --- a/extra/sequence-parser/sequence-parser-tests.factor +++ b/extra/sequence-parser/sequence-parser-tests.factor @@ -118,10 +118,10 @@ IN: sequence-parser.tests [ "abcd e \\\"f g" ] [ "\"abcd e \\\"f g\"" CHAR: \ CHAR: " take-token* ] unit-test -[ "" ] +[ f ] [ "" take-rest ] unit-test -[ "" ] +[ f ] [ "abc" dup "abc" take-sequence drop take-rest ] unit-test [ f ] diff --git a/extra/sequence-parser/sequence-parser.factor b/extra/sequence-parser/sequence-parser.factor index 4cc10fd5fd..e46abe8090 100644 --- a/extra/sequence-parser/sequence-parser.factor +++ b/extra/sequence-parser/sequence-parser.factor @@ -35,6 +35,8 @@ TUPLE: sequence-parser sequence n ; : advance* ( sequence-parser -- ) advance drop ; inline +: next ( sequence-parser -- obj ) [ current ] [ advance* ] bi ; + : get+increment ( sequence-parser -- char/f ) [ current ] [ advance drop ] bi ; inline @@ -148,7 +150,7 @@ TUPLE: sequence-parser sequence n ; 2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline : take-rest ( sequence-parser -- sequence ) - [ take-rest-slice ] [ sequence>> like ] bi ; + [ take-rest-slice ] [ sequence>> like ] bi f like ; : take-until-object ( sequence-parser obj -- sequence ) '[ current _ = ] take-until ; @@ -190,7 +192,7 @@ TUPLE: sequence-parser sequence n ; :: take-n ( sequence-parser n -- seq/f ) n sequence-parser [ n>> + ] [ sequence>> length ] bi > [ - f + sequence-parser take-rest ] [ sequence-parser n>> dup n + sequence-parser sequence>> subseq sequence-parser [ n + ] change-n drop diff --git a/extra/terrain/generation/generation.factor b/extra/terrain/generation/generation.factor index 18f73e8e8b..72221d7b0e 100644 --- a/extra/terrain/generation/generation.factor +++ b/extra/terrain/generation/generation.factor @@ -1,6 +1,7 @@ -USING: accessors arrays byte-arrays combinators fry grouping -images kernel math math.affine-transforms math.order -math.vectors noise random sequences ; +USING: accessors arrays byte-arrays combinators +combinators.smart fry grouping images kernel math +math.affine-transforms math.order math.vectors noise random +sequences ; IN: terrain.generation CONSTANT: terrain-segment-size { 512 512 } @@ -31,15 +32,21 @@ TUPLE: terrain big-noise-table small-noise-table tiny-noise-seed ; TUPLE: segment image ; +: ( bytes -- image ) + + swap >>bitmap + RGBA >>component-order + terrain-segment-size >>dim ; + : terrain-segment ( terrain at -- image ) - { - [ big-noise-segment ] - [ small-noise-segment ] - [ tiny-noise-segment ] - [ padding ] - } 2cleave - 4array flip concat >byte-array - [ terrain-segment-size RGBA f ] dip image boa ; + [ + { + [ big-noise-segment ] + [ small-noise-segment ] + [ tiny-noise-segment ] + [ padding ] + } 2cleave + ] output>array flip B{ } concat-as ; : 4max ( a b c d -- max ) max max max ; inline diff --git a/extra/images/processing/rotation/authors.txt b/unmaintained/images/processing/rotation/authors.txt similarity index 100% rename from extra/images/processing/rotation/authors.txt rename to unmaintained/images/processing/rotation/authors.txt diff --git a/extra/images/processing/rotation/rotation-tests.factor b/unmaintained/images/processing/rotation/rotation-tests.factor similarity index 78% rename from extra/images/processing/rotation/rotation-tests.factor rename to unmaintained/images/processing/rotation/rotation-tests.factor index 9d9e72a205..390e6deeff 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/unmaintained/images/processing/rotation/rotation-tests.factor @@ -21,23 +21,17 @@ IN: images.processing.rotation.tests >> -CONSTANT: pasted-image - $[ - "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" - load-image clone-image - ] +: pasted-image ( -- image ) + "vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp" + load-image clone-image ; -CONSTANT: pasted-image90 - $[ - "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" - load-image clone-image - ] +: pasted-image90 ( -- image ) + "vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp" + load-image clone-image ; -CONSTANT: lake-image - $[ - "vocab:images/processing/rotation/test-bitmaps/lake.bmp" - load-image preprocess - ] +: lake-image ( -- image ) + "vocab:images/processing/rotation/test-bitmaps/lake.bmp" + load-image clone-image image>pixel-rows ; [ t ] [ pasted-image dup clone-image 4 [ 90 rotate ] times = ] unit-test [ t ] [ pasted-image dup clone-image 2 [ 180 rotate ] times = ] unit-test diff --git a/extra/images/processing/rotation/rotation.factor b/unmaintained/images/processing/rotation/rotation.factor similarity index 91% rename from extra/images/processing/rotation/rotation.factor rename to unmaintained/images/processing/rotation/rotation.factor index c10bfa0ee0..87cea5f255 100644 --- a/extra/images/processing/rotation/rotation.factor +++ b/unmaintained/images/processing/rotation/rotation.factor @@ -40,20 +40,17 @@ ERROR: unsupported-rotation degrees ; : flatten-table ( seq^3 -- seq ) [ concat ] map concat ; -: preprocess ( image -- pixelrows ) - normalize-image image>pixel-rows ; - : ?reverse-dimensions ( image n -- ) { 270 90 } member? [ [ reverse ] change-dim ] when drop ; : normalize-degree ( n -- n' ) 360 rem ; : processing-effect ( image quot -- image' ) - '[ preprocess @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline + '[ image>pixel-rows @ flatten-table ] [ (>>bitmap) ] [ ] tri ; inline :: rotate' ( image n -- image ) n normalize-degree :> n' - image preprocess :> pixel-table + image image>pixel-rows :> pixel-table image n' ?reverse-dimensions pixel-table n' (rotate) :> table-rotated image table-rotated flatten-table >>bitmap ; diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage.bmp b/unmaintained/images/processing/rotation/test-bitmaps/PastedImage.bmp similarity index 100% rename from extra/images/processing/rotation/test-bitmaps/PastedImage.bmp rename to unmaintained/images/processing/rotation/test-bitmaps/PastedImage.bmp diff --git a/extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp b/unmaintained/images/processing/rotation/test-bitmaps/PastedImage90.bmp similarity index 100% rename from extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp rename to unmaintained/images/processing/rotation/test-bitmaps/PastedImage90.bmp diff --git a/extra/images/processing/rotation/test-bitmaps/lake.bmp b/unmaintained/images/processing/rotation/test-bitmaps/lake.bmp similarity index 100% rename from extra/images/processing/rotation/test-bitmaps/lake.bmp rename to unmaintained/images/processing/rotation/test-bitmaps/lake.bmp diff --git a/extra/images/processing/rotation/test-bitmaps/small-rotated.bmp b/unmaintained/images/processing/rotation/test-bitmaps/small-rotated.bmp similarity index 100% rename from extra/images/processing/rotation/test-bitmaps/small-rotated.bmp rename to unmaintained/images/processing/rotation/test-bitmaps/small-rotated.bmp diff --git a/extra/images/processing/rotation/test-bitmaps/small.bmp b/unmaintained/images/processing/rotation/test-bitmaps/small.bmp similarity index 100% rename from extra/images/processing/rotation/test-bitmaps/small.bmp rename to unmaintained/images/processing/rotation/test-bitmaps/small.bmp