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

basis/bit-arrays/bit-arrays.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types accessors math alien.accessors kernel
-kernel.private locals sequences sequences.private byte-arrays
+kernel.private sequences sequences.private byte-arrays
 parser prettyprint.custom fry ;
 IN: bit-arrays
 
@@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
 
 : ?{ \ } [ >bit-array ] parse-literal ; parsing
 
-:: integer>bit-array ( n -- bit-array ) 
+: integer>bit-array ( n -- bit-array )
-    n zero? [ 0 <bit-array> ] [
+    dup 0 = [
-        [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
+        <bit-array>
-            [ n' zero? ] [
+    ] [
-                n' out underlying>> i set-alien-unsigned-1
+        [ log2 1+ <bit-array> 0 ] keep
-                n' -8 shift n'!
+        [ dup 0 = ] [
-                i 1+ i!
+            [ pick underlying>> pick set-alien-unsigned-1 ] keep
-            ] [ ] until
+            [ 1+ ] [ -8 shift ] bi*
-            out
+        ] [ ] until 2drop
-        ]
     ] if ;
 
 : bit-array>integer ( bit-array -- n )

basis/cocoa/messages/messages.factor

@@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot )
 ! Runtime introspection
 SYMBOL: class-init-hooks
 
-class-init-hooks [ H{ } clone or ] initialize
+class-init-hooks [ H{ } clone ] initialize
 
 : (objc-class) ( name word -- class )
     2dup execute dup [ 2nip ] [

core/combinators/combinators-tests.factor

@@ -323,4 +323,18 @@ DEFER: corner-case-1
 [ t ] [ \ corner-case-1 optimized>> ] unit-test
 [ 4 ] [ 2 corner-case-1 ] unit-test
 
-[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
+[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
+
+: test-case-8 ( n -- )
+    {
+        { 1 [ "foo" ] }
+    } case ;
+
+[ 3 test-case-8 ]
+[ object>> 3 = ] must-fail-with
+
+[
+    3 {
+        { 1 [ "foo" ] }
+    } case
+] [ object>> 3 = ] must-fail-with

core/combinators/combinators.factor

@@ -49,7 +49,7 @@ ERROR: no-cond ;
     reverse [ no-cond ] swap alist>quot ;
 
 ! case
-ERROR: no-case ;
+ERROR: no-case object ;
 
 : case-find ( obj assoc -- obj' )
     [
@@ -66,7 +66,7 @@ ERROR: no-case ;
     case-find {
         { [ dup array? ] [ nip second call ] }
         { [ dup callable? ] [ call ] }
-        { [ dup not ] [ no-case ] }
+        { [ dup not ] [ drop no-case ] }
     } cond ;
 
 : linear-case-quot ( default assoc -- quot )

extra/images/backend/backend.factor

@@ -1,18 +1,51 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel ;
+USING: accessors kernel grouping fry sequences combinators
+images.bitmap math ;
 IN: images.backend
 
-TUPLE: image width height depth pitch buffer ;
+SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
+
+TUPLE: image dim component-order bitmap ;
+
+TUPLE: normalized-image < image ;
 
 GENERIC: load-image* ( path tuple -- image )
 
-: load-image ( path class -- image )
+GENERIC: >image ( object -- image )
-    new load-image* ;
 
-: new-image ( width height depth buffer class -- image )
+: no-op ( -- ) ;
+
+: normalize-component-order ( image -- image )
+    dup component-order>>
+    {
+        { RGBA [ no-op ] }
+        { BGRA [
+            [
+                [ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
+                [ RGBA >>component-order ] bi
+            ] change-bitmap
+        ] }
+        { RGB [
+            [ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
+        ] }
+        { BGR [
+            [
+                3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
+                [ 255 suffix ] map concat
+            ] change-bitmap
+        ] }
+    } case RGBA >>component-order ;
+
+GENERIC: normalize-scan-line-order ( image -- image )
+
+M: image normalize-scan-line-order ;
+: normalize-image ( image -- image )
+    normalize-component-order
+    normalize-scan-line-order ;
+
+: new-image ( dim component-order bitmap class -- image )
     new 
-        swap >>buffer
+        swap >>bitmap
-        swap >>depth
+        swap >>component-order
-        swap >>height
+        swap >>dim ; inline
-        swap >>width ; inline

extra/images/bitmap/bitmap-tests.factor

@@ -5,9 +5,6 @@ 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" ;
 

extra/images/bitmap/bitmap.factor

@@ -15,7 +15,6 @@ TUPLE: bitmap-image < image ;
 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?
 buffer ;
 
 : array-copy ( bitmap array -- bitmap array' )
@@ -87,23 +86,36 @@ M: bitmap-magic summary
         parse-file-header parse-bitmap-header parse-bitmap
     ] with-file-reader ;
 
-: alpha-channel-zero? ( bitmap -- ? )
-    buffer>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
-
 : process-bitmap-data ( bitmap -- bitmap )
-    dup raw-bitmap>buffer >>buffer
+    dup raw-bitmap>buffer >>buffer ;
-    dup alpha-channel-zero? >>alpha-channel-zero? ;
 
 : load-bitmap ( path -- bitmap )
     load-bitmap-data process-bitmap-data ;
 
-: bitmap>image ( bitmap -- bitmap-image )
+ERROR: unknown-component-order bitmap ;
-    { [ width>> ] [ height>> ] [ bit-count>> ] [ buffer>> ] } cleave
+
-    bitmap-image new-image ;
+: bitmap>component-order ( bitmap -- object )
+    bit-count>> {
+        { 32 [ BGRA ] }
+        { 24 [ BGR ] }
+        { 8 [ BGR ] }
+        [ unknown-component-order ]
+    } case ;
+
+M: bitmap >image ( bitmap -- bitmap-image )
+    {
+        [ [ width>> ] [ height>> ] bi 2array ]
+        [ bitmap>component-order ]
+        [ buffer>> ]
+    } cleave bitmap-image new-image ;
 
 M: bitmap-image load-image* ( path bitmap -- bitmap-image )
-    drop load-bitmap
+    drop load-bitmap >image ;
-    bitmap>image ;
+
+M: bitmap-image normalize-scan-line-order
+    dup dim>> '[
+        _ first 4 * <sliced-groups> reverse concat
+    ] change-bitmap ;
 
 MACRO: (nbits>bitmap) ( bits -- )
     [ -3 shift ] keep '[
@@ -112,7 +124,7 @@ MACRO: (nbits>bitmap) ( bits -- )
             swap >>height
             swap >>width
             swap array-copy [ >>buffer ] [ >>color-index ] bi
-            _ >>bit-count bitmap>image
+            _ >>bit-count >image
     ] ;
 
 : bgr>bitmap ( array height width -- bitmap )

extra/images/images.factor

@@ -5,9 +5,17 @@ accessors images.bitmap images.tiff images.backend io.backend
 io.pathnames ;
 IN: images
 
-: <image> ( path -- image )
+ERROR: unknown-image-extension extension ;
-    normalize-path dup "." split1-last nip >lower
+
-    {
+: image-class ( path -- class )
-        { "bmp" [ bitmap-image load-image ] }
+    file-extension >lower {
-        { "tiff" [ tiff-image load-image ] }
+        { "bmp" [ bitmap-image ] }
+        { "tiff" [ tiff-image ] }
+        [ unknown-image-extension ]
     } case ;
+
+: load-image ( path -- image )
+    dup image-class new load-image* ;
+
+: <image> ( path -- image )
+    load-image normalize-image ;

extra/images/tiff/tiff.factor

@@ -1,7 +1,7 @@
 ! 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
+kernel pack endian constructors sequences arrays
 sorting.slots math.order math.parser prettyprint classes
 io.binary assocs math math.bitwise byte-arrays grouping
 images.backend ;
@@ -13,7 +13,7 @@ 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 ;
+processed-tags strips bitmap ;
 CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
 
 TUPLE: ifd-entry tag type count offset/value ;
@@ -257,29 +257,37 @@ ERROR: bad-small-ifd-type n ;
     dup ifd-entries>>
     [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
 
-: strips>buffer ( ifd -- ifd )
+: strips>bitmap ( ifd -- ifd )
-    dup strips>> concat >>buffer ;
+    dup strips>> concat >>bitmap ;
 
-: ifd>image ( ifd -- image )
+ERROR: unknown-component-order ifd ;
+
+: ifd-component-order ( ifd -- byte-order )
+    bits-per-sample find-tag sum {
+        { 32 [ RGBA ] }
+        { 24 [ RGB ] }
+        [ unknown-component-order ]
+    } case ;
+
+M: ifd >image ( ifd -- image )
     {
-        [ image-width find-tag ]
+        [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
-        [ image-length find-tag ]
+        [ ifd-component-order ]
-        [ bits-per-sample find-tag sum ]
+        [ bitmap>> ]
-        [ buffer>> ]
     } cleave tiff-image new-image ;
 
-: parsed-tiff>images ( tiff -- sequence )
+M: parsed-tiff >image ( image -- image )
-    ifds>> [ ifd>image ] map ;
+    ifds>> [ >image ] map first ;
 
 : load-tiff ( path -- parsed-tiff )
     binary [
         <parsed-tiff>
         read-header dup endianness>> [
             read-ifds
-            dup ifds>> [ process-ifd read-strips strips>buffer drop ] each
+            dup ifds>> [ process-ifd read-strips strips>bitmap 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 ;
+    drop load-tiff >image ;

extra/images/viewer/viewer.factor

@@ -1,19 +1,19 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators images.bitmap kernel math
+USING: accessors images images.backend io.pathnames kernel
-math.functions namespaces opengl opengl.gl ui ui.gadgets
+namespaces opengl opengl.gl sequences strings ui ui.gadgets
-ui.gadgets.panes ui.render images.tiff sequences multiline
+ui.gadgets.panes ui.render ;
-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>>
+    image>> dim>> ;
-    [ width>> ] [ height>> ] bi
+
-    [ abs ] bi@ 2array ;
+: draw-image ( tiff -- )
+    0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
+    [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
+    [ bitmap>> ] bi glDrawPixels ;
 
 M: image-gadget draw-gadget* ( gadget -- )
     origin get [ image>> draw-image ] with-translation ;
@@ -22,48 +22,16 @@ M: image-gadget draw-gadget* ( 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 -- )
+GENERIC: image. ( object -- )
-    0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
-    {
-        [ height>> ]
-        [ width>> ]
-        [ depth>> bits>gl-params ]
-        [ buffer>> ]
-    } cleave glDrawPixels ;
 
-GENERIC: image. ( image -- )
+: default-image. ( path -- )
+    <image-gadget> gadget. ;
 
-M: string image. ( image -- ) <image> <image-gadget> gadget. ;
+M: string image. ( image -- ) <image> default-image. ;
 
-M: pathname image. ( image -- ) <image> <image-gadget> gadget. ;
+M: pathname image. ( image -- ) <image> default-image. ;
 
-M: image image. ( image -- ) <image-gadget> gadget. ;
+M: image image. ( image -- ) default-image. ;