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

Add byte-order slot to image tuple; rename <image> to load-image, add <image> for making images from scratch

db4
Slava Pestov 2009-02-12 04:25:33 -06:00
parent a550c9874c
commit cf9e7d1e75
5 changed files with 14 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,10 +1,9 @@
! Copyright (C) 2007, 2009 Doug Coleman. ! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary combinators fry grouping io io.binary io.encodings.binary io.files
io.files kernel libc macros math math.bitwise math.functions kernel macros math math.bitwise math.functions namespaces sequences
namespaces opengl opengl.gl prettyprint sequences strings strings images endian summary ;
summary ui ui.gadgets.panes images ;
IN: images.bitmap IN: images.bitmap
TUPLE: bitmap-image < image ; TUPLE: bitmap-image < image ;
@ -106,8 +105,9 @@ ERROR: unknown-component-order bitmap ;
{ {
[ [ width>> ] [ height>> ] bi 2array ] [ [ width>> ] [ height>> ] bi 2array ]
[ bitmap>component-order ] [ bitmap>component-order ]
[ drop little-endian ] ! XXX
[ buffer>> ] [ buffer>> ]
} cleave bitmap-image new-image ; } cleave bitmap-image boa ;
M: bitmap-image load-image* ( path bitmap -- bitmap-image ) M: bitmap-image load-image* ( path bitmap -- bitmap-image )
drop load-bitmap >image ; drop load-bitmap >image ;

10
basis/images/images.factor
View File

@ -5,7 +5,9 @@ IN: images
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
TUPLE: image dim component-order bitmap ; TUPLE: image dim component-order byte-order bitmap ;
: <image> ( -- image ) image new ; inline
GENERIC: load-image* ( path tuple -- image ) GENERIC: load-image* ( path tuple -- image )
@ -38,9 +40,3 @@ M: image normalize-scan-line-order ;
: normalize-image ( image -- image ) : normalize-image ( image -- image )
normalize-component-order normalize-component-order
normalize-scan-line-order ; normalize-scan-line-order ;
: new-image ( dim component-order bitmap class -- image )
new
swap >>bitmap
swap >>component-order
swap >>dim ; inline

5
basis/images/loader/loader.factor
View File

@ -15,7 +15,4 @@ ERROR: unknown-image-extension extension ;
} case ; } case ;
: load-image ( path -- image ) : load-image ( path -- image )
dup image-class new load-image* ; dup image-class new load-image* normalize-image ;
: <image> ( path -- image )
load-image normalize-image ;

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

@ -272,8 +272,9 @@ ERROR: unknown-component-order ifd ;
{ {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ] [ ifd-component-order ]
[ drop big-endian ] ! XXX
[ bitmap>> ] [ bitmap>> ]
} cleave tiff-image new-image ; } cleave tiff-image boa ;
: tiff>image ( image -- image ) : tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ; ifds>> [ ifd>image ] map first ;

6
extra/images/viewer/viewer.factor
View File

@ -23,15 +23,15 @@ M: image-gadget draw-gadget* ( gadget -- )
swap >>image ; swap >>image ;
: image-window ( path -- gadget ) : image-window ( path -- gadget )
[ <image> <image-gadget> dup ] [ open-window ] bi ; [ load-image <image-gadget> dup ] [ open-window ] bi ;
GENERIC: image. ( object -- ) GENERIC: image. ( object -- )
: default-image. ( path -- ) : default-image. ( path -- )
<image-gadget> gadget. ; <image-gadget> gadget. ;
M: string image. ( image -- ) <image> default-image. ; M: string image. ( image -- ) load-image default-image. ;
M: pathname image. ( image -- ) <image> default-image. ; M: pathname image. ( image -- ) load-image default-image. ;
M: image image. ( image -- ) default-image. ; M: image image. ( image -- ) default-image. ;