From 1c89045f0ec02c15c51fa16d6bd6ac376e3f5cc3 Mon Sep 17 00:00:00 2001 From: prunedtree Date: Thu, 4 Jun 2009 20:42:29 -0700 Subject: [PATCH 01/51] m^n binary exponentiation of matrices --- basis/math/matrices/matrices.factor | 11 ++++++++--- 1 file changed, 8 insertions(+), 3 deletions(-) mode change 100755 => 100644 basis/math/matrices/matrices.factor diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor old mode 100755 new mode 100644 index cfdbe17c06..61e98ee444 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,7 +1,7 @@ ! 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 ; IN: math.matrices ! Matrices @@ -60,4 +60,9 @@ 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 ; + From 5e31d6266e86ab68c827adae9b8f2a1c82946659 Mon Sep 17 00:00:00 2001 From: Marc Fauconneau Date: Fri, 5 Jun 2009 15:29:36 +0900 Subject: [PATCH 02/51] ML-style (* nested (* comments *) *) --- extra/nested-comments/nested-comments.factor | 20 ++++++++++++++++++++ 1 file changed, 20 insertions(+) create mode 100644 extra/nested-comments/nested-comments.factor 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 From 9612b430343a8a9fc503edfb420ffe003c9feece Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 5 Jun 2009 03:26:50 -0700 Subject: [PATCH 03/51] bit alignement and absolute positionning for bit-reader --- basis/bitstreams/bitstreams.factor | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) 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 From f09a2807fa0c9dc0407517e055b5300e6f7be95b Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 5 Jun 2009 03:29:12 -0700 Subject: [PATCH 04/51] implemented inflate-raw (uncompressed chunks) --- basis/compression/inflate/inflate.factor | 433 ++++++++++++----------- 1 file changed, 221 insertions(+), 212 deletions(-) mode change 100755 => 100644 basis/compression/inflate/inflate.factor diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor old mode 100755 new mode 100644 index 7cb43ac68f..ce352827ea --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -1,212 +1,221 @@ -! 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> + +! 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 ; From 011abaa079169c370ed874917669436066144f64 Mon Sep 17 00:00:00 2001 From: prunedtree Date: Fri, 5 Jun 2009 05:28:18 -0700 Subject: [PATCH 05/51] images.jpeg: added support for yuv444 and black and white images --- basis/images/jpeg/jpeg.factor | 665 ++++++++++++++++++---------------- 1 file changed, 359 insertions(+), 306 deletions(-) mode change 100755 => 100644 basis/images/jpeg/jpeg.factor 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 ; + From 88f8af4b697f8ff271854685be894869412fd2f4 Mon Sep 17 00:00:00 2001 From: Marc Fauconneau Date: Fri, 5 Jun 2009 21:33:04 +0900 Subject: [PATCH 06/51] images.jpeg: added support for yuv444 and black and white images --- basis/images/jpeg/jpeg.factor | 665 ++++++++++++++++++---------------- 1 file changed, 359 insertions(+), 306 deletions(-) diff --git a/basis/images/jpeg/jpeg.factor b/basis/images/jpeg/jpeg.factor index 2cdc32e9df..b66aed043d 100755 --- 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 ; + From ce37c8e082b188c6a3be6a131b13eda2fb974bc1 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 5 Jun 2009 22:49:07 -0500 Subject: [PATCH 07/51] add a hexdump-file word --- basis/tools/hexdump/hexdump.factor | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) 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 Date: Sat, 6 Jun 2009 21:10:40 -0400 Subject: [PATCH 08/51] refactoring bitmap to bitmap.loading and bitmap.saving vocabs --- basis/images/bitmap/bitmap.factor | 168 +++--------------- basis/images/bitmap/loading/authors.txt | 1 + basis/images/bitmap/loading/loading.factor | 197 +++++++++++++++++++++ 3 files changed, 225 insertions(+), 141 deletions(-) create mode 100644 basis/images/bitmap/loading/authors.txt create mode 100644 basis/images/bitmap/loading/loading.factor diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 4f2ad720b6..004bca6db0 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,34 +2,23 @@ ! 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 -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 ; +images.bitmap.loading images.loader io io.binary +io.encodings.8-bit 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 ; QUALIFIED-WITH: bitstreams b 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 +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; + > { + dup file-header>> header-length>> { { 12 [ os2-color-lookup ] } { 64 [ os2v2-color-lookup ] } { 40 [ v3-color-lookup ] } @@ -66,7 +55,7 @@ ERROR: bmp-not-supported n ; ] { } map-as B{ } concat-as ; : bitmap>bytes ( loading-bitmap -- byte-array ) - dup bit-count>> + dup header>> bit-count>> { { 32 [ color-index>> ] } { 24 [ color-index>> ] } @@ -82,13 +71,13 @@ ERROR: bmp-not-supported n ; color-index>> ] } { 8 [ color-lookup ] } - { 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] } + { 4 [ B [ 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>> { + dup header>> bit-count>> { { 16 [ dup color-palette>> 4 group [ le> ] map ] } { 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] } } case reverse >>bitfields ; @@ -100,7 +89,7 @@ M: unsupported-bitfield-widths summary : uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' ) set-bitfield-widths - dup bit-count>> { + dup header>> bit-count>> { { 16 [ dup bitfields>> '[ byte-array>ushort-array _ uncompress-bitfield @@ -116,8 +105,16 @@ M: unsupported-bitfield-widths summary ERROR: unsupported-bitmap-compression compression ; -: uncompress-bitmap ( loading-bitmap -- loading-bitmap' ) - dup 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 ; + +M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) + compression>> { { f [ ] } { 0 [ ] } { 1 [ [ run-length-uncompress ] change-color-index ] } @@ -134,73 +131,11 @@ ERROR: unsupported-bitmap-compression compression ; 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 ) + file-header>> [ offset>> 14 - ] [ header-length>> ] bi - ; -: color-index-length ( loading-bitmap -- n ) +: color-index-length ( header -- n ) { [ width>> ] [ planes>> * ] @@ -208,57 +143,8 @@ ERROR: unknown-bitmap-header n ; [ 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 ) @@ -301,7 +187,7 @@ PRIVATE> ! compression [ drop 0 write4 ] - ! size-image + ! image-size [ bitmap>color-index length write4 ] ! x-pels 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..f8fa52cd6f --- /dev/null +++ b/basis/images/bitmap/loading/loading.factor @@ -0,0 +1,197 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators images images.bitmap +images.bitmap.private io io.binary io.encodings.8-bit +io.encodings.binary io.encodings.string io.streams.limited +kernel math math.bitwise ; +IN: images.bitmap.loading + +! http://www.fileformat.info/format/bmp/egff.htm + +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 size reserved1 reserved2 offset header-length ; + +TUPLE: v3-header + width height planes bit-count + compression image-size x-resolution y-resolution + colors-used colors-important ; + +TUPLE: v4-header < v3-header + red-mask green-mask blue-mask alpha-mask + cs-type end-points + gamma-red gamma-green gamma-blue ; + +TUPLE: v5-header < v4-header + intent profile-data profile-size reserved3 ; + +TUPLE: os2v1-header width height planes bit-count ; +TUPLE: os2v2-header < os2v1-header + compression image-size x-resolution y-resolution + colors-used colors-important units reserved + recording rendering size1 size2 color-encoding identifier ; + +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 + 4 read >>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 ; + +: 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>> [ + nip + ] [ + color-index-length + ] if* read >>color-index ; + +: bitmap>component-order ( loading-bitmap -- object ) + header>> bit-count>> { + { 32 [ BGR ] } + { 24 [ BGR ] } + { 16 [ BGR ] } + { 8 [ BGR ] } + { 4 [ BGR ] } + { 1 [ BGR ] } + [ unknown-component-order ] + } 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 ; + +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 ; From 989cb7d5df00151dba54f912f71017686156723c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 7 Jun 2009 20:12:18 -0400 Subject: [PATCH 09/51] better implementation of zero-matrix --- basis/math/matrices/matrices.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index cfdbe17c06..346da45ad8 100755 --- 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 +USING: arrays fry kernel math math.order math.vectors sequences sequences.private accessors columns ; 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,4 @@ 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 ; From 2ff32e838e42ace2351f68457957161f0b7f9f6d Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 00:18:15 -0400 Subject: [PATCH 10/51] add a constructor that calls all of its superclass initializers --- basis/constructors/constructors.factor | 27 +++++++++++++++++--------- 1 file changed, 18 insertions(+), 9 deletions(-) diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index e6982e3d98..d67d07810d 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -1,7 +1,7 @@ ! 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 +USING: accessors assocs classes classes.tuple effects.parser +fry generalizations generic.standard kernel lexer locals macros parser sequences slots vocabs words ; IN: constructors @@ -35,20 +35,29 @@ MACRO:: slots>constructor ( class slots -- quot ) 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 -- ) + constructor-word class effect def (define-constructor) + class superclasses [ lookup-initializer ] map sift + '[ @ _ [ 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: AUTO-CONSTRUCTOR: parse-constructor define-auto-constructor ; "initializers" create-vocab drop From a59bf32a330586441143b1c6e4963455160e3258 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 11:48:39 -0400 Subject: [PATCH 11/51] fix cloning weirdness in images rotation tests --- .../processing/rotation/rotation-tests.factor | 24 +++++++------------ .../processing/rotation/rotation.factor | 7 ++---- 2 files changed, 11 insertions(+), 20 deletions(-) diff --git a/extra/images/processing/rotation/rotation-tests.factor b/extra/images/processing/rotation/rotation-tests.factor index 9d9e72a205..390e6deeff 100755 --- a/extra/images/processing/rotation/rotation-tests.factor +++ b/extra/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/extra/images/processing/rotation/rotation.factor index c10bfa0ee0..87cea5f255 100644 --- a/extra/images/processing/rotation/rotation.factor +++ b/extra/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 ; From 9861fdc9b3a30dee34cb298995c9bc273e964f66 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 11:49:22 -0400 Subject: [PATCH 12/51] take-n returns the rest of the sequence if not enough elements are present --- extra/sequence-parser/sequence-parser-tests.factor | 4 ++-- extra/sequence-parser/sequence-parser.factor | 6 ++++-- 2 files changed, 6 insertions(+), 4 deletions(-) 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 From 6e26ea1952b4c49fd387d9854cdc8727a85296a8 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 11:50:21 -0400 Subject: [PATCH 13/51] fix bitmap unit tests, tweaking bitmap loading --- basis/images/bitmap/bitmap-tests.factor | 7 +- basis/images/bitmap/bitmap.factor | 63 ++++++-------- basis/images/bitmap/loading/loading.factor | 97 +++++++++++++++++----- 3 files changed, 107 insertions(+), 60 deletions(-) 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 004bca6db0..cf75a40d97 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,10 +2,10 @@ ! 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.bitmap.loading images.loader io io.binary -io.encodings.8-bit io.encodings.binary io.encodings.string -io.files io.streams.limited kernel locals macros math -math.bitwise math.functions namespaces sequences +images.bitmap.loading images.bitmap.saving images.loader io +io.binary io.encodings.8-bit 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 ; QUALIFIED-WITH: bitstreams b @@ -16,33 +16,26 @@ SINGLETON: bitmap-image ! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint -: write2 ( n -- ) 2 >le write ; -: write4 ( n -- ) 4 >le write ; - > >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-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 [ os2-color-lookup ] } - { 64 [ os2v2-color-lookup ] } - { 40 [ v3-color-lookup ] } - ! { 108 [ v4-color-lookup ] } - ! { 124 [ v5-color-lookup ] } + { 12 [ color-lookup3 ] } + { 64 [ color-lookup4 ] } + { 40 [ color-lookup4 ] } + { 108 [ color-lookup4 ] } + { 124 [ color-lookup4 ] } } case ; ERROR: bmp-not-supported n ; @@ -71,7 +64,7 @@ ERROR: bmp-not-supported n ; color-index>> ] } { 8 [ color-lookup ] } - { 4 [ B [ 4 b:byte-array-n>seq ] change-color-index 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 ; @@ -95,11 +88,7 @@ M: unsupported-bitfield-widths summary byte-array>ushort-array _ uncompress-bitfield ] change-color-index ] } - { 32 [ - dup bitfields>> '[ - byte-array>uint-array _ uncompress-bitfield - ] change-color-index - ] } + { 32 [ ] } [ unsupported-bitfield-widths ] } case ; @@ -113,12 +102,20 @@ GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap ) M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) drop ; +: do-run-length-uncompress ( loading-bitmap -- loading-bitmap ) + dup '[ + _ header>> [ width>> ] [ height>> ] bi + run-length-uncompress-bitmap + ] change-color-index ; + M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) 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 ] } + { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress ] change-color-index ] } + ! { 1 [ do-run-length-uncompress ] } + ! { 2 [ [ 4 b:byte-array-n>seq ] change-color-index do-run-length-uncompress ] } { 3 [ uncompress-bitfield-widths ] } { 4 [ "jpeg" unsupported-bitmap-compression ] } { 5 [ "png" unsupported-bitmap-compression ] } @@ -128,8 +125,7 @@ M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) 3 * 4 mod 4 swap - 4 mod ; inline : loading-bitmap>bytes ( loading-bitmap -- byte-array ) - uncompress-bitmap - bitmap>bytes ; + uncompress-bitmap bitmap>bytes ; : color-palette-length ( loading-bitmap -- n ) file-header>> @@ -169,7 +165,7 @@ PRIVATE> 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 @@ -188,7 +184,7 @@ PRIVATE> [ drop 0 write4 ] ! image-size - [ bitmap>color-index length write4 ] + [ bitmap>> length write4 ] ! x-pels [ drop 0 write4 ] @@ -203,12 +199,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/loading.factor b/basis/images/bitmap/loading/loading.factor index f8fa52cd6f..3b2bafa92e 100644 --- a/basis/images/bitmap/loading/loading.factor +++ b/basis/images/bitmap/loading/loading.factor @@ -3,10 +3,12 @@ USING: accessors arrays combinators images images.bitmap images.bitmap.private io io.binary io.encodings.8-bit io.encodings.binary io.encodings.string io.streams.limited -kernel math math.bitwise ; +kernel math math.bitwise grouping sequences ; +QUALIFIED-WITH: syntax S IN: images.bitmap.loading ! 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 ; @@ -19,26 +21,63 @@ TUPLE: loading-bitmap color-palette color-index bitfields ; TUPLE: file-header - magic size reserved1 reserved2 offset header-length ; + { magic initial: "BM" } + { size } + { reserved1 initial: 0 } + { reserved2 initial: 0 } + { offset } + { header-length } ; TUPLE: v3-header - width height planes bit-count - compression image-size x-resolution y-resolution - colors-used colors-important ; + { 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 green-mask blue-mask alpha-mask - cs-type end-points - gamma-red gamma-green gamma-blue ; + { 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 profile-data profile-size reserved3 ; + { 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: os2v1-header width height planes bit-count ; TUPLE: os2v2-header < os2v1-header - compression image-size x-resolution y-resolution - colors-used colors-important units reserved - recording rendering size1 size2 color-encoding identifier ; + { 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 ; @@ -121,7 +160,7 @@ UNION: os2-header os2v1-header os2v2-header ; read4 >>size1 read4 >>size2 read4 >>color-encoding - 4 read >>identifier ; + read4 >>identifier ; : read-os2v2-header ( -- os2v2-header ) \ os2v2-header new @@ -149,15 +188,20 @@ 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>> [ - nip - ] [ - color-index-length - ] if* read >>color-index ; + 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 [ BGR ] } + { 32 [ BGRX ] } { 24 [ BGR ] } { 16 [ BGR ] } { 8 [ BGR ] } @@ -166,6 +210,19 @@ M: object parse-color-data* ( loading-bitmap header -- loading-bitmap ) [ 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 ; + +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 ; + ERROR: unsupported-bitmap-file magic ; : load-bitmap ( path -- loading-bitmap ) From 9649a191bbfe29a782e23cc71dfd5430930bc903 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 11:52:14 -0400 Subject: [PATCH 14/51] make run-length compression output a byte-array --- basis/compression/run-length/run-length.factor | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index 6553860546..43be6ccf36 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -1,7 +1,11 @@ ! 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 ; + From e64acee0239f97763f388e9df436d8655963262a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 11:52:47 -0400 Subject: [PATCH 15/51] add authors file --- basis/compression/run-length/authors.txt | 1 + 1 file changed, 1 insertion(+) create mode 100644 basis/compression/run-length/authors.txt 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 From 0d308e6a4b281e5856a2cd76011fc7d40e84e99b Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 12:31:00 -0400 Subject: [PATCH 16/51] fix constructors for shadowed slots --- basis/constructors/constructors-tests.factor | 8 ++++++++ basis/constructors/constructors.factor | 15 +++++++++------ 2 files changed, 17 insertions(+), 6 deletions(-) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index 271e173718..bb63838f5d 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -57,3 +57,11 @@ 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 diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index d67d07810d..6fd6fa1906 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs classes classes.tuple effects.parser fry generalizations generic.standard kernel lexer locals macros -parser sequences slots vocabs words ; +parser sequences slots vocabs words arrays ; IN: constructors ! An experiment @@ -25,14 +25,17 @@ 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 -- word quot ) From 6434e4acf1603e0e89512a1d4b13c90a1907af68 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Tue, 9 Jun 2009 22:48:19 -0400 Subject: [PATCH 17/51] move images.processing to unmaintained for now --- .../images/processing/rotation/authors.txt | 0 .../processing/rotation/rotation-tests.factor | 0 .../images/processing/rotation/rotation.factor | 0 .../rotation/test-bitmaps/PastedImage.bmp | Bin .../rotation/test-bitmaps/PastedImage90.bmp | Bin .../processing/rotation/test-bitmaps/lake.bmp | Bin .../rotation/test-bitmaps/small-rotated.bmp | Bin .../processing/rotation/test-bitmaps/small.bmp | Bin 8 files changed, 0 insertions(+), 0 deletions(-) rename {extra => unmaintained}/images/processing/rotation/authors.txt (100%) rename {extra => unmaintained}/images/processing/rotation/rotation-tests.factor (100%) rename {extra => unmaintained}/images/processing/rotation/rotation.factor (100%) rename {extra => unmaintained}/images/processing/rotation/test-bitmaps/PastedImage.bmp (100%) rename {extra => unmaintained}/images/processing/rotation/test-bitmaps/PastedImage90.bmp (100%) rename {extra => unmaintained}/images/processing/rotation/test-bitmaps/lake.bmp (100%) rename {extra => unmaintained}/images/processing/rotation/test-bitmaps/small-rotated.bmp (100%) rename {extra => unmaintained}/images/processing/rotation/test-bitmaps/small.bmp (100%) 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 100% rename from extra/images/processing/rotation/rotation-tests.factor rename to unmaintained/images/processing/rotation/rotation-tests.factor diff --git a/extra/images/processing/rotation/rotation.factor b/unmaintained/images/processing/rotation/rotation.factor similarity index 100% rename from extra/images/processing/rotation/rotation.factor rename to unmaintained/images/processing/rotation/rotation.factor 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 From 50f4db1ce247d1d30410e505561e85b72780c6b3 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Wed, 10 Jun 2009 13:06:06 -0500 Subject: [PATCH 18/51] half-precision float vocab --- extra/half-floats/authors.txt | 1 + extra/half-floats/half-floats-tests.factor | 46 ++++++++++++++++++++++ extra/half-floats/half-floats.factor | 42 ++++++++++++++++++++ extra/half-floats/summary.txt | 1 + 4 files changed, 90 insertions(+) create mode 100644 extra/half-floats/authors.txt create mode 100644 extra/half-floats/half-floats-tests.factor create mode 100644 extra/half-floats/half-floats.factor create mode 100644 extra/half-floats/summary.txt 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..15ad53d611 --- /dev/null +++ b/extra/half-floats/half-floats-tests.factor @@ -0,0 +1,46 @@ +USING: alien.c-types alien.syntax half-floats kernel 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: fe00 ] [ 0/0. 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 +[ 0/0. ] [ HEX: 7e00 bits>half ] 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 From 0262074b97060c055c98e26749f4dc9b2ef9aa3f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 15:16:17 -0400 Subject: [PATCH 19/51] working on rle uncompresion for bitmaps --- .../compression/run-length/run-length.factor | 66 ++++++++++++++++++- basis/images/bitmap/bitmap.factor | 14 ++-- 2 files changed, 71 insertions(+), 9 deletions(-) diff --git a/basis/compression/run-length/run-length.factor b/basis/compression/run-length/run-length.factor index 43be6ccf36..cde2a7e113 100644 --- a/basis/compression/run-length/run-length.factor +++ b/basis/compression/run-length/run-length.factor @@ -5,7 +5,71 @@ 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 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/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index cf75a40d97..a8d7dae373 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -102,20 +102,18 @@ GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap ) M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) drop ; -: do-run-length-uncompress ( loading-bitmap -- loading-bitmap ) - dup '[ +: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap ) + dupd '[ _ header>> [ width>> ] [ height>> ] bi - run-length-uncompress-bitmap - ] change-color-index ; + _ execute + ] change-color-index ; inline M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' ) compression>> { { f [ ] } { 0 [ ] } - { 1 [ [ run-length-uncompress ] change-color-index ] } - { 2 [ [ 4 b:byte-array-n>seq run-length-uncompress ] change-color-index ] } - ! { 1 [ do-run-length-uncompress ] } - ! { 2 [ [ 4 b:byte-array-n>seq ] change-color-index do-run-length-uncompress ] } + { 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 ] } From 38ac04d31791e04a7e86817a9343ffb83a58025a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 15:50:16 -0400 Subject: [PATCH 20/51] make png-loading not an image tuple --- basis/images/png/png.factor | 51 ++++++++++++++++++------------------- 1 file changed, 25 insertions(+), 26 deletions(-) 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 ; From 71f0ce568817a16f951a9bc728fac515b3eb3b5f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 15:50:35 -0400 Subject: [PATCH 21/51] more effective use of byte-arrays --- basis/compression/inflate/inflate.factor | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index 7cb43ac68f..48b831be9e 100755 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -195,16 +195,16 @@ CONSTANT: dist-table PRIVATE> ! for debug -- shows residual values -: reverse-png-filter' ( lines -- filtered ) +: reverse-png-filter' ( lines -- byte-array ) [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip - concat [ 128 + 256 wrap ] map ; + concat [ 128 + ] B{ } map-as ; -: reverse-png-filter ( lines -- filtered ) +: 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 concat ; + ] map B{ } concat-as ; : zlib-inflate ( bytes -- bytes ) bs: From 0fd46ac59d9852af50d669544156f5190aa8a1f6 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 15:52:55 -0400 Subject: [PATCH 22/51] dont use boa constructor in tiff --- basis/images/tiff/tiff.factor | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index 876076e9fe..d0a84dcf0a 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -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 ; From b96a8588724774f2a08c91c24b988f2065832959 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 15:59:14 -0400 Subject: [PATCH 23/51] refactor terrain generation to not use an image boa constructor --- extra/terrain/generation/generation.factor | 29 ++++++++++++++-------- 1 file changed, 18 insertions(+), 11 deletions(-) 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 From ae034f1f09b845ce425986ab0da4399cb751cecf Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 16:01:46 -0400 Subject: [PATCH 24/51] use concat-as --- basis/images/tiff/tiff.factor | 2 +- basis/io/sockets/sockets.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index d0a84dcf0a..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 ) 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> From b8b0e114928414c3063f5919eb6ce76fb2cb0a32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 16:05:17 -0400 Subject: [PATCH 25/51] remove use of image boa from noise --- extra/noise/noise.factor | 14 +++++++++----- 1 file changed, 9 insertions(+), 5 deletions(-) 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 From 95234ae15c4936f8a5eb2add5c9de50d5b2d8605 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 16:23:57 -0400 Subject: [PATCH 26/51] dont use paren names when there's not a word with that name already --- basis/opengl/textures/textures.factor | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) 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 ; From a8bc1d36cb632b9ee6f637e878e09f5c53c693e9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Wed, 10 Jun 2009 17:59:14 -0400 Subject: [PATCH 27/51] 2map and 3map work in cursors --- extra/cursors/cursors-tests.factor | 18 ++++++++++ extra/cursors/cursors.factor | 55 ++++++++++++++++++++++++++++-- 2 files changed, 71 insertions(+), 2 deletions(-) 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 From 28a4dd870e5caace1a23161adf35a04132b05c3a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 11:02:40 -0500 Subject: [PATCH 28/51] minor indentation changes --- basis/debugger/debugger.factor | 13 ++++++++----- basis/porter-stemmer/porter-stemmer.factor | 2 +- 2 files changed, 9 insertions(+), 6 deletions(-) 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/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? [ From 52d8c841f18d7bac37ed6efe6eb5c41fd82312df Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 11:03:18 -0500 Subject: [PATCH 29/51] add nover, nbi-curry, and nbi to generalizations --- basis/generalizations/generalizations.factor | 9 +++++++++ 1 file changed, 9 insertions(+) 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 From 19f914bf721ed1c856db42d1dcf9616ec6ac5f8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 11:08:56 -0500 Subject: [PATCH 30/51] add some unit tests for generalizations --- basis/generalizations/generalizations-tests.factor | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) 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 From 41a2894083a61147e2887609a050ddfa96deb538 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 13:16:04 -0500 Subject: [PATCH 31/51] move more bitmap code to bitmap.loading --- basis/images/bitmap/bitmap.factor | 152 +-------------------- basis/images/bitmap/loading/loading.factor | 130 +++++++++++++++++- 2 files changed, 128 insertions(+), 154 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index a8d7dae373..1c19d06732 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,8 +2,7 @@ ! 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.bitmap.loading images.bitmap.saving images.loader io -io.binary io.encodings.8-bit io.encodings.binary +images.bitmap.loading images.loader io 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 @@ -11,153 +10,8 @@ summary ; QUALIFIED-WITH: bitstreams b IN: images.bitmap -SINGLETON: bitmap-image -"bmp" bitmap-image register-image-class - -! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint - -> >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 ; - -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 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 ; - -: bitmap-padding ( width -- n ) - 3 * 4 mod 4 swap - 4 mod ; inline - -: loading-bitmap>bytes ( loading-bitmap -- byte-array ) - uncompress-bitmap bitmap>bytes ; - -: color-palette-length ( loading-bitmap -- n ) - file-header>> - [ offset>> 14 - ] [ header-length>> ] bi - ; - -: color-index-length ( header -- n ) - { - [ width>> ] - [ planes>> * ] - [ bit-count>> * 31 + 32 /i 4 * ] - [ height>> abs * ] - } cleave ; - -ERROR: unsupported-bitmap-file magic ; - -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 +: write2 ( n -- ) 2 >le write ; +: write4 ( n -- ) 4 >le write ; : save-bitmap ( image path -- ) binary [ diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor index 3b2bafa92e..b0bd501f09 100644 --- a/basis/images/bitmap/loading/loading.factor +++ b/basis/images/bitmap/loading/loading.factor @@ -1,12 +1,16 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators images images.bitmap -images.bitmap.private io io.binary io.encodings.8-bit -io.encodings.binary io.encodings.string io.streams.limited -kernel math math.bitwise grouping sequences ; -QUALIFIED-WITH: syntax S +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 @@ -176,6 +180,18 @@ UNION: os2-header os2v1-header os2v2-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 ; @@ -217,12 +233,113 @@ GENERIC: bitmap>component-order* ( loading-bitmap header -- object ) [ 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 ) @@ -243,6 +360,9 @@ ERROR: unsupported-bitmap-file magic ; } 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 From 39047be85d3b1451b7dc23490e8f7eec9f841b8c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 13:19:54 -0500 Subject: [PATCH 32/51] call initializers in reverse order to allow base classes to set state after slots are set in a subclass --- basis/constructors/constructors-tests.factor | 12 ++++++++++++ basis/constructors/constructors.factor | 2 +- 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index bb63838f5d..ae7fd0409c 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -65,3 +65,15 @@ TUPLE: inherit2 < inherit1 a ; CONSTRUCTOR: inherit2 ( a -- obj ) ; [ T{ inherit2 f f 100 } ] [ 100 ] unit-test + + +TUPLE: inherit3 hp max-hp ; +TUPLE: inherit4 < inherit3 ; + +CONSTRUCTOR: inherit3 ( -- obj ) + dup max-hp>> >>hp ; + +AUTO-CONSTRUCTOR: inherit4 ( -- obj ) + 10 >>max-hp ; + +[ 10 ] [ hp>> ] unit-test diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index 6fd6fa1906..a2c8d7637d 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -50,7 +50,7 @@ MACRO:: slots>constructor ( class slots -- quot ) :: define-auto-constructor ( constructor-word class effect def -- ) constructor-word class effect def (define-constructor) - class superclasses [ lookup-initializer ] map sift + class superclasses [ lookup-initializer ] map sift reverse '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ; : scan-constructor ( -- class word ) From 74fbe979bbf37090cf0a0f04ffe0f9c1c591602c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 14:31:04 -0500 Subject: [PATCH 33/51] forward/backward constructors instead of auto-constructors --- basis/constructors/constructors-tests.factor | 9 ++++++++- basis/constructors/constructors.factor | 9 +++++---- 2 files changed, 13 insertions(+), 5 deletions(-) diff --git a/basis/constructors/constructors-tests.factor b/basis/constructors/constructors-tests.factor index ae7fd0409c..59ecb8ff77 100644 --- a/basis/constructors/constructors-tests.factor +++ b/basis/constructors/constructors-tests.factor @@ -69,11 +69,18 @@ CONSTRUCTOR: inherit2 ( a -- obj ) ; TUPLE: inherit3 hp max-hp ; TUPLE: inherit4 < inherit3 ; +TUPLE: inherit5 < inherit3 ; CONSTRUCTOR: inherit3 ( -- obj ) dup max-hp>> >>hp ; -AUTO-CONSTRUCTOR: inherit4 ( -- obj ) +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 a2c8d7637d..b4091a1234 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -48,9 +48,10 @@ MACRO:: slots>constructor ( class slots -- quot ) class lookup-initializer '[ @ _ execute( obj -- obj ) ] effect define-declared ; -:: define-auto-constructor ( constructor-word class effect def -- ) +:: define-auto-constructor ( constructor-word class effect def reverse? -- ) constructor-word class effect def (define-constructor) - class superclasses [ lookup-initializer ] map sift reverse + class superclasses [ lookup-initializer ] map sift + reverse? [ reverse ] when '[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ; : scan-constructor ( -- class word ) @@ -60,7 +61,7 @@ MACRO:: slots>constructor ( class slots -- quot ) scan-constructor complete-effect parse-definition ; SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ; - -SYNTAX: AUTO-CONSTRUCTOR: parse-constructor define-auto-constructor ; +SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ; +SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ; "initializers" create-vocab drop From 8ea400ca472902eea79397a257b98bb8da69f3a2 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 14:35:55 -0500 Subject: [PATCH 34/51] fix using --- basis/images/bitmap/bitmap.factor | 11 +++++------ 1 file changed, 5 insertions(+), 6 deletions(-) diff --git a/basis/images/bitmap/bitmap.factor b/basis/images/bitmap/bitmap.factor index 1c19d06732..cb73e4e274 100755 --- a/basis/images/bitmap/bitmap.factor +++ b/basis/images/bitmap/bitmap.factor @@ -2,12 +2,11 @@ ! 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.bitmap.loading images.loader io -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 ; -QUALIFIED-WITH: bitstreams b +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 ; IN: images.bitmap : write2 ( n -- ) 2 >le write ; From a7d02fde2843b733d82e19fd46b11b13df547b1a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 15:15:22 -0500 Subject: [PATCH 35/51] re-add AUTO-CONSTRUCTOR --- basis/constructors/constructors.factor | 1 + 1 file changed, 1 insertion(+) diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index b4091a1234..d041fdf5c9 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -63,5 +63,6 @@ MACRO:: slots>constructor ( class slots -- quot ) SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ; SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ; SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ; +ALIAS: AUTO-CONSTRUCTOR FORWARD-CONSTRUCTOR "initializers" create-vocab drop From 9a8b7122ac3b0bf3dc52a0426f755a4c93567160 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 15:19:00 -0500 Subject: [PATCH 36/51] fix typo --- basis/constructors/constructors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index d041fdf5c9..110c7cc9c3 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -63,6 +63,6 @@ MACRO:: slots>constructor ( class slots -- quot ) SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ; SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ; SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ; -ALIAS: AUTO-CONSTRUCTOR FORWARD-CONSTRUCTOR +ALIAS: AUTO-CONSTRUCTOR: FORWARD-CONSTRUCTOR: "initializers" create-vocab drop From 54a1a8f3269d34d46bbf4f9407ee6d19404d09c4 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 15:23:36 -0500 Subject: [PATCH 37/51] ALIAS: doesn't not work with SYNTAX: words. oops --- basis/constructors/constructors.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/constructors/constructors.factor b/basis/constructors/constructors.factor index 110c7cc9c3..b8fe598f84 100644 --- a/basis/constructors/constructors.factor +++ b/basis/constructors/constructors.factor @@ -63,6 +63,6 @@ MACRO:: slots>constructor ( class slots -- quot ) SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ; SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ; SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ; -ALIAS: AUTO-CONSTRUCTOR: FORWARD-CONSTRUCTOR: +SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ; "initializers" create-vocab drop From 46a50fe0b9f25e2ff614e47689dbd6fe5138ec32 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 16:53:52 -0500 Subject: [PATCH 38/51] fix duplicate using --- basis/game-input/dinput/dinput.factor | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) 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 From a2640672d79e22ca246e9ae8d431803075bc3e89 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Jun 2009 17:47:52 -0500 Subject: [PATCH 39/51] =?UTF-8?q?=C2=AB0.0=201.0=20^=C2=BB=20was=20returni?= =?UTF-8?q?ng=200=20instead=20of=200.0?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- basis/math/functions/functions-tests.factor | 3 ++- basis/math/functions/functions.factor | 2 +- 2 files changed, 3 insertions(+), 2 deletions(-) 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 ] From 226c76aa1fd5b1115742462d035f640896af75a2 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 11 Jun 2009 18:00:01 -0500 Subject: [PATCH 40/51] stop playing fast and loose with NaN representations in half-floats tests --- extra/half-floats/half-floats-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/extra/half-floats/half-floats-tests.factor b/extra/half-floats/half-floats-tests.factor index 15ad53d611..d026ca2933 100644 --- a/extra/half-floats/half-floats-tests.factor +++ b/extra/half-floats/half-floats-tests.factor @@ -1,4 +1,4 @@ -USING: alien.c-types alien.syntax half-floats kernel tools.test ; +USING: alien.c-types alien.syntax half-floats kernel math tools.test ; IN: half-floats.tests [ HEX: 0000 ] [ 0.0 half>bits ] unit-test @@ -7,7 +7,7 @@ IN: half-floats.tests [ 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: fe00 ] [ 0/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 @@ -25,7 +25,7 @@ IN: half-floats.tests [ -1.5 ] [ HEX: be00 bits>half ] unit-test [ 1/0. ] [ HEX: 7c00 bits>half ] unit-test [ -1/0. ] [ HEX: fc00 bits>half ] unit-test -[ 0/0. ] [ HEX: 7e00 bits>half ] unit-test +[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test C-STRUCT: halves { "half" "tom" } From 059eb399f02643264949dd9b3630b4657a0467a9 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 19:48:14 -0500 Subject: [PATCH 41/51] add initial-quot: syntax for tuples --- core/bootstrap/syntax.factor | 1 + core/classes/tuple/parser/parser-tests.factor | 16 +++++++++++++++- core/classes/tuple/tuple.factor | 15 +++++++++++++-- core/slots/slots.factor | 15 +++++++++++++-- core/syntax/syntax.factor | 4 +++- 5 files changed, 45 insertions(+), 6 deletions(-) diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index f5182a0210..24538229c6 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -80,6 +80,7 @@ IN: bootstrap.syntax ">>" "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..88fca567f4 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,17 @@ 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 + +[ ] [ + <" IN: classes.tuple.tests + TUPLE: monster { hp virtual } ;"> + eval( -- ) +] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 225176f4e5..9e0c0b7316 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ; PRIVATE> +: initial-value ( slot -- obj ) + dup initial>> [ + nip + ] [ + dup initial-quot>> [ + nip call( -- obj ) + ] [ + drop f + ] if* + ] if* ; + : initial-values ( class -- slots ) - all-slots [ initial>> ] map ; + all-slots [ initial-value ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline @@ -176,7 +187,7 @@ ERROR: bad-superclass class ; : compute-slot-permutation ( new-slots old-slots -- triples ) [ [ [ name>> ] map ] bi@ [ index ] curry map ] [ drop [ class>> ] map ] - [ drop [ initial>> ] map ] + [ drop [ initial-value ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..9db26846d0 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,10 +3,10 @@ USING: arrays byte-arrays kernel kernel.private math namespaces make sequences strings effects generic generic.standard classes classes.algebra slots.private combinators accessors -words sequences.private assocs alien quotations hashtables ; +words sequences.private assocs alien quotations hashtables summary ; 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,17 @@ ERROR: bad-slot-attribute key ; ERROR: bad-initial-value name ; +ERROR: duplicate-initial-values slot ; + +M: duplicate-initial-values summary + drop "Slots can either define initial: or initial-quot:, but not both" ; + +: 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 From 4bd06486fb662d55db3773b4eb3f2c5fa4e7c02c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 20:20:21 -0500 Subject: [PATCH 42/51] make a word not generic, remove unit test for unimplemented feature --- core/classes/tuple/parser/parser-tests.factor | 6 ------ core/classes/tuple/tuple.factor | 4 +--- 2 files changed, 1 insertion(+), 9 deletions(-) diff --git a/core/classes/tuple/parser/parser-tests.factor b/core/classes/tuple/parser/parser-tests.factor index 88fca567f4..350b594274 100644 --- a/core/classes/tuple/parser/parser-tests.factor +++ b/core/classes/tuple/parser/parser-tests.factor @@ -150,9 +150,3 @@ TUPLE: parsing-corner-case x ; TUPLE: book { name initial-quot: [ "Lord of the " "Rings" append ] } ;"> eval( -- ) ] unit-test - -[ ] [ - <" IN: classes.tuple.tests - TUPLE: monster { hp virtual } ;"> - eval( -- ) -] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 9e0c0b7316..55fbdf725f 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -75,9 +75,7 @@ PRIVATE> : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -GENERIC: slots>tuple ( seq class -- tuple ) - -M: tuple-class slots>tuple +: slots>tuple ( seq class -- tuple ) check-slots pad-slots tuple-layout [ [ tuple-size ] From 6c2e4839136d363f34bca7c7233c211ef0441e20 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 20:20:38 -0500 Subject: [PATCH 43/51] use initital-quot: in threaded-server tuple declaration --- basis/io/servers/connection/connection.factor | 23 +++++++------------ 1 file changed, 8 insertions(+), 15 deletions(-) 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 ; From f9fb81a96226dd96bdc9507af36ae39be4a8ff34 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 21:22:24 -0400 Subject: [PATCH 44/51] merge --- basis/game-input/dinput/dinput.factor | 19 +++++++-------- basis/io/servers/connection/connection.factor | 23 ++++++++++++------- core/bootstrap/syntax.factor | 1 - core/classes/tuple/parser/parser-tests.factor | 10 +------- core/classes/tuple/tuple.factor | 19 ++++----------- core/slots/slots.factor | 15 ++---------- core/syntax/syntax.factor | 4 +--- 7 files changed, 34 insertions(+), 57 deletions(-) diff --git a/basis/game-input/dinput/dinput.factor b/basis/game-input/dinput/dinput.factor index 0ecf543baa..8540907db9 100755 --- a/basis/game-input/dinput/dinput.factor +++ b/basis/game-input/dinput/dinput.factor @@ -1,13 +1,14 @@ -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 ; +USING: windows.dinput windows.dinput.constants parser +alien.c-types windows.ole32 namespaces assocs kernel arrays +vectors windows.kernel32 windows.com windows.dinput shuffle +windows.user32 windows.messages sequences combinators locals +math.rectangles accessors math alien alien.strings +io.encodings.utf16 io.encodings.utf16n continuations +byte-arrays game-input.dinput.keys-array game-input +ui.backend.windows windows.errors struct-arrays +math.bitwise ; IN: game-input.dinput + CONSTANT: MOUSE-BUFFER-SIZE 16 SINGLETON: dinput-game-input-backend diff --git a/basis/io/servers/connection/connection.factor b/basis/io/servers/connection/connection.factor index de75165c7a..df6c21e7cc 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 initial: "server" } -{ log-level initial: DEBUG } +name +log-level secure insecure -{ secure-config initial-quot: [ ] } -{ sockets initial-quot: [ V{ } clone ] } +secure-config +sockets max-connections semaphore -{ timeout initial-quot: [ 1 minutes ] } +timeout encoding -{ handler initial: [ "No handler quotation" throw ] } -{ ready initial-quot: [ ] } ; +handler +ready ; : local-server ( port -- addrspec ) "localhost" swap ; @@ -29,7 +29,14 @@ encoding : new-threaded-server ( encoding class -- threaded-server ) new - swap >>encoding ; + swap >>encoding + "server" >>name + DEBUG >>log-level + 1 minutes >>timeout + V{ } clone >>sockets + >>secure-config + [ "No handler quotation" throw ] >>handler + >>ready ; inline : ( encoding -- threaded-server ) threaded-server new-threaded-server ; diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index 24538229c6..f5182a0210 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -80,7 +80,6 @@ IN: bootstrap.syntax ">>" "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 350b594274..b95507c78b 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 multiline ; +arrays classes.tuple eval ; TUPLE: test-1 ; @@ -142,11 +142,3 @@ 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.factor b/core/classes/tuple/tuple.factor index 55fbdf725f..225176f4e5 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,19 +50,8 @@ M: tuple class layout-of 2 slot { word } declare ; PRIVATE> -: initial-value ( slot -- obj ) - dup initial>> [ - nip - ] [ - dup initial-quot>> [ - nip call( -- obj ) - ] [ - drop f - ] if* - ] if* ; - : initial-values ( class -- slots ) - all-slots [ initial-value ] map ; + all-slots [ initial>> ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline @@ -75,7 +64,9 @@ PRIVATE> : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -: slots>tuple ( seq class -- tuple ) +GENERIC: slots>tuple ( seq class -- tuple ) + +M: tuple-class slots>tuple check-slots pad-slots tuple-layout [ [ tuple-size ] @@ -185,7 +176,7 @@ ERROR: bad-superclass class ; : compute-slot-permutation ( new-slots old-slots -- triples ) [ [ [ name>> ] map ] bi@ [ index ] curry map ] [ drop [ class>> ] map ] - [ drop [ initial-value ] map ] + [ drop [ initial>> ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 9db26846d0..304ded0adb 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,10 +3,10 @@ USING: arrays byte-arrays kernel kernel.private math namespaces make sequences strings effects generic generic.standard classes classes.algebra slots.private combinators accessors -words sequences.private assocs alien quotations hashtables summary ; +words sequences.private assocs alien quotations hashtables ; IN: slots -TUPLE: slot-spec name offset class initial initial-quot read-only ; +TUPLE: slot-spec name offset class initial read-only ; PREDICATE: reader < word "reader" word-prop ; @@ -190,7 +190,6 @@ 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 @@ -198,17 +197,7 @@ ERROR: bad-slot-attribute key ; ERROR: bad-initial-value name ; -ERROR: duplicate-initial-values slot ; - -M: duplicate-initial-values summary - drop "Slots can either define initial: or initial-quot:, but not both" ; - -: 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 8093b6345b..56ac9fa36e 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -245,9 +245,7 @@ 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 From a390fe9644f2555c5b47445136113569fb68a8cc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 21:23:47 -0400 Subject: [PATCH 45/51] Revert "merge" This reverts commit c2a03d259a7b853b586afd68a0b842140188e0db. --- basis/game-input/dinput/dinput.factor | 19 ++++++++------- basis/io/servers/connection/connection.factor | 23 +++++++------------ core/bootstrap/syntax.factor | 1 + core/classes/tuple/parser/parser-tests.factor | 10 +++++++- core/classes/tuple/tuple.factor | 19 +++++++++++---- core/slots/slots.factor | 15 ++++++++++-- core/syntax/syntax.factor | 4 +++- 7 files changed, 57 insertions(+), 34 deletions(-) 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/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/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index f5182a0210..24538229c6 100644 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -80,6 +80,7 @@ IN: bootstrap.syntax ">>" "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.factor b/core/classes/tuple/tuple.factor index 225176f4e5..55fbdf725f 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,8 +50,19 @@ M: tuple class layout-of 2 slot { word } declare ; PRIVATE> +: initial-value ( slot -- obj ) + dup initial>> [ + nip + ] [ + dup initial-quot>> [ + nip call( -- obj ) + ] [ + drop f + ] if* + ] if* ; + : initial-values ( class -- slots ) - all-slots [ initial>> ] map ; + all-slots [ initial-value ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline @@ -64,9 +75,7 @@ PRIVATE> : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -GENERIC: slots>tuple ( seq class -- tuple ) - -M: tuple-class slots>tuple +: slots>tuple ( seq class -- tuple ) check-slots pad-slots tuple-layout [ [ tuple-size ] @@ -176,7 +185,7 @@ ERROR: bad-superclass class ; : compute-slot-permutation ( new-slots old-slots -- triples ) [ [ [ name>> ] map ] bi@ [ index ] curry map ] [ drop [ class>> ] map ] - [ drop [ initial>> ] map ] + [ drop [ initial-value ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 304ded0adb..9db26846d0 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,10 +3,10 @@ USING: arrays byte-arrays kernel kernel.private math namespaces make sequences strings effects generic generic.standard classes classes.algebra slots.private combinators accessors -words sequences.private assocs alien quotations hashtables ; +words sequences.private assocs alien quotations hashtables summary ; 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,17 @@ ERROR: bad-slot-attribute key ; ERROR: bad-initial-value name ; +ERROR: duplicate-initial-values slot ; + +M: duplicate-initial-values summary + drop "Slots can either define initial: or initial-quot:, but not both" ; + +: 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 From 50be248db0d229bd11f247d2a0a27b40c4ce8b28 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 11 Jun 2009 20:26:49 -0500 Subject: [PATCH 46/51] don't use summary in slots --- core/slots/slots.factor | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 9db26846d0..c8be08e79b 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -3,7 +3,7 @@ USING: arrays byte-arrays kernel kernel.private math namespaces make sequences strings effects generic generic.standard classes classes.algebra slots.private combinators accessors -words sequences.private assocs alien quotations hashtables summary ; +words sequences.private assocs alien quotations hashtables ; IN: slots TUPLE: slot-spec name offset class initial initial-quot read-only ; @@ -200,9 +200,6 @@ ERROR: bad-initial-value name ; ERROR: duplicate-initial-values slot ; -M: duplicate-initial-values summary - drop "Slots can either define initial: or initial-quot:, but not both" ; - : check-duplicate-initial-values ( slot-spec -- slot-spec ) dup [ initial>> ] [ initial-quot>> ] bi and [ duplicate-initial-values ] when ; From 6a67f02f69a3bb6446715bb7b23deea735672142 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 02:43:05 -0500 Subject: [PATCH 47/51] fix load error --- basis/math/matrices/matrices.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/basis/math/matrices/matrices.factor b/basis/math/matrices/matrices.factor index 3a3b470ac8..d6bee78c14 100644 --- a/basis/math/matrices/matrices.factor +++ b/basis/math/matrices/matrices.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays columns kernel math math.bits -math.order math.vectors sequences sequences.private ; +math.order math.vectors sequences sequences.private fry ; IN: math.matrices ! Matrices From c5a5e943812f1e35dd85f7a6f5714dac1bc85556 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 02:43:13 -0500 Subject: [PATCH 48/51] fix destructors docs --- core/destructors/destructors-docs.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/destructors/destructors-docs.factor b/core/destructors/destructors-docs.factor index 536ee19c8b..40482fce05 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 f } "." } ; +"The default implementation assumes the object has a " { $slot "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link f } "." } ; 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 From 21a33419a737795190e13f37ed87d8e33607c822 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 09:21:51 -0500 Subject: [PATCH 49/51] initial-quot: works fully, need to make a couple simplifications --- core/classes/tuple/tuple.factor | 63 ++++++++++++++++++++++++--------- 1 file changed, 46 insertions(+), 17 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 55fbdf725f..8aaed4aaae 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -50,19 +50,11 @@ M: tuple class layout-of 2 slot { word } declare ; PRIVATE> -: initial-value ( slot -- obj ) - dup initial>> [ - nip - ] [ - dup initial-quot>> [ - nip call( -- obj ) - ] [ - drop f - ] if* - ] if* ; +: initial-quots? ( class -- ? ) + all-slots [ initial-quot>> ] any? ; : initial-values ( class -- slots ) - all-slots [ initial-value ] map ; + all-slots [ initial>> ] map ; : pad-slots ( slots class -- slots' class ) [ initial-values over length tail append ] keep ; inline @@ -75,7 +67,9 @@ PRIVATE> : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -: slots>tuple ( seq class -- tuple ) +GENERIC: slots>tuple ( seq class -- tuple ) + +M: tuple-class slots>tuple ( seq class -- tuple ) check-slots pad-slots tuple-layout [ [ tuple-size ] @@ -156,8 +150,8 @@ ERROR: bad-superclass class ; dup boa-check-quot "boa-check" set-word-prop ; : 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 ; @@ -182,10 +176,40 @@ ERROR: bad-superclass class ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; +: define-tuple-constructor ( class -- ) + { + { [ dup initial-quots? ] [ "initial-quots" ] } + { [ dup "prototype" word-prop ] [ "prototype" ] } + [ f ] + } cond "constructor" set-word-prop ; + +: define-tuple-initial-quots ( class -- ) + dup all-slots [ initial-quot>> ] filter + [ + [ + [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ] + [ offset>> , ] bi \ set-slot , + ] each + ] [ ] make "initial-quots-setter" set-word-prop ; + +: set-initial-quots ( tuple -- tuple' ) + dup class "initial-quots-setter" word-prop call( obj -- obj ) ; + +: 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-value ] map ] + [ drop [ calculate-initial-value ] map ] 2tri 3array flip ; : update-slot ( old-values n class initial -- value ) @@ -233,6 +257,8 @@ M: tuple-class update-class [ define-tuple-slots ] [ define-tuple-predicate ] [ define-tuple-prototype ] + [ define-tuple-constructor ] + [ define-tuple-initial-quots ] } cleave ; : define-new-tuple-class ( class superclass slots -- ) @@ -349,8 +375,11 @@ M: tuple tuple-hashcode M: tuple hashcode* tuple-hashcode ; M: tuple-class new - dup "prototype" word-prop - [ (clone) ] [ tuple-layout ] ?if ; + dup "constructor" word-prop { + { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] } + { "prototype" [ "prototype" word-prop (clone) ] } + [ drop tuple-layout ] + } case ; M: tuple-class boa [ "boa-check" word-prop [ call ] when* ] From 99bfeb62c4c630a33ac0d3a7edfec90b8805c03c Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 11:45:53 -0500 Subject: [PATCH 50/51] simplify implementation of initial-quot: --- core/classes/tuple/tuple.factor | 43 ++++++++++++--------------------- 1 file changed, 16 insertions(+), 27 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 8aaed4aaae..e5ea80bc39 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -149,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 ] [ 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 ; @@ -176,25 +186,6 @@ ERROR: bad-superclass class ; : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: define-tuple-constructor ( class -- ) - { - { [ dup initial-quots? ] [ "initial-quots" ] } - { [ dup "prototype" word-prop ] [ "prototype" ] } - [ f ] - } cond "constructor" set-word-prop ; - -: define-tuple-initial-quots ( class -- ) - dup all-slots [ initial-quot>> ] filter - [ - [ - [ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ] - [ offset>> , ] bi \ set-slot , - ] each - ] [ ] make "initial-quots-setter" set-word-prop ; - -: set-initial-quots ( tuple -- tuple' ) - dup class "initial-quots-setter" word-prop call( obj -- obj ) ; - : calculate-initial-value ( slot-spec -- value ) dup initial>> [ nip @@ -257,8 +248,6 @@ M: tuple-class update-class [ define-tuple-slots ] [ define-tuple-predicate ] [ define-tuple-prototype ] - [ define-tuple-constructor ] - [ define-tuple-initial-quots ] } cleave ; : define-new-tuple-class ( class superclass slots -- ) @@ -375,11 +364,11 @@ M: tuple tuple-hashcode M: tuple hashcode* tuple-hashcode ; M: tuple-class new - dup "constructor" word-prop { - { "initial-quots" [ "prototype" word-prop (clone) set-initial-quots ] } - { "prototype" [ "prototype" word-prop (clone) ] } - [ drop tuple-layout ] - } case ; + dup "prototype" word-prop [ + first2 [ (clone) ] dip [ call( obj -- obj ) ] when* + ] [ + tuple-layout + ] ?if ; M: tuple-class boa [ "boa-check" word-prop [ call ] when* ] From 258abe31abdd200c12ba21c0a1c73082bd57cc2a Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Fri, 12 Jun 2009 11:58:07 -0500 Subject: [PATCH 51/51] add some unit tests for reshaping tuples with initial-quot: slots --- core/classes/tuple/tuple-tests.factor | 35 ++++++++++++++++++--------- 1 file changed, 24 insertions(+), 11 deletions(-) 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