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

2009-02-09 22:39:21 -06:00 · 2009-02-09 22:39:21 -06:00 · b75f6f88da
parent 0ba4a08ea9 dd9ceba26a
commit b75f6f88da
44 changed files with 286 additions and 189 deletions
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;

 M: array stack-size drop "void*" stack-size ;

-M: array c-type-boxer-quot drop f ;
+M: array c-type-boxer-quot drop [ ] ;

 M: array c-type-unboxer-quot drop [ >c-ptr ] ;

--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces make parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects continuations fry call ;
+accessors combinators effects continuations fry call classes ;
 IN: alien.c-types

 DEFER: <int>
@ -13,18 +13,20 @@ DEFER: *char
 : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable

 TUPLE: c-type
-class
-boxer boxer-quot unboxer unboxer-quot
-getter setter
-reg-class size align stack-align? ;
-
-: new-c-type ( class -- type )
-    new
-        int-regs >>reg-class
-        object >>class ; inline
+{ class class initial: object }
+boxer
+{ boxer-quot callable }
+unboxer
+{ unboxer-quot callable }
+{ getter callable }
+{ setter callable }
+{ reg-class initial: int-regs }
+size
+align
+stack-align? ;

 : <c-type> ( -- type )
-    \ c-type new-c-type ;
+    \ c-type new ;

 SYMBOL: c-types

@ -224,7 +226,7 @@ M: f byte-length drop 0 ;
 TUPLE: long-long-type < c-type ;

 : <long-long-type> ( -- type )
-    long-long-type new-c-type ;
+    long-long-type new ;

 M: long-long-type unbox-parameter ( n type -- )
    c-type-unboxer %unbox-long-long ;
--- a/basis/alien/fortran/fortran-docs.factor
+++ b/basis/alien/fortran/fortran-docs.factor
@ -44,7 +44,7 @@ HELP: fortran-invoke
 ;

 ARTICLE: "alien.fortran" "Fortran FFI"
-"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code shared libraries written in Fortran."
+"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
 { $subsection "alien.fortran-types" }
 { $subsection POSTPONE: LIBRARY: }
 { $subsection POSTPONE: FUNCTION: }
--- a/basis/alien/fortran/tags.txt
+++ b/basis/alien/fortran/tags.txt
@ -1,2 +1,3 @@
 fortran
 ffi
+unportable
--- a/basis/alien/structs/structs-tests.factor
+++ b/basis/alien/structs/structs-tests.factor
@ -42,3 +42,18 @@ C-UNION: barx
    [ ] [ \ foox-x "help" get execute ] unit-test
    [ ] [ \ set-foox-x "help" get execute ] unit-test
 ] when
+
+C-STRUCT: nested
+    { "int" "x" } ;
+
+C-STRUCT: nested-2
+    { "nested" "y" } ;
+
+[ 4 ] [
+    "nested-2" <c-object>
+    "nested" <c-object>
+    4 over set-nested-x
+    over set-nested-2-y
+    nested-2-y
+    nested-x
+] unit-test
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@ -2,10 +2,18 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs generic hashtables kernel kernel.private
 math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture math.order ;
+alien.c-types alien.structs.fields cpu.architecture math.order
+quotations ;
 IN: alien.structs

-TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
+TUPLE: struct-type
+size
+align
+fields
+{ boxer-quot callable }
+{ unboxer-quot callable }
+{ getter callable }
+{ setter callable } ;

 M: struct-type heap-size size>> ;

--- a/basis/io/launcher/windows/nt/nt-tests.factor
+++ b/basis/io/launcher/windows/nt/nt-tests.factor
@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests
    "out.txt" temp-file ascii file-lines first
 ] unit-test

-[ ] [
+[ "( scratchpad ) " ] [
    <process>
        console-vm "-run=listener" 2array >>command
        +closed+ >>stdin
-    try-process
+        +stdout+ >>stderr
+    ascii [ input-stream get contents ] with-process-reader
 ] unit-test

 : launcher-test-path ( -- str )
@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests
   
    "append-test" temp-file ascii file-contents
 ] unit-test
