Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
978647dc39
basis
alien
parser
compression/inflate
cpu
architecture
ppc
game/input
images/png
io/mmap
math/vectors/conversion
tools/deploy/test/8
extra/gpu/util/wasd
|
|
@ -56,7 +56,6 @@ $nl
|
|||
{ $subsections
|
||||
malloc-object
|
||||
malloc-byte-array
|
||||
malloc-file-contents
|
||||
}
|
||||
"The " { $vocab-link "libc" } " vocabulary defines several words which directly call C standard library memory management functions:"
|
||||
{ $subsections
|
||||
|
|
|
|||
|
|
@ -56,9 +56,6 @@ M: word <c-direct-array>
|
|||
: malloc-string ( string encoding -- alien )
|
||||
string>alien malloc-byte-array ;
|
||||
|
||||
: malloc-file-contents ( path -- alien len )
|
||||
binary file-contents [ malloc-byte-array ] [ length ] bi ;
|
||||
|
||||
M: memory-stream stream-read
|
||||
[
|
||||
[ index>> ] [ alien>> ] bi <displaced-alien>
|
||||
|
|
@ -81,3 +78,4 @@ M: value-type c-type-setter ( type -- quot )
|
|||
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
|
||||
'[ @ swap @ _ memcpy ] ;
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ IN: alien.parser
|
|||
: parse-c-type-name ( name -- word )
|
||||
dup search [ nip ] [ no-word ] if* ;
|
||||
|
||||
: parse-c-type ( string -- array )
|
||||
: parse-c-type ( string -- type )
|
||||
{
|
||||
{ [ dup "void" = ] [ drop void ] }
|
||||
{ [ CHAR: ] over member? ] [ parse-array-type parse-c-type-name prefix ] }
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: tools.test compression.inflate ;
|
|||
IN: compression.inflate.tests
|
||||
|
||||
[
|
||||
BV{
|
||||
B{
|
||||
1 255 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
|
||||
0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 122 121 94 119
|
||||
239 237 227 88 16 16 10 5 16 17 26 172 3 20 19 245 22 54 55
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays assocs byte-vectors combinators
|
||||
combinators.smart compression.huffman fry hashtables io.binary
|
||||
kernel literals locals math math.bitwise math.order math.ranges
|
||||
sequences sorting memoize combinators.short-circuit ;
|
||||
sequences sorting memoize combinators.short-circuit byte-arrays ;
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
IN: compression.inflate
|
||||
|
||||
|
|
@ -88,14 +88,14 @@ CONSTANT: dist-table
|
|||
: nth* ( n seq -- elt )
|
||||
[ length 1 - swap - ] [ nth ] bi ; inline
|
||||
|
||||
:: inflate-lz77 ( seq -- bytes )
|
||||
:: inflate-lz77 ( seq -- byte-array )
|
||||
1000 <byte-vector> :> bytes
|
||||
seq [
|
||||
dup array?
|
||||
[ first2 '[ _ 1 - bytes nth* bytes push ] times ]
|
||||
[ bytes push ] if
|
||||
] each
|
||||
bytes ;
|
||||
bytes >byte-array ;
|
||||
|
||||
:: inflate-huffman ( bitstream tables -- bytes )
|
||||
bitstream tables [ <huffman-decoder> ] with map :> tables
|
||||
|
|
|
|||
|
|
@ -324,6 +324,46 @@ HOOK: %shr-vector-reps cpu ( -- reps )
|
|||
HOOK: %horizontal-shl-vector-reps cpu ( -- reps )
|
||||
HOOK: %horizontal-shr-vector-reps cpu ( -- reps )
|
||||
|
||||
M: object %zero-vector-reps { } ;
|
||||
M: object %fill-vector-reps { } ;
|
||||
M: object %gather-vector-2-reps { } ;
|
||||
M: object %gather-vector-4-reps { } ;
|
||||
M: object %shuffle-vector-reps { } ;
|
||||
M: object %merge-vector-reps { } ;
|
||||
M: object %signed-pack-vector-reps { } ;
|
||||
M: object %unsigned-pack-vector-reps { } ;
|
||||
M: object %unpack-vector-head-reps { } ;
|
||||
M: object %unpack-vector-tail-reps { } ;
|
||||
M: object %integer>float-vector-reps { } ;
|
||||
M: object %float>integer-vector-reps { } ;
|
||||
M: object %compare-vector-reps drop { } ;
|
||||
M: object %compare-vector-ccs 2drop { } f ;
|
||||
M: object %test-vector-reps { } ;
|
||||
M: object %add-vector-reps { } ;
|
||||
M: object %saturated-add-vector-reps { } ;
|
||||
M: object %add-sub-vector-reps { } ;
|
||||
M: object %sub-vector-reps { } ;
|
||||
M: object %saturated-sub-vector-reps { } ;
|
||||
M: object %mul-vector-reps { } ;
|
||||
M: object %saturated-mul-vector-reps { } ;
|
||||
M: object %div-vector-reps { } ;
|
||||
M: object %min-vector-reps { } ;
|
||||
M: object %max-vector-reps { } ;
|
||||
M: object %dot-vector-reps { } ;
|
||||
M: object %sqrt-vector-reps { } ;
|
||||
M: object %horizontal-add-vector-reps { } ;
|
||||
M: object %horizontal-sub-vector-reps { } ;
|
||||
M: object %abs-vector-reps { } ;
|
||||
M: object %and-vector-reps { } ;
|
||||
M: object %andn-vector-reps { } ;
|
||||
M: object %or-vector-reps { } ;
|
||||
M: object %xor-vector-reps { } ;
|
||||
M: object %not-vector-reps { } ;
|
||||
M: object %shl-vector-reps { } ;
|
||||
M: object %shr-vector-reps { } ;
|
||||
M: object %horizontal-shl-vector-reps { } ;
|
||||
M: object %horizontal-shr-vector-reps { } ;
|
||||
|
||||
HOOK: %unbox-alien cpu ( dst src -- )
|
||||
HOOK: %unbox-any-c-ptr cpu ( dst src temp -- )
|
||||
HOOK: %box-alien cpu ( dst src temp -- )
|
||||
|
|
|
|||
|
|
@ -256,45 +256,6 @@ M:: ppc %binary-float-function ( dst src1 src2 func -- )
|
|||
M: ppc %single>double-float double-rep %copy ;
|
||||
M: ppc %double>single-float double-rep %copy ;
|
||||
|
||||
! VMX/AltiVec not supported yet
|
||||
M: ppc %zero-vector-reps { } ;
|
||||
M: ppc %fill-vector-reps { } ;
|
||||
M: ppc %gather-vector-2-reps { } ;
|
||||
M: ppc %gather-vector-4-reps { } ;
|
||||
M: ppc %shuffle-vector-reps { } ;
|
||||
M: ppc %merge-vector-reps { } ;
|
||||
M: ppc %signed-pack-vector-reps { } ;
|
||||
M: ppc %unsigned-pack-vector-reps { } ;
|
||||
M: ppc %unpack-vector-reps { } ;
|
||||
M: ppc %integer>float-vector-reps { } ;
|
||||
M: ppc %float>integer-vector-reps { } ;
|
||||
M: ppc %compare-vector-reps drop { } ;
|
||||
M: ppc %test-vector-reps { } ;
|
||||
M: ppc %add-vector-reps { } ;
|
||||
M: ppc %saturated-add-vector-reps { } ;
|
||||
M: ppc %add-sub-vector-reps { } ;
|
||||
M: ppc %sub-vector-reps { } ;
|
||||
M: ppc %saturated-sub-vector-reps { } ;
|
||||
M: ppc %mul-vector-reps { } ;
|
||||
M: ppc %saturated-mul-vector-reps { } ;
|
||||
M: ppc %div-vector-reps { } ;
|
||||
M: ppc %min-vector-reps { } ;
|
||||
M: ppc %max-vector-reps { } ;
|
||||
M: ppc %dot-vector-reps { } ;
|
||||
M: ppc %sqrt-vector-reps { } ;
|
||||
M: ppc %horizontal-add-vector-reps { } ;
|
||||
M: ppc %horizontal-sub-vector-reps { } ;
|
||||
M: ppc %abs-vector-reps { } ;
|
||||
M: ppc %and-vector-reps { } ;
|
||||
M: ppc %andn-vector-reps { } ;
|
||||
M: ppc %or-vector-reps { } ;
|
||||
M: ppc %xor-vector-reps { } ;
|
||||
M: ppc %not-vector-reps { } ;
|
||||
M: ppc %shl-vector-reps { } ;
|
||||
M: ppc %shr-vector-reps { } ;
|
||||
M: ppc %horizontal-shl-vector-reps { } ;
|
||||
M: ppc %horizontal-shr-vector-reps { } ;
|
||||
|
||||
M: ppc %unbox-alien ( dst src -- )
|
||||
alien-offset LWZ ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ sequences strings math ;
|
|||
IN: game.input
|
||||
|
||||
ARTICLE: "game-input" "Game controller input"
|
||||
"The " { $vocab-link "game-input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
|
||||
"The " { $vocab-link "game.input" } " vocabulary provides cross-platform access to game controller devices such as joysticks and gamepads. It also provides an interface for polling raw keyboard and mouse input." $nl
|
||||
"The game input interface must be initialized before being used:"
|
||||
{ $subsections
|
||||
open-game-input
|
||||
|
|
|
|||
|
|
@ -50,6 +50,11 @@ HELP: firstn
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: set-firstn
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link set-first } " "
|
||||
"that sets the first " { $snippet "n" } " elements of a sequence from the top " { $snippet "n" } " elements of the stack." } ;
|
||||
|
||||
HELP: npick
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link dup } ", "
|
||||
|
|
@ -257,7 +262,7 @@ HELP: nweave
|
|||
HELP: n*quot
|
||||
{ $values
|
||||
{ "n" integer } { "quot" quotation }
|
||||
{ "quot'" quotation }
|
||||
{ "quotquot" quotation }
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations prettyprint math ;"
|
||||
|
|
@ -303,11 +308,18 @@ HELP: ntuck
|
|||
}
|
||||
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
|
||||
|
||||
HELP: nspin
|
||||
{ $values
|
||||
{ "n" integer }
|
||||
}
|
||||
{ $description "A generalization of " { $link spin } " that can work for any stack depth. The top " { $snippet "n" } " items will be reversed in order." } ;
|
||||
|
||||
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
|
||||
{ $subsections
|
||||
narray
|
||||
nsequence
|
||||
firstn
|
||||
set-firstn
|
||||
nappend
|
||||
nappend-as
|
||||
} ;
|
||||
|
|
@ -321,6 +333,7 @@ ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
|
|||
nnip
|
||||
ndrop
|
||||
ntuck
|
||||
nspin
|
||||
mnswap
|
||||
nweave
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -26,6 +26,8 @@ IN: generalizations.tests
|
|||
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
|
||||
[ [ 1 ] 5 ndip ] must-infer
|
||||
[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
|
||||
[ 5 nspin ] must-infer
|
||||
[ 1 5 4 3 2 ] [ 1 2 3 4 5 4 nspin ] unit-test
|
||||
|
||||
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
|
||||
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
|
||||
|
|
@ -38,6 +40,8 @@ IN: generalizations.tests
|
|||
[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test
|
||||
|
||||
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
|
||||
[ { 1 2 3 4 } ] [ 1 2 3 4 { f f f f } [ 4 set-firstn ] keep ] unit-test
|
||||
[ 1 2 3 4 { f f f } [ 4 set-firstn ] keep ] must-fail
|
||||
[ ] [ { } 0 firstn ] unit-test
|
||||
[ "a" ] [ { "a" } 1 firstn ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -2,22 +2,19 @@
|
|||
! Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private math combinators
|
||||
macros quotations fry effects ;
|
||||
macros quotations fry effects memoize.private ;
|
||||
IN: generalizations
|
||||
|
||||
<<
|
||||
|
||||
: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
|
||||
ALIAS: n*quot (n*quot)
|
||||
|
||||
: repeat ( n obj quot -- ) swapd times ; inline
|
||||
|
||||
>>
|
||||
|
||||
MACRO: nsequence ( n seq -- )
|
||||
[
|
||||
[ drop iota <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
|
||||
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
|
||||
] keep
|
||||
[ [nsequence] ] keep
|
||||
'[ @ _ like ] ;
|
||||
|
||||
MACRO: narray ( n -- )
|
||||
|
|
@ -27,7 +24,7 @@ MACRO: nsum ( n -- )
|
|||
1 - [ + ] n*quot ;
|
||||
|
||||
MACRO: firstn-unsafe ( n -- )
|
||||
iota [ '[ [ _ ] dip nth-unsafe ] ] map '[ _ cleave ] ;
|
||||
[firstn] ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
|
|
@ -51,6 +48,18 @@ MACRO: nrot ( n -- )
|
|||
MACRO: -nrot ( n -- )
|
||||
1 - [ ] [ '[ swap _ dip ] ] repeat ;
|
||||
|
||||
MACRO: set-firstn-unsafe ( n -- )
|
||||
[ 1 + ]
|
||||
[ iota [ '[ _ rot [ set-nth-unsafe ] keep ] ] map ] bi
|
||||
'[ _ -nrot _ spread drop ] ;
|
||||
|
||||
MACRO: set-firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ 1 - swap bounds-check 2drop ]
|
||||
[ set-firstn-unsafe ]
|
||||
bi-curry '[ _ _ bi ]
|
||||
] if ;
|
||||
|
||||
MACRO: ndrop ( n -- )
|
||||
[ drop ] n*quot ;
|
||||
|
||||
|
|
@ -104,3 +113,6 @@ MACRO: nbi-curry ( n -- )
|
|||
[ narray concat ] dip like ; inline
|
||||
|
||||
: nappend ( n -- seq ) narray concat ; inline
|
||||
|
||||
MACRO: nspin ( n -- )
|
||||
[ [ ] ] swap [ swap [ ] curry compose ] n*quot [ call ] 3append ;
|
||||
|
|
|
|||
|
|
@ -3,7 +3,9 @@
|
|||
USING: accessors arrays checksums checksums.crc32 combinators
|
||||
compression.inflate fry grouping images images.loader io
|
||||
io.binary io.encodings.ascii io.encodings.string kernel locals
|
||||
math math.bitwise math.ranges sequences sorting ;
|
||||
math math.bitwise math.ranges sequences sorting assocs
|
||||
math.functions math.order ;
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
IN: images.png
|
||||
|
||||
SINGLETON: png-image
|
||||
|
|
@ -57,13 +59,16 @@ ERROR: bad-checksum ;
|
|||
4 read = [ bad-checksum ] unless
|
||||
4 cut-slice
|
||||
[ ascii decode >>type ] [ B{ } like >>data ] bi*
|
||||
[ over chunks>> push ]
|
||||
[ over chunks>> push ]
|
||||
[ type>> ] bi "IEND" =
|
||||
[ read-png-chunks ] unless ;
|
||||
|
||||
: find-chunk ( loading-png string -- chunk )
|
||||
[ chunks>> ] dip '[ type>> _ = ] find nip ;
|
||||
|
||||
: find-chunks ( loading-png string -- chunk )
|
||||
[ chunks>> ] dip '[ type>> _ = ] filter ;
|
||||
|
||||
: parse-ihdr-chunk ( loading-png -- loading-png )
|
||||
dup "IHDR" find-chunk data>> {
|
||||
[ [ 0 4 ] dip subseq be> >>width ]
|
||||
|
|
@ -76,30 +81,31 @@ ERROR: bad-checksum ;
|
|||
} cleave ;
|
||||
|
||||
: find-compressed-bytes ( loading-png -- bytes )
|
||||
chunks>> [ type>> "IDAT" = ] filter
|
||||
[ data>> ] map concat ;
|
||||
"IDAT" find-chunks [ data>> ] map concat ;
|
||||
|
||||
ERROR: unknown-color-type n ;
|
||||
ERROR: unimplemented-color-type image ;
|
||||
|
||||
: inflate-data ( loading-png -- bytes )
|
||||
find-compressed-bytes zlib-inflate ;
|
||||
find-compressed-bytes zlib-inflate ;
|
||||
|
||||
: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline
|
||||
|
||||
: png-bytes-per-pixel ( loading-png -- n )
|
||||
dup color-type>> {
|
||||
{ truecolor [ scale-bit-depth 3 * ] }
|
||||
{ truecolor-alpha [ scale-bit-depth 4 * ] }
|
||||
: png-components-per-pixel ( loading-png -- n )
|
||||
color-type>> {
|
||||
{ greyscale [ 1 ] }
|
||||
{ truecolor [ 3 ] }
|
||||
{ greyscale-alpha [ 2 ] }
|
||||
{ indexed-color [ 1 ] }
|
||||
{ truecolor-alpha [ 4 ] }
|
||||
[ unknown-color-type ]
|
||||
} case ; inline
|
||||
|
||||
: png-group-width ( loading-png -- n )
|
||||
! 1 + is for the filter type, 1 byte preceding each line
|
||||
[ png-bytes-per-pixel ] [ width>> ] bi * 1 + ;
|
||||
[ [ png-components-per-pixel ] [ bit-depth>> ] bi * ]
|
||||
[ width>> ] bi * 1 + ;
|
||||
|
||||
:: paeth ( a b c -- p )
|
||||
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
|
||||
:: paeth ( a b c -- p )
|
||||
a b + c - { a b c } [ [ - abs ] keep 2array ] with map
|
||||
sort-keys first second ;
|
||||
|
||||
:: png-unfilter-line ( width prev curr filter -- curr' )
|
||||
|
|
@ -114,10 +120,10 @@ ERROR: unimplemented-color-type image ;
|
|||
{ filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] }
|
||||
{ filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] }
|
||||
{ filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] }
|
||||
} case
|
||||
} case
|
||||
curr width tail ;
|
||||
|
||||
:: reverse-png-filter ( n lines -- byte-array )
|
||||
:: reverse-png-filter ( lines n -- byte-array )
|
||||
lines dup first length 0 <array> prefix
|
||||
[ n 1 - 0 <array> prepend ] map
|
||||
2 clump [
|
||||
|
|
@ -130,48 +136,82 @@ ERROR: unimplemented-color-type image ;
|
|||
|
||||
ERROR: unimplemented-interlace ;
|
||||
|
||||
: reverse-interlace ( byte-array loading-png -- byte-array )
|
||||
: reverse-interlace ( byte-array loading-png -- bitstream )
|
||||
{
|
||||
{ interlace-none [ ] }
|
||||
{ interlace-adam7 [ unimplemented-interlace ] }
|
||||
[ unimplemented-interlace ]
|
||||
} case ;
|
||||
} case bs:<msb0-bit-reader> ;
|
||||
|
||||
: png-image-bytes ( loading-png -- byte-array )
|
||||
[ png-bytes-per-pixel ]
|
||||
[ [ inflate-data ] [ interlace-method>> ] bi reverse-interlace ]
|
||||
[ png-group-width ] tri group reverse-png-filter ;
|
||||
: uncompress-bytes ( loading-png -- bitstream )
|
||||
[ inflate-data ] [ interlace-method>> ] bi reverse-interlace ;
|
||||
|
||||
ERROR: bad-filter n ;
|
||||
|
||||
:: raw-bytes ( loading-png -- array )
|
||||
loading-png uncompress-bytes :> bs
|
||||
loading-png width>> :> width
|
||||
loading-png height>> :> height
|
||||
loading-png png-components-per-pixel :> #components
|
||||
loading-png bit-depth>> :> bit-depth
|
||||
bit-depth :> depth!
|
||||
#components width * :> count!
|
||||
|
||||
! Only read up to 8 bits at a time
|
||||
bit-depth 16 = [
|
||||
8 depth!
|
||||
count 2 * count!
|
||||
] when
|
||||
|
||||
height [
|
||||
8 bs bs:read dup 0 4 between? [ bad-filter ] unless
|
||||
count [ depth bs bs:read ] replicate swap prefix
|
||||
8 bs bs:align
|
||||
] replicate
|
||||
#components bit-depth 16 = [ 2 * ] when reverse-png-filter ;
|
||||
|
||||
ERROR: unknown-component-type n ;
|
||||
|
||||
: png-component ( loading-png -- obj )
|
||||
bit-depth>> {
|
||||
{ 1 [ ubyte-components ] }
|
||||
{ 2 [ ubyte-components ] }
|
||||
{ 4 [ ubyte-components ] }
|
||||
{ 8 [ ubyte-components ] }
|
||||
{ 16 [ ushort-components ] }
|
||||
[ unknown-component-type ]
|
||||
} case ;
|
||||
|
||||
: loading-png>image ( loading-png -- image )
|
||||
[ image new ] dip {
|
||||
[ png-image-bytes >>bitmap ]
|
||||
[ [ width>> ] [ height>> ] bi 2array >>dim ]
|
||||
[ png-component >>component-type ]
|
||||
} cleave ;
|
||||
: scale-factor ( n -- n' )
|
||||
{
|
||||
{ 1 [ 255 ] }
|
||||
{ 2 [ 127 ] }
|
||||
{ 4 [ 17 ] }
|
||||
} case ;
|
||||
|
||||
: decode-greyscale ( loading-png -- image )
|
||||
unimplemented-color-type ;
|
||||
: scale-greyscale ( byte-array loading-png -- byte-array' )
|
||||
bit-depth>> {
|
||||
{ 8 [ ] }
|
||||
{ 16 [ 2 group [ swap ] assoc-map B{ } concat-as ] }
|
||||
[ scale-factor '[ _ * ] B{ } map-as ]
|
||||
} case ;
|
||||
|
||||
: decode-truecolor ( loading-png -- image )
|
||||
loading-png>image RGB >>component-order ;
|
||||
|
||||
: decode-indexed-color ( loading-png -- image )
|
||||
unimplemented-color-type ;
|
||||
: decode-greyscale ( loading-png -- byte-array )
|
||||
[ raw-bytes ] keep scale-greyscale ;
|
||||
|
||||
: decode-greyscale-alpha ( loading-png -- image )
|
||||
unimplemented-color-type ;
|
||||
: decode-greyscale-alpha ( loading-image -- byte-array )
|
||||
[ raw-bytes ] [ bit-depth>> ] bi 16 = [
|
||||
4 group [ first4 [ swap ] 2dip 4array ] map B{ } concat-as
|
||||
] when ;
|
||||
|
||||
: decode-truecolor-alpha ( loading-png -- image )
|
||||
loading-png>image RGBA >>component-order ;
|
||||
ERROR: invalid-PLTE array ;
|
||||
|
||||
: verify-PLTE ( seq -- seq )
|
||||
dup length 3 divisor? [ invalid-PLTE ] unless ;
|
||||
|
||||
: decode-indexed-color ( loading-image -- byte-array )
|
||||
[ raw-bytes ] keep "PLTE" find-chunk data>> verify-PLTE
|
||||
3 group '[ _ nth ] { } map-as B{ } concat-as ; inline
|
||||
|
||||
ERROR: invalid-color-type/bit-depth loading-png ;
|
||||
|
||||
|
|
@ -194,16 +234,33 @@ ERROR: invalid-color-type/bit-depth loading-png ;
|
|||
: validate-truecolor-alpha ( loading-png -- loading-png )
|
||||
{ 8 16 } validate-bit-depth ;
|
||||
|
||||
: png>image ( loading-png -- image )
|
||||
: loading-png>bitmap ( loading-png -- bytes component-order )
|
||||
dup color-type>> {
|
||||
{ greyscale [ validate-greyscale decode-greyscale ] }
|
||||
{ truecolor [ validate-truecolor decode-truecolor ] }
|
||||
{ indexed-color [ validate-indexed-color decode-indexed-color ] }
|
||||
{ greyscale-alpha [ validate-greyscale-alpha decode-greyscale-alpha ] }
|
||||
{ truecolor-alpha [ validate-truecolor-alpha decode-truecolor-alpha ] }
|
||||
{ greyscale [
|
||||
validate-greyscale decode-greyscale L
|
||||
] }
|
||||
{ truecolor [
|
||||
validate-truecolor raw-bytes RGB
|
||||
] }
|
||||
{ indexed-color [
|
||||
validate-indexed-color decode-indexed-color RGB
|
||||
] }
|
||||
{ greyscale-alpha [
|
||||
validate-greyscale-alpha decode-greyscale-alpha LA
|
||||
] }
|
||||
{ truecolor-alpha [
|
||||
validate-truecolor-alpha raw-bytes RGBA
|
||||
] }
|
||||
[ unknown-color-type ]
|
||||
} case ;
|
||||
|
||||
: loading-png>image ( loading-png -- image )
|
||||
[ image new ] dip {
|
||||
[ loading-png>bitmap [ >>bitmap ] [ >>component-order ] bi* ]
|
||||
[ [ width>> ] [ height>> ] bi 2array >>dim ]
|
||||
[ png-component >>component-type ]
|
||||
} cleave ;
|
||||
|
||||
: load-png ( stream -- loading-png )
|
||||
[
|
||||
<loading-png>
|
||||
|
|
@ -213,4 +270,4 @@ ERROR: invalid-color-type/bit-depth loading-png ;
|
|||
] with-input-stream ;
|
||||
|
||||
M: png-image stream>image
|
||||
drop load-png png>image ;
|
||||
drop load-png loading-png>image ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
USING: help.markup help.syntax alien math continuations
|
||||
destructors specialized-arrays ;
|
||||
USING: alien alien.c-types continuations destructors
|
||||
help.markup help.syntax kernel math quotations
|
||||
specialized-arrays ;
|
||||
IN: io.mmap
|
||||
|
||||
HELP: mapped-file
|
||||
|
|
@ -33,9 +34,42 @@ HELP: close-mapped-file
|
|||
{ $contract "Releases system resources associated with the mapped file. This word should not be called by user code; use " { $link dispose } " instead." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: <mapped-file-reader>
|
||||
{ $values { "path" "a pathname string" } { "mmap" mapped-file } }
|
||||
{ $contract "Opens a file for reading only and maps its contents into memory. The length is permitted to exceed the length of the file on disk, in which case the remaining space is padded with zero bytes." }
|
||||
{ $notes "You must call " { $link dispose } " when you are finished working with the returned object, to reclaim resources. The " { $link with-mapped-file } " provides an abstraction which can close the mapped file for you." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: with-mapped-array
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "c-type" c-type } { "quot" quotation }
|
||||
}
|
||||
{ $description "Memory-maps a file for reading and writing as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||
{ $examples
|
||||
{ $unchecked-example
|
||||
"USING: alien.c-types io.mmap prettyprint specialized-arrays ;"
|
||||
"SPECIALIZED-ARRAY: uint"
|
||||
""""resource:license.txt" uint [
|
||||
[ . ] each
|
||||
] with-mapped-array"""
|
||||
""
|
||||
}
|
||||
}
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
HELP: with-mapped-array-reader
|
||||
{ $values
|
||||
{ "path" "a pathname string" } { "c-type" c-type } { "quot" quotation }
|
||||
}
|
||||
{ $description "Memory-maps a file for reading as a mapped-array of the given c-type. The mapped file is disposed of when the quotation returns, or if an error is thrown." }
|
||||
{ $errors "Throws an error if a memory mapping could not be established." } ;
|
||||
|
||||
ARTICLE: "io.mmap.arrays" "Working with memory-mapped data"
|
||||
"The " { $link <mapped-file> } " word returns an instance of " { $link mapped-file } ", which doesn't directly support the sequence protocol. Instead, it needs to be wrapped in a specialized array of the appropriate C type:"
|
||||
{ $subsections <mapped-array> }
|
||||
"Additionally, files may be opened with two combinators which take a c-type as input:"
|
||||
{ $subsections with-mapped-array }
|
||||
{ $subsections with-mapped-array-reader }
|
||||
"The appropriate specialized array type must first be generated with " { $link POSTPONE: SPECIALIZED-ARRAY: } "."
|
||||
$nl
|
||||
"Data can also be read and written from the " { $link mapped-file } " by applying low-level alien words to the " { $slot "address" } " slot. This approach is not recommended, though, since in most cases the compiler will generate efficient code for specialized array usage. See " { $link "reading-writing-memory" } " for a description of low-level memory access primitives." ;
|
||||
|
|
@ -46,10 +80,10 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
|
|||
"USING: alien.c-types grouping io.mmap sequences" "specialized-arrays ;"
|
||||
"SPECIALIZED-ARRAY: char"
|
||||
""
|
||||
"\"mydata.dat\" ["
|
||||
" char <mapped-array> 4 <sliced-groups>"
|
||||
"\"mydata.dat\" char ["
|
||||
" 4 <sliced-groups>"
|
||||
" [ reverse-here ] change-each"
|
||||
"] with-mapped-file"
|
||||
"] with-mapped-array"
|
||||
}
|
||||
"Normalize a file containing packed quadrupes of floats:"
|
||||
{ $code
|
||||
|
|
@ -57,17 +91,20 @@ ARTICLE: "io.mmap.examples" "Memory-mapped file examples"
|
|||
"SIMD: float"
|
||||
"SPECIALIZED-ARRAY: float-4"
|
||||
""
|
||||
"\"mydata.dat\" ["
|
||||
" float-4 <mapped-array>"
|
||||
"\"mydata.dat\" float-4 ["
|
||||
" [ normalize ] change-each"
|
||||
"] with-mapped-file"
|
||||
"] with-mapped-array"
|
||||
} ;
|
||||
|
||||
ARTICLE: "io.mmap" "Memory-mapped files"
|
||||
"The " { $vocab-link "io.mmap" } " vocabulary implements support for memory-mapped files."
|
||||
{ $subsections <mapped-file> }
|
||||
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } ". A utility combinator which wraps the above:"
|
||||
"Memory-mapped files are disposable and can be closed with " { $link dispose } " or " { $link with-disposal } "." $nl
|
||||
"Utility combinators which wrap the above:"
|
||||
{ $subsections with-mapped-file }
|
||||
{ $subsections with-mapped-file-reader }
|
||||
{ $subsections with-mapped-array }
|
||||
{ $subsections with-mapped-array-reader }
|
||||
"Instances of " { $link mapped-file } " don't support any interesting operations in themselves. There are two facilities for accessing their contents:"
|
||||
{ $subsections
|
||||
"io.mmap.arrays"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
USING: io io.mmap io.files io.files.temp io.directories kernel
|
||||
tools.test continuations sequences io.encodings.ascii accessors
|
||||
math compiler.tree.debugger alien.data alien.c-types
|
||||
sequences.private ;
|
||||
USING: alien.c-types alien.data compiler.tree.debugger
|
||||
continuations io.directories io.encodings.ascii io.files
|
||||
io.files.temp io.mmap kernel math sequences sequences.private
|
||||
specialized-arrays specialized-arrays.instances.uint tools.test ;
|
||||
IN: io.mmap.tests
|
||||
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
|
|
@ -10,6 +10,19 @@ IN: io.mmap.tests
|
|||
[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file ] unit-test
|
||||
[ 5 ] [ "mmap-test-file.txt" temp-file [ char <mapped-array> length ] with-mapped-file-reader ] unit-test
|
||||
[ "22345" ] [ "mmap-test-file.txt" temp-file ascii file-contents ] unit-test
|
||||
|
||||
SPECIALIZED-ARRAY: uint
|
||||
|
||||
[ t ] [
|
||||
"mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array
|
||||
integer?
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
"mmap-test-file.txt" temp-file uint [ sum ] with-mapped-array-reader
|
||||
integer?
|
||||
] unit-test
|
||||
|
||||
[ "mmap-test-file.txt" temp-file delete-file ] ignore-errors
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -8,13 +8,13 @@ IN: io.mmap
|
|||
|
||||
TUPLE: mapped-file < disposable address handle length ;
|
||||
|
||||
HOOK: (mapped-file-reader) os ( path length -- address handle )
|
||||
HOOK: (mapped-file-r/w) os ( path length -- address handle )
|
||||
|
||||
ERROR: bad-mmap-size n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
HOOK: (mapped-file-reader) os ( path length -- address handle )
|
||||
HOOK: (mapped-file-r/w) os ( path length -- address handle )
|
||||
|
||||
: prepare-mapped-file ( path quot -- mapped-file path' length )
|
||||
[
|
||||
[ normalize-path ] [ file-info size>> ] bi
|
||||
|
|
@ -45,6 +45,19 @@ M: mapped-file dispose* ( mmap -- ) close-mapped-file ;
|
|||
: with-mapped-file-reader ( path quot -- )
|
||||
[ <mapped-file-reader> ] dip with-disposal ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (with-mapped-array) ( c-type quot -- )
|
||||
[ [ <mapped-array> ] curry ] dip compose with-disposal ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: with-mapped-array ( path c-type quot -- )
|
||||
[ <mapped-file> ] 2dip (with-mapped-array) ; inline
|
||||
|
||||
: with-mapped-array-reader ( path c-type quot -- )
|
||||
[ <mapped-file-reader> ] 2dip (with-mapped-array) ; inline
|
||||
|
||||
{
|
||||
{ [ os unix? ] [ "io.mmap.unix" require ] }
|
||||
{ [ os winnt? ] [ "io.mmap.windows" require ] }
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien io io.files kernel math math.bitwise system unix
|
||||
io.backend.unix io.ports io.mmap destructors locals accessors ;
|
||||
USING: accessors destructors io.backend.unix io.mmap
|
||||
io.mmap.private kernel locals math.bitwise system unix ;
|
||||
IN: io.mmap.unix
|
||||
|
||||
:: mmap-open ( path length prot flags open-mode -- alien fd )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: alien alien.c-types arrays destructors generic io.mmap
|
||||
io.ports io.backend.windows io.files.windows io.backend.windows.privileges
|
||||
kernel libc math math.bitwise namespaces quotations sequences
|
||||
io.mmap.private kernel libc math math.bitwise namespaces quotations sequences
|
||||
windows windows.advapi32 windows.kernel32 io.backend system
|
||||
accessors locals windows.errors ;
|
||||
IN: io.mmap.windows
|
||||
|
|
|
|||
|
|
@ -39,32 +39,45 @@ ERROR: bad-vconvert-input value expected-type ;
|
|||
} cond
|
||||
[ from-type check-vconvert-type ] prepose ;
|
||||
|
||||
:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
|
||||
from-size to-size /i log2 :> steps
|
||||
|
||||
:: check-vpack ( from-element to-element from-type to-type steps -- )
|
||||
{
|
||||
[ steps 1 = not ]
|
||||
[ from-element to-element [ float-type? ] bi@ xor ]
|
||||
[ from-element unsigned-type? to-element unsigned-type? not and ]
|
||||
} 0|| [ from-type to-type bad-vconvert ] when
|
||||
} 0|| [ from-type to-type bad-vconvert ] when ;
|
||||
|
||||
to-element unsigned-type? [ to-type (vpack-unsigned) ] [ to-type (vpack-signed) ] ?
|
||||
[ [ from-type check-vconvert-type ] bi@ ] prepose ;
|
||||
:: [[vpack-unsigned]] ( from-type to-type -- quot )
|
||||
[ [ from-type check-vconvert-type ] bi@ to-type (vpack-unsigned) ] ;
|
||||
|
||||
:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
|
||||
to-size from-size /i log2 :> steps
|
||||
:: [[vpack-signed]] ( from-type to-type -- quot )
|
||||
[ [ from-type check-vconvert-type ] bi@ to-type (vpack-signed) ] ;
|
||||
|
||||
:: [vpack] ( from-element to-element from-size to-size from-type to-type -- quot )
|
||||
from-size to-size /i log2 :> steps
|
||||
|
||||
from-element to-element from-type to-type steps check-vpack
|
||||
|
||||
from-type to-type to-element unsigned-type?
|
||||
[ [[vpack-unsigned]] ] [ [[vpack-signed]] ] if ;
|
||||
|
||||
:: check-vunpack ( from-element to-element from-type to-type steps -- )
|
||||
{
|
||||
[ steps 1 = not ]
|
||||
[ from-element to-element [ float-type? ] bi@ xor ]
|
||||
[ from-element unsigned-type? not to-element unsigned-type? and ]
|
||||
} 0|| [ from-type to-type bad-vconvert ] when
|
||||
} 0|| [ from-type to-type bad-vconvert ] when ;
|
||||
|
||||
:: [[vunpack]] ( from-type to-type -- quot )
|
||||
[
|
||||
from-type check-vconvert-type
|
||||
[ to-type (vunpack-head) ] [ to-type (vunpack-tail) ] bi
|
||||
] ;
|
||||
|
||||
:: [vunpack] ( from-element to-element from-size to-size from-type to-type -- quot )
|
||||
to-size from-size /i log2 :> steps
|
||||
from-element to-element from-type to-type steps check-vunpack
|
||||
from-type to-type [[vunpack]] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO:: vconvert ( from-type to-type -- )
|
||||
|
|
|
|||
|
|
@ -19,12 +19,10 @@ ABOUT: "memoize"
|
|||
|
||||
HELP: define-memoized
|
||||
{ $values { "word" word } { "quot" quotation } { "effect" effect } }
|
||||
{ $description "defines the given word at runtime as one which memoizes its output given a particular input" }
|
||||
{ $notes "A maximum of four input and four output arguments can be used" }
|
||||
{ $see-also POSTPONE: MEMO: } ;
|
||||
{ $description "Defines the given word at run time as one which memoizes its outputs given a particular input." } ;
|
||||
|
||||
HELP: MEMO:
|
||||
{ $syntax "MEMO: word ( stack -- effect ) definition ;" }
|
||||
{ $description "defines the given word at parsetime as one which memoizes its output given a particular input. The stack effect is mandatory." }
|
||||
{ $notes "A maximum of four input and four output arguments can be used" }
|
||||
{ $see-also define-memoized } ;
|
||||
{ $description "Defines the given word at parse time as one which memoizes its output given a particular input. The stack effect is mandatory." } ;
|
||||
|
||||
{ define-memoized POSTPONE: MEMO: } related-words
|
||||
|
|
|
|||
|
|
@ -7,9 +7,18 @@ IN: memoize.tests
|
|||
MEMO: fib ( m -- n )
|
||||
dup 1 <= [ drop 1 ] [ dup 1 - fib swap 2 - fib + ] if ;
|
||||
|
||||
MEMO: x ( a b c d e -- f g h i j )
|
||||
[ 1 + ] 4 ndip ;
|
||||
|
||||
[ 89 ] [ 10 fib ] unit-test
|
||||
|
||||
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1 + ] 4 ndip ;" eval( -- ) ] must-fail
|
||||
[
|
||||
1 0 0 0 0
|
||||
1 0 0 0 0
|
||||
] [
|
||||
0 0 0 0 0 x
|
||||
0 0 0 0 0 x
|
||||
] unit-test
|
||||
|
||||
MEMO: see-test ( a -- b ) reverse ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,22 +1,36 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel hashtables sequences arrays words namespaces make
|
||||
parser math assocs effects definitions quotations summary
|
||||
accessors fry ;
|
||||
USING: kernel hashtables sequences sequences.private arrays
|
||||
words namespaces make parser math assocs effects definitions
|
||||
quotations summary accessors fry ;
|
||||
IN: memoize
|
||||
|
||||
ERROR: too-many-arguments ;
|
||||
|
||||
M: too-many-arguments summary
|
||||
drop "There must be no more than 4 input and 4 output arguments" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
! We can't use n*quot, narray and firstn from generalizations because
|
||||
! they're macros, and macros use memoize!
|
||||
: (n*quot) ( n quot -- quotquot )
|
||||
<repetition> concat >quotation ;
|
||||
|
||||
: [nsequence] ( length exemplar -- quot )
|
||||
[ [ [ 1 - ] keep ] dip '[ _ _ _ new-sequence ] ]
|
||||
[ drop [ [ set-nth-unsafe ] 2keep [ 1 - ] dip ] (n*quot) ] 2bi
|
||||
[ nip ] 3append ;
|
||||
|
||||
: [firstn] ( length -- quot )
|
||||
[ 0 swap ] swap
|
||||
[ [ nth-unsafe ] 2keep [ 1 + ] dip ] (n*quot)
|
||||
[ 2drop ] 3append ;
|
||||
|
||||
: packer ( seq -- quot )
|
||||
length { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ;
|
||||
length dup 4 <=
|
||||
[ { [ f ] [ ] [ 2array ] [ 3array ] [ 4array ] } nth ]
|
||||
[ { } [nsequence] ] if ;
|
||||
|
||||
: unpacker ( seq -- quot )
|
||||
length { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ;
|
||||
length dup 4 <=
|
||||
[ { [ drop ] [ ] [ first2 ] [ first3 ] [ first4 ] } nth ]
|
||||
[ [firstn] ] if ;
|
||||
|
||||
: pack/unpack ( quot effect -- newquot )
|
||||
[ in>> packer ] [ out>> unpacker ] bi surround ;
|
||||
|
|
@ -24,11 +38,7 @@ M: too-many-arguments summary
|
|||
: unpack/pack ( quot effect -- newquot )
|
||||
[ in>> unpacker ] [ out>> packer ] bi surround ;
|
||||
|
||||
: check-memoized ( effect -- )
|
||||
[ in>> ] [ out>> ] bi [ length 4 > ] either? [ too-many-arguments ] when ;
|
||||
|
||||
: make-memoizer ( table quot effect -- quot )
|
||||
[ check-memoized ] keep
|
||||
[ unpack/pack '[ _ _ cache ] ] keep
|
||||
pack/unpack ;
|
||||
|
||||
|
|
@ -62,4 +72,4 @@ M: memoized reset-word
|
|||
: invalidate-memoized ( inputs... word -- )
|
||||
[ stack-effect in>> packer call ] [ "memoize" word-prop delete-at ] bi ;
|
||||
|
||||
\ invalidate-memoized t "no-compile" set-word-prop
|
||||
\ invalidate-memoized t "no-compile" set-word-prop
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
USING: calendar game-input threads ui ui.gadgets.worlds kernel
|
||||
USING: calendar game.input threads ui ui.gadgets.worlds kernel
|
||||
method-chains system ;
|
||||
IN: tools.deploy.test.8
|
||||
|
||||
|
|
@ -18,4 +18,4 @@ AFTER: my-world end-world drop close-game-input ;
|
|||
0 exit
|
||||
] with-ui ;
|
||||
|
||||
MAIN: test-game-input
|
||||
MAIN: test-game-input
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors arrays combinators.smart game-input
|
||||
USING: accessors arrays combinators.smart game.input
|
||||
game.input.scancodes game.loop game.worlds
|
||||
gpu.render gpu.state kernel literals
|
||||
locals math math.constants math.functions math.matrices
|
||||
|
|
|
|||
|
|
@ -10,7 +10,7 @@ const char *vm_executable_path()
|
|||
static Dl_info info = {0};
|
||||
if (!info.dli_fname)
|
||||
dladdr((void *)main, &info);
|
||||
return info.dli_fname;
|
||||
return safe_strdup(info.dli_fname);
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
Loading…
Reference in New Issue