steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix conflict

db4
Slava Pestov 2009-06-13 17:49:20 -05:00
parent 7076d89fc3 2adeecb9a4
commit a0e3f356c3
51 changed files with 1511 additions and 969 deletions

19
basis/bitstreams/bitstreams.factor
View File

@ -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

432
basis/compression/inflate/inflate.factor Executable file → Normal file
View File

@ -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 ;

1
basis/compression/run-length/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

72
basis/compression/run-length/run-length.factor
View File

@ -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 ;

27
basis/constructors/constructors-tests.factor
View File

@ -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

44
basis/constructors/constructors.factor
View File

@ -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

13
basis/debugger/debugger.factor
View File

@ -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

19
basis/game-input/dinput/dinput.factor
View File

@ -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

9
basis/generalizations/generalizations-tests.factor
View File

@ -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

9
basis/generalizations/generalizations.factor
View File

@ -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

7
basis/images/bitmap/bitmap-tests.factor
View File

@ -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 = ;

286
basis/images/bitmap/bitmap.factor
View File

@ -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 ;

1
basis/images/bitmap/loading/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

374
basis/images/bitmap/loading/loading.factor Normal file
View File

@ -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 ;

665
basis/images/jpeg/jpeg.factor Executable file → Normal file
View File

@ -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 ;

51
basis/images/png/png.factor
View File

@ -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 ;

12
basis/images/tiff/tiff.factor
View File

@ -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 ;

23
basis/io/servers/connection/connection.factor
View File

@ -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 ;

2
basis/io/sockets/sockets.factor
View File

@ -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>

3
basis/math/functions/functions-tests.factor
View File

@ -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

2
basis/math/functions/functions.factor
View File

@ -89,7 +89,7 @@ PRIVATE>
: ^ ( x y -- z )
{
{ [ over zero? ] [ nip 0^ ] }
{ [ over 0 = ] [ nip 0^ ] }
{ [ dup integer? ] [ integer^ ] }
{ [ 2dup real^? ] [ fpow ] }
[ ^complex ]

12
basis/math/matrices/matrices.factor Executable file → Normal file
View File

@ -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 ;

12
basis/opengl/textures/textures.factor
View File

@ -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 ;

2
basis/porter-stemmer/porter-stemmer.factor
View File

@ -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? [

9
basis/tools/hexdump/hexdump.factor
View File

@ -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. ;

1
core/bootstrap/syntax.factor
View File

@ -80,6 +80,7 @@ IN: bootstrap.syntax
">>"
"call-next-method"
"initial:"
"initial-quot:"
"read-only"
"call("
"execute("

10
core/classes/tuple/parser/parser-tests.factor
View File

@ -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

35
core/classes/tuple/tuple-tests.factor
View File

@ -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

41
core/classes/tuple/tuple.factor
View File

@ -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* ]

6
core/destructors/destructors-docs.factor
View File

@ -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

10
core/slots/slots.factor
View File

@ -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?

4
core/syntax/syntax.factor
View File

@ -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

18
extra/cursors/cursors-tests.factor
View File

@ -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

55
extra/cursors/cursors.factor
View File

@ -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

1
extra/half-floats/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

46
extra/half-floats/half-floats-tests.factor Normal file
View File

@ -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

42
extra/half-floats/half-floats.factor Normal file
View File

@ -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
>>

1
extra/half-floats/summary.txt Normal file
View File

@ -0,0 +1 @@
Half-precision float support for FFI

20
extra/nested-comments/nested-comments.factor Normal file
View File

@ -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-(* ;

14
extra/noise/noise.factor
View File

@ -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

4
extra/sequence-parser/sequence-parser-tests.factor
View File

@ -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 ]

6
extra/sequence-parser/sequence-parser.factor
View File

@ -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

29
extra/terrain/generation/generation.factor
View File

@ -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

0
extra/images/processing/rotation/authors.txt → unmaintained/images/processing/rotation/authors.txt
View File

24
extra/images/processing/rotation/rotation-tests.factor → unmaintained/images/processing/rotation/rotation-tests.factor
View File

@ -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

7
extra/images/processing/rotation/rotation.factor → unmaintained/images/processing/rotation/rotation.factor
View File

@ -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 ;

0
extra/images/processing/rotation/test-bitmaps/PastedImage.bmp → unmaintained/images/processing/rotation/test-bitmaps/PastedImage.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 43 KiB

After

Width:  |  Height:  |  Size: 43 KiB

0
extra/images/processing/rotation/test-bitmaps/PastedImage90.bmp → unmaintained/images/processing/rotation/test-bitmaps/PastedImage90.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 43 KiB

After

Width:  |  Height:  |  Size: 43 KiB

0
extra/images/processing/rotation/test-bitmaps/lake.bmp → unmaintained/images/processing/rotation/test-bitmaps/lake.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 485 B

After

Width:  |  Height:  |  Size: 485 B

0
extra/images/processing/rotation/test-bitmaps/small-rotated.bmp → unmaintained/images/processing/rotation/test-bitmaps/small-rotated.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 454 B

After

Width:  |  Height:  |  Size: 454 B

0
extra/images/processing/rotation/test-bitmaps/small.bmp → unmaintained/images/processing/rotation/test-bitmaps/small.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 470 B

After

Width:  |  Height:  |  Size: 470 B