Fix conflict
|
@ -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
|
||||
|
|
|
@ -1,212 +1,220 @@
|
|||
! Copyright (C) 2009 Marc Fauconneau.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs byte-arrays
|
||||
byte-vectors combinators constructors fry grouping hashtables
|
||||
compression.huffman images io.binary kernel locals
|
||||
math math.bitwise math.order math.ranges multiline sequences
|
||||
sorting ;
|
||||
IN: compression.inflate
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: enum>seq ( assoc -- seq )
|
||||
dup keys [ ] [ max ] map-reduce 1 + f <array>
|
||||
[ '[ 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 <hashtable> :> 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 <array> clone <enum>
|
||||
[ '[ _ 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 <huffman-decoder>
|
||||
[ 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 <repetition> append ] bi* ] [ suffix ] if ] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 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 <byte-vector> :> 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 <huffman-decoder> ] 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:<lsb0-bit-reader>
|
||||
[ 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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: enum>seq ( assoc -- seq )
|
||||
dup keys [ ] [ max ] map-reduce 1 + f <array>
|
||||
[ '[ 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 <hashtable> :> 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 <array> clone <enum>
|
||||
[ '[ _ 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 <huffman-decoder>
|
||||
[ 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 <repetition> append ] bi* ] [ suffix ] if ] reduce
|
||||
[ dup array? [ second 0 <repetition> ] [ 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 <byte-vector> :> 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 <huffman-decoder> ] 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>> <slice>
|
||||
len 8 * bitstream bs:seek ;
|
||||
|
||||
: inflate-static ( bitstream -- bytes ) zlib-unimplemented ;
|
||||
|
||||
:: inflate-loop ( bitstream -- bytes )
|
||||
[ 1 bitstream bs:read 0 = ]
|
||||
[
|
||||
bitstream
|
||||
2 bitstream bs:read
|
||||
{
|
||||
{ 0 [ inflate-raw ] }
|
||||
{ 1 [ inflate-static ] }
|
||||
{ 2 [ inflate-dynamic ] }
|
||||
{ 3 [ bad-zlib-data f ] }
|
||||
}
|
||||
case
|
||||
]
|
||||
[ produce ] keep call suffix concat ;
|
||||
|
||||
! [ produce ] keep dip swap suffix
|
||||
|
||||
:: paeth ( a b c -- p )
|
||||
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
|
||||
sort-keys first second ;
|
||||
|
||||
:: png-unfilter-line ( prev curr filter -- curr' )
|
||||
prev :> c
|
||||
prev 3 tail-slice :> b
|
||||
curr :> a
|
||||
curr 3 tail-slice :> x
|
||||
x length [0,b)
|
||||
filter
|
||||
{
|
||||
{ 0 [ drop ] }
|
||||
{ 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
|
||||
{ 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
|
||||
{ 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
|
||||
|
||||
} case
|
||||
curr 3 tail ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: reverse-png-filter' ( lines -- byte-array )
|
||||
[ first ] [ 1 tail ] [ map ] bi-curry@ bi nip
|
||||
concat [ 128 + ] B{ } map-as ;
|
||||
|
||||
: reverse-png-filter ( lines -- byte-array )
|
||||
dup first [ 0 ] replicate prefix
|
||||
[ { 0 0 } prepend ] map
|
||||
2 clump [
|
||||
first2 dup [ third ] [ 0 2 rot set-nth ] bi png-unfilter-line
|
||||
] map B{ } concat-as ;
|
||||
|
||||
: zlib-inflate ( bytes -- bytes )
|
||||
bs:<lsb0-bit-reader>
|
||||
[ check-zlib-header ] [ inflate-loop ] bi
|
||||
inflate-lz77 ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -1,7 +1,75 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays grouping sequences ;
|
||||
USING: accessors arrays combinators grouping kernel locals math
|
||||
math.matrices math.order multiline sequence-parser sequences
|
||||
tools.continuations ;
|
||||
IN: compression.run-length
|
||||
|
||||
: run-length-uncompress ( byte-array -- byte-array' )
|
||||
2 group [ first2 <array> ] map concat ;
|
||||
2 group [ first2 <array> ] 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 <sequence-parser> :> 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 <repetition> 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 <sequence-parser> :> 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 <array> [ 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 ;
|
||||
|
|
|
@ -57,3 +57,30 @@ TUPLE: default { a integer initial: 0 } ;
|
|||
CONSTRUCTOR: default ( -- obj ) ;
|
||||
|
||||
[ 0 ] [ <default> a>> ] unit-test
|
||||
|
||||
|
||||
TUPLE: inherit1 a ;
|
||||
TUPLE: inherit2 < inherit1 a ;
|
||||
|
||||
CONSTRUCTOR: inherit2 ( a -- obj ) ;
|
||||
|
||||
[ T{ inherit2 f f 100 } ] [ 100 <inherit2> ] unit-test
|
||||
|
||||
|
||||
TUPLE: inherit3 hp max-hp ;
|
||||
TUPLE: inherit4 < inherit3 ;
|
||||
TUPLE: inherit5 < inherit3 ;
|
||||
|
||||
CONSTRUCTOR: inherit3 ( -- obj )
|
||||
dup max-hp>> >>hp ;
|
||||
|
||||
BACKWARD-CONSTRUCTOR: inherit4 ( -- obj )
|
||||
10 >>max-hp ;
|
||||
|
||||
[ 10 ] [ <inherit4> hp>> ] unit-test
|
||||
|
||||
FORWARD-CONSTRUCTOR: inherit5 ( -- obj )
|
||||
5 >>hp
|
||||
10 >>max-hp ;
|
||||
|
||||
[ 5 ] [ <inherit5> hp>> ] unit-test
|
||||
|
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs classes.tuple effects.parser fry
|
||||
generalizations generic.standard kernel lexer locals macros
|
||||
parser sequences slots vocabs words ;
|
||||
USING: accessors assocs classes classes.tuple effects.parser
|
||||
fry generalizations generic.standard kernel lexer locals macros
|
||||
parser sequences slots vocabs words arrays ;
|
||||
IN: constructors
|
||||
|
||||
! An experiment
|
||||
|
@ -25,30 +25,44 @@ IN: constructors
|
|||
[ drop define-initializer-generic ]
|
||||
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
|
||||
|
||||
: all-slots-assoc ( class -- slots )
|
||||
superclasses [ [ "slots" word-prop ] keep '[ _ ] { } map>assoc ] map concat ;
|
||||
|
||||
MACRO:: slots>constructor ( class slots -- quot )
|
||||
class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
|
||||
class all-slots-assoc slots [ '[ first name>> _ = ] find-last nip ] with map :> slot-assoc
|
||||
class all-slots-assoc [ [ ] [ first initial>> ] bi ] { } map>assoc :> default-params
|
||||
slots length
|
||||
params length
|
||||
default-params length
|
||||
'[
|
||||
_ narray slots swap zip
|
||||
params swap assoc-union
|
||||
values _ firstn class boa
|
||||
_ narray slot-assoc swap zip
|
||||
default-params swap assoc-union values _ firstn class boa
|
||||
] ;
|
||||
|
||||
:: define-constructor ( constructor-word class effect def -- )
|
||||
:: (define-constructor) ( constructor-word class effect def -- word quot )
|
||||
constructor-word
|
||||
class def define-initializer
|
||||
class effect in>> '[ _ _ slots>constructor ]
|
||||
class effect in>> '[ _ _ slots>constructor ] ;
|
||||
|
||||
:: define-constructor ( constructor-word class effect def -- )
|
||||
constructor-word class effect def (define-constructor)
|
||||
class lookup-initializer
|
||||
'[ @ _ execute( obj -- obj ) ] effect define-declared ;
|
||||
|
||||
:: define-auto-constructor ( constructor-word class effect def reverse? -- )
|
||||
constructor-word class effect def (define-constructor)
|
||||
class superclasses [ lookup-initializer ] map sift
|
||||
reverse? [ reverse ] when
|
||||
'[ @ _ [ execute( obj -- obj ) ] each ] effect define-declared ;
|
||||
|
||||
: scan-constructor ( -- class word )
|
||||
scan-word [ name>> "<" ">" surround create-in ] keep ;
|
||||
|
||||
SYNTAX: CONSTRUCTOR:
|
||||
scan-constructor
|
||||
complete-effect
|
||||
parse-definition
|
||||
define-constructor ;
|
||||
: parse-constructor ( -- class word effect def )
|
||||
scan-constructor complete-effect parse-definition ;
|
||||
|
||||
SYNTAX: CONSTRUCTOR: parse-constructor define-constructor ;
|
||||
SYNTAX: FORWARD-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
|
||||
SYNTAX: BACKWARD-CONSTRUCTOR: parse-constructor t define-auto-constructor ;
|
||||
SYNTAX: AUTO-CONSTRUCTOR: parse-constructor f define-auto-constructor ;
|
||||
|
||||
"initializers" create-vocab drop
|
||||
|
|
|
@ -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
|
||||
} cond
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
[ 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
|
||||
|
|
|
@ -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 <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||
'[ _ _ ncleave ] ;
|
||||
|
||||
MACRO: nbi-curry ( n -- )
|
||||
[ bi-curry ] n*quot ;
|
||||
|
||||
: nappend-as ( n exemplar -- seq )
|
||||
[ narray concat ] dip like ; inline
|
||||
|
||||
|
|
|
@ -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 = ;
|
||||
|
||||
|
|
|
@ -2,288 +2,21 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays byte-arrays columns
|
||||
combinators compression.run-length endian fry grouping images
|
||||
images.loader io io.binary io.encodings.binary io.files
|
||||
images.bitmap.loading images.loader io io.binary
|
||||
io.encodings.binary io.encodings.string io.files
|
||||
io.streams.limited kernel locals macros math math.bitwise
|
||||
math.functions namespaces sequences specialized-arrays.uint
|
||||
specialized-arrays.ushort strings summary io.encodings.8-bit
|
||||
io.encodings.string ;
|
||||
QUALIFIED-WITH: bitstreams b
|
||||
specialized-arrays.ushort strings summary ;
|
||||
IN: images.bitmap
|
||||
|
||||
: read2 ( -- n ) 2 read le> ;
|
||||
: read4 ( -- n ) 4 read le> ;
|
||||
: write2 ( n -- ) 2 >le write ;
|
||||
: write4 ( n -- ) 4 >le write ;
|
||||
|
||||
SINGLETON: bitmap-image
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
TUPLE: loading-bitmap
|
||||
magic size reserved1 reserved2 offset header-length width
|
||||
height planes bit-count compression size-image
|
||||
x-pels y-pels color-used color-important
|
||||
red-mask green-mask blue-mask alpha-mask
|
||||
cs-type end-points
|
||||
gamma-red gamma-green gamma-blue
|
||||
intent profile-data profile-size reserved3
|
||||
color-palette color-index bitfields ;
|
||||
|
||||
! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: os2-color-lookup ( loading-bitmap -- seq )
|
||||
[ color-index>> >array ]
|
||||
[ color-palette>> 3 <sliced-groups> ] bi
|
||||
'[ _ nth ] map concat ;
|
||||
|
||||
: os2v2-color-lookup ( loading-bitmap -- seq )
|
||||
[ color-index>> >array ]
|
||||
[ color-palette>> 3 <sliced-groups> ] bi
|
||||
'[ _ nth ] map concat ;
|
||||
|
||||
: v3-color-lookup ( loading-bitmap -- seq )
|
||||
[ color-index>> >array ]
|
||||
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
|
||||
'[ _ nth ] map concat ;
|
||||
|
||||
: color-lookup ( loading-bitmap -- seq )
|
||||
dup header-length>> {
|
||||
{ 12 [ os2-color-lookup ] }
|
||||
{ 64 [ os2v2-color-lookup ] }
|
||||
{ 40 [ v3-color-lookup ] }
|
||||
! { 108 [ v4-color-lookup ] }
|
||||
! { 124 [ v5-color-lookup ] }
|
||||
} case ;
|
||||
|
||||
ERROR: bmp-not-supported n ;
|
||||
|
||||
: uncompress-bitfield ( seq masks -- bytes' )
|
||||
'[
|
||||
_ [
|
||||
[ bitand ] [ bit-count ] [ log2 ] tri - shift
|
||||
] with map
|
||||
] { } map-as B{ } concat-as ;
|
||||
|
||||
: bitmap>bytes ( loading-bitmap -- byte-array )
|
||||
dup bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
{ 24 [ color-index>> ] }
|
||||
{ 16 [
|
||||
[
|
||||
! byte-array>ushort-array
|
||||
2 group [ le> ] map
|
||||
! 5 6 5
|
||||
! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
|
||||
! 5 5 5
|
||||
{ HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
|
||||
] change-color-index
|
||||
color-index>>
|
||||
] }
|
||||
{ 8 [ color-lookup ] }
|
||||
{ 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
|
||||
{ 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
|
||||
[ bmp-not-supported ]
|
||||
} case >byte-array ;
|
||||
|
||||
: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
|
||||
dup bit-count>> {
|
||||
{ 16 [ dup color-palette>> 4 group [ le> ] map ] }
|
||||
{ 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
|
||||
} case reverse >>bitfields ;
|
||||
|
||||
ERROR: unsupported-bitfield-widths n ;
|
||||
|
||||
M: unsupported-bitfield-widths summary
|
||||
drop "Bitmaps only support bitfield compression in 16/32bit images" ;
|
||||
|
||||
: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
|
||||
set-bitfield-widths
|
||||
dup bit-count>> {
|
||||
{ 16 [
|
||||
dup bitfields>> '[
|
||||
byte-array>ushort-array _ uncompress-bitfield
|
||||
] change-color-index
|
||||
] }
|
||||
{ 32 [
|
||||
dup bitfields>> '[
|
||||
byte-array>uint-array _ uncompress-bitfield
|
||||
] change-color-index
|
||||
] }
|
||||
[ unsupported-bitfield-widths ]
|
||||
} case ;
|
||||
|
||||
ERROR: unsupported-bitmap-compression compression ;
|
||||
|
||||
: uncompress-bitmap ( loading-bitmap -- loading-bitmap' )
|
||||
dup compression>> {
|
||||
{ f [ ] }
|
||||
{ 0 [ ] }
|
||||
{ 1 [ [ run-length-uncompress ] change-color-index ] }
|
||||
{ 2 [ [ 4 b:byte-array-n>seq run-length-uncompress >byte-array ] change-color-index ] }
|
||||
{ 3 [ uncompress-bitfield-widths ] }
|
||||
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
|
||||
{ 5 [ "png" unsupported-bitmap-compression ] }
|
||||
} case ;
|
||||
|
||||
: bitmap-padding ( width -- n )
|
||||
3 * 4 mod 4 swap - 4 mod ; inline
|
||||
|
||||
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
|
||||
uncompress-bitmap
|
||||
bitmap>bytes ;
|
||||
|
||||
: parse-file-header ( loading-bitmap -- loading-bitmap )
|
||||
2 read latin1 decode >>magic
|
||||
read4 >>size
|
||||
read2 >>reserved1
|
||||
read2 >>reserved2
|
||||
read4 >>offset ;
|
||||
|
||||
: read-v3-header ( loading-bitmap -- loading-bitmap )
|
||||
read4 >>width
|
||||
read4 32 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count
|
||||
read4 >>compression
|
||||
read4 >>size-image
|
||||
read4 >>x-pels
|
||||
read4 >>y-pels
|
||||
read4 >>color-used
|
||||
read4 >>color-important ;
|
||||
|
||||
: read-v4-header ( loading-bitmap -- loading-bitmap )
|
||||
read-v3-header
|
||||
read4 >>red-mask
|
||||
read4 >>green-mask
|
||||
read4 >>blue-mask
|
||||
read4 >>alpha-mask
|
||||
read4 >>cs-type
|
||||
read4 read4 read4 3array >>end-points
|
||||
read4 >>gamma-red
|
||||
read4 >>gamma-green
|
||||
read4 >>gamma-blue ;
|
||||
|
||||
: read-v5-header ( loading-bitmap -- loading-bitmap )
|
||||
read-v4-header
|
||||
read4 >>intent
|
||||
read4 >>profile-data
|
||||
read4 >>profile-size
|
||||
read4 >>reserved3 ;
|
||||
|
||||
: read-os2-header ( loading-bitmap -- loading-bitmap )
|
||||
read2 >>width
|
||||
read2 16 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count ;
|
||||
|
||||
: read-os2v2-header ( loading-bitmap -- loading-bitmap )
|
||||
read4 >>width
|
||||
read4 32 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count ;
|
||||
|
||||
ERROR: unknown-bitmap-header n ;
|
||||
|
||||
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
|
||||
read4 [ >>header-length ] keep
|
||||
{
|
||||
{ 12 [ read-os2-header ] }
|
||||
{ 64 [ read-os2v2-header ] }
|
||||
{ 40 [ read-v3-header ] }
|
||||
{ 108 [ read-v4-header ] }
|
||||
{ 124 [ read-v5-header ] }
|
||||
[ unknown-bitmap-header ]
|
||||
} case ;
|
||||
|
||||
: color-palette-length ( loading-bitmap -- n )
|
||||
[ offset>> 14 - ] [ header-length>> ] bi - ;
|
||||
|
||||
: color-index-length ( loading-bitmap -- n )
|
||||
{
|
||||
[ width>> ]
|
||||
[ planes>> * ]
|
||||
[ bit-count>> * 31 + 32 /i 4 * ]
|
||||
[ height>> abs * ]
|
||||
} cleave ;
|
||||
|
||||
: image-size ( loading-bitmap -- n )
|
||||
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
|
||||
|
||||
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
||||
dup color-palette-length read >>color-palette
|
||||
dup size-image>> dup 0 > [
|
||||
read >>color-index
|
||||
] [
|
||||
drop dup color-index-length read >>color-index
|
||||
] if ;
|
||||
|
||||
ERROR: unsupported-bitmap-file magic ;
|
||||
|
||||
: load-bitmap ( path -- loading-bitmap )
|
||||
binary stream-throws <limited-file-reader> [
|
||||
loading-bitmap new
|
||||
parse-file-header dup magic>> {
|
||||
{ "BM" [ parse-bitmap-header parse-bitmap ] }
|
||||
! { "BA" [ parse-os2-bitmap-array ] }
|
||||
! { "CI" [ parse-os2-color-icon ] }
|
||||
! { "CP" [ parse-os2-color-pointer ] }
|
||||
! { "IC" [ parse-os2-icon ] }
|
||||
! { "PT" [ parse-os2-pointer ] }
|
||||
[ unsupported-bitmap-file ]
|
||||
} case
|
||||
] with-input-stream ;
|
||||
|
||||
ERROR: unknown-component-order bitmap ;
|
||||
|
||||
: bitmap>component-order ( loading-bitmap -- object )
|
||||
bit-count>> {
|
||||
{ 32 [ BGR ] }
|
||||
{ 24 [ BGR ] }
|
||||
{ 16 [ BGR ] }
|
||||
{ 8 [ BGR ] }
|
||||
{ 4 [ BGR ] }
|
||||
{ 1 [ BGR ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
M: bitmap-image load-image* ( path bitmap-image -- bitmap )
|
||||
drop load-bitmap
|
||||
[ image new ] dip
|
||||
{
|
||||
[ loading-bitmap>bytes >>bitmap ]
|
||||
[ [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
||||
[ height>> 0 < not >>upside-down? ]
|
||||
[ compression>> 3 = [ t >>upside-down? ] when ]
|
||||
[ bitmap>component-order >>component-order ]
|
||||
} cleave ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bitmap>color-index ( bitmap -- byte-array )
|
||||
[
|
||||
bitmap>>
|
||||
4 <sliced-groups>
|
||||
[ 3 head-slice <reversed> ] map
|
||||
B{ } join
|
||||
] [
|
||||
dim>> first dup bitmap-padding dup 0 > [
|
||||
[ 3 * group ] dip '[ _ <byte-array> append ] map
|
||||
B{ } join
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] bi ;
|
||||
|
||||
: reverse-lines ( byte-array width -- byte-array )
|
||||
<sliced-groups> <reversed> concat ; inline
|
||||
|
||||
: save-bitmap ( image path -- )
|
||||
binary [
|
||||
B{ CHAR: B CHAR: M } write
|
||||
[
|
||||
bitmap>color-index length 14 + 40 + write4
|
||||
bitmap>> length 14 + 40 + write4
|
||||
0 write4
|
||||
54 write4
|
||||
40 write4
|
||||
|
@ -301,8 +34,8 @@ PRIVATE>
|
|||
! compression
|
||||
[ drop 0 write4 ]
|
||||
|
||||
! size-image
|
||||
[ bitmap>color-index length write4 ]
|
||||
! image-size
|
||||
[ bitmap>> length write4 ]
|
||||
|
||||
! x-pels
|
||||
[ drop 0 write4 ]
|
||||
|
@ -317,12 +50,7 @@ PRIVATE>
|
|||
[ drop 0 write4 ]
|
||||
|
||||
! color-palette
|
||||
[
|
||||
[ bitmap>color-index ]
|
||||
[ dim>> first 3 * ]
|
||||
[ dim>> first bitmap-padding + ] tri
|
||||
reverse-lines write
|
||||
]
|
||||
[ bitmap>> write ]
|
||||
} cleave
|
||||
] bi
|
||||
] with-file-writer ;
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
|
@ -0,0 +1,374 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays combinators
|
||||
compression.run-length fry grouping images images.loader io
|
||||
io.binary io.encodings.8-bit io.encodings.binary
|
||||
io.encodings.string io.streams.limited kernel math math.bitwise
|
||||
sequences specialized-arrays.ushort summary ;
|
||||
QUALIFIED-WITH: bitstreams b
|
||||
IN: images.bitmap.loading
|
||||
|
||||
SINGLETON: bitmap-image
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
! http://www.fileformat.info/format/bmp/egff.htm
|
||||
! http://www.digicamsoft.com/bmp/bmp.html
|
||||
|
||||
ERROR: unknown-component-order bitmap ;
|
||||
ERROR: unknown-bitmap-header n ;
|
||||
|
||||
: read2 ( -- n ) 2 read le> ;
|
||||
: read4 ( -- n ) 4 read le> ;
|
||||
|
||||
TUPLE: loading-bitmap
|
||||
file-header header
|
||||
color-palette color-index bitfields ;
|
||||
|
||||
TUPLE: file-header
|
||||
{ magic initial: "BM" }
|
||||
{ size }
|
||||
{ reserved1 initial: 0 }
|
||||
{ reserved2 initial: 0 }
|
||||
{ offset }
|
||||
{ header-length } ;
|
||||
|
||||
TUPLE: v3-header
|
||||
{ width initial: 0 }
|
||||
{ height initial: 0 }
|
||||
{ planes initial: 0 }
|
||||
{ bit-count initial: 0 }
|
||||
{ compression initial: 0 }
|
||||
{ image-size initial: 0 }
|
||||
{ x-resolution initial: 0 }
|
||||
{ y-resolution initial: 0 }
|
||||
{ colors-used initial: 0 }
|
||||
{ colors-important initial: 0 } ;
|
||||
|
||||
TUPLE: v4-header < v3-header
|
||||
{ red-mask initial: 0 }
|
||||
{ green-mask initial: 0 }
|
||||
{ blue-mask initial: 0 }
|
||||
{ alpha-mask initial: 0 }
|
||||
{ cs-type initial: 0 }
|
||||
{ end-points initial: 0 }
|
||||
{ gamma-red initial: 0 }
|
||||
{ gamma-green initial: 0 }
|
||||
{ gamma-blue initial: 0 } ;
|
||||
|
||||
TUPLE: v5-header < v4-header
|
||||
{ intent initial: 0 }
|
||||
{ profile-data initial: 0 }
|
||||
{ profile-size initial: 0 }
|
||||
{ reserved3 initial: 0 } ;
|
||||
|
||||
TUPLE: os2v1-header
|
||||
{ width initial: 0 }
|
||||
{ height initial: 0 }
|
||||
{ planes initial: 0 }
|
||||
{ bit-count initial: 0 } ;
|
||||
|
||||
TUPLE: os2v2-header < os2v1-header
|
||||
{ compression initial: 0 }
|
||||
{ image-size initial: 0 }
|
||||
{ x-resolution initial: 0 }
|
||||
{ y-resolution initial: 0 }
|
||||
{ colors-used initial: 0 }
|
||||
{ colors-important initial: 0 }
|
||||
{ units initial: 0 }
|
||||
{ reserved initial: 0 }
|
||||
{ recording initial: 0 }
|
||||
{ rendering initial: 0 }
|
||||
{ size1 initial: 0 }
|
||||
{ size2 initial: 0 }
|
||||
{ color-encoding initial: 0 }
|
||||
{ identifier initial: 0 } ;
|
||||
|
||||
UNION: v-header v3-header v4-header v5-header ;
|
||||
UNION: os2-header os2v1-header os2v2-header ;
|
||||
|
||||
: parse-file-header ( -- file-header )
|
||||
\ file-header new
|
||||
2 read latin1 decode >>magic
|
||||
read4 >>size
|
||||
read2 >>reserved1
|
||||
read2 >>reserved2
|
||||
read4 >>offset
|
||||
read4 >>header-length ;
|
||||
|
||||
: read-v3-header-data ( header -- header )
|
||||
read4 >>width
|
||||
read4 32 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count
|
||||
read4 >>compression
|
||||
read4 >>image-size
|
||||
read4 >>x-resolution
|
||||
read4 >>y-resolution
|
||||
read4 >>colors-used
|
||||
read4 >>colors-important ;
|
||||
|
||||
: read-v3-header ( -- header )
|
||||
\ v3-header new
|
||||
read-v3-header-data ;
|
||||
|
||||
: read-v4-header-data ( header -- header )
|
||||
read4 >>red-mask
|
||||
read4 >>green-mask
|
||||
read4 >>blue-mask
|
||||
read4 >>alpha-mask
|
||||
read4 >>cs-type
|
||||
read4 read4 read4 3array >>end-points
|
||||
read4 >>gamma-red
|
||||
read4 >>gamma-green
|
||||
read4 >>gamma-blue ;
|
||||
|
||||
: read-v4-header ( -- v4-header )
|
||||
\ v4-header new
|
||||
read-v3-header-data
|
||||
read-v4-header-data ;
|
||||
|
||||
: read-v5-header-data ( v5-header -- v5-header )
|
||||
read4 >>intent
|
||||
read4 >>profile-data
|
||||
read4 >>profile-size
|
||||
read4 >>reserved3 ;
|
||||
|
||||
: read-v5-header ( -- loading-bitmap )
|
||||
\ v5-header new
|
||||
read-v3-header-data
|
||||
read-v4-header-data
|
||||
read-v5-header-data ;
|
||||
|
||||
: read-os2v1-header ( -- os2v1-header )
|
||||
\ os2v1-header new
|
||||
read2 >>width
|
||||
read2 16 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count ;
|
||||
|
||||
: read-os2v2-header-data ( os2v2-header -- os2v2-header )
|
||||
read4 >>width
|
||||
read4 32 >signed >>height
|
||||
read2 >>planes
|
||||
read2 >>bit-count
|
||||
read4 >>compression
|
||||
read4 >>image-size
|
||||
read4 >>x-resolution
|
||||
read4 >>y-resolution
|
||||
read4 >>colors-used
|
||||
read4 >>colors-important
|
||||
read2 >>units
|
||||
read2 >>reserved
|
||||
read2 >>recording
|
||||
read2 >>rendering
|
||||
read4 >>size1
|
||||
read4 >>size2
|
||||
read4 >>color-encoding
|
||||
read4 >>identifier ;
|
||||
|
||||
: read-os2v2-header ( -- os2v2-header )
|
||||
\ os2v2-header new
|
||||
read-os2v2-header-data ;
|
||||
|
||||
: parse-header ( n -- header )
|
||||
{
|
||||
{ 12 [ read-os2v1-header ] }
|
||||
{ 64 [ read-os2v2-header ] }
|
||||
{ 40 [ read-v3-header ] }
|
||||
{ 108 [ read-v4-header ] }
|
||||
{ 124 [ read-v5-header ] }
|
||||
[ unknown-bitmap-header ]
|
||||
} case ;
|
||||
|
||||
: color-index-length ( header -- n )
|
||||
{
|
||||
[ width>> ]
|
||||
[ planes>> * ]
|
||||
[ bit-count>> * 31 + 32 /i 4 * ]
|
||||
[ height>> abs * ]
|
||||
} cleave ;
|
||||
|
||||
: color-palette-length ( loading-bitmap -- n )
|
||||
file-header>>
|
||||
[ offset>> 14 - ] [ header-length>> ] bi - ;
|
||||
|
||||
: parse-color-palette ( loading-bitmap -- loading-bitmap )
|
||||
dup color-palette-length read >>color-palette ;
|
||||
|
||||
GENERIC: parse-color-data* ( loading-bitmap header -- loading-bitmap )
|
||||
|
||||
: parse-color-data ( loading-bitmap -- loading-bitmap )
|
||||
dup header>> parse-color-data* ;
|
||||
|
||||
M: os2v1-header parse-color-data* ( loading-bitmap header -- loading-bitmap )
|
||||
color-index-length read >>color-index ;
|
||||
|
||||
M: object parse-color-data* ( loading-bitmap header -- loading-bitmap )
|
||||
dup image-size>> [ 0 ] unless* dup 0 >
|
||||
[ nip ] [ drop color-index-length ] if read >>color-index ;
|
||||
|
||||
: alpha-used? ( loading-bitmap -- ? )
|
||||
color-index>> 4 <sliced-groups> [ fourth 0 = ] all? not ;
|
||||
|
||||
GENERIC: bitmap>component-order* ( loading-bitmap header -- object )
|
||||
|
||||
: bitmap>component-order ( loading-bitmap -- object )
|
||||
dup header>> bitmap>component-order* ;
|
||||
|
||||
: simple-bitmap>component-order ( loading-bitamp -- object )
|
||||
header>> bit-count>> {
|
||||
{ 32 [ BGRX ] }
|
||||
{ 24 [ BGR ] }
|
||||
{ 16 [ BGR ] }
|
||||
{ 8 [ BGR ] }
|
||||
{ 4 [ BGR ] }
|
||||
{ 1 [ BGR ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: advanced-bitmap>component-order ( loading-bitmap -- object )
|
||||
[ ] [ header>> bit-count>> ] [ alpha-used? ] tri 2array {
|
||||
{ { 32 t } [ drop BGRA ] }
|
||||
{ { 32 f } [ drop BGRX ] }
|
||||
[ drop simple-bitmap>component-order ]
|
||||
} case ;
|
||||
|
||||
: color-lookup3 ( loading-bitmap -- seq )
|
||||
[ color-index>> >array ]
|
||||
[ color-palette>> 3 <sliced-groups> ] bi
|
||||
'[ _ nth ] map concat ;
|
||||
|
||||
: color-lookup4 ( loading-bitmap -- seq )
|
||||
[ color-index>> >array ]
|
||||
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ] bi
|
||||
'[ _ nth ] map concat ;
|
||||
|
||||
! os2v1 is 3bytes each, all others are 3 + 1 unused
|
||||
: color-lookup ( loading-bitmap -- seq )
|
||||
dup file-header>> header-length>> {
|
||||
{ 12 [ color-lookup3 ] }
|
||||
{ 64 [ color-lookup4 ] }
|
||||
{ 40 [ color-lookup4 ] }
|
||||
{ 108 [ color-lookup4 ] }
|
||||
{ 124 [ color-lookup4 ] }
|
||||
} case ;
|
||||
|
||||
M: os2v1-header bitmap>component-order* drop simple-bitmap>component-order ;
|
||||
M: os2v2-header bitmap>component-order* drop simple-bitmap>component-order ;
|
||||
M: v3-header bitmap>component-order* drop simple-bitmap>component-order ;
|
||||
M: v4-header bitmap>component-order* drop advanced-bitmap>component-order ;
|
||||
M: v5-header bitmap>component-order* drop advanced-bitmap>component-order ;
|
||||
|
||||
: uncompress-bitfield ( seq masks -- bytes' )
|
||||
'[
|
||||
_ [
|
||||
[ bitand ] [ bit-count ] [ log2 ] tri - shift
|
||||
] with map
|
||||
] { } map-as B{ } concat-as ;
|
||||
|
||||
ERROR: bmp-not-supported n ;
|
||||
|
||||
: bitmap>bytes ( loading-bitmap -- byte-array )
|
||||
dup header>> bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
{ 24 [ color-index>> ] }
|
||||
{ 16 [
|
||||
[
|
||||
! byte-array>ushort-array
|
||||
2 group [ le> ] map
|
||||
! 5 6 5
|
||||
! { HEX: f800 HEX: 7e0 HEX: 1f } uncompress-bitfield
|
||||
! 5 5 5
|
||||
{ HEX: 7c00 HEX: 3e0 HEX: 1f } uncompress-bitfield
|
||||
] change-color-index
|
||||
color-index>>
|
||||
] }
|
||||
{ 8 [ color-lookup ] }
|
||||
{ 4 [ [ 4 b:byte-array-n>seq ] change-color-index color-lookup ] }
|
||||
{ 1 [ [ 1 b:byte-array-n>seq ] change-color-index color-lookup ] }
|
||||
[ bmp-not-supported ]
|
||||
} case >byte-array ;
|
||||
|
||||
: set-bitfield-widths ( loading-bitmap -- loading-bitmap' )
|
||||
dup header>> bit-count>> {
|
||||
{ 16 [ dup color-palette>> 4 group [ le> ] map ] }
|
||||
{ 32 [ { HEX: ff0000 HEX: ff00 HEX: ff } ] }
|
||||
} case reverse >>bitfields ;
|
||||
|
||||
ERROR: unsupported-bitfield-widths n ;
|
||||
|
||||
M: unsupported-bitfield-widths summary
|
||||
drop "Bitmaps only support bitfield compression in 16/32bit images" ;
|
||||
|
||||
: uncompress-bitfield-widths ( loading-bitmap -- loading-bitmap' )
|
||||
set-bitfield-widths
|
||||
dup header>> bit-count>> {
|
||||
{ 16 [
|
||||
dup bitfields>> '[
|
||||
byte-array>ushort-array _ uncompress-bitfield
|
||||
] change-color-index
|
||||
] }
|
||||
{ 32 [ ] }
|
||||
[ unsupported-bitfield-widths ]
|
||||
} case ;
|
||||
|
||||
ERROR: unsupported-bitmap-compression compression ;
|
||||
|
||||
GENERIC: uncompress-bitmap* ( loading-bitmap header -- loading-bitmap )
|
||||
|
||||
: uncompress-bitmap ( loading-bitmap -- loading-bitmap )
|
||||
dup header>> uncompress-bitmap* ;
|
||||
|
||||
M: os2-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
|
||||
drop ;
|
||||
|
||||
: do-run-length-uncompress ( loading-bitmap word -- loading-bitmap )
|
||||
dupd '[
|
||||
_ header>> [ width>> ] [ height>> ] bi
|
||||
_ execute
|
||||
] change-color-index ; inline
|
||||
|
||||
M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
|
||||
compression>> {
|
||||
{ f [ ] }
|
||||
{ 0 [ ] }
|
||||
{ 1 [ \ run-length-uncompress-bitmap8 do-run-length-uncompress ] }
|
||||
{ 2 [ \ run-length-uncompress-bitmap4 do-run-length-uncompress ] }
|
||||
{ 3 [ uncompress-bitfield-widths ] }
|
||||
{ 4 [ "jpeg" unsupported-bitmap-compression ] }
|
||||
{ 5 [ "png" unsupported-bitmap-compression ] }
|
||||
} case ;
|
||||
|
||||
ERROR: unsupported-bitmap-file magic ;
|
||||
|
||||
: load-bitmap ( path -- loading-bitmap )
|
||||
binary stream-throws <limited-file-reader> [
|
||||
\ loading-bitmap new
|
||||
parse-file-header [ >>file-header ] [ ] bi magic>> {
|
||||
{ "BM" [
|
||||
dup file-header>> header-length>> parse-header >>header
|
||||
parse-color-palette
|
||||
parse-color-data
|
||||
] }
|
||||
! { "BA" [ parse-os2-bitmap-array ] }
|
||||
! { "CI" [ parse-os2-color-icon ] }
|
||||
! { "CP" [ parse-os2-color-pointer ] }
|
||||
! { "IC" [ parse-os2-icon ] }
|
||||
! { "PT" [ parse-os2-pointer ] }
|
||||
[ unsupported-bitmap-file ]
|
||||
} case
|
||||
] with-input-stream ;
|
||||
|
||||
: loading-bitmap>bytes ( loading-bitmap -- byte-array )
|
||||
uncompress-bitmap bitmap>bytes ;
|
||||
|
||||
M: bitmap-image load-image* ( path bitmap-image -- bitmap )
|
||||
drop load-bitmap
|
||||
[ image new ] dip
|
||||
{
|
||||
[ loading-bitmap>bytes >>bitmap ]
|
||||
[ header>> [ width>> ] [ height>> abs ] bi 2array >>dim ]
|
||||
[ header>> height>> 0 < not >>upside-down? ]
|
||||
[ bitmap>component-order >>component-order ]
|
||||
} cleave ;
|
|
@ -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 } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
|
||||
|
||||
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
|
||||
APP JPG COM TEM RES ;
|
||||
|
||||
! ISO/IEC 10918-1 Table B.1
|
||||
:: >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 <jpeg-color-info>
|
||||
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 <jpeg-chunk>
|
||||
] [ 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 <array> :> 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 <array> >>bitmap
|
||||
drop ;
|
||||
|
||||
: baseline-decompress ( -- )
|
||||
jpeg> bitstream>> cleanup-bitstream { 255 255 255 255 } append
|
||||
>byte-array bs:<msb0-bit-reader> jpeg> (>>bitstream)
|
||||
jpeg> [ bitstream>> ] [ [ [ <huffman-decoder> ] 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 <loading-jpeg>
|
||||
] with-file-reader
|
||||
dup loading-jpeg [
|
||||
baseline-parse
|
||||
baseline-decompress
|
||||
jpeg> bitmap>> 3 <groups> [ 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 } ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
|
||||
|
||||
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
|
||||
APP JPG COM TEM RES ;
|
||||
|
||||
! ISO/IEC 10918-1 Table B.1
|
||||
:: >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 <jpeg-color-info>
|
||||
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 <jpeg-chunk>
|
||||
] [ 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 <array> :> 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 <array> pos 1 jpeg> draw-block
|
||||
64 0 <array> 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 <array> >>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:<msb0-bit-reader> jpeg> (>>bitstream)
|
||||
jpeg>
|
||||
[ bitstream>> ]
|
||||
[ [ [ <huffman-decoder> ] 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 <groups> [ 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 <jpeg-image>
|
||||
] with-file-reader
|
||||
dup jpeg-image [
|
||||
baseline-parse
|
||||
baseline-decompress
|
||||
] with-variable ;
|
||||
|
||||
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
||||
drop load-jpeg ;
|
||||
|
||||
|
|
|
@ -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 )
|
||||
<png-chunk>
|
||||
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 )
|
||||
[ <image> ] 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 ;
|
||||
|
||||
|
|
|
@ -443,7 +443,7 @@ ERROR: unhandled-compression compression ;
|
|||
'[
|
||||
_ group
|
||||
[ _ group unclip [ v+ ] accumulate swap suffix concat ] map
|
||||
concat >byte-array
|
||||
B{ } concat-as
|
||||
] change-bitmap ;
|
||||
|
||||
: strips-predictor ( ifd -- ifd )
|
||||
|
@ -492,11 +492,11 @@ ERROR: unknown-component-order ifd ;
|
|||
} case ;
|
||||
|
||||
: ifd>image ( ifd -- image )
|
||||
{
|
||||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order f ]
|
||||
[ bitmap>> ]
|
||||
} cleave image boa ;
|
||||
[ <image> ] 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 ;
|
||||
|
|
|
@ -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: [ <secure-config> ] }
|
||||
{ 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: [ <flag> ] } ;
|
||||
|
||||
: local-server ( port -- addrspec ) "localhost" swap <inet> ;
|
||||
|
||||
|
@ -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> >>secure-config
|
||||
[ "No handler quotation" throw ] >>handler
|
||||
<flag> >>ready ; inline
|
||||
swap >>encoding ;
|
||||
|
||||
: <threaded-server> ( encoding -- threaded-server )
|
||||
threaded-server new-threaded-server ;
|
||||
|
|
|
@ -117,7 +117,7 @@ M: invalid-inet6 summary drop "Invalid IPv6 address" ;
|
|||
<byte-array> glue ;
|
||||
|
||||
: inet6-bytes ( seq -- bytes )
|
||||
[ 2 >be ] { } map-as concat >byte-array ;
|
||||
[ 2 >be ] { } map-as B{ } concat-as ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
|
@ -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
|
||||
[ C{ 1 2 } ] [ C{ 1 2 } 1 ^ ] unit-test
|
||||
|
|
|
@ -89,7 +89,7 @@ PRIVATE>
|
|||
|
||||
: ^ ( x y -- z )
|
||||
{
|
||||
{ [ over zero? ] [ nip 0^ ] }
|
||||
{ [ over 0 = ] [ nip 0^ ] }
|
||||
{ [ dup integer? ] [ integer^ ] }
|
||||
{ [ 2dup real^? ] [ fpow ] }
|
||||
[ ^complex ]
|
||||
|
|
|
@ -1,12 +1,12 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.order math.vectors
|
||||
sequences sequences.private accessors columns ;
|
||||
USING: accessors arrays columns kernel math math.bits
|
||||
math.order math.vectors sequences sequences.private fry ;
|
||||
IN: math.matrices
|
||||
|
||||
! Matrices
|
||||
: zero-matrix ( m n -- matrix )
|
||||
[ nip 0 <array> ] curry map ;
|
||||
'[ _ 0 <array> ] replicate ;
|
||||
|
||||
: identity-matrix ( n -- matrix )
|
||||
#! Make a nxn identity matrix.
|
||||
|
@ -60,4 +60,8 @@ PRIVATE>
|
|||
gram-schmidt [ normalize ] map ;
|
||||
|
||||
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
||||
[ [ 2array ] with map ] curry map ;
|
||||
[ [ 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 ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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? [
|
||||
|
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
@ -42,3 +42,6 @@ M: byte-vector hexdump. hexdump-bytes ;
|
|||
|
||||
: hexdump ( byte-array -- str )
|
||||
[ hexdump. ] with-string-writer ;
|
||||
|
||||
: hexdump-file ( path -- )
|
||||
binary file-contents hexdump. ;
|
||||
|
|
|
@ -80,6 +80,7 @@ IN: bootstrap.syntax
|
|||
">>"
|
||||
"call-next-method"
|
||||
"initial:"
|
||||
"initial-quot:"
|
||||
"read-only"
|
||||
"call("
|
||||
"execute("
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -50,6 +50,9 @@ M: tuple class layout-of 2 slot { word } declare ;
|
|||
|
||||
PRIVATE>
|
||||
|
||||
: initial-quots? ( class -- ? )
|
||||
all-slots [ initial-quot>> ] any? ;
|
||||
|
||||
: initial-values ( class -- slots )
|
||||
all-slots [ initial>> ] map ;
|
||||
|
||||
|
@ -66,7 +69,7 @@ PRIVATE>
|
|||
|
||||
GENERIC: slots>tuple ( seq class -- tuple )
|
||||
|
||||
M: tuple-class slots>tuple
|
||||
M: tuple-class slots>tuple ( seq class -- tuple )
|
||||
check-slots pad-slots
|
||||
tuple-layout <tuple> [
|
||||
[ tuple-size ]
|
||||
|
@ -146,12 +149,22 @@ ERROR: bad-superclass class ;
|
|||
: define-boa-check ( class -- )
|
||||
dup boa-check-quot "boa-check" set-word-prop ;
|
||||
|
||||
: tuple-initial-quots-quot ( class -- quot )
|
||||
all-slots [ initial-quot>> ] filter
|
||||
[
|
||||
[
|
||||
[ initial-quot>> , (( -- obj )) , \ call-effect , \ over , ]
|
||||
[ offset>> , ] bi \ set-slot ,
|
||||
] each
|
||||
] [ ] make f like ;
|
||||
|
||||
: tuple-prototype ( class -- prototype )
|
||||
[ initial-values ] keep
|
||||
over [ ] any? [ slots>tuple ] [ 2drop f ] if ;
|
||||
[ initial-values ] [ over [ ] any? ] [ initial-quots? or ] tri
|
||||
[ slots>tuple ] [ 2drop f ] if ;
|
||||
|
||||
: define-tuple-prototype ( class -- )
|
||||
dup tuple-prototype "prototype" set-word-prop ;
|
||||
dup [ tuple-prototype ] [ tuple-initial-quots-quot ] bi 2array
|
||||
dup [ ] any? [ drop f ] unless "prototype" set-word-prop ;
|
||||
|
||||
: prepare-slots ( slots superclass -- slots' )
|
||||
[ make-slots ] [ class-size 2 + ] bi* finalize-slots ;
|
||||
|
@ -173,10 +186,21 @@ ERROR: bad-superclass class ;
|
|||
: define-tuple-layout ( class -- )
|
||||
dup make-tuple-layout "layout" set-word-prop ;
|
||||
|
||||
: calculate-initial-value ( slot-spec -- value )
|
||||
dup initial>> [
|
||||
nip
|
||||
] [
|
||||
dup initial-quot>> [
|
||||
nip call( -- obj )
|
||||
] [
|
||||
drop f
|
||||
] if*
|
||||
] if* ;
|
||||
|
||||
: compute-slot-permutation ( new-slots old-slots -- triples )
|
||||
[ [ [ name>> ] map ] bi@ [ index ] curry map ]
|
||||
[ drop [ class>> ] map ]
|
||||
[ drop [ initial>> ] map ]
|
||||
[ drop [ calculate-initial-value ] map ]
|
||||
2tri 3array flip ;
|
||||
|
||||
: update-slot ( old-values n class initial -- value )
|
||||
|
@ -340,8 +364,11 @@ M: tuple tuple-hashcode
|
|||
M: tuple hashcode* tuple-hashcode ;
|
||||
|
||||
M: tuple-class new
|
||||
dup "prototype" word-prop
|
||||
[ (clone) ] [ tuple-layout <tuple> ] ?if ;
|
||||
dup "prototype" word-prop [
|
||||
first2 [ (clone) ] dip [ call( obj -- obj ) ] when*
|
||||
] [
|
||||
tuple-layout <tuple>
|
||||
] ?if ;
|
||||
|
||||
M: tuple-class boa
|
||||
[ "boa-check" word-prop [ call ] when* ]
|
||||
|
|
|
@ -8,16 +8,16 @@ HELP: dispose
|
|||
$nl
|
||||
"No further operations can be performed on a disposable object after this call."
|
||||
$nl
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $snippet "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
|
||||
"Disposing an object which has already been disposed should have no effect, and in particular it should not fail with an error. To help implement this pattern, add a " { $slot "disposed" } " slot to your object and implement the " { $link dispose* } " method instead." }
|
||||
{ $notes "You must close disposable objects after you are finished working with them, to avoid leaking operating system resources. A convenient way to automate this is by using the " { $link with-disposal } " word."
|
||||
$nl
|
||||
"The default implementation assumes the object has a " { $snippet "disposable" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
|
||||
"The default implementation assumes the object has a " { $snippet "disposed" } " slot. If the slot is set to " { $link f } ", it calls " { $link dispose* } " and sets the slot to " { $link t } "." } ;
|
||||
|
||||
HELP: dispose*
|
||||
{ $values { "disposable" "a disposable object" } }
|
||||
{ $contract "Releases operating system resources associated with a disposable object. Disposable objects include streams, memory mapped files, and so on." }
|
||||
{ $notes
|
||||
"This word should not be called directly. It can be implemented on objects with a " { $snippet "disposable" } " slot to ensure that the object is only disposed once."
|
||||
"This word should not be called directly. It can be implemented on objects with a " { $slot "disposed" } " slot to ensure that the object is only disposed once."
|
||||
} ;
|
||||
|
||||
HELP: with-disposal
|
||||
|
|
|
@ -6,7 +6,7 @@ classes classes.algebra slots.private combinators accessors
|
|||
words sequences.private assocs alien quotations hashtables ;
|
||||
IN: slots
|
||||
|
||||
TUPLE: slot-spec name offset class initial read-only ;
|
||||
TUPLE: slot-spec name offset class initial initial-quot read-only ;
|
||||
|
||||
PREDICATE: reader < word "reader" word-prop ;
|
||||
|
||||
|
@ -190,6 +190,7 @@ ERROR: bad-slot-attribute key ;
|
|||
dup empty? [
|
||||
unclip {
|
||||
{ initial: [ [ first >>initial ] [ rest ] bi ] }
|
||||
{ initial-quot: [ [ first >>initial-quot ] [ rest ] bi ] }
|
||||
{ read-only [ [ t >>read-only ] dip ] }
|
||||
[ bad-slot-attribute ]
|
||||
} case
|
||||
|
@ -197,7 +198,14 @@ ERROR: bad-slot-attribute key ;
|
|||
|
||||
ERROR: bad-initial-value name ;
|
||||
|
||||
ERROR: duplicate-initial-values slot ;
|
||||
|
||||
: check-duplicate-initial-values ( slot-spec -- slot-spec )
|
||||
dup [ initial>> ] [ initial-quot>> ] bi and
|
||||
[ duplicate-initial-values ] when ;
|
||||
|
||||
: check-initial-value ( slot-spec -- slot-spec )
|
||||
check-duplicate-initial-values
|
||||
dup initial>> [
|
||||
[ ] [
|
||||
dup [ initial>> ] [ class>> ] bi instance?
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
Joe Groff
|
|
@ -0,0 +1,46 @@
|
|||
USING: alien.c-types alien.syntax half-floats kernel math tools.test ;
|
||||
IN: half-floats.tests
|
||||
|
||||
[ HEX: 0000 ] [ 0.0 half>bits ] unit-test
|
||||
[ HEX: 8000 ] [ -0.0 half>bits ] unit-test
|
||||
[ HEX: 3e00 ] [ 1.5 half>bits ] unit-test
|
||||
[ HEX: be00 ] [ -1.5 half>bits ] unit-test
|
||||
[ HEX: 7c00 ] [ 1/0. half>bits ] unit-test
|
||||
[ HEX: fc00 ] [ -1/0. half>bits ] unit-test
|
||||
[ HEX: 7eaa ] [ HEX: aaaaaaaaaaaaa <fp-nan> half>bits ] unit-test
|
||||
|
||||
! too-big floats overflow to infinity
|
||||
[ HEX: 7c00 ] [ 65536.0 half>bits ] unit-test
|
||||
[ HEX: fc00 ] [ -65536.0 half>bits ] unit-test
|
||||
[ HEX: 7c00 ] [ 131072.0 half>bits ] unit-test
|
||||
[ HEX: fc00 ] [ -131072.0 half>bits ] unit-test
|
||||
|
||||
! too-small floats flush to zero
|
||||
[ HEX: 0000 ] [ 1.0e-9 half>bits ] unit-test
|
||||
[ HEX: 8000 ] [ -1.0e-9 half>bits ] unit-test
|
||||
|
||||
[ 0.0 ] [ HEX: 0000 bits>half ] unit-test
|
||||
[ -0.0 ] [ HEX: 8000 bits>half ] unit-test
|
||||
[ 1.5 ] [ HEX: 3e00 bits>half ] unit-test
|
||||
[ -1.5 ] [ HEX: be00 bits>half ] unit-test
|
||||
[ 1/0. ] [ HEX: 7c00 bits>half ] unit-test
|
||||
[ -1/0. ] [ HEX: fc00 bits>half ] unit-test
|
||||
[ t ] [ HEX: 7e00 bits>half fp-nan? ] unit-test
|
||||
|
||||
C-STRUCT: halves
|
||||
{ "half" "tom" }
|
||||
{ "half" "dick" }
|
||||
{ "half" "harry" }
|
||||
{ "half" "harry-jr" } ;
|
||||
|
||||
[ 8 ] [ "halves" heap-size ] unit-test
|
||||
|
||||
[ 3.0 ] [
|
||||
"halves" <c-object>
|
||||
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
|
||||
|
|
@ -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 <ushort> ] >>unboxer-quot
|
||||
[ *ushort bits>half ] >>boxer-quot
|
||||
drop
|
||||
|
||||
"half" define-array
|
||||
"half" define-direct-array
|
||||
|
||||
>>
|
|
@ -0,0 +1 @@
|
|||
Half-precision float support for FFI
|
|
@ -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-(* ;
|
|
@ -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
|
||||
|
||||
: <perlin-noise-table> ( -- 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
|
||||
|
|
|
@ -118,10 +118,10 @@ IN: sequence-parser.tests
|
|||
[ "abcd e \\\"f g" ]
|
||||
[ "\"abcd e \\\"f g\"" <sequence-parser> CHAR: \ CHAR: " take-token* ] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ f ]
|
||||
[ "" <sequence-parser> take-rest ] unit-test
|
||||
|
||||
[ "" ]
|
||||
[ f ]
|
||||
[ "abc" <sequence-parser> dup "abc" take-sequence drop take-rest ] unit-test
|
||||
|
||||
[ f ]
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
: <terrain-image> ( bytes -- image )
|
||||
<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 <terrain-image> ;
|
||||
|
||||
: 4max ( a b c d -- max )
|
||||
max max max ; inline
|
||||
|
|
|
@ -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
|
|
@ -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 ;
|
Before Width: | Height: | Size: 43 KiB After Width: | Height: | Size: 43 KiB |
Before Width: | Height: | Size: 43 KiB After Width: | Height: | Size: 43 KiB |
Before Width: | Height: | Size: 485 B After Width: | Height: | Size: 485 B |
Before Width: | Height: | Size: 454 B After Width: | Height: | Size: 454 B |
Before Width: | Height: | Size: 470 B After Width: | Height: | Size: 470 B |