Merge branch 'master' of git://factorcode.org/git/factor
Slava Pestov
commit
b73716d8cb
|
|
@ -158,3 +158,9 @@ M: msb0-bit-reader peek ( n bs -- bits ) \ be> \ subseq>bits-be (peek) ;
|
|||
writer bytes>> swap push
|
||||
] unless
|
||||
writer bytes>> ;
|
||||
|
||||
:: byte-array-n>seq ( byte-array n -- seq )
|
||||
byte-array length 8 * n / iota
|
||||
byte-array <msb0-bit-reader> '[
|
||||
drop n _ read
|
||||
] { } map-as ;
|
||||
|
|
|
|||
|
|
@ -3,5 +3,5 @@
|
|||
USING: arrays grouping sequences ;
|
||||
IN: compression.run-length
|
||||
|
||||
: run-length-uncompress8 ( byte-array -- byte-array' )
|
||||
: run-length-uncompress ( byte-array -- byte-array' )
|
||||
2 group [ first2 <array> ] map concat ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test constructors calendar kernel accessors
|
||||
combinators.short-circuit ;
|
||||
combinators.short-circuit initializers math ;
|
||||
IN: constructors.tests
|
||||
|
||||
TUPLE: stock-spread stock spread timestamp ;
|
||||
|
|
@ -18,4 +18,42 @@ SYMBOL: AAPL
|
|||
[ spread>> 1234 = ]
|
||||
[ timestamp>> timestamp? ]
|
||||
} 1&&
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
||||
TUPLE: ct1 a ;
|
||||
TUPLE: ct2 < ct1 b ;
|
||||
TUPLE: ct3 < ct2 c ;
|
||||
TUPLE: ct4 < ct3 d ;
|
||||
|
||||
CONSTRUCTOR: ct1 ( a -- obj )
|
||||
[ 1 + ] change-a ;
|
||||
|
||||
CONSTRUCTOR: ct2 ( a b -- obj )
|
||||
initialize-ct1
|
||||
[ 1 + ] change-a ;
|
||||
|
||||
CONSTRUCTOR: ct3 ( a b c -- obj )
|
||||
initialize-ct1
|
||||
[ 1 + ] change-a ;
|
||||
|
||||
CONSTRUCTOR: ct4 ( a b c d -- obj )
|
||||
initialize-ct3
|
||||
[ 1 + ] change-a ;
|
||||
|
||||
[ 1001 ] [ 1000 <ct1> a>> ] unit-test
|
||||
[ 2 ] [ 0 0 <ct2> a>> ] unit-test
|
||||
[ 2 ] [ 0 0 0 <ct3> a>> ] unit-test
|
||||
[ 3 ] [ 0 0 0 0 <ct4> a>> ] unit-test
|
||||
|
||||
|
||||
TUPLE: rofl a b c ;
|
||||
CONSTRUCTOR: rofl ( b c a -- obj ) ;
|
||||
|
||||
[ T{ rofl { a 3 } { b 1 } { c 2 } } ] [ 1 2 3 <rofl> ] unit-test
|
||||
|
||||
|
||||
TUPLE: default { a integer initial: 0 } ;
|
||||
|
||||
CONSTRUCTOR: default ( -- obj ) ;
|
||||
|
||||
[ 0 ] [ <default> a>> ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,23 +1,54 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: slots kernel sequences fry accessors parser lexer words
|
||||
effects.parser macros ;
|
||||
USING: accessors assocs classes.tuple effects.parser fry
|
||||
generalizations generic.standard kernel lexer locals macros
|
||||
parser sequences slots vocabs words ;
|
||||
IN: constructors
|
||||
|
||||
! An experiment
|
||||
|
||||
MACRO: set-slots ( slots -- quot )
|
||||
<reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
|
||||
: initializer-name ( class -- word )
|
||||
name>> "initialize-" prepend ;
|
||||
|
||||
: construct ( ... class slots -- instance )
|
||||
[ new ] dip set-slots ; inline
|
||||
: lookup-initializer ( class -- word/f )
|
||||
initializer-name "initializers" lookup ;
|
||||
|
||||
: define-constructor ( name class effect body -- )
|
||||
[ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
|
||||
define-declared ;
|
||||
: initializer-word ( class -- word )
|
||||
initializer-name
|
||||
"initializers" create-vocab create
|
||||
[ t "initializer" set-word-prop ] [ ] bi ;
|
||||
|
||||
: define-initializer-generic ( name -- )
|
||||
initializer-word (( object -- object )) define-simple-generic ;
|
||||
|
||||
: define-initializer ( class def -- )
|
||||
[ drop define-initializer-generic ]
|
||||
[ [ dup lookup-initializer ] dip H{ } clone define-typecheck ] 2bi ;
|
||||
|
||||
MACRO:: slots>constructor ( class slots -- quot )
|
||||
class all-slots [ [ name>> ] [ initial>> ] bi ] { } map>assoc :> params
|
||||
slots length
|
||||
params length
|
||||
'[
|
||||
_ narray slots swap zip
|
||||
params swap assoc-union
|
||||
values _ firstn class boa
|
||||
] ;
|
||||
|
||||
:: define-constructor ( constructor-word class effect def -- )
|
||||
constructor-word
|
||||
class def define-initializer
|
||||
class effect in>> '[ _ _ slots>constructor ]
|
||||
class lookup-initializer
|
||||
'[ @ _ execute( obj -- obj ) ] effect define-declared ;
|
||||
|
||||
: scan-constructor ( -- class word )
|
||||
scan-word [ name>> "<" ">" surround create-in ] keep ;
|
||||
|
||||
SYNTAX: CONSTRUCTOR:
|
||||
scan-word [ name>> "<" ">" surround create-in ] keep
|
||||
scan-constructor
|
||||
complete-effect
|
||||
parse-definition
|
||||
define-constructor ;
|
||||
define-constructor ;
|
||||
|
||||
"initializers" create-vocab drop
|
||||
|
|
|
|||
|
|
@ -2,77 +2,146 @@
|
|||
! 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 kernel
|
||||
locals macros math math.bitwise math.functions namespaces
|
||||
sequences strings summary ;
|
||||
images.loader io io.binary io.encodings.binary io.files
|
||||
io.streams.limited kernel locals macros math math.bitwise
|
||||
math.functions namespaces sequences specialized-arrays.uint
|
||||
specialized-arrays.ushort strings summary io.encodings.8-bit
|
||||
io.encodings.string ;
|
||||
QUALIFIED-WITH: bitstreams b
|
||||
IN: images.bitmap
|
||||
|
||||
: assert-sequence= ( a b -- )
|
||||
2dup sequence= [ 2drop ] [ assert ] if ;
|
||||
|
||||
: read2 ( -- n ) 2 read le> ;
|
||||
: read4 ( -- n ) 4 read le> ;
|
||||
: write2 ( n -- ) 2 >le write ;
|
||||
: write4 ( n -- ) 4 >le write ;
|
||||
|
||||
TUPLE: bitmap-image < image ;
|
||||
|
||||
! Used to construct the final bitmap-image
|
||||
SINGLETON: bitmap-image
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
TUPLE: loading-bitmap
|
||||
size reserved offset header-length width
|
||||
magic size reserved1 reserved2 offset header-length width
|
||||
height planes bit-count compression size-image
|
||||
x-pels y-pels color-used color-important color-palette color-index
|
||||
uncompressed-bytes ;
|
||||
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 ;
|
||||
|
||||
ERROR: bitmap-magic magic ;
|
||||
|
||||
M: bitmap-magic summary
|
||||
drop "First two bytes of bitmap stream must be 'BM'" ;
|
||||
! endpoints-triple is ciexyzX/Y/Z, 3x fixed-point-2.30 aka 3x uint
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: 8bit>buffer ( bitmap -- array )
|
||||
[ color-palette>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
||||
[ color-index>> >array ] bi [ swap nth ] with map concat ;
|
||||
: 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 ;
|
||||
|
||||
: reverse-lines ( byte-array width -- byte-array )
|
||||
<sliced-groups> <reversed> concat ; inline
|
||||
: uncompress-bitfield ( seq masks -- bytes' )
|
||||
'[
|
||||
_ [
|
||||
[ bitand ] [ bit-count ] [ log2 ] tri - shift
|
||||
] with map
|
||||
] { } map-as B{ } concat-as ;
|
||||
|
||||
: bitmap>bytes ( loading-bitmap -- array )
|
||||
: bitmap>bytes ( loading-bitmap -- byte-array )
|
||||
dup bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
{ 24 [ [ color-index>> ] [ width>> 3 * ] bi reverse-lines ] }
|
||||
{ 8 [ [ 8bit>buffer ] [ width>> 3 * ] bi reverse-lines ] }
|
||||
{ 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-uncompress8 ] change-color-index ] }
|
||||
{ 2 [ "run-length encoding 4" unsupported-bitmap-compression ] }
|
||||
{ 3 [ "bitfields" unsupported-bitmap-compression ] }
|
||||
{ 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 ;
|
||||
uncompress-bitmap
|
||||
bitmap>bytes ;
|
||||
|
||||
: parse-file-header ( loading-bitmap -- loading-bitmap )
|
||||
2 read "BM" assert-sequence=
|
||||
2 read latin1 decode >>magic
|
||||
read4 >>size
|
||||
read4 >>reserved
|
||||
read2 >>reserved1
|
||||
read2 >>reserved2
|
||||
read4 >>offset ;
|
||||
|
||||
: parse-bitmap-header ( loading-bitmap -- loading-bitmap )
|
||||
read4 >>header-length
|
||||
: read-v3-header ( loading-bitmap -- loading-bitmap )
|
||||
read4 >>width
|
||||
read4 32 >signed >>height
|
||||
read2 >>planes
|
||||
|
|
@ -84,6 +153,50 @@ ERROR: unsupported-bitmap-compression compression ;
|
|||
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 - ;
|
||||
|
||||
|
|
@ -98,56 +211,54 @@ ERROR: unsupported-bitmap-compression compression ;
|
|||
: image-size ( loading-bitmap -- n )
|
||||
[ [ width>> ] [ height>> ] bi * ] [ bit-count>> 8 /i ] bi * abs ;
|
||||
|
||||
: bitmap-padding ( width -- n )
|
||||
3 * 4 mod 4 swap - 4 mod ; inline
|
||||
|
||||
:: fixup-color-index ( loading-bitmap -- loading-bitmap )
|
||||
loading-bitmap width>> :> width
|
||||
width 3 * :> width*3
|
||||
loading-bitmap width>> bitmap-padding :> padding
|
||||
loading-bitmap [ color-index>> length ] [ height>> abs ] bi /i :> stride
|
||||
loading-bitmap
|
||||
padding 0 > [
|
||||
[
|
||||
stride <sliced-groups>
|
||||
[ width*3 head-slice ] map concat
|
||||
] change-color-index
|
||||
] when ;
|
||||
|
||||
: parse-bitmap ( loading-bitmap -- loading-bitmap )
|
||||
dup color-palette-length read >>color-palette
|
||||
dup color-index-length read >>color-index
|
||||
fixup-color-index ;
|
||||
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 [
|
||||
binary stream-throws <limited-file-reader> [
|
||||
loading-bitmap new
|
||||
parse-file-header parse-bitmap-header parse-bitmap
|
||||
] with-file-reader ;
|
||||
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 [ BGRA ] }
|
||||
{ 32 [ BGR ] }
|
||||
{ 24 [ BGR ] }
|
||||
{ 16 [ BGR ] }
|
||||
{ 8 [ BGR ] }
|
||||
{ 4 [ BGR ] }
|
||||
{ 1 [ BGR ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: loading-bitmap>bitmap-image ( bitmap-image loading-bitmap -- bitmap-image )
|
||||
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 < [ t >>upside-down? ] when ]
|
||||
[ height>> 0 < not >>upside-down? ]
|
||||
[ compression>> 3 = [ t >>upside-down? ] when ]
|
||||
[ bitmap>component-order >>component-order ]
|
||||
} cleave ;
|
||||
|
||||
M: bitmap-image load-image* ( path loading-bitmap -- bitmap )
|
||||
swap load-bitmap loading-bitmap>bitmap-image ;
|
||||
|
||||
"bmp" bitmap-image register-image-class
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: bitmap>color-index ( bitmap -- byte-array )
|
||||
|
|
@ -165,6 +276,9 @@ PRIVATE>
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -34,14 +34,7 @@ TUPLE: image dim component-order upside-down? bitmap ;
|
|||
|
||||
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: make-image ( bitmap -- image )
|
||||
! bitmap is a sequence of sequences of pixels which are RGBA
|
||||
<image>
|
||||
over [ first length ] [ length ] bi 2array >>dim
|
||||
RGBA >>component-order
|
||||
swap concat concat B{ } like >>bitmap ;
|
||||
GENERIC: load-image* ( path class -- image )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
|
|||
|
|
@ -7,11 +7,13 @@ 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
|
||||
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
SINGLETON: jpeg-image
|
||||
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
|
||||
|
||||
TUPLE: jpeg-image < image
|
||||
TUPLE: loading-jpeg < image
|
||||
{ headers }
|
||||
{ bitstream }
|
||||
{ color-info initial: { f f f f } }
|
||||
|
|
@ -21,7 +23,7 @@ TUPLE: jpeg-image < image
|
|||
|
||||
<PRIVATE
|
||||
|
||||
CONSTRUCTOR: jpeg-image ( headers bitstream -- image ) ;
|
||||
CONSTRUCTOR: loading-jpeg ( headers bitstream -- image ) ;
|
||||
|
||||
SINGLETONS: SOF DHT DAC RST SOI EOI SOS DQT DNL DRI DHP EXP
|
||||
APP JPG COM TEM RES ;
|
||||
|
|
@ -63,7 +65,7 @@ TUPLE: jpeg-color-info
|
|||
|
||||
CONSTRUCTOR: jpeg-color-info ( h v quant-table -- jpeg-color-info ) ;
|
||||
|
||||
: jpeg> ( -- jpeg-image ) jpeg-image get ;
|
||||
: jpeg> ( -- jpeg-image ) loading-jpeg get ;
|
||||
|
||||
: apply-diff ( dc color -- dc' )
|
||||
[ diff>> + dup ] [ (>>diff) ] bi ;
|
||||
|
|
@ -291,9 +293,9 @@ PRIVATE>
|
|||
binary [
|
||||
parse-marker { SOI } assert=
|
||||
parse-headers
|
||||
contents <jpeg-image>
|
||||
contents <loading-jpeg>
|
||||
] with-file-reader
|
||||
dup jpeg-image [
|
||||
dup loading-jpeg [
|
||||
baseline-parse
|
||||
baseline-decompress
|
||||
jpeg> bitmap>> 3 <groups> [ color-transform ] change-each
|
||||
|
|
@ -302,5 +304,3 @@ PRIVATE>
|
|||
|
||||
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
|
||||
drop load-jpeg ;
|
||||
|
||||
{ "jpg" "jpeg" } [ jpeg-image register-image-class ] each
|
||||
|
|
|
|||
|
|
@ -7,16 +7,18 @@ IN: images.loader
|
|||
ERROR: unknown-image-extension extension ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: types
|
||||
types [ H{ } clone ] initialize
|
||||
|
||||
: image-class ( path -- class )
|
||||
file-extension >lower types get ?at
|
||||
[ unknown-image-extension ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: register-image-class ( extension class -- )
|
||||
swap types get set-at ;
|
||||
|
||||
: load-image ( path -- image )
|
||||
dup image-class new load-image* ;
|
||||
dup image-class load-image* ;
|
||||
|
|
|
|||
|
|
@ -7,12 +7,15 @@ checksums checksums.crc32 compression.inflate grouping byte-arrays
|
|||
images.loader ;
|
||||
IN: images.png
|
||||
|
||||
TUPLE: png-image < image chunks
|
||||
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 ;
|
||||
|
||||
CONSTRUCTOR: png-image ( -- image )
|
||||
V{ } clone >>chunks ;
|
||||
CONSTRUCTOR: loading-png ( -- image )
|
||||
V{ } clone >>chunks ;
|
||||
|
||||
TUPLE: png-chunk length type data ;
|
||||
|
||||
|
|
@ -104,9 +107,8 @@ ERROR: unimplemented-color-type image ;
|
|||
} case ;
|
||||
|
||||
: load-png ( path -- image )
|
||||
[ binary <file-reader> ] [ file-info size>> ] bi
|
||||
stream-throws <limited-stream> [
|
||||
<png-image>
|
||||
binary stream-throws <limited-file-reader> [
|
||||
<loading-png>
|
||||
read-png-header
|
||||
read-png-chunks
|
||||
parse-ihdr-chunk
|
||||
|
|
@ -116,5 +118,3 @@ ERROR: unimplemented-color-type image ;
|
|||
|
||||
M: png-image load-image*
|
||||
drop load-png ;
|
||||
|
||||
"png" png-image register-image-class
|
||||
|
|
|
|||
|
|
@ -9,10 +9,10 @@ strings math.vectors specialized-arrays.float locals
|
|||
images.loader ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
SINGLETON: tiff-image
|
||||
|
||||
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
|
||||
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
|
||||
TUPLE: loading-tiff endianness the-answer ifd-offset ifds ;
|
||||
CONSTRUCTOR: loading-tiff ( -- tiff ) V{ } clone >>ifds ;
|
||||
|
||||
TUPLE: ifd count ifd-entries next
|
||||
processed-tags strips bitmap ;
|
||||
|
|
@ -410,7 +410,7 @@ ERROR: bad-small-ifd-type n ;
|
|||
[ nip unhandled-ifd-entry swap ]
|
||||
} case ;
|
||||
|
||||
: process-ifds ( parsed-tiff -- parsed-tiff )
|
||||
: process-ifds ( loading-tiff -- loading-tiff )
|
||||
[
|
||||
[
|
||||
dup ifd-entries>>
|
||||
|
|
@ -483,18 +483,6 @@ ERROR: unknown-component-order ifd ;
|
|||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: normalize-alpha-data ( seq -- byte-array )
|
||||
B{ } like dup
|
||||
byte-array>float-array
|
||||
4 <sliced-groups>
|
||||
[
|
||||
dup fourth dup 0 = [
|
||||
2drop
|
||||
] [
|
||||
[ 3 head-slice ] dip '[ _ / ] change-each
|
||||
] if
|
||||
] each ;
|
||||
|
||||
: handle-alpha-data ( ifd -- ifd )
|
||||
dup extra-samples find-tag {
|
||||
{ extra-samples-associated-alpha-data [ ] }
|
||||
|
|
@ -508,17 +496,17 @@ ERROR: unknown-component-order ifd ;
|
|||
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
|
||||
[ ifd-component-order f ]
|
||||
[ bitmap>> ]
|
||||
} cleave tiff-image boa ;
|
||||
} cleave image boa ;
|
||||
|
||||
: tiff>image ( image -- image )
|
||||
ifds>> [ ifd>image ] map first ;
|
||||
|
||||
: with-tiff-endianness ( parsed-tiff quot -- )
|
||||
: with-tiff-endianness ( loading-tiff quot -- )
|
||||
[ dup endianness>> ] dip with-endianness ; inline
|
||||
|
||||
: load-tiff-ifds ( path -- parsed-tiff )
|
||||
: load-tiff-ifds ( path -- loading-tiff )
|
||||
binary [
|
||||
<parsed-tiff>
|
||||
<loading-tiff>
|
||||
read-header [
|
||||
dup ifd-offset>> read-ifds
|
||||
process-ifds
|
||||
|
|
@ -550,10 +538,10 @@ ERROR: unknown-component-order ifd ;
|
|||
drop "no planar configuration" throw
|
||||
] if ;
|
||||
|
||||
: process-tif-ifds ( parsed-tiff -- )
|
||||
: process-tif-ifds ( loading-tiff -- )
|
||||
ifds>> [ process-ifd ] each ;
|
||||
|
||||
: load-tiff ( path -- parsed-tiff )
|
||||
: load-tiff ( path -- loading-tiff )
|
||||
[ load-tiff-ifds dup ] keep
|
||||
binary [
|
||||
[ process-tif-ifds ] with-tiff-endianness
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math io io.encodings destructors accessors
|
||||
sequences namespaces byte-vectors fry combinators ;
|
||||
USING: accessors byte-vectors combinators destructors fry io
|
||||
io.encodings io.files io.files.info kernel math namespaces
|
||||
sequences ;
|
||||
IN: io.streams.limited
|
||||
|
||||
TUPLE: limited-stream stream count limit mode stack ;
|
||||
|
|
@ -16,6 +17,12 @@ SINGLETONS: stream-throws stream-eofs ;
|
|||
swap >>stream
|
||||
0 >>count ;
|
||||
|
||||
: <limited-file-reader> ( path encoding mode -- stream' )
|
||||
[
|
||||
[ <file-reader> ]
|
||||
[ drop file-info size>> ] 2bi
|
||||
] dip <limited-stream> ;
|
||||
|
||||
GENERIC# limit 2 ( stream limit mode -- stream' )
|
||||
|
||||
M: decoder limit ( stream limit mode -- stream' )
|
||||
|
|
|
|||
|
|
@ -1872,7 +1872,7 @@ GL-FUNCTION: void glUniform4uivEXT { } ( GLint location, GLsizei count, GLuint*
|
|||
GL-FUNCTION: void glGetUniformuivEXT { } ( GLuint program, GLint location, GLuint* params ) ;
|
||||
|
||||
GL-FUNCTION: void glBindFragDataLocationEXT { } ( GLuint program, GLuint colorNumber, GLchar* name ) ;
|
||||
GL-FUNCTION: GLint GetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
|
||||
GL-FUNCTION: GLint glGetFragDataLocationEXT { } ( GLuint program, GLchar* name ) ;
|
||||
|
||||
CONSTANT: GL_VERTEX_ATTRIB_ARRAY_INTEGER_EXT HEX: 88FD
|
||||
CONSTANT: GL_SAMPLER_1D_ARRAY_EXT HEX: 8DC0
|
||||
|
|
|
|||
|
|
@ -217,4 +217,3 @@ M: world check-world-pixel-format
|
|||
: with-world-pixel-format ( world quot -- )
|
||||
[ dup dup world-pixel-format-attributes <pixel-format> ]
|
||||
dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -206,8 +206,11 @@ PRIVATE>
|
|||
: open-world-window ( world -- )
|
||||
dup pref-dim >>dim dup relayout graft ;
|
||||
|
||||
: open-window* ( gadget title/attributes -- window )
|
||||
?attributes <world> [ open-world-window ] keep ;
|
||||
|
||||
: open-window ( gadget title/attributes -- )
|
||||
?attributes <world> open-world-window ;
|
||||
open-window* drop ;
|
||||
|
||||
: set-fullscreen ( gadget ? -- )
|
||||
[ find-world ] dip (set-fullscreen) ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: accessors calendar destructors kernel math math.order namespaces
|
||||
system threads ;
|
||||
USING: accessors calendar continuations destructors kernel math
|
||||
math.order namespaces system threads ui ui.gadgets.worlds ;
|
||||
IN: game-loop
|
||||
|
||||
TUPLE: game-loop
|
||||
|
|
@ -27,6 +27,16 @@ SYMBOL: game-loop
|
|||
|
||||
CONSTANT: MAX-FRAMES-TO-SKIP 5
|
||||
|
||||
DEFER: stop-loop
|
||||
|
||||
TUPLE: game-loop-error game-loop error ;
|
||||
|
||||
: ?ui-error ( error -- )
|
||||
ui-running? [ ui-error ] [ rethrow ] if ;
|
||||
|
||||
: game-loop-error ( game-loop error -- )
|
||||
[ drop stop-loop ] [ \ game-loop-error boa ?ui-error ] 2bi ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: redraw ( loop -- )
|
||||
|
|
@ -54,7 +64,9 @@ CONSTANT: MAX-FRAMES-TO-SKIP 5
|
|||
[ drop ] if ;
|
||||
|
||||
: run-loop ( loop -- )
|
||||
dup game-loop [ (run-loop) ] with-variable ;
|
||||
dup game-loop
|
||||
[ [ (run-loop) ] [ game-loop-error ] recover ]
|
||||
with-variable ;
|
||||
|
||||
: benchmark-millis ( loop -- millis )
|
||||
millis swap benchmark-time>> - ;
|
||||
|
|
@ -91,3 +103,6 @@ PRIVATE>
|
|||
M: game-loop dispose
|
||||
stop-loop ;
|
||||
|
||||
USING: vocabs vocabs.loader ;
|
||||
|
||||
"prettyprint" vocab [ "game-loop.prettyprint" require ] when
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
! (c)2009 Joe Groff bsd license
|
||||
USING: accessors debugger game-loop io ;
|
||||
IN: game-loop.prettyprint
|
||||
|
||||
M: game-loop-error error.
|
||||
"An error occurred inside a game loop." print
|
||||
"The game loop has been stopped to prevent runaway errors." print
|
||||
"The error was:" print nl
|
||||
error>> error. ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Kobi Lurie, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors fry images.loader images.normalization
|
||||
USING: accessors fry images.loader
|
||||
images.processing.rotation kernel literals math sequences
|
||||
tools.test images.processing.rotation.private ;
|
||||
IN: images.processing.rotation.tests
|
||||
|
|
@ -24,13 +24,13 @@ IN: images.processing.rotation.tests
|
|||
CONSTANT: pasted-image
|
||||
$[
|
||||
"vocab:images/processing/rotation/test-bitmaps/PastedImage.bmp"
|
||||
load-image normalize-image clone-image
|
||||
load-image clone-image
|
||||
]
|
||||
|
||||
CONSTANT: pasted-image90
|
||||
$[
|
||||
"vocab:images/processing/rotation/test-bitmaps/PastedImage90.bmp"
|
||||
load-image normalize-image clone-image
|
||||
load-image clone-image
|
||||
]
|
||||
|
||||
CONSTANT: lake-image
|
||||
|
|
@ -55,7 +55,7 @@ CONSTANT: lake-image
|
|||
"vocab:images/processing/rotation/test-bitmaps/small.bmp"
|
||||
load-image 90 rotate
|
||||
"vocab:images/processing/rotation/test-bitmaps/small-rotated.bmp"
|
||||
load-image normalize-image =
|
||||
load-image =
|
||||
] unit-test
|
||||
|
||||
[ t ] [
|
||||
|
|
|
|||
|
|
@ -126,7 +126,8 @@ M: chat-server handle-client-disconnect
|
|||
] "" append-outputs-as send-everyone ;
|
||||
|
||||
M: chat-server handle-already-logged-in
|
||||
username username-taken-string send-line ;
|
||||
username username-taken-string send-line
|
||||
t client (>>quit?) ;
|
||||
|
||||
M: chat-server handle-managed-client*
|
||||
readln dup f = [ t client (>>quit?) ] when
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ TUPLE: managed-server < threaded-server clients ;
|
|||
|
||||
TUPLE: managed-client
|
||||
input-stream output-stream local-address remote-address
|
||||
username object quit? ;
|
||||
username object quit? logged-in? ;
|
||||
|
||||
HOOK: handle-login threaded-server ( -- username )
|
||||
HOOK: handle-managed-client* managed-server ( -- )
|
||||
|
|
@ -62,26 +62,39 @@ PRIVATE>
|
|||
local-address get >>local-address
|
||||
remote-address get >>remote-address ;
|
||||
|
||||
: check-logged-in ( username -- username )
|
||||
dup clients key? [ handle-already-logged-in ] when ;
|
||||
: maybe-login-client ( -- )
|
||||
username clients key? [
|
||||
handle-already-logged-in
|
||||
] [
|
||||
t client (>>logged-in?)
|
||||
client username clients set-at
|
||||
] if ;
|
||||
|
||||
: add-managed-client ( -- )
|
||||
client username check-logged-in clients set-at ;
|
||||
: when-logged-in ( quot -- )
|
||||
client logged-in?>> [ call ] [ drop ] if ; inline
|
||||
|
||||
: delete-managed-client ( -- )
|
||||
username server clients>> delete-at ;
|
||||
[ username server clients>> delete-at ] when-logged-in ;
|
||||
|
||||
: handle-managed-client ( -- )
|
||||
handle-login <managed-client> managed-client set
|
||||
add-managed-client handle-client-join
|
||||
[ handle-managed-client* client quit?>> not ] loop ;
|
||||
maybe-login-client [
|
||||
handle-client-join
|
||||
[ handle-managed-client* client quit?>> not ] loop
|
||||
] when-logged-in ;
|
||||
|
||||
: cleanup-client ( -- )
|
||||
[
|
||||
delete-managed-client
|
||||
handle-client-disconnect
|
||||
] when-logged-in ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: managed-server handle-client*
|
||||
managed-server set
|
||||
[ handle-managed-client ]
|
||||
[ delete-managed-client handle-client-disconnect ]
|
||||
[ cleanup-client ]
|
||||
[ ] cleanup ;
|
||||
|
||||
: new-managed-server ( port name encoding class -- server )
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
USING: accessors kernel ui ui.backend ui.gadgets
|
||||
ui.gadgets.worlds ui.pixel-formats ;
|
||||
IN: ui.gadgets.worlds.null
|
||||
|
||||
TUPLE: null-world < world ;
|
||||
M: null-world begin-world drop ;
|
||||
M: null-world end-world drop ;
|
||||
M: null-world draw-world* drop ;
|
||||
M: null-world resize-world drop ;
|
||||
M: null-world pref-dim* drop { 512 512 } ;
|
||||
|
||||
: null-window ( title -- world )
|
||||
<world-attributes>
|
||||
swap >>title
|
||||
null-world >>world-class
|
||||
{
|
||||
windowed
|
||||
double-buffered
|
||||
backing-store
|
||||
T{ depth-bits f 24 }
|
||||
} >>pixel-format-attributes
|
||||
f swap open-window* ;
|
||||
|
||||
: into-window ( world quot -- world )
|
||||
[ dup handle>> ] dip with-gl-context ; inline
|
||||
|
||||
|
||||
Loading…
Reference in New Issue