basis: use lint.vocabs tool to trim using lists

[factor.git] / basis / images / images.factor

diff --git a/basis/images/images.factor b/basis/images/images.factor
old mode 100755 (executable)
new mode 100644 (file)
index 9519968..4c392b8
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel accessors sequences math arrays ;
+USING: accessors combinators kernel math sequences ;
 IN: images
 
 SINGLETONS:
@@ -14,15 +14,16 @@ SINGLETONS:
     u-5-5-5-1-components u-5-6-5-components
     u-10-10-10-2-components
     u-24-components u-24-8-components
+    float-32-u-8-components
     u-9-9-9-e5-components
     float-11-11-10-components ;
 
-UNION: component-order 
+UNION: component-order
     A L LA BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
     INTENSITY DEPTH DEPTH-STENCIL R RG ;
 
 UNION: component-type
-    ubyte-components ushort-components
+    ubyte-components ushort-components uint-components
     half-components float-components
     byte-integer-components ubyte-integer-components
     short-integer-components ushort-integer-components
@@ -30,6 +31,7 @@ UNION: component-type
     u-5-5-5-1-components u-5-6-5-components
     u-10-10-10-2-components
     u-24-components u-24-8-components
+    float-32-u-8-components
     u-9-9-9-e5-components
     float-11-11-10-components ;
 
@@ -38,10 +40,21 @@ UNION: unnormalized-integer-components
     short-integer-components ushort-integer-components
     int-integer-components uint-integer-components ;
 
+UNION: signed-unnormalized-integer-components
+    byte-integer-components
+    short-integer-components
+    int-integer-components ;
+
+UNION: unsigned-unnormalized-integer-components
+    ubyte-integer-components
+    ushort-integer-components
+    uint-integer-components ;
+
 UNION: packed-components
     u-5-5-5-1-components u-5-6-5-components
     u-10-10-10-2-components
     u-24-components u-24-8-components
+    float-32-u-8-components
     u-9-9-9-e5-components
     float-11-11-10-components ;
 
@@ -49,13 +62,17 @@ UNION: alpha-channel BGRA RGBA ABGR ARGB LA A INTENSITY ;
 
 UNION: alpha-channel-precedes-colors ABGR ARGB XBGR XRGB ;
 
-TUPLE: image dim component-order component-type upside-down? bitmap ;
+TUPLE: image
+    dim component-order component-type
+    upside-down? premultiplied-alpha?
+    bitmap 2x? ;
 
 : <image> ( -- image ) image new ; inline
 
-: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+: image-dim ( image -- dim )
+    [ dim>> ] [ 2x?>> ] bi [ [ 2.0 / ] map ] when ;
 
-GENERIC: load-image* ( path class -- image )
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
 
 : bytes-per-component ( component-type -- n )
     {
@@ -81,6 +98,7 @@ GENERIC: load-image* ( path class -- image )
         { u-24-8-components [ 4 ] }
         { u-9-9-9-e5-components [ 4 ] }
         { float-11-11-10-components [ 4 ] }
+        { float-32-u-8-components [ 8 ] }
     } case ;
 
 : component-count ( component-order -- n )
@@ -105,27 +123,57 @@ GENERIC: load-image* ( path class -- image )
         { RG [ 2 ] }
     } case ;
 
-: bytes-per-pixel ( image -- n )
-    dup component-type>> packed-components?
-    [ component-type>> bytes-per-packed-pixel ] [
-        [ component-order>> component-count ]
-        [ component-type>>  bytes-per-component ] bi *
+: (bytes-per-pixel) ( component-order component-type -- n )
+    dup packed-components?
+    [ nip bytes-per-packed-pixel ] [
+        [ component-count ] [ bytes-per-component ] bi* *
     ] if ;
 
+: bytes-per-pixel ( image -- n )
+    [ component-order>> ] [ component-type>> ] bi (bytes-per-pixel) ;
+
+: bytes-per-image ( image -- n )
+    [ dim>> product ] [ bytes-per-pixel ] bi * ;
+
+: rowstride ( image -- n )
+    [ dim>> first ] [ bytes-per-pixel ] bi * ;
+
 <PRIVATE
 
-: pixel@ ( x y image -- start end bitmap )
-    [ dim>> first * + ]
-    [ bytes-per-pixel [ * dup ] keep + ]
-    [ bitmap>> ] tri ;
+:: pixel@ ( x y w image -- start end bitmap )
+    image dim>> first y * x + :> start
+    start w [ image bytes-per-pixel * ] bi@ :> ( start' w' )
+    start'  start' w' +  image bitmap>> ; inline
 
 : set-subseq ( new-value from to victim -- )
     <slice> 0 swap copy ; inline
 
 PRIVATE>
 
+: pixel-row-at ( x y w image -- pixels )
+    pixel@ subseq ; inline
+
+: pixel-row-slice-at ( x y w image -- pixels )
+    pixel@ <slice> ; inline
+
+: set-pixel-row-at ( pixel x y w image -- )
+    pixel@ set-subseq ; inline
+
 : pixel-at ( x y image -- pixel )
-    pixel@ subseq ;
+    [ 1 ] dip pixel-row-at ; inline
+
+: pixel-slice-at ( x y image -- pixels )
+    [ 1 ] dip pixel-row-slice-at ; inline
 
 : set-pixel-at ( pixel x y image -- )
-    pixel@ set-subseq ;
+    [ 1 ] dip set-pixel-row-at ; inline
+
+:: each-pixel ( ... image quot: ( ... x y pixel -- ... ) -- ... )
+    image dim>> first2 :> ( width height )
+    image bytes-per-pixel :> n
+    height width [ <iota> ] bi@ [| y x |
+        y width * x + :> start
+        start n * :> from
+        from n + :> to
+        x y from to image bitmap>> <slice> quot call
+    ] cartesian-each ; inline