Merge branch 'master' of git://factorcode.org/git/factor

db4
Joe Groff 2009-08-26 14:59:18 -05:00
commit 8f99661f9a
10 changed files with 67 additions and 30 deletions

View File

@ -342,8 +342,8 @@ M: v-header uncompress-bitmap* ( loading-bitmap header -- loading-bitmap' )
ERROR: unsupported-bitmap-file magic ; ERROR: unsupported-bitmap-file magic ;
: load-bitmap ( path -- loading-bitmap ) : load-bitmap ( stream -- loading-bitmap )
binary stream-throws <limited-file-reader> [ [
\ loading-bitmap new \ loading-bitmap new
parse-file-header [ >>file-header ] [ ] bi magic>> { parse-file-header [ >>file-header ] [ ] bi magic>> {
{ "BM" [ { "BM" [
@ -363,7 +363,7 @@ ERROR: unsupported-bitmap-file magic ;
: loading-bitmap>bytes ( loading-bitmap -- byte-array ) : loading-bitmap>bytes ( loading-bitmap -- byte-array )
uncompress-bitmap bitmap>bytes ; uncompress-bitmap bitmap>bytes ;
M: bitmap-image load-image* ( path bitmap-image -- bitmap ) M: bitmap-image stream>image ( stream bitmap-image -- bitmap )
drop load-bitmap drop load-bitmap
[ image new ] dip [ image new ] dip
{ {

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client images.loader images.loader.private kernel ;
IN: images.http
: load-http-image ( path -- image )
[ http-get nip ] [ image-class new ] bi load-image* ;

View File

@ -68,8 +68,6 @@ TUPLE: image dim component-order component-type upside-down? bitmap ;
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ; : has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
GENERIC: load-image* ( path class -- image )
: bytes-per-component ( component-type -- n ) : bytes-per-component ( component-type -- n )
{ {
{ ubyte-components [ 1 ] } { ubyte-components [ 1 ] }

View File

@ -6,7 +6,7 @@ images.processing io io.binary io.encodings.binary io.files
io.streams.byte-array kernel locals math math.bitwise io.streams.byte-array kernel locals math math.bitwise
math.constants math.functions math.matrices math.order math.constants math.functions math.matrices math.order
math.ranges math.vectors memoize multiline namespaces math.ranges math.vectors memoize multiline namespaces
sequences sequences.deep ; sequences sequences.deep images.loader ;
IN: images.jpeg IN: images.jpeg
QUALIFIED-WITH: bitstreams bs QUALIFIED-WITH: bitstreams bs
@ -19,6 +19,9 @@ TUPLE: jpeg-image < image
{ huff-tables initial: { f f f f } } { huff-tables initial: { f f f f } }
{ components } ; { components } ;
"jpg" jpeg-image register-image-class
"jpeg" jpeg-image register-image-class
<PRIVATE <PRIVATE
: <jpeg-image> ( headers bitstream -- image ) : <jpeg-image> ( headers bitstream -- image )
@ -353,17 +356,13 @@ ERROR: not-a-jpeg-image ;
PRIVATE> PRIVATE>
: load-jpeg ( path -- image ) M: jpeg-image stream>image ( stream jpeg-image -- bitmap )
binary [ drop [
parse-marker { SOI } = [ not-a-jpeg-image ] unless parse-marker { SOI } = [ not-a-jpeg-image ] unless
parse-headers parse-headers
contents <jpeg-image> contents <jpeg-image>
] with-file-reader ] with-input-stream
dup jpeg-image [ dup jpeg-image [
baseline-parse baseline-parse
baseline-decompress baseline-decompress
] with-variable ; ] with-variable ;
M: jpeg-image load-image* ( path jpeg-image -- bitmap )
drop load-jpeg ;

View File

@ -1,7 +1,9 @@
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg. ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting unicode.case combinators accessors images USING: accessors assocs byte-arrays combinators images
io.pathnames namespaces assocs ; io.encodings.binary io.pathnames io.streams.byte-array
io.streams.limited kernel namespaces splitting strings
unicode.case ;
IN: images.loader IN: images.loader
ERROR: unknown-image-extension extension ; ERROR: unknown-image-extension extension ;
@ -15,10 +17,26 @@ types [ H{ } clone ] initialize
file-extension >lower types get ?at file-extension >lower types get ?at
[ unknown-image-extension ] unless ; [ unknown-image-extension ] unless ;
: open-image-file ( path -- stream )
binary stream-throws <limited-file-reader> ;
PRIVATE> PRIVATE>
GENERIC# load-image* 1 ( obj class -- image )
GENERIC: stream>image ( stream class -- image )
: register-image-class ( extension class -- ) : register-image-class ( extension class -- )
swap types get set-at ; swap types get set-at ;
: load-image ( path -- image ) : load-image ( path -- image )
dup image-class load-image* ; [ open-image-file ] [ image-class ] bi load-image* ;
M: byte-array load-image*
[ binary <byte-reader> ] dip stream>image ;
M: limited-stream load-image* stream>image ;
M: string load-image* [ open-image-file ] dip stream>image ;
M: pathname load-image* [ open-image-file ] dip stream>image ;

View File

@ -111,14 +111,11 @@ ERROR: unimplemented-color-type image ;
[ unknown-color-type ] [ unknown-color-type ]
} case ; } case ;
: load-png ( path -- image ) M: png-image stream>image
binary stream-throws <limited-file-reader> [ drop [
<loading-png> <loading-png>
read-png-header read-png-header
read-png-chunks read-png-chunks
parse-ihdr-chunk parse-ihdr-chunk
decode-png decode-png
] with-input-stream ; ] with-input-stream ;
M: png-image load-image*
drop load-png ;

View File

@ -517,14 +517,14 @@ ERROR: unknown-component-order ifd ;
: with-tiff-endianness ( loading-tiff quot -- ) : with-tiff-endianness ( loading-tiff quot -- )
[ dup endianness>> ] dip with-endianness ; inline [ dup endianness>> ] dip with-endianness ; inline
: load-tiff-ifds ( path -- loading-tiff ) : load-tiff-ifds ( stream -- loading-tiff )
binary [ [
<loading-tiff> <loading-tiff>
read-header [ read-header [
dup ifd-offset>> read-ifds dup ifd-offset>> read-ifds
process-ifds process-ifds
] with-tiff-endianness ] with-tiff-endianness
] with-file-reader ; ] with-input-stream* ;
: process-chunky-ifd ( ifd -- ) : process-chunky-ifd ( ifd -- )
read-strips read-strips
@ -555,13 +555,18 @@ ERROR: unknown-component-order ifd ;
ifds>> [ process-ifd ] each ; ifds>> [ process-ifd ] each ;
: load-tiff ( path -- loading-tiff ) : load-tiff ( path -- loading-tiff )
[ load-tiff-ifds dup ] keep [ load-tiff-ifds dup ]
binary [ [
[ [ 0 seek-absolute ] dip stream-seek ]
[
[
[ process-tif-ifds ] with-tiff-endianness [ process-tif-ifds ] with-tiff-endianness
] with-file-reader ; ] with-input-stream
] bi
] bi ;
! tiff files can store several images -- we just take the first for now ! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image ) M: tiff-image stream>image ( stream tiff-image -- image )
drop load-tiff tiff>image ; drop load-tiff tiff>image ;
{ "tif" "tiff" } [ tiff-image register-image-class ] each { "tif" "tiff" } [ tiff-image register-image-class ] each

View File

@ -98,5 +98,8 @@ PRIVATE>
M: limited-stream stream-read-until M: limited-stream stream-read-until
swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ; swap BV{ } clone (read-until) [ 2nip B{ } like ] dip ;
M: limited-stream stream-seek
stream>> stream-seek ;
M: limited-stream dispose M: limited-stream dispose
stream>> dispose ; stream>> dispose ;

View File

@ -3,7 +3,7 @@
USING: assocs html.parser kernel math sequences strings ascii USING: assocs html.parser kernel math sequences strings ascii
arrays generalizations shuffle namespaces make arrays generalizations shuffle namespaces make
splitting http accessors io combinators http.client urls splitting http accessors io combinators http.client urls
urls.encoding fry prettyprint sets ; urls.encoding fry prettyprint sets combinators.short-circuit ;
IN: html.parser.analyzer IN: html.parser.analyzer
TUPLE: link attributes clickable ; TUPLE: link attributes clickable ;
@ -103,6 +103,15 @@ TUPLE: link attributes clickable ;
[ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ] [ [ name>> "a" = ] [ attributes>> "href" swap at ] bi and ]
find-between-all ; find-between-all ;
: find-images ( vector -- vector' )
[
{
[ name>> "img" = ]
[ attributes>> "src" swap at ]
} 1&&
] find-all
values [ attributes>> "src" swap at ] map ;
: <link> ( vector -- link ) : <link> ( vector -- link )
[ first attributes>> ] [ first attributes>> ]
[ [ name>> { text "img" } member? ] filter ] bi [ [ name>> { text "img" } member? ] filter ] bi