+
+
--- a/basis/math/blas/ffi/tags.txt
+++ b/basis/math/blas/ffi/tags.txt
@ -1,3 +1,4 @@
 math
 bindings
 fortran
+unportable
--- a/basis/math/blas/matrices/tags.txt
+++ b/basis/math/blas/matrices/tags.txt
@ -1,2 +1,3 @@
 math
 bindings
+unportable
--- a/basis/math/blas/vectors/tags.txt
+++ b/basis/math/blas/vectors/tags.txt
@ -1 +1,3 @@
 math
+bindings
+unportable
--- a/basis/specialized-arrays/specialized-arrays-docs.factor
+++ b/basis/specialized-arrays/specialized-arrays-docs.factor
@ -28,6 +28,8 @@ $nl
    { $snippet "ulonglong" }
    { $snippet "float" }
    { $snippet "double" }
+    { $snippet "complex-float" }
+    { $snippet "complex-double" }
    { $snippet "void*" }
    { $snippet "bool" }
 }
--- a/basis/tools/deploy/backend/backend.factor
+++ b/basis/tools/deploy/backend/backend.factor
@ -11,8 +11,8 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8
 destructors accessors ;
 IN: tools.deploy.backend

-: copy-vm ( executable bundle-name extension -- vm )
-    [ prepend-path ] dip append vm over copy-file ;
+: copy-vm ( executable bundle-name -- vm )
+    prepend-path vm over copy-file ;

 : copy-fonts ( name dir -- )
    deploy-ui? get [
--- a/basis/tools/deploy/macosx/macosx.factor
+++ b/basis/tools/deploy/macosx/macosx.factor
@ -54,7 +54,7 @@ IN: tools.deploy.macosx
        } cleave
    ]
    [ create-app-plist ]
-    [ "Contents/MacOS/" append-path "" copy-vm ] 2tri
+    [ "Contents/MacOS/" append-path copy-vm ] 2tri
    dup OCT: 755 set-file-permissions ;

 : deploy.app-image ( vocab bundle-name -- str )
--- a/basis/tools/deploy/unix/unix.factor
+++ b/basis/tools/deploy/unix/unix.factor
@ -8,7 +8,7 @@ IN: tools.deploy.unix

 : create-app-dir ( vocab bundle-name -- vm )
    dup "" copy-fonts
-    "" copy-vm
+    copy-vm
    dup OCT: 755 set-file-permissions ;

 : bundle-name ( -- str )
--- a/basis/tools/deploy/windows/windows.factor
+++ b/basis/tools/deploy/windows/windows.factor
@ -1,9 +1,9 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.directories kernel namespaces sequences system
-tools.deploy.backend tools.deploy.config
-tools.deploy.config.editor assocs hashtables prettyprint
-combinators windows.shell32 windows.user32 ;
+USING: io io.files io.pathnames io.directories kernel namespaces
+sequences locals system splitting tools.deploy.backend
+tools.deploy.config tools.deploy.config.editor assocs hashtables
+prettyprint combinators windows.shell32 windows.user32 ;
 IN: tools.deploy.windows

 : copy-dll ( bundle-name -- )
@ -15,13 +15,18 @@ IN: tools.deploy.windows
        "resource:zlib1.dll"
    } swap copy-files-into ;

