Merge branch 'master' of git://github.com/mrjbq7/factor
commit
d2b20ddb35
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators io kernel math namespaces
|
||||
sequences vectors ;
|
||||
USING: accessors combinators io kernel math math.order
|
||||
namespaces sequences vectors ;
|
||||
QUALIFIED-WITH: bitstreams bs
|
||||
IN: compression.lzw
|
||||
|
||||
|
@ -62,8 +62,13 @@ GENERIC: code-space-full? ( lzw -- ? )
|
|||
M: tiff-lzw code-space-full? size-and-limit 1 - = ;
|
||||
M: gif-lzw code-space-full? size-and-limit = ;
|
||||
|
||||
GENERIC: increment-code-size ( lzw -- lzw )
|
||||
|
||||
M: lzw increment-code-size [ 1 + ] change-code-size ;
|
||||
M: gif-lzw increment-code-size [ 1 + 12 min ] change-code-size ;
|
||||
|
||||
: maybe-increment-code-size ( lzw -- lzw )
|
||||
dup code-space-full? [ [ 1 + ] change-code-size ] when ;
|
||||
dup code-space-full? [ increment-code-size ] when ;
|
||||
|
||||
: add-to-table ( seq lzw -- )
|
||||
[ table>> push ]
|
||||
|
@ -108,7 +113,7 @@ DEFER: lzw-uncompress-char
|
|||
[ output>> push-all ] [ add-to-table ] 2bi
|
||||
] [ code>old-code ] bi
|
||||
] if ;
|
||||
|
||||
|
||||
: lzw-uncompress-char ( lzw -- )
|
||||
[ >>code handle-uncompress-code lzw-uncompress-char ]
|
||||
lzw-process-next-code ;
|
||||
|
|
|
@ -13,9 +13,11 @@ ERROR: unknown-image-extension extension ;
|
|||
SYMBOL: types
|
||||
types [ H{ } clone ] initialize
|
||||
|
||||
: (image-class) ( type -- class )
|
||||
>lower types get ?at [ unknown-image-extension ] unless ;
|
||||
|
||||
: image-class ( path -- class )
|
||||
file-extension >lower types get ?at
|
||||
[ unknown-image-extension ] unless ;
|
||||
file-extension (image-class) ;
|
||||
|
||||
: open-image-file ( path -- stream )
|
||||
binary <limited-file-reader> ;
|
||||
|
|
|
@ -109,7 +109,7 @@ M: sequence null?
|
|||
M: sequence cardinality
|
||||
length ;
|
||||
|
||||
: combine ( sets -- set )
|
||||
: combine ( sets -- set/f )
|
||||
[ f ]
|
||||
[ [ [ members ] map concat ] [ first ] bi set-like ]
|
||||
if-empty ;
|
||||
|
|
|
@ -140,7 +140,8 @@ ERROR: unimplemented message ;
|
|||
: sort? ( image -- ? ) flags>> 5 bit? ; inline
|
||||
: color-table-size ( image -- ? ) flags>> 3 bits 1 + 2^ 3 * ; inline
|
||||
: transparency? ( image -- ? )
|
||||
graphic-control-extensions>> first flags>> 0 bit? ; inline
|
||||
graphic-control-extensions>>
|
||||
[ f ] [ first flags>> 0 bit? ] if-empty ; inline
|
||||
|
||||
: color-resolution ( image -- ? ) flags>> -4 shift 3 bits ; inline
|
||||
|
||||
|
|
|
@ -1,11 +1,21 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: http.client images.loader images.loader.private kernel
|
||||
images.viewer ;
|
||||
USING: accessors assocs http.client images.loader
|
||||
images.loader.private images.viewer io.pathnames kernel
|
||||
namespaces sequences ;
|
||||
IN: images.http
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: content-type ( response -- type/f )
|
||||
content-type>> dup "image/" head?
|
||||
[ 6 tail ] [ drop f ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: load-http-image ( path -- image )
|
||||
[ http-get nip ] [ image-class ] bi load-image* ;
|
||||
[ http-get swap content-type ] [ file-extension ] bi or
|
||||
(image-class) load-image* ;
|
||||
|
||||
: http-image. ( path -- )
|
||||
load-http-image image. ;
|
||||
|
|
Loading…
Reference in New Issue