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

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 ] ;
 

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

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

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>> ;
 

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
+
+

basis/pack/pack.factor

@@ -87,12 +87,12 @@ CONSTANT: packed-length-table
         { CHAR: D 8 }
     }
 
+PRIVATE>
+
 MACRO: pack ( str -- quot )
     [ pack-table at '[ _ execute ] ] { } map-as
     '[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
 
-PRIVATE>
-
 : ch>packed-length ( ch -- n )
     packed-length-table at ; inline
 
@@ -113,14 +113,14 @@ PRIVATE>
 : start/end ( seq -- seq1 seq2 )
     [ 0 [ + ] accumulate nip dup ] keep v+ ; inline
 
+PRIVATE>
+
 MACRO: unpack ( str -- quot )
     [ [ ch>packed-length ] { } map-as start/end ]
     [ [ unpack-table at '[ @ ] ] { } map-as ] bi
     [ '[ [ _ _ ] dip <slice> @ ] ] 3map
     '[ [ _ cleave ] output>array ] ;
 
-PRIVATE>
-
 : unpack-native ( seq str -- seq )
     '[ _ _ unpack ] with-native-endian ; inline
 

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 )
+: copy-vm ( executable bundle-name -- vm )
-    [ prepend-path ] dip append vm over copy-file ;
+    prepend-path vm over copy-file ;
 
 : copy-fonts ( name dir -- )
     deploy-ui? get [

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 )

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 )

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
+USING: io io.files io.pathnames io.directories kernel namespaces
-tools.deploy.backend tools.deploy.config
+sequences locals system splitting tools.deploy.backend
-tools.deploy.config.editor assocs hashtables prettyprint
+tools.deploy.config tools.deploy.config.editor assocs hashtables
-combinators windows.shell32 windows.user32 ;
+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
+        [ copy-freetype ]
-        dup "" copy-fonts
+        [ "" copy-fonts ]
-    ] when
+        [ ".exe" copy-vm ] tri
-    ".exe" copy-vm ;
+    ] [ ".com" copy-vm ] if ;
 
 M: winnt deploy*
     "resource:" [

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 ;
 

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 ; 

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

extra/graphics/tiff/tiff-tests.factor

@@ -1,9 +0,0 @@
-! Copyright (C) 2009 Your name.
-! 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" ;
-
-

extra/graphics/tiff/tiff.factor

@@ -1,227 +0,0 @@
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-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 ;
-IN: graphics.tiff
-
-TUPLE: tiff
-endianness
-the-answer
-ifd-offset
-ifds ;
-
-CONSTRUCTOR: tiff ( -- tiff )
-    V{ } clone >>ifds ;
-
-TUPLE: ifd count ifd-entries next processed-tags strips ;
-
-CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
-
-TUPLE: ifd-entry tag type count offset ;
-
-CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ;
-
-
-TUPLE: photometric-interpretation color ;
-
-CONSTRUCTOR: photometric-interpretation ( color -- object ) ;
-
-SINGLETONS: white-is-zero black-is-zero rgb palette-color ;
-
-ERROR: bad-photometric-interpretation n ;
-
-: lookup-photometric-interpretation ( n -- singleton )
-    {
-        { 0 [ white-is-zero ] }
-        { 1 [ black-is-zero ] }
-        { 2 [ rgb ] }
-        { 3 [ palette-color ] }
-        [ bad-photometric-interpretation ]
-    } case <photometric-interpretation> ;
-
-
-TUPLE: compression method ;
-
-CONSTRUCTOR: compression ( method -- object ) ;
-
-SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
-
-ERROR: bad-compression n ;
-
-: lookup-compression ( n -- compression )
-    {
-        { 1 [ no-compression ] }
-        { 2 [ CCITT-2 ] }
-        { 5 [ lzw ] }
-        { 32773 [ pack-bits ] }
-        [ bad-compression ]
-    } case <compression> ;
-
-TUPLE: image-length n ;
-CONSTRUCTOR: image-length ( n -- object ) ;
-
-TUPLE: image-width n ;
-CONSTRUCTOR: image-width ( n -- object ) ;
-
-TUPLE: x-resolution n ;
-CONSTRUCTOR: x-resolution ( n -- object ) ;
-
-TUPLE: y-resolution n ;
-CONSTRUCTOR: y-resolution ( n -- object ) ;
-
-TUPLE: rows-per-strip n ;
-CONSTRUCTOR: rows-per-strip ( n -- object ) ;
-
-TUPLE: strip-offsets n ;
-CONSTRUCTOR: strip-offsets ( n -- object ) ;
-
-TUPLE: strip-byte-counts n ;
-CONSTRUCTOR: strip-byte-counts ( n -- object ) ;
-
-TUPLE: bits-per-sample n ;
-CONSTRUCTOR: bits-per-sample ( n -- object ) ;
-
-TUPLE: samples-per-pixel n ;
-CONSTRUCTOR: samples-per-pixel ( n -- object ) ;
-
-SINGLETONS: no-resolution-unit
-inch-resolution-unit
-centimeter-resolution-unit ;
-
-TUPLE: resolution-unit type ;
-CONSTRUCTOR: resolution-unit ( type -- object ) ;
-
-ERROR: bad-resolution-unit n ;
-
-: lookup-resolution-unit ( n -- object )
-    {
-        { 1 [ no-resolution-unit ] }
-        { 2 [ inch-resolution-unit ] }
-        { 3 [ centimeter-resolution-unit ] }
-        [ bad-resolution-unit ]
-    } case <resolution-unit> ;
-
-
-TUPLE: predictor type ;
-CONSTRUCTOR: predictor ( type -- object ) ;
-
-SINGLETONS: no-predictor horizontal-differencing-predictor ;
-
-ERROR: bad-predictor n ;
-
-: lookup-predictor ( n -- object )
-    {
-        { 1 [ no-predictor ] }
-        { 2 [ horizontal-differencing-predictor ] }
-        [ bad-predictor ]
-    } case <predictor> ;
-
-
-TUPLE: planar-configuration type ;
-CONSTRUCTOR: planar-configuration ( type -- object ) ;
-
-SINGLETONS: chunky planar ;
-
-ERROR: bad-planar-configuration n ;
-
-: lookup-planar-configuration ( n -- object )
-    {
-        { 1 [ no-predictor ] }
-        { 2 [ horizontal-differencing-predictor ] }
-        [ bad-predictor ]
-    } case <planar-configuration> ;
-
-
-TUPLE: new-subfile-type n ;
-CONSTRUCTOR: new-subfile-type ( n -- object ) ;
-
-ERROR: bad-tiff-magic bytes ;
-
-: tiff-endianness ( byte-array -- ? )
-    {
-        { B{ CHAR: M CHAR: M } [ big-endian ] }
-        { B{ CHAR: I CHAR: I } [ little-endian ] }
-        [ bad-tiff-magic ]
-    } case ;
-
-: with-tiff-endianness ( tiff quot -- tiff )
-    [ dup endianness>> ] dip with-endianness ; inline
-
-: read-header ( tiff -- tiff )
-    2 read tiff-endianness [ >>endianness ] keep
-    [
-        2 read endian> >>the-answer
-        4 read endian> >>ifd-offset
-    ] with-endianness ;
-
-: push-ifd ( tiff ifd -- tiff )
-    over ifds>> push ;
-
-: read-ifd ( -- ifd )
-    2 read endian>
-    2 read endian>
-    4 read endian>
-    4 read endian> <ifd-entry> ;
-
-: read-ifds ( tiff -- tiff )
-    [
-        dup ifd-offset>> seek-absolute seek-input
-        2 read endian>
-        dup [ read-ifd ] replicate
-        4 read endian>
-        [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi
-    ] with-tiff-endianness ;
-
-: read-strips ( ifd -- ifd )
-    dup processed-tags>>
-    [ [ strip-byte-counts instance? ] find nip n>> ]
-    [ [ strip-offsets instance? ] find nip n>> ] bi
-    [ seek-absolute seek-input read ] { } 2map-as >>strips ;
-
-! ERROR: unhandled-ifd-entry data n ;
-
-: unhandled-ifd-entry ;
-
-: ifd-entry-value ( ifd-entry -- n )
-    dup count>> 1 = [
-        offset>>
-    ] [
-        [ offset>> seek-absolute seek-input ] [ count>> read ] bi
-    ] if ;
-
-: process-ifd-entry ( ifd-entry -- object )
-    [ ifd-entry-value ] [ tag>> ] bi {
-        { 254 [ <new-subfile-type> ] }
-        { 256 [ <image-width> ] }
-        { 257 [ <image-length> ] }
-        { 258 [ <bits-per-sample> ] }
-        { 259 [ lookup-compression ] }
-        { 262 [ lookup-photometric-interpretation ] }
-        { 273 [ <strip-offsets> ] }
-        { 277 [ <samples-per-pixel> ] }
-        { 278 [ <rows-per-strip> ] }
-        { 279 [ <strip-byte-counts> ] }
-        { 282 [ <x-resolution> ] }
-        { 283 [ <y-resolution> ] }
-        { 284 [ <planar-configuration> ] }
-        { 296 [ lookup-resolution-unit ] }
-        { 317 [ lookup-predictor ] }
-        [ unhandled-ifd-entry swap 2array ]
-    } case ;
-
-: process-ifd ( ifd -- ifd )
-    dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
-
-: (load-tiff) ( path -- tiff )
-    binary [
-        <tiff>
-        read-header
-        read-ifds
-        dup ifds>> [ process-ifd read-strips drop ] each
-    ] with-file-reader ;
-
-: load-tiff ( path -- tiff )
-    (load-tiff) ;
-
-! TODO: duplicate ifds = error, seeking out of bounds = error

extra/graphics/viewer/authors.txt

@@ -1 +0,0 @@
-Doug Coleman

extra/graphics/viewer/viewer.factor

@@ -1,50 +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 ;
-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 ;
-
-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>> {
-            { 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
-    ] 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 ;

extra/id3/id3-docs.factor

@@ -0,0 +1,10 @@
+IN: id3
+USING: help.markup help.syntax sequences kernel ;
+
+HELP: id3-parse-mp3-file
+{ $values { "path" "a path string" } { "object/f" "either a tuple consisting of the data from an MP3 file, or an f indicating this file has no ID3 information." }
+
+ARTICLE: "id3" "ID3 tags"
+{ $emphasis "id3" } " tags are textual data that is used to describe the information (title, artist, etc.) in an .MP3 file"
+
+ABOUT: "id3"

extra/id3/id3-tests.factor

@@ -0,0 +1,182 @@
+! Copyright (C) 2009 Tim Wawrzynczak
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test id3 ;
+IN: id3.tests
+
+[ T{ mp3v2-file
+     { header  T{ header f t 0 502 } }
+     { frames
+       {
+           T{ frame
+              { frame-id "COMM" }
+              { flags B{ 0 0 } }
+              { size 19 }
+              { data "eng, AG# 08E1C12E" }
+           }
+           T{ frame
+              { frame-id "TIT2" }
+              { flags B{ 0 0 } }
+              { size 15 }
+              { data "Stormy Weather" }
+           }
+           T{ frame
+              { frame-id "TRCK" }
+              { flags B{ 0 0 } }
+              { size 3 }
+              { data "32" }
+           }
+           T{ frame
+              { frame-id "TCON" }
+              { flags B{ 0 0 } }
+              { size 5 }
+              { data "(96)" }
+           }
+           T{ frame
+              { frame-id "TALB" }
+              { flags B{ 0 0 } }
+              { size 28 }
+              { data "Night and Day Frank Sinatra" }
+           }
+           T{ frame
+              { frame-id "PRIV" }
+              { flags B{ 0 0 } }
+              { size 39 }
+              { data "WM/MediaClassPrimaryID<49>}`<60>#<23><>K<EFBFBD>H<EFBFBD>*(D" }
+           }
+           T{ frame
+              { frame-id "PRIV" }
+              { flags B{ 0 0 } }
+              { size 41 }
+              { data "WM/MediaClassSecondaryID" }
+           }
+           T{ frame
+              { frame-id "TPE1" }
+              { flags B{ 0 0 } }
+              { size 14 }
+              { data "Frank Sinatra" }
+           }
+       }
+     }
+}
+] [ "resource:extra/id3/tests/blah3.mp3" id3-parse-mp3-file ] unit-test
+
+[
+    T{ mp3v2-file
+    { header
+        T{ header { version t } { flags 0 } { size 1405 } }
+    }
+    { frames
+        {
+            T{ frame
+                { frame-id "TIT2" }
+                { flags B{ 0 0 } }
+                { size 22 }
+                { data "Anthem of the Trinity" }
+            }
+            T{ frame
+                { frame-id "TPE1" }
+                { flags B{ 0 0 } }
+                { size 12 }
+                { data "Terry Riley" }
+            }
+            T{ frame
+                { frame-id "TALB" }
+                { flags B{ 0 0 } }
+                { size 11 }
+                { data "Shri Camel" }
+            }
+            T{ frame
+                { frame-id "TCON" }
+                { flags B{ 0 0 } }
+                { size 10 }
+                { data "Classical" }
+            }
+            T{ frame
+                { frame-id "UFID" }
+                { flags B{ 0 0 } }
+                { size 23 }
+                { data "http://musicbrainz.org" }
+            }
+            T{ frame
+                { frame-id "TXXX" }
+                { flags B{ 0 0 } }
+                { size 23 }
+                { data "MusicBrainz Artist Id" }
+            }
+            T{ frame
+                { frame-id "TXXX" }
+                { flags B{ 0 0 } }
+                { size 22 }
+                { data "musicbrainz_artistid" }
+            }
+            T{ frame
+                { frame-id "TRCK" }
+                { flags B{ 0 0 } }
+                { size 2 }
+                { data "1" }
+            }
+            T{ frame
+                { frame-id "TXXX" }
+                { flags B{ 0 0 } }
+                { size 22 }
+                { data "MusicBrainz Album Id" }
+            }
+            T{ frame
+                { frame-id "TXXX" }
+                { flags B{ 0 0 } }
+                { size 21 }
+                { data "musicbrainz_albumid" }
+            }
+            T{ frame
+                { frame-id "TXXX" }
+                { flags B{ 0 0 } }
+                { size 29 }
+                { data "MusicBrainz Album Artist Id" }
+            }
+            T{ frame
+                { frame-id "TXXX" }
+                { flags B{ 0 0 } }
+                { size 27 }
+                { data "musicbrainz_albumartistid" }
+            }
+            T{ frame
+                { frame-id "TPOS" }
+                { flags B{ 0 0 } }
+                { size 2 }
+                { data "1" }
+            }
+            T{ frame
+                { frame-id "TSOP" }
+                { flags B{ 0 0 } }
+                { size 1 }
+            }
+            T{ frame
+                { frame-id "TMED" }
+                { flags B{ 0 0 } }
+                { size 4 }
+                { data "DIG" }
+            }
+        }
+    }
+}
+] [ "resource:extra/id3/tests/blah2.mp3" id3-parse-mp3-file ] unit-test
+
+[    
+  T{ mp3v1-file
+     { title
+       "BLAH\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+     }
+     { artist
+       "ARTIST\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+     }
+     { album
+       "ALBUM\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+     }
+     { year "2009" }
+     { comment
+       "COMMENT\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+     }
+     { genre 89 }
+  }
+] [ "resource:extra/id3/tests/blah.mp3" id3-parse-mp3-file ] unit-test
+

extra/id3/id3.factor

@@ -0,0 +1,154 @@
+! Copyright (C) 2009 Tim Wawrzynczak
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ;
+IN: id3
+
+! tuples
+
+TUPLE: header version flags size ;
+
+TUPLE: frame frame-id flags size data ;
+
+TUPLE: mp3v2-file header frames ;
+
+TUPLE: mp3v1-file title artist album year comment genre ;
+
+: <mp3v1-file> ( -- object ) mp3v1-file new ;
+
+: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ;
+
+: <header> ( -- object ) header new ;
+
+: <frame> ( -- object ) frame new ;
+
+<PRIVATE
+
+! utility words
+
+: id3v2? ( mmap -- ? )
+    "ID3" head? ;
+
+: id3v1? ( mmap -- ? )
+    128 tail-slice* "TAG" head? ;
+
+: >28bitword ( seq -- int )
+    0 [ swap 7 shift bitor ] reduce ;
+
+: filter-text-data ( data -- filtered )
+    [ printable? ] filter ;
+
+! frame details stuff
+
+: valid-frame-id? ( id -- ? )
+    [ [ digit? ] [ LETTER? ] bi or ] all? ;
+
+: read-frame-id ( mmap -- id )
+    4 head-slice ;
+
+: read-frame-size ( mmap -- size )
+    [ 4 8 ] dip subseq ;
+
+: read-frame-flags ( mmap -- flags )
+    [ 8 10 ] dip subseq ;
+
+: read-frame-data ( frame mmap -- frame data )
+    [ 10 over size>> 10 + ] dip <slice> filter-text-data ;
+
+! read whole frames
+
+: (read-frame) ( mmap -- frame )
+    [ <frame> ] dip
+    {
+        [ read-frame-id    ascii decode >>frame-id ]
+        [ read-frame-flags >byte-array  >>flags ]
+        [ read-frame-size  >28bitword   >>size ]
+        [ read-frame-data  ascii decode >>data ]
+    } cleave ;
+
+: read-frame ( mmap -- frame/f )
+    dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ;
+
+: remove-frame ( mmap frame -- mmap )
+    size>> 10 + tail-slice ;
+
+: read-frames ( mmap -- frames )
+    [ dup read-frame dup ]
+    [ [ remove-frame ] keep ]
+    [ drop ] produce nip ;
+    
+! header stuff
+
+: read-header-supported-version? ( mmap -- ? )
+    3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ;
+
+: read-header-flags ( mmap -- flags )
+    5 swap nth ;
+
+: read-header-size ( mmap -- size )
+    [ 6 10 ] dip <slice> >28bitword ;
+
+: read-v2-header ( mmap -- id3header )
+    [ <header> ] dip
+    {
+        [ read-header-supported-version?  >>version ]
+        [ read-header-flags >>flags ]
+        [ read-header-size >>size ]
+    } cleave ;
+
+: drop-header ( mmap -- seq1 seq2 )
+    dup 10 tail-slice swap ;
+
+: read-v2-tag-data ( seq -- mp3v2-file )
+    drop-header read-v2-header swap read-frames <mp3v2-file> ;
+
+! v1 information
+
+: skip-to-v1-data ( seq -- seq )
+    125 tail-slice* ;
+
+: read-title ( seq -- title )
+    30 head-slice ;
+
+: read-artist ( seq -- title )
+    [ 30 60 ] dip subseq ;
+
+: read-album ( seq -- album )
+    [ 60 90 ] dip subseq ;
+
+: read-year ( seq -- year )
+    [ 90 94 ] dip subseq ;
+
+: read-comment ( seq -- comment )
+    [ 94 124 ] dip subseq ;
+
+: read-genre ( seq -- genre )
+    [ 124 ] dip nth ;
+
+: (read-v1-tag-data) ( seq -- mp3-file )
+    [ <mp3v1-file> ] dip
+    {
+        [ read-title   ascii decode  >>title ]
+        [ read-artist  ascii decode  >>artist ]
+        [ read-album   ascii decode  >>album ]
+        [ read-year    ascii decode  >>year ]
+        [ read-comment ascii decode  >>comment ]
+        [ read-genre   >fixnum       >>genre ]
+    } cleave ;
+
+: read-v1-tag-data ( seq -- mp3-file )
+    skip-to-v1-data (read-v1-tag-data) ;
+
+PRIVATE>
+
+! main stuff
+
+: id3-parse-mp3-file ( path -- object )
+    [
+        {
+            { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file )
+            { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file )
+            [ drop f ] ! ( mmap -- f )
+        } cond
+    ] with-mapped-uchar-file ;
+
+! end

extra/images/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

extra/images/backend/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

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

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

extra/images/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 ;
+summary ui ui.gadgets.panes images.backend ;
-IN: graphics.bitmap
+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 -- )
+: 8bit>buffer ( bitmap -- array )
-    [ -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 )
     [ 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)
+    load-bitmap-data process-bitmap-data ;
-    dup raw-bitmap>array >>array
+
-    dup alpha-channel-zero? >>alpha-channel-zero? ;
+: 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

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 ;

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" ;

extra/images/tiff/tiff.factor

@@ -0,0 +1,285 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+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
+images.backend ;
+IN: images.tiff
+
+TUPLE: tiff-image < image ;
+
+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 ;
+CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
+
+TUPLE: ifd-entry tag type count offset/value ;
+CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
+
+SINGLETONS: photometric-interpretation
+photometric-interpretation-white-is-zero
+photometric-interpretation-black-is-zero
+photometric-interpretation-rgb
+photometric-interpretation-palette-color ;
+ERROR: bad-photometric-interpretation n ;
+: lookup-photometric-interpretation ( n -- singleton )
+    {
+        { 0 [ photometric-interpretation-white-is-zero ] }
+        { 1 [ photometric-interpretation-black-is-zero ] }
+        { 2 [ photometric-interpretation-rgb ] }
+        { 3 [ photometric-interpretation-palette-color ] }
+        [ bad-photometric-interpretation ]
+    } case ;
+
+SINGLETONS: compression
+compression-none
+compression-CCITT-2
+compression-lzw
+compression-pack-bits ;
+ERROR: bad-compression n ;
+: lookup-compression ( n -- compression )
+    {
+        { 1 [ compression-none ] }
+        { 2 [ compression-CCITT-2 ] }
+        { 5 [ compression-lzw ] }
+        { 32773 [ compression-pack-bits ] }
+        [ bad-compression ]
+    } case ;
+
+SINGLETONS: resolution-unit
+resolution-unit-none
+resolution-unit-inch
+resolution-unit-centimeter ;
+ERROR: bad-resolution-unit n ;
+: lookup-resolution-unit ( n -- object )
+    {
+        { 1 [ resolution-unit-none ] }
+        { 2 [ resolution-unit-inch ] }
+        { 3 [ resolution-unit-centimeter ] }
+        [ bad-resolution-unit ]
+    } case ;
+
+SINGLETONS: predictor
+predictor-none
+predictor-horizontal-differencing ;
+ERROR: bad-predictor n ;
+: lookup-predictor ( n -- object )
+    {
+        { 1 [ predictor-none ] }
+        { 2 [ predictor-horizontal-differencing ] }
+        [ bad-predictor ]
+    } case ;
+
+SINGLETONS: planar-configuration
+planar-configuration-chunky
+planar-configuration-planar ;
+ERROR: bad-planar-configuration n ;
+: lookup-planar-configuration ( n -- object )
+    {
+        { 1 [ planar-configuration-chunky ] }
+        { 2 [ planar-configuration-planar ] }
+        [ bad-planar-configuration ]
+    } case ;
+
+SINGLETONS: sample-format
+sample-format-unsigned-integer
+sample-format-signed-integer
+sample-format-ieee-float
+sample-format-undefined-data ;
+ERROR: bad-sample-format n ;
+: lookup-sample-format ( sequence -- object )
+    [
+        {
+            { 1 [ sample-format-unsigned-integer ] }
+            { 2 [ sample-format-signed-integer ] }
+            { 3 [ sample-format-ieee-float ] }
+            { 4 [ sample-format-undefined-data ] }
+            [ bad-sample-format ]
+        } case
+    ] map ;
+
+SINGLETONS: extra-samples
+extra-samples-unspecified-alpha-data
+extra-samples-associated-alpha-data
+extra-samples-unassociated-alpha-data ;
+ERROR: bad-extra-samples n ;
+: lookup-extra-samples ( sequence -- object )
+    {
+        { 0 [ extra-samples-unspecified-alpha-data ] }
+        { 1 [ extra-samples-associated-alpha-data ] }
+        { 2 [ extra-samples-unassociated-alpha-data ] }
+        [ bad-extra-samples ]
+    } case ;
+
+SINGLETONS: image-length image-width x-resolution y-resolution
+rows-per-strip strip-offsets strip-byte-counts bits-per-sample
+samples-per-pixel new-subfile-type orientation
+unhandled-ifd-entry ;
+
+ERROR: bad-tiff-magic bytes ;
+: tiff-endianness ( byte-array -- ? )
+    {
+        { B{ CHAR: M CHAR: M } [ big-endian ] }
+        { B{ CHAR: I CHAR: I } [ little-endian ] }
+        [ bad-tiff-magic ]
+    } case ;
+
+: read-header ( tiff -- tiff )
+    2 read tiff-endianness [ >>endianness ] keep
+    [
+        2 read endian> >>the-answer
+        4 read endian> >>ifd-offset
+    ] with-endianness ;
+
+: push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
+
+: read-ifd ( -- ifd )
+    2 read endian>
+    2 read endian>
+    4 read endian>
+    4 read endian> <ifd-entry> ;
+
+: read-ifds ( tiff -- tiff )
+    dup ifd-offset>> seek-absolute seek-input
+    2 read endian>
+    dup [ read-ifd ] replicate
+    4 read endian>
+    [ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
+
+ERROR: no-tag class ;
+
+: ?at ( key assoc -- value/key ? )
+    dupd at* [ nip t ] [ drop f ] if ; inline
+
+: find-tag ( idf class -- tag )
+    swap processed-tags>> ?at [ no-tag ] unless ;
+
+: read-strips ( ifd -- ifd )
+    dup
+    [ strip-byte-counts find-tag ]
+    [ strip-offsets find-tag ] bi
+    2dup [ integer? ] both? [
+        seek-absolute seek-input read 1array
+    ] [
+        [ seek-absolute seek-input read ] { } 2map-as
+    ] if >>strips ;
+
+ERROR: unknown-ifd-type n ;
+
+: bytes>bits ( n/byte-array -- n )
+    dup byte-array? [ byte-array>bignum ] when ;
+
+: value-length ( ifd-entry -- n )
+    [ count>> ] [ type>> ] bi {
+        { 1 [ ] }
+        { 2 [ ] }
+        { 3 [ 2 * ] }
+        { 4 [ 4 * ] }
+        { 5 [ 8 * ] }
+        { 6 [ ] }
+        { 7 [ ] }
+        { 8 [ 2 * ] }
+        { 9 [ 4 * ] }
+        { 10 [ 8 * ] }
+        { 11 [ 4 * ] }
+        { 12 [ 8 * ] }
+        [ unknown-ifd-type ]
+    } case ;
+
+ERROR: bad-small-ifd-type n ;
+
+: adjust-offset/value ( ifd-entry -- obj )
+    [ offset/value>> 4 >endian ] [ type>> ] bi
+    {
+        { 1 [ 1 head endian> ] }
+        { 3 [ 2 head endian> ] }
+        { 4 [ endian> ] }
+        { 6 [ 1 head endian> 8 >signed ] }
+        { 8 [ 2 head endian> 16 >signed ] }
+        { 9 [ endian> 32 >signed ] }
+        { 11 [ endian> bits>float ] }
+        [ bad-small-ifd-type ]
+    } case ;
+
+: offset-bytes>obj ( bytes type -- obj )
+    {
+        { 1 [ ] } ! blank
+        { 2 [ ] } ! read c strings here
+        { 3 [ 2 <sliced-groups> [ endian> ] map ] }
+        { 4 [ 4 <sliced-groups> [ endian> ] map ] }
+        { 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
+        { 6 [ [ 8 >signed ] map ] }
+        { 7 [ ] } ! blank
+        { 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
+        { 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
+        { 10 [ 8 group [ "ii" unpack first2 / ] map ] }
+        { 11 [ 4 group [ "f" unpack ] map ] }
+        { 12 [ 8 group [ "d" unpack ] map ] }
+        [ unknown-ifd-type ]
+    } case ;
+
+: ifd-entry-value ( ifd-entry -- n )
+    dup value-length 4 <= [
+        adjust-offset/value
+    ] [
+        [ offset/value>> seek-absolute seek-input ]
+        [ value-length read ]
+        [ type>> ] tri offset-bytes>obj
+    ] if ;
+
+: process-ifd-entry ( ifd-entry -- value class )
+    [ ifd-entry-value ] [ tag>> ] bi {
+        { 254 [ new-subfile-type ] }
+        { 256 [ image-width ] }
+        { 257 [ image-length ] }
+        { 258 [ bits-per-sample ] }
+        { 259 [ lookup-compression compression ] }
+        { 262 [ lookup-photometric-interpretation photometric-interpretation ] }
+        { 273 [ strip-offsets ] }
+        { 274 [ orientation ] }
+        { 277 [ samples-per-pixel ] }
+        { 278 [ rows-per-strip ] }
+        { 279 [ strip-byte-counts ] }
+        { 282 [ x-resolution ] }
+        { 283 [ y-resolution ] }
+        { 284 [ planar-configuration ] }
+        { 296 [ lookup-resolution-unit resolution-unit ] }
+        { 317 [ lookup-predictor predictor ] }
+        { 338 [ lookup-extra-samples extra-samples ] }
+        { 339 [ lookup-sample-format sample-format ] }
+        [ nip unhandled-ifd-entry ]
+    } case ;
+
+: process-ifd ( ifd -- ifd )
+    dup ifd-entries>>
+    [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
+
+: strips>buffer ( ifd -- ifd )
+    dup strips>> concat >>buffer ;
+
+: 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 [
+        <parsed-tiff>
+        read-header dup endianness>> [
+            read-ifds
+            dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
+        ] with-endianness
+    ] with-file-reader ;
+
+! 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 ;

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. ;

extra/taxes/usa/futa/futa.factor

@@ -11,5 +11,4 @@ IN: taxes.usa.futa
 
 : futa-tax ( salary w4 -- x )
     drop futa-base-rate min
-    futa-tax-rate futa-tax-offset-credit -
+    futa-tax-rate futa-tax-offset-credit - * ;
-    * ;

extra/taxes/usa/usa.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! 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 ;
+namespaces sequences money math.order taxes.usa.w4
+taxes.usa.futa math.finance ;
 IN: taxes.usa
 
 ! Withhold: FICA, Medicare, Federal (FICA is social security)

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>

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

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