+:: copy-vm ( executable bundle-name extension -- vm )
+    vm "." split1-last drop extension append
+    bundle-name executable ".exe" append append-path
+    [ copy-file ] keep ;
+
 : create-exe-dir ( vocab bundle-name -- vm )
    dup copy-dll
    deploy-ui? get [
-        dup copy-freetype
-        dup "" copy-fonts
-    ] when
-    ".exe" copy-vm ;
+        [ copy-freetype ]
+        [ "" copy-fonts ]
+        [ ".exe" copy-vm ] tri
+    ] [ ".com" copy-vm ] if ;

 M: winnt deploy*
    "resource:" [
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ;
        { [ array bootstrap-word over class<= ] [ { } ] }
        { [ byte-array bootstrap-word over class<= ] [ B{ } ] }
        { [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
+        { [ quotation bootstrap-word over class<= ] [ [ ] ] }
        [ dup initial-value* ]
    } cond nip ;

--- a/extra/cap/cap.factor
+++ b/extra/cap/cap.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer
+opengl.gl sequences math.vectors ui images.bitmap images.viewer
 models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
 IN: cap

@ -27,4 +27,4 @@ IN: cap
    [ screenshot ] dip save-bitmap ;

 : screenshot. ( window -- )
-    [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ; 
+    [ screenshot <image-gadget> ] [ title>> ] bi open-window ; 
--- a/extra/graphics/bitmap/bitmap-tests.factor
+++ b/extra/graphics/bitmap/bitmap-tests.factor
@ -1,30 +0,0 @@
-USING: graphics.bitmap graphics.viewer io.encodings.binary
-io.files io.files.unique kernel tools.test ;
-IN: graphics.bitmap.tests
-
-: test-bitmap32-alpha ( -- path )
-    "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
-
-: test-bitmap24 ( -- path )
-    "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
-
-: test-bitmap16 ( -- path )
-    "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
-
-: test-bitmap8 ( -- path )
-    "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ;
-
-: test-bitmap4 ( -- path )
-    "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ;
-
-: test-bitmap1 ( -- path )
-    "resource:extra/graphics/bitmap/test-images/1bit.bmp" ;
-
-[ t ]
-[
-    test-bitmap24
-    [ binary file-contents ] [ load-bitmap ] bi
-
-    "test-bitmap24" unique-file
-    [ save-bitmap ] [ binary file-contents ] bi =
-] unit-test
--- a/extra/graphics/tiff/tiff-tests.factor
+++ b/extra/graphics/tiff/tiff-tests.factor
@ -1,11 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test graphics.tiff ;
-IN: graphics.tiff.tests
-
-: tiff-test-path ( -- path )
-    "resource:extra/graphics/tiff/rgb.tiff" ;
-
-: tiff-test-path2 ( -- path )
-    "resource:extra/graphics/tiff/octagon.tiff" ;
-
--- a/extra/graphics/viewer/authors.txt
+++ b/extra/graphics/viewer/authors.txt
@ -1 +0,0 @@
-Doug Coleman
--- a/extra/graphics/viewer/viewer.factor
+++ b/extra/graphics/viewer/viewer.factor
@ -1,66 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators graphics.bitmap kernel math
-math.functions namespaces opengl opengl.gl ui ui.gadgets
-ui.gadgets.panes ui.render graphics.tiff sequences ;
-IN: graphics.viewer
-
-TUPLE: graphics-gadget < gadget image ;
-
-GENERIC: draw-image ( image -- )
-GENERIC: width ( image -- w )
-GENERIC: height ( image -- h )
-
-M: graphics-gadget pref-dim*
-    image>> [ width ] keep height abs 2array ;
-
-M: graphics-gadget draw-gadget* ( gadget -- )
-    origin get [ image>> draw-image ] with-translation ;
-
-: <graphics-gadget> ( bitmap -- gadget )
-    \ graphics-gadget new-gadget
-        swap >>image ;
-
-: bits>gl-params ( n -- gl-bgr gl-format )
-    {
-        { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
-        { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
-        { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
-        { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
-    } case ;
-
-M: bitmap draw-image ( bitmap -- )
-    dup height>> 0 < [
-        0 0 glRasterPos2i
-        1.0 -1.0 glPixelZoom
-    ] [
-        0 over height>> abs glRasterPos2i
-        1.0 1.0 glPixelZoom
-    ] if
-    [ width>> ] keep
-    [
-        [ height>> abs ] keep
-        bit-count>> bits>gl-params
-    ] keep array>> glDrawPixels ;
-
-M: bitmap width ( bitmap -- ) width>> ;
-M: bitmap height ( bitmap -- ) height>> ;
-
-: bitmap. ( path -- )
-    load-bitmap <graphics-gadget> gadget. ;
-
-: bitmap-window ( path -- gadget )
-    load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
-
-M: tiff width ( tiff -- ) ifds>> first image-width find-tag ;
-M: tiff height ( tiff -- ) ifds>> first image-length find-tag ;
-
-M: tiff draw-image ( tiff -- )
-    [ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom ] dip
-    ifds>> first
-    {
-        [ image-width find-tag ]
-        [ image-length find-tag ]
-        [ bits-per-sample find-tag sum bits>gl-params ]
-        [ buffer>> ]
-    } cleave glDrawPixels ;
--- a/extra/images/authors.txt
+++ b/extra/images/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/extra/images/backend/authors.txt
+++ b/extra/images/backend/authors.txt
@ -0,0 +1 @@
+Doug Coleman
--- a/extra/images/backend/backend.factor
+++ b/extra/images/backend/backend.factor
@ -0,0 +1,18 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel ;
+IN: images.backend
+
+TUPLE: image width height depth pitch buffer ;
+
+GENERIC: load-image* ( path tuple -- image )
+
+: load-image ( path class -- image )
+    new load-image* ;
+
+: new-image ( width height depth buffer class -- image )
+    new 
+        swap >>buffer
+        swap >>depth
+        swap >>height
+        swap >>width ; inline
--- a/extra/images/bitmap/authors.txt
+++ b/extra/images/bitmap/authors.txt
--- a/extra/images/bitmap/bitmap-tests.factor
+++ b/extra/images/bitmap/bitmap-tests.factor
@ -0,0 +1,27 @@
+USING: images.bitmap images.viewer io.encodings.binary
+io.files io.files.unique kernel tools.test ;
+IN: images.bitmap.tests
+
+: test-bitmap24 ( -- path )
+    "resource:extra/images/test-images/thiswayup24.bmp" ;
+
+: test-bitmap16 ( -- path )
+    "resource:extra/images/test-images/rgb16bit.bmp" ;
+
+: test-bitmap8 ( -- path )
+    "resource:extra/images/test-images/rgb8bit.bmp" ;
+
+: test-bitmap4 ( -- path )
+    "resource:extra/images/test-images/rgb4bit.bmp" ;
+
+: test-bitmap1 ( -- path )
+    "resource:extra/images/test-images/1bit.bmp" ;
+
+[ t ]
+[
+    test-bitmap24
+    [ binary file-contents ] [ load-bitmap ] bi
+
+    "test-bitmap24" unique-file
+    [ save-bitmap ] [ binary file-contents ] bi =
+] unit-test
--- a/extra/graphics/bitmap/bitmap.factor
+++ b/extra/graphics/bitmap/bitmap.factor
@ -4,8 +4,10 @@ USING: accessors alien alien.c-types arrays byte-arrays columns
 combinators fry grouping io io.binary io.encodings.binary
 io.files kernel libc macros math math.bitwise math.functions
 namespaces opengl opengl.gl prettyprint sequences strings
-summary ui ui.gadgets.panes ;
-IN: graphics.bitmap
+summary ui ui.gadgets.panes images.backend ;
+IN: images.bitmap
+
+TUPLE: bitmap-image < image ;

 ! Currently can only handle 24/32bit bitmaps.
 ! Handles row-reversed bitmaps (their height is negative)
@ -14,40 +16,24 @@ TUPLE: bitmap magic size reserved offset header-length width
 height planes bit-count compression size-image
 x-pels y-pels color-used color-important rgb-quads color-index
 alpha-channel-zero?
-array ;
+buffer ;

 : array-copy ( bitmap array -- bitmap array' )
    over size-image>> abs memory>byte-array ;

-MACRO: (nbits>bitmap) ( bits -- )
-    [ -3 shift ] keep '[
-        bitmap new
-            2over * _ * >>size-image
-            swap >>height
-            swap >>width
-            swap array-copy [ >>array ] [ >>color-index ] bi
-            _ >>bit-count
-    ] ;
-
-: bgr>bitmap ( array height width -- bitmap )
-    24 (nbits>bitmap) ;
-
-: bgra>bitmap ( array height width -- bitmap )
-    32 (nbits>bitmap) ;
-
-: 8bit>array ( bitmap -- array )
+: 8bit>buffer ( bitmap -- array )
    [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
    [ color-index>> >array ] bi [ swap nth ] with map concat ;

 ERROR: bmp-not-supported n ;

-: raw-bitmap>array ( bitmap -- array )
+: raw-bitmap>buffer ( bitmap -- array )
    dup bit-count>>
    {
        { 32 [ color-index>> ] }
        { 24 [ color-index>> ] }
        { 16 [ bmp-not-supported ] }
-        { 8 [ 8bit>array ] }
+        { 8 [ 8bit>buffer ] }
        { 4 [ bmp-not-supported ] }
        { 2 [ bmp-not-supported ] }
        { 1 [ bmp-not-supported ] }
@ -95,19 +81,45 @@ M: bitmap-magic summary
    dup rgb-quads-length read >>rgb-quads
    dup color-index-length read >>color-index ;

-: (load-bitmap) ( path -- bitmap )
+: load-bitmap-data ( path -- bitmap )
    binary [
        bitmap new
        parse-file-header parse-bitmap-header parse-bitmap
    ] with-file-reader ;

 : alpha-channel-zero? ( bitmap -- ? )
-    array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
+    buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
+
+: process-bitmap-data ( bitmap -- bitmap )
+    dup raw-bitmap>buffer >>buffer
+    dup alpha-channel-zero? >>alpha-channel-zero? ;

 : load-bitmap ( path -- bitmap )
-    (load-bitmap)
-    dup raw-bitmap>array >>array
-    dup alpha-channel-zero? >>alpha-channel-zero? ;
+    load-bitmap-data process-bitmap-data ;
+
+: bitmap>image ( bitmap -- bitmap-image )
+    { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
+    bitmap-image new-image ;
+
+M: bitmap-image load-image* ( path bitmap -- bitmap-image )
+    drop load-bitmap
+    bitmap>image ;
+
+MACRO: (nbits>bitmap) ( bits -- )
+    [ -3 shift ] keep '[
+        bitmap new
+            2over * _ * >>size-image
+            swap >>height
+            swap >>width
+            swap array-copy [ >>buffer ] [ >>color-index ] bi
+            _ >>bit-count bitmap>image
+    ] ;
+
+: bgr>bitmap ( array height width -- bitmap )
+    24 (nbits>bitmap) ;
+
+: bgra>bitmap ( array height width -- bitmap )
+    32 (nbits>bitmap) ;

 : write2 ( n -- ) 2 >le write ;
 : write4 ( n -- ) 4 >le write ;
@ -116,7 +128,7 @@ M: bitmap-magic summary
    binary [
        B{ CHAR: B CHAR: M } write
        [
-            array>> length 14 + 40 + write4
+            buffer>> length 14 + 40 + write4
            0 write4
            54 write4
            40 write4
--- a/extra/images/images.factor
+++ b/extra/images/images.factor
@ -0,0 +1,13 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: constructors kernel splitting unicode.case combinators
+accessors images.bitmap images.tiff images.backend io.backend
+io.pathnames ;
+IN: images
+
+: <image> ( path -- image )
+    normalize-path dup "." split1-last nip >lower
+    {
+        { "bmp" [ bitmap-image load-image ] }
+        { "tiff" [ tiff-image load-image ] }
+    } case ;
--- a/extra/graphics/tags.txt
+++ b/extra/graphics/tags.txt
--- a/extra/graphics/bitmap/test-images/1bit.bmp
+++ b/extra/graphics/bitmap/test-images/1bit.bmp
--- a/extra/images/test-images/octagon.tiff
+++ b/extra/images/test-images/octagon.tiff
--- a/extra/images/test-images/rgb.tiff
+++ b/extra/images/test-images/rgb.tiff
--- a/extra/graphics/bitmap/test-images/rgb4bit.bmp
+++ b/extra/graphics/bitmap/test-images/rgb4bit.bmp
--- a/extra/graphics/bitmap/test-images/rgb8bit.bmp
+++ b/extra/graphics/bitmap/test-images/rgb8bit.bmp
--- a/extra/graphics/bitmap/test-images/thiswayup24.bmp
+++ b/extra/graphics/bitmap/test-images/thiswayup24.bmp
--- a/extra/graphics/bitmap/authors.txt
+++ b/extra/graphics/bitmap/authors.txt
--- a/extra/images/tiff/tiff-tests.factor
+++ b/extra/images/tiff/tiff-tests.factor
@ -0,0 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test images.tiff ;
+IN: images.tiff.tests
+
+: tiff-test-path ( -- path )
+    "resource:extra/images/test-images/rgb.tiff" ;
+
+: tiff-test-path2 ( -- path )
+    "resource:extra/images/test-images/octagon.tiff" ;
--- a/extra/graphics/tiff/tiff.factor
+++ b/extra/graphics/tiff/tiff.factor
@ -3,13 +3,14 @@
 USING: accessors combinators io io.encodings.binary io.files
 kernel pack endian tools.hexdump constructors sequences arrays
 sorting.slots math.order math.parser prettyprint classes
-io.binary assocs math math.bitwise byte-arrays grouping ;
-IN: graphics.tiff
+io.binary assocs math math.bitwise byte-arrays grouping
+images.backend ;
+IN: images.tiff

-TUPLE: tiff endianness the-answer ifd-offset ifds ;
+TUPLE: tiff-image < image ;

-CONSTRUCTOR: tiff ( -- tiff )
-    V{ } clone >>ifds ;
+TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
+CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;

 TUPLE: ifd count ifd-entries next
 processed-tags strips buffer ;
@ -83,13 +84,13 @@ ERROR: bad-planar-configuration n ;
        [ bad-planar-configuration ]
    } case ;

-ERROR: bad-sample-format n ;
 SINGLETONS: sample-format
 sample-format-unsigned-integer
 sample-format-signed-integer
 sample-format-ieee-float
 sample-format-undefined-data ;
-: lookup-sample-format ( seq -- object )
+ERROR: bad-sample-format n ;
+: lookup-sample-format ( sequence -- object )
    [
        {
            { 1 [ sample-format-unsigned-integer ] }
@ -100,12 +101,12 @@ sample-format-undefined-data ;
        } case
    ] map ;

-ERROR: bad-extra-samples n ;
 SINGLETONS: extra-samples
 extra-samples-unspecified-alpha-data
 extra-samples-associated-alpha-data
 extra-samples-unassociated-alpha-data ;
-: lookup-extra-samples ( seq -- object )
+ERROR: bad-extra-samples n ;
+: lookup-extra-samples ( sequence -- object )
    {
        { 0 [ extra-samples-unspecified-alpha-data ] }
        { 1 [ extra-samples-associated-alpha-data ] }
@ -259,13 +260,26 @@ ERROR: bad-small-ifd-type n ;
 : strips>buffer ( ifd -- ifd )
    dup strips>> concat >>buffer ;

-: (load-tiff) ( path -- tiff )
+: ifd>image ( ifd -- image )
+    {
+        [ image-width find-tag ]
+        [ image-length find-tag ]
+        [ bits-per-sample find-tag sum ]
+        [ buffer>> ]
+    } cleave tiff-image new-image ;
+
+: parsed-tiff>images ( tiff -- sequence )
+    ifds>> [ ifd>image ] map ;
+
+: load-tiff ( path -- parsed-tiff )
    binary [
-        <tiff>
+        <parsed-tiff>
        read-header dup endianness>> [
            read-ifds
            dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
        ] with-endianness
    ] with-file-reader ;

-: load-tiff ( path -- tiff ) (load-tiff) ;
+! tiff files can store several images -- we just take the first for now
+M: tiff-image load-image* ( path tiff-image -- image )
+    drop load-tiff parsed-tiff>images first ;
--- a/extra/images/viewer/authors.txt
+++ b/extra/images/viewer/authors.txt
--- a/extra/images/viewer/viewer.factor
+++ b/extra/images/viewer/viewer.factor
@ -0,0 +1,69 @@
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators images.bitmap kernel math
+math.functions namespaces opengl opengl.gl ui ui.gadgets
+ui.gadgets.panes ui.render images.tiff sequences multiline
+images.backend images io.pathnames strings ;
+IN: images.viewer
+
+TUPLE: image-gadget < gadget { image image } ;
+
+GENERIC: draw-image ( image -- )
+
+M: image-gadget pref-dim*
+    image>>
+    [ width>> ] [ height>> ] bi
+    [ abs ] bi@ 2array ;
+
+M: image-gadget draw-gadget* ( gadget -- )
+    origin get [ image>> draw-image ] with-translation ;
+
+: <image-gadget> ( image -- gadget )
+    \ image-gadget new-gadget
+        swap >>image ;
+
+: bits>gl-params ( n -- gl-bgr gl-format )
+    {
+        { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
+        { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
+        { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
+        { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
+    } case ;
+
+M: bitmap-image draw-image ( bitmap -- )
+    {
+        [
+            height>> dup 0 < [
+                drop
+                0 0 glRasterPos2i
+                1.0 -1.0 glPixelZoom
+            ] [
+                0 swap abs glRasterPos2i
+                1.0 1.0 glPixelZoom
+            ] if
+        ]
+        [ width>> abs ]
+        [ height>> abs ]
+        [ depth>> bits>gl-params ]
+        [ buffer>> ]
+    } cleave glDrawPixels ;
+
+: image-window ( path -- gadget )
+    [ <image> <image-gadget> dup ] [ open-window ] bi ;
+
+M: tiff-image draw-image ( tiff -- )
+    0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
+    {
+        [ height>> ]
+        [ width>> ]
+        [ depth>> bits>gl-params ]
+        [ buffer>> ]
+    } cleave glDrawPixels ;
+
+GENERIC: image. ( image -- )
+
+M: string image. ( image -- ) <image> <image-gadget> gadget. ;
+
+M: pathname image. ( image -- ) <image> <image-gadget> gadget. ;
+
+M: image image. ( image -- ) <image-gadget> gadget. ;
--- a/extra/taxes/usa/usa.factor
+++ b/extra/taxes/usa/usa.factor
@ -2,8 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs kernel math math.intervals
 namespaces sequences money math.order taxes.usa.w4
-taxes.usa.futa math.finance taxes.usa.fica
-taxes.usa.federal ;
+taxes.usa.futa math.finance ;
 IN: taxes.usa

 ! Withhold: FICA, Medicare, Federal (FICA is social security)
--- a/extra/ui/offscreen/offscreen-docs.factor
+++ b/extra/ui/offscreen/offscreen-docs.factor
@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel quotations ui.gadgets
-graphics.bitmap strings ui.gadgets.worlds ;
+images.bitmap strings ui.gadgets.worlds ;
 IN: ui.offscreen

 HELP: <offscreen-world>
--- a/extra/ui/offscreen/offscreen.factor
+++ b/extra/ui/offscreen/offscreen.factor
@ -1,5 +1,5 @@
 ! (c) 2008 Joe Groff, see license for details
-USING: accessors continuations graphics.bitmap kernel math
+USING: accessors continuations images.bitmap kernel math
 sequences ui.gadgets ui.gadgets.worlds ui ui.backend
 destructors ;
 IN: ui.offscreen
--- a/extra/ui/render/test/test.factor
+++ b/extra/ui/render/test/test.factor
@ -1,10 +1,10 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors colors arrays kernel sequences math byte-arrays
-namespaces grouping fry cap graphics.bitmap
+namespaces grouping fry cap images.bitmap
 ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
 ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
-ui.render ui opengl opengl.gl ;
+ui.render ui opengl opengl.gl images ;
 IN: ui.render.test

 SINGLETON: line-test
@ -30,7 +30,7 @@ SYMBOL: render-output

 : bitmap= ( bitmap1 bitmap2 -- ? )
    [
-        [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi
+        [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi
        '[ _ head twiddle ] map
    ] bi@ = ;

@ -38,7 +38,7 @@ SYMBOL: render-output
    screenshot
    [ render-output set-global ]
    [
-        "resource:extra/ui/render/test/reference.bmp" load-bitmap
+        "resource:extra/ui/render/test/reference.bmp" <image>
        bitmap= "is perfect" "needs work" ?
        "Your UI rendering " prepend
        message